error checking, more gadget words for cairo

extra/cairo/gadgets/gadgets.factor

@@ -1,4 +1,4 @@
-USING: cairo ui.render kernel opengl.gl opengl
+USING: cairo cairo.lib ui.render kernel opengl.gl opengl
 math byte-arrays ui.gadgets accessors arrays 
 namespaces io.backend ;
 
@@ -8,63 +8,64 @@ IN: cairo.gadgets
 ! one performs the cairo ops once and caches the bytes, the other
 ! performs cairo ops every refresh
 
-TUPLE: cairo-gadget width height quot ;
+TUPLE: cairo-gadget width height quot cache? bytes ;
+PREDICATE: cached-cairo < cairo-gadget cache?>> ;
 : <cairo-gadget> ( width height quot -- cairo-gadget )
     cairo-gadget construct-gadget 
     swap >>quot
     swap >>height
     swap >>width ;
 
-: (with-surface) ( surface quot -- surface )
+: <cached-cairo> ( width height quot -- cairo-gadget )
-    >r dup cairo_create dup r> call cairo_destroy ;
+    <cairo-gadget> t >>cache? ;
 
-: with-surface ( surface quot -- )
+: width>stride ( width -- stride ) 4 * ;
-    (with-surface) cairo_surface_destroy ;
     
