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 memoize ;
   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? texture ;
  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 : 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 : with-cairo-gl ( quot -- )
  42     >r origin get [
  43         0 0 glRasterPos2i
  44         1.0 -1.0 glPixelZoom
  45     ] r> compose with-translation ;
  46
  47 M: cairo-gadget draw-gadget* ( gadget -- )
  48     [
  49         [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
  50         [ cairo>bytes ] tri glDrawPixels
  51     ] with-cairo-gl ;
  52
  53 MEMO: render-to-texture ( gadget -- )
  54     GL_TEXTURE_BIT [
  55         GL_TEXTURE_2D over texture>> glBindTexture
  56         >r GL_TEXTURE_2D 0 GL_RGBA r>
  57         [ width>> ] [ height>> 0 GL_BGRA GL_UNSIGNED_BYTE ]
  58         [ cairo>bytes ] tri glTexImage2D
  59         init-texture
  60         GL_TEXTURE_2D 0 glBindTexture
  61     ] do-attribs ;
  62
  63 M: cached-cairo draw-gadget* ( gadget -- )
  64     GL_TEXTURE_2D [
  65         [
  66             dup render-to-texture
  67             GL_TEXTURE_2D over texture>> glBindTexture
  68             GL_QUADS [
  69                 [ width>> ] [ height>> ] bi 2array four-sides
  70             ] do-state
  71             GL_TEXTURE_2D 0 glBindTexture
  72         ] with-cairo-gl
  73     ] do-enabled ;
  74
  75 M: cached-cairo graft* ( gadget -- )
  76     gen-texture >>texture drop ;
  77
  78 M: cached-cairo ungraft* ( gadget -- )
  79     texture>> delete-texture ;
  80
  81 M: cairo-gadget pref-dim* ( gadget -- rect )
  82     [ width>> ] [ height>> ] bi 2array ;
  83
  84 : copy-surface ( surface -- )
  85     cr swap 0 0 cairo_set_source_surface
  86     cr cairo_paint ;
  87
  88 : <bytes-gadget> ( width height bytes -- cairo-gadget )
  89     >r [ ] <cached-cairo> r> >>texture ;
  90
  91 : <png-gadget> ( path -- gadget )
  92     normalize-path cairo_image_surface_create_from_png
  93     [ cairo_image_surface_get_width ]
  94     [ cairo_image_surface_get_height 2dup ]
  95     [ [ copy-surface ] curry copy-cairo ] tri
  96     <bytes-gadget> ;
  97
  98