From d05f9704c6adfc4773bf8bd35d7e4cfa60ed64d5 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 10 May 2008 14:22:12 -0700 Subject: [PATCH] error checking, more gadget words for cairo --- extra/cairo/gadgets/gadgets.factor | 75 +++++++++++++++--------------- extra/cairo/lib/lib.factor | 49 +++++++++---------- extra/cairo/samples/samples.factor | 19 ++++---- 3 files changed, 70 insertions(+), 73 deletions(-) diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index e5b18f72b7..f3b053c756 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/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?>> ; : ( width height quot -- cairo-gadget ) cairo-gadget construct-gadget swap >>quot swap >>height swap >>width ; -: (with-surface) ( surface quot -- surface ) - >r dup cairo_create dup r> call cairo_destroy ; - -: with-surface ( surface quot -- ) - (with-surface) cairo_surface_destroy ; +: ( width height quot -- cairo-gadget ) + t >>cache? ; -: cairo>bytes ( width height quot -- byte-array ) - >r over 4 * +: width>stride ( width -- stride ) 4 * ; + +: copy-cairo ( width height quot -- byte-array ) + >r over width>stride [ * nip 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 -- ) - >r >r CAIRO_FORMAT_ARGB32 -rot - cairo_image_surface_create - r> (with-surface) dup r> cairo_surface_write_to_png - drop cairo_surface_destroy ; +: (cairo>bytes) ( gadget -- byte-array ) + [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ; + +GENERIC: cairo>bytes +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 - [ drop GL_BGRA GL_UNSIGNED_BYTE ] [ cairo>bytes ] 3bi - glDrawPixels + [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ] + [ cairo>bytes ] tri glDrawPixels ] with-translation ; M: cairo-gadget pref-dim* ( gadget -- rect ) [ width>> ] [ height>> ] bi 2array ; -TUPLE: pixels-gadget width height bytes ; -: ( width height bytes -- pixel-gadget ) - pixels-gadget construct-gadget - swap >>bytes - swap >>height - swap >>width ; - -M: pixels-gadget draw-gadget* ( gadget -- ) - origin get [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - [ width>> ] [ height>> ] [ bytes>> ] tri - GL_BGRA GL_UNSIGNED_BYTE rot glDrawPixels - ] with-translation ; +: copy-surface ( surface -- ) + cr swap 0 0 cairo_set_source_surface + cr cairo_paint ; -M: pixels-gadget pref-dim* ( gadget -- rect ) - [ width>> ] [ height>> ] bi 2array ; +: ( width height bytes -- cairo-gadget ) + >r [ ] r> >>bytes ; : ( path -- gadget ) normalize-path cairo_image_surface_create_from_png - [ cairo_image_surface_get_width ] [ cairo_image_surface_get_height 2dup ] - [ [ dupd 0 0 cairo_set_source_surface cairo_paint ] curry cairo>bytes ] tri - ; \ No newline at end of file + [ cairo_image_surface_get_width ] + [ cairo_image_surface_get_height 2dup ] + [ [ copy-surface ] curry copy-cairo ] tri + ; \ No newline at end of file diff --git a/extra/cairo/lib/lib.factor b/extra/cairo/lib/lib.factor index 4f532cd9ec..c9700e82c0 100755 --- a/extra/cairo/lib/lib.factor +++ b/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 -kernel libc locals math shuffle accessors ; +USING: cairo kernel accessors sequences +namespaces fry continuations ; IN: cairo.lib TUPLE: cairo-t alien ; C: cairo-t M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ; -: cairo-t-destroy-always ( alien -- ) add-always-destructor ; -: cairo-t-destroy-later ( alien -- ) add-error-destructor ; - + TUPLE: cairo-surface-t alien ; C: cairo-surface-t M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ; -: cairo-surface-t-destroy-always ( alien -- ) - add-always-destructor ; +: check-cairo ( cairo_status_t -- ) + dup CAIRO_STATUS_SUCCESS = [ drop ] + [ cairo_status_to_string "Cairo error: " prepend throw ] if ; -: cairo-surface-t-destroy-later ( alien -- ) - add-error-destructor ; +SYMBOL: cairo +: cr ( -- cairo ) cairo get ; -: cairo-surface>array ( surface -- cairo-t byte-array ) - [ - dup - [ drop CAIRO_FORMAT_ARGB32 ] - [ cairo_image_surface_get_width ] - [ cairo_image_surface_get_height ] tri - over 4 * - 2dup * [ - malloc dup free-always [ - 5 -nrot cairo_image_surface_create_for_data - dup cairo-surface-t-destroy-always - cairo_create dup cairo-t-destroy-later - [ swap 0 0 cairo_set_source_surface ] keep - dup cairo_paint - ] keep - ] keep memory>byte-array - ] with-destructors ; +: (with-cairo) ( cairo-t quot -- ) + >r alien>> cairo r> [ cr cairo_status check-cairo ] + compose with-variable ; inline + +: with-cairo ( cairo quot -- ) + >r r> [ (with-cairo) ] curry with-disposal ; inline + +: (with-surface) ( cairo-surface-t quot -- ) + >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline + +: with-surface ( cairo_surface quot -- ) + >r r> [ (with-surface) ] curry with-disposal ; inline + +: with-cairo-from-surface ( cairo_surface quot -- ) + '[ cairo_create , with-cairo ] with-surface ; inline diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor index 882aabfc0c..2d8d34a376 100644 --- a/extra/cairo/samples/samples.factor +++ b/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 -io.backend kernel alien.c-types libc ; +USING: cairo cairo.lib locals math.constants math +io.backend kernel alien.c-types libc namespaces ; IN: cairo.samples -SYMBOL: cr -:: arc ( cr -- ) +:: arc ( -- ) [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