-: cairo>bytes ( width height quot -- byte-array )
+: copy-cairo ( width height quot -- byte-array )
-    >r over 4 *
+    >r over width>stride
     [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
     [ cairo_image_surface_create_for_data ] 3bi
-    r> with-surface ;
+    r> with-cairo-from-surface ;
 
-: cairo>png ( width height quot path -- )
+: (cairo>bytes) ( gadget -- byte-array )
-    >r >r CAIRO_FORMAT_ARGB32 -rot
+    [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
-    cairo_image_surface_create
+
-    r> (with-surface) dup r> cairo_surface_write_to_png
+GENERIC: cairo>bytes
-    drop cairo_surface_destroy ;
+M: cairo-gadget cairo>bytes ( gadget -- byte-array )
+    (cairo>bytes) ;
+
+M: cached-cairo cairo>bytes ( gadget -- byte-array )
+    dup bytes>> [ ] [
+        dup (cairo>bytes) [ >>bytes drop ] keep
+    ] ?if ;
+
+: cairo>png ( gadget path -- )
+    >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
+    [ height>> ] tri over width>stride
+    cairo_image_surface_create_for_data
+    r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
 
 M: cairo-gadget draw-gadget* ( gadget -- )
     origin get [
         0 0 glRasterPos2i
         1.0 -1.0 glPixelZoom
-        [ width>> ] [ height>> ] [ quot>> ] tri
+        [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
-        [ drop GL_BGRA GL_UNSIGNED_BYTE ] [ cairo>bytes ] 3bi
+        [ cairo>bytes ] tri glDrawPixels
-        glDrawPixels
     ] with-translation ;
     
 M: cairo-gadget pref-dim* ( gadget -- rect )
     [ width>> ] [ height>> ] bi 2array ;
 
-TUPLE: pixels-gadget width height bytes ;
+: copy-surface ( surface -- )
-: <pixels-gadget> ( width height bytes -- pixel-gadget )
+    cr swap 0 0 cairo_set_source_surface
-    pixels-gadget construct-gadget
+    cr cairo_paint ;
-    swap >>bytes
-    swap >>height
-    swap >>width ;
 
-M: pixels-gadget draw-gadget* ( gadget -- )
+: <bytes-gadget> ( width height bytes -- cairo-gadget )
-    origin get [
+    >r [ ] <cached-cairo> r> >>bytes ;
-        0 0 glRasterPos2i
-        1.0 -1.0 glPixelZoom
-        [ width>> ] [ height>> ] [ bytes>> ] tri
-        GL_BGRA GL_UNSIGNED_BYTE rot glDrawPixels
-    ] with-translation ;
-
-M: pixels-gadget pref-dim* ( gadget -- rect )
-    [ width>> ] [ height>> ] bi 2array ;
 
 : <png-gadget> ( path -- gadget )
     normalize-path cairo_image_surface_create_from_png
-    [ cairo_image_surface_get_width ] [ cairo_image_surface_get_height 2dup ]
+    [ cairo_image_surface_get_width ]
-    [ [ dupd 0 0 cairo_set_source_surface cairo_paint ]  curry cairo>bytes ] tri
+    [ cairo_image_surface_get_height 2dup ]
-    <pixels-gadget> ;
+    [ [ copy-surface ] curry copy-cairo ] tri
+    <bytes-gadget> ;

extra/cairo/lib/lib.factor

@@ -1,39 +1,36 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types cairo.ffi continuations destructors
+USING: cairo kernel accessors sequences
-kernel libc locals math shuffle accessors ;
+namespaces fry continuations ;
 IN: cairo.lib
 
 TUPLE: cairo-t alien ;
 C: <cairo-t> cairo-t
 M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
-: cairo-t-destroy-always ( alien -- ) <cairo-t> add-always-destructor ;
-: cairo-t-destroy-later ( alien -- ) <cairo-t> add-error-destructor ;
 
 TUPLE: cairo-surface-t alien ;
 C: <cairo-surface-t> cairo-surface-t
 M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
 
-: cairo-surface-t-destroy-always ( alien -- )
+: check-cairo ( cairo_status_t -- )
-    <cairo-surface-t> add-always-destructor ;
+    dup CAIRO_STATUS_SUCCESS = [ drop ]
+    [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
 
-: cairo-surface-t-destroy-later ( alien -- )
+SYMBOL: cairo
-    <cairo-surface-t> add-error-destructor ;
+: cr ( -- cairo ) cairo get ;
 
-: cairo-surface>array ( surface -- cairo-t byte-array )
+: (with-cairo) ( cairo-t quot -- )
-    [
+    >r alien>> cairo r> [ cr cairo_status check-cairo ]
-        dup
+    compose with-variable ; inline
-        [ drop CAIRO_FORMAT_ARGB32 ]
+    
-        [ cairo_image_surface_get_width ]
+: with-cairo ( cairo quot -- )
-        [ cairo_image_surface_get_height ] tri
+    >r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
-        over 4 *
+
-        2dup * [
+: (with-surface) ( cairo-surface-t quot -- )
-            malloc dup free-always [
+    >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
-                5 -nrot cairo_image_surface_create_for_data
+
-                dup cairo-surface-t-destroy-always
+: with-surface ( cairo_surface quot -- )
-                cairo_create dup cairo-t-destroy-later
+    >r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
-                [ swap 0 0 cairo_set_source_surface ] keep
+
-                dup cairo_paint
+: with-cairo-from-surface ( cairo_surface quot -- )
-            ] keep
+    '[ cairo_create , with-cairo ] with-surface ; inline
-        ] keep memory>byte-array
-    ] with-destructors ;

extra/cairo/samples/samples.factor

@@ -3,13 +3,12 @@
 !
 ! these samples are a subset of the samples on
 ! http://cairographics.org/samples/
-USING: cairo locals math.constants math
+USING: cairo cairo.lib locals math.constants math
-io.backend kernel alien.c-types libc ;
+io.backend kernel alien.c-types libc namespaces ;
 
 IN: cairo.samples
 
-SYMBOL: cr
+:: arc ( -- )
-:: arc ( cr -- )
     [let | xc [ 128.0 ]
            yc [ 128.0 ]
            radius [ 100.0 ]
@@ -33,7 +32,7 @@ SYMBOL: cr
         cr cairo_stroke
     ] ;
 
-:: clip ( cr -- )
+: clip ( -- )
     cr 128 128 76.8 0 2 pi * cairo_arc
     cr cairo_clip
     cr cairo_new_path
@@ -48,7 +47,7 @@ SYMBOL: cr
     cr 10 cairo_set_line_width
     cr cairo_stroke ;
 
-:: clip-image ( cr -- )
+:: clip-image ( -- )
     [let* | png [ "resource:misc/icons/Factor_128x128.png"
                   normalize-path cairo_image_surface_create_from_png ]
             w [ png cairo_image_surface_get_width ]
@@ -63,7 +62,7 @@ SYMBOL: cr
         png cairo_surface_destroy
     ] ;
 
-:: dash ( cr -- )
+:: dash ( -- )
     [let | dashes [ { 50 10 10 10 } >c-double-array ]
            ndash [ 4 ] |
         cr dashes ndash -50 cairo_set_dash
@@ -75,7 +74,7 @@ SYMBOL: cr
         cr cairo_stroke
     ] ;
 
-:: gradient ( cr -- )
+:: gradient ( -- )
     [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 ] |
@@ -94,7 +93,7 @@ SYMBOL: cr
         radial cairo_pattern_destroy
     ] ;
 
-:: text ( cr -- )
+: text ( -- )
     cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
     cairo_select_font_face
     cr 50 cairo_set_font_size
@@ -116,7 +115,7 @@ SYMBOL: cr
     cr 70 165 5.12 0 2 pi * cairo_arc
     cr cairo_fill ;
 
-:: utf8 ( cr -- )
+: utf8 ( -- )
     cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
     cairo_select_font_face
     cr 50 cairo_set_font_size