extra/cairo/gadgets/gadgets.factor

   1 ! Copyright (C) 2008 Matthew Willis.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: cairo cairo.ffi ui.render kernel opengl.gl opengl
   4 math byte-arrays ui.gadgets accessors arrays
   5 namespaces io.backend ;
   6
   7 IN: cairo.gadgets
   8
   9 ! We need two kinds of gadgets:
  10 ! one performs the cairo ops once and caches the bytes, the other
  11 ! performs cairo ops every refresh
  12
  13 TUPLE: cairo-gadget width height quot cache? bytes ;
  14 PREDICATE: cached-cairo < cairo-gadget cache?>> ;
  15 : <cairo-gadget> ( width height quot -- cairo-gadget )
  16     cairo-gadget construct-gadget
  17     swap >>quot
  18     swap >>height
  19     swap >>width ;
  20
  21 : <cached-cairo> ( width height quot -- cairo-gadget )
  22     <cairo-gadget> t >>cache? ;
  23
  24 : width>stride ( width -- stride ) 4 * ;
  25
  26 : copy-cairo ( width height quot -- byte-array )
  27     >r over width>stride
  28     [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
  29     [ cairo_image_surface_create_for_data ] 3bi
  30     r> with-cairo-from-surface ;
  31
  32 : (cairo>bytes) ( gadget -- byte-array )
  33     [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
  34
  35 GENERIC: cairo>bytes
  36 M: cairo-gadget cairo>bytes ( gadget -- byte-array )
  37     (cairo>bytes) ;
  38
  39 M: cached-cairo cairo>bytes ( gadget -- byte-array )
  40     dup bytes>> [ ] [
  41         dup (cairo>bytes) [ >>bytes drop ] keep
  42     ] ?if ;
  43
  44 : cairo>png ( gadget path -- )
  45     >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
  46     [ height>> ] tri over width>stride
  47     cairo_image_surface_create_for_data
  48     r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
  49
  50 M: cairo-gadget draw-gadget* ( gadget -- )
  51     origin get [
  52         0 0 glRasterPos2i
  53         1.0 -1.0 glPixelZoom
  54         [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
  55         [ cairo>bytes ] tri glDrawPixels
  56     ] with-translation ;
  57
  58 M: cairo-gadget pref-dim* ( gadget -- rect )
  59     [ width>> ] [ height>> ] bi 2array ;
  60
  61 : copy-surface ( surface -- )
  62     cr swap 0 0 cairo_set_source_surface
  63     cr cairo_paint ;
  64
  65 : <bytes-gadget> ( width height bytes -- cairo-gadget )
  66     >r [ ] <cached-cairo> r> >>bytes ;
  67
  68 : <png-gadget> ( path -- gadget )
  69     normalize-path cairo_image_surface_create_from_png
  70     [ cairo_image_surface_get_width ]
  71     [ cairo_image_surface_get_height 2dup ]
  72     [ [ copy-surface ] curry copy-cairo ] tri
  73     <bytes-gadget> ;