bring cairo bindings back from the dead
parent
161c917748
commit
6189bfd1f0
|
@ -16,17 +16,17 @@ IN: opengl
|
|||
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
|
||||
[ first2 [ >fixnum ] bi@ ] bi@ ;
|
||||
|
||||
: gl-color ( color -- ) first4 glColor4d ; inline
|
||||
: color>raw ( object -- r g b a )
|
||||
>rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
|
||||
|
||||
: gl-color ( color -- ) color>raw glColor4d ; inline
|
||||
|
||||
: gl-clear-color ( color -- )
|
||||
first4 glClearColor ;
|
||||
color>raw glClearColor ;
|
||||
|
||||
: gl-clear ( color -- )
|
||||
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
|
||||
|
||||
: color>raw ( object -- r g b a )
|
||||
>rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
|
||||
|
||||
: set-color ( object -- ) color>raw glColor4d ;
|
||||
: set-clear-color ( object -- ) color>raw glClearColor ;
|
||||
|
||||
|
|
|
@ -6,7 +6,7 @@ fry assocs
|
|||
destructors sequences ui.render colors ;
|
||||
IN: opengl.gadgets
|
||||
|
||||
TUPLE: texture-gadget ;
|
||||
TUPLE: texture-gadget < gadget ;
|
||||
|
||||
GENERIC: render* ( gadget -- texture dims )
|
||||
GENERIC: cache-key* ( gadget -- key )
|
||||
|
|
|
@ -33,4 +33,4 @@ SYMBOL: cairo
|
|||
>r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
|
||||
|
||||
: with-cairo-from-surface ( cairo_surface quot -- )
|
||||
'[ cairo_create , with-cairo ] with-surface ; inline
|
||||
'[ cairo_create _ with-cairo ] with-surface ; inline
|
||||
|
|
|
@ -10,7 +10,7 @@ alien.c-types accessors sequences arrays ui.gadgets ;
|
|||
IN: cairo.ffi
|
||||
<< "cairo" {
|
||||
{ [ os winnt? ] [ "libcairo-2.dll" ] }
|
||||
{ [ os macosx? ] [ "libcairo.dylib" ] }
|
||||
{ [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
|
||||
{ [ os unix? ] [ "libcairo.so.2" ] }
|
||||
} cond "cdecl" add-library >>
|
||||
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: sequences math opengl.gadgets kernel
|
||||
byte-arrays cairo.ffi cairo io.backend
|
||||
ui.gadgets accessors opengl.gl
|
||||
arrays ;
|
||||
arrays fry classes ;
|
||||
|
||||
IN: cairo.gadgets
|
||||
|
||||
|
@ -15,21 +15,22 @@ IN: cairo.gadgets
|
|||
[ cairo_image_surface_create_for_data ] 3bi
|
||||
r> with-cairo-from-surface ; inline
|
||||
|
||||
TUPLE: cairo-gadget < texture-gadget dim quot ;
|
||||
TUPLE: cairo-gadget < texture-gadget ;
|
||||
|
||||
: <cairo-gadget> ( dim quot -- gadget )
|
||||
cairo-gadget construct-gadget
|
||||
swap >>quot
|
||||
: <cairo-gadget> ( dim -- gadget )
|
||||
cairo-gadget new-gadget
|
||||
swap >>dim ;
|
||||
|
||||
M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
|
||||
M: cairo-gadget cache-key* [ dim>> ] [ class ] bi 2array ;
|
||||
|
||||
: render-cairo ( dim quot -- bytes format )
|
||||
>r 2^-bounds r> copy-cairo GL_BGRA ; inline
|
||||
|
||||
! M: cairo-gadget render*
|
||||
! [ dim>> dup ] [ quot>> ] bi
|
||||
! render-cairo render-bytes* ;
|
||||
GENERIC: render-cairo* ( gadget -- )
|
||||
|
||||
M: cairo-gadget render*
|
||||
[ dim>> dup ] [ '[ _ render-cairo* ] ] bi
|
||||
render-cairo render-bytes* ;
|
||||
|
||||
! maybe also texture>png
|
||||
! : cairo>png ( gadget path -- )
|
||||
|
@ -44,7 +45,7 @@ M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
|
|||
|
||||
TUPLE: png-gadget < texture-gadget path ;
|
||||
: <png> ( path -- gadget )
|
||||
png-gadget construct-gadget
|
||||
png-gadget new-gadget
|
||||
swap >>path ;
|
||||
|
||||
M: png-gadget render*
|
||||
|
|
|
@ -4,11 +4,13 @@
|
|||
! these samples are a subset of the samples on
|
||||
! http://cairographics.org/samples/
|
||||
USING: cairo cairo.ffi locals math.constants math
|
||||
io.backend kernel alien.c-types libc namespaces ;
|
||||
io.backend kernel alien.c-types libc namespaces
|
||||
cairo.gadgets ui.gadgets accessors ;
|
||||
|
||||
IN: cairo.samples
|
||||
|
||||
:: arc ( -- )
|
||||
TUPLE: arc-gadget < cairo-gadget ;
|
||||
M:: arc-gadget render-cairo* ( gadget -- )
|
||||
[let | xc [ 128.0 ]
|
||||
yc [ 128.0 ]
|
||||
radius [ 100.0 ]
|
||||
|
@ -32,7 +34,9 @@ IN: cairo.samples
|
|||
cr cairo_stroke
|
||||
] ;
|
||||
|
||||
: clip ( -- )
|
||||
TUPLE: clip-gadget < cairo-gadget ;
|
||||
M: clip-gadget render-cairo* ( gadget -- )
|
||||
drop
|
||||
cr 128 128 76.8 0 2 pi * cairo_arc
|
||||
cr cairo_clip
|
||||
cr cairo_new_path
|
||||
|
@ -47,7 +51,8 @@ IN: cairo.samples
|
|||
cr 10 cairo_set_line_width
|
||||
cr cairo_stroke ;
|
||||
|
||||
:: clip-image ( -- )
|
||||
TUPLE: clip-image-gadget < cairo-gadget ;
|
||||
M:: clip-image-gadget render-cairo* ( gadget -- )
|
||||
[let* | png [ "resource:misc/icons/Factor_128x128.png"
|
||||
normalize-path cairo_image_surface_create_from_png ]
|
||||
w [ png cairo_image_surface_get_width ]
|
||||
|
@ -62,7 +67,8 @@ IN: cairo.samples
|
|||
png cairo_surface_destroy
|
||||
] ;
|
||||
|
||||
:: dash ( -- )
|
||||
TUPLE: dash-gadget < cairo-gadget ;
|
||||
M:: dash-gadget render-cairo* ( gadget -- )
|
||||
[let | dashes [ { 50 10 10 10 } >c-double-array ]
|
||||
ndash [ 4 ] |
|
||||
cr dashes ndash -50 cairo_set_dash
|
||||
|
@ -74,7 +80,8 @@ IN: cairo.samples
|
|||
cr cairo_stroke
|
||||
] ;
|
||||
|
||||
:: gradient ( -- )
|
||||
TUPLE: gradient-gadget < cairo-gadget ;
|
||||
M:: gradient-gadget render-cairo* ( gadget -- )
|
||||
[let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
|
||||
radial [ 115.2 102.4 25.6 102.4 102.4 128.0
|
||||
cairo_pattern_create_radial ] |
|
||||
|
@ -93,7 +100,9 @@ IN: cairo.samples
|
|||
radial cairo_pattern_destroy
|
||||
] ;
|
||||
|
||||
: text ( -- )
|
||||
TUPLE: text-gadget < cairo-gadget ;
|
||||
M: text-gadget render-cairo* ( gadget -- )
|
||||
drop
|
||||
cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
|
||||
cairo_select_font_face
|
||||
cr 50 cairo_set_font_size
|
||||
|
@ -115,7 +124,9 @@ IN: cairo.samples
|
|||
cr 70 165 5.12 0 2 pi * cairo_arc
|
||||
cr cairo_fill ;
|
||||
|
||||
: utf8 ( -- )
|
||||
TUPLE: utf8-gadget < cairo-gadget ;
|
||||
M: utf8-gadget render-cairo* ( gadget -- )
|
||||
drop
|
||||
cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
|
||||
cairo_select_font_face
|
||||
cr 50 cairo_set_font_size
|
||||
|
@ -141,7 +152,10 @@ IN: cairo.samples
|
|||
|
||||
USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
|
||||
: samples ( -- )
|
||||
{ arc clip clip-image dash gradient text utf8 }
|
||||
[ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
|
||||
{
|
||||
arc-gadget clip-gadget clip-image-gadget dash-gadget
|
||||
gradient-gadget text-gadget utf8-gadget
|
||||
}
|
||||
[ new-gadget { 256 256 } >>dim gadget. ] each ;
|
||||
|
||||
MAIN: samples
|
||||
|
|
Loading…
Reference in New Issue