extra/cairo-gadgets/cairo-gadgets.factor

   1 ! Copyright (C) 2008 Matthew Willis.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences math kernel byte-arrays cairo.ffi cairo
   4 io.backend ui.gadgets accessors opengl.gl arrays fry
   5 classes ui.render namespaces destructors libc ;
   6 IN: cairo-gadgets
   7
   8 SYMBOL: current-cairo
   9
  10 : cr ( -- cairo )
  11     current-cairo get ;
  12
  13 <PRIVATE
  14
  15 : width>stride ( width -- stride ) 4 * ;
  16
  17 : image-dims ( gadget -- width height stride )
  18     dim>> first2 over width>stride ; inline
  19
  20 : image-buffer ( width height stride -- alien )
  21     * nip malloc &free ; inline
  22
  23 : with-cairo ( cairo quot -- )
  24     [ &cairo_destroy current-cairo ] dip
  25     '[ @ current-cairo get check-cairo ] with-variable ; inline
  26
  27 : with-surface ( cairo_surface quot -- alien )
  28     [ &cairo_surface_destroy ] dip [ check-surface ] bi ; inline
  29
  30 : with-cairo-from-surface ( cairo_surface quot -- )
  31     '[ cairo_create _ with-cairo ] with-surface ; inline
  32
  33 PRIVATE>
  34
  35 GENERIC: render-cairo* ( gadget -- )
  36
  37 : render-cairo ( gadget -- alien )
  38     [
  39         image-dims
  40         [ image-buffer dup CAIRO_FORMAT_ARGB32 ]
  41         [ cairo_image_surface_create_for_data ] 3bi
  42     ] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
  43
  44 TUPLE: cairo-gadget < gadget ;
  45
  46 : <cairo-gadget> ( dim -- gadget )
  47     cairo-gadget new
  48         swap >>dim ;
  49
  50 M: cairo-gadget draw-gadget*
  51     [
  52         [ dim>> ] [ render-cairo ] bi
  53         0 0 glRasterPos2i
  54         1.0 -1.0 glPixelZoom
  55         [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
  56         glDrawPixels
  57     ] with-destructors ;
  58
  59 : copy-surface ( surface -- )
  60     cr swap 0 0 cairo_set_source_surface
  61     cr cairo_paint ;