bring cairo bindings back from the dead

db4
Joe Groff 2008-11-10 17:01:14 -08:00
parent 161c917748
commit 6189bfd1f0
6 changed files with 43 additions and 28 deletions

View File

@ -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 ;

View File

@ -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 )

View File

@ -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

View File

@ -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 >>

View File

@ -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*

View File

@ -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