extra/cairo/gadgets/gadgets.factor

   1 ! Copyright (C) 2008 Matthew Willis.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences math opengl.gadgets kernel
   4 byte-arrays cairo.ffi cairo io.backend
   5 ui.gadgets accessors opengl.gl
   6 arrays ;
   7
   8 IN: cairo.gadgets
   9
  10 : width>stride ( width -- stride ) 4 * ;
  11
  12 : copy-cairo ( dim quot -- byte-array )
  13     >r first2 over width>stride
  14     [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
  15     [ cairo_image_surface_create_for_data ] 3bi
  16     r> with-cairo-from-surface ; inline
  17
  18 TUPLE: cairo-gadget < texture-gadget dim quot ;
  19
  20 : <cairo-gadget> ( dim quot -- gadget )
  21     cairo-gadget construct-gadget
  22         swap >>quot
  23         swap >>dim ;
  24
  25 M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
  26
  27 : render-cairo ( dim quot -- bytes format )
  28     >r 2^-bounds r> copy-cairo GL_BGRA ; inline
  29
  30 ! M: cairo-gadget render*
  31 !     [ dim>> dup ] [ quot>> ] bi
  32 !     render-cairo render-bytes* ;
  33
  34 ! maybe also texture>png
  35 ! : cairo>png ( gadget path -- )
  36 !    >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
  37 !    [ height>> ] tri over width>stride
  38 !    cairo_image_surface_create_for_data
  39 !    r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
  40
  41 : copy-surface ( surface -- )
  42     cr swap 0 0 cairo_set_source_surface
  43     cr cairo_paint ;
  44
  45 TUPLE: png-gadget < texture-gadget path ;
  46 : <png> ( path -- gadget )
  47     png-gadget construct-gadget
  48         swap >>path ;
  49
  50 M: png-gadget render*
  51     path>> normalize-path cairo_image_surface_create_from_png
  52     [ cairo_image_surface_get_width ]
  53     [ cairo_image_surface_get_height 2array dup 2^-bounds ]
  54     [ [ copy-surface ] curry copy-cairo ] tri
  55     GL_BGRA render-bytes* ;
  56
  57 M: png-gadget cache-key* path>> ;