extra/cairo/png/png.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel accessors math ui.gadgets ui.render
   4 opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib
   5 inspector sequences combinators io.backend ;
   6 IN: cairo.png
   7
   8 TUPLE: png surface width height cairo-t array ;
   9 TUPLE: png-gadget png ;
  10
  11 ERROR: cairo-error string ;
  12
  13 : check-zero ( n -- n )
  14     dup zero? [
  15         "PNG dimension is 0" cairo-error
  16     ] when ;
  17
  18 : cairo-png-error ( n -- )
  19     {
  20         { CAIRO_STATUS_NO_MEMORY [ "Cairo: no memory" cairo-error ] }
  21         { CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
  22         { CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
  23         [ drop ]
  24     } case ;
  25
  26 : <png> ( path -- png )
  27     normalize-path
  28     cairo_image_surface_create_from_png
  29     dup cairo_surface_status cairo-png-error
  30     dup [ cairo_image_surface_get_width check-zero ]
  31     [ cairo_image_surface_get_height check-zero ] [ ] tri
  32     cairo-surface>array png boa ;
  33
  34 : write-png ( png path -- )
  35     >r png-surface r>
  36     cairo_surface_write_to_png
  37     zero? [ "write png failed" throw ] unless ;
  38
  39 : <png-gadget> ( path -- gadget )
  40     png-gadget construct-gadget swap
  41     <png> >>png ;
  42
  43 M: png-gadget pref-dim* ( gadget -- )
  44     png>>
  45     [ width>> ] [ height>> ] bi 2array ;
  46
  47 M: png-gadget draw-gadget* ( gadget -- )
  48     origin get [
  49         0 0 glRasterPos2i
  50         1.0 -1.0 glPixelZoom
  51         png>>
  52         [ width>> ]
  53         [ height>> GL_RGBA GL_UNSIGNED_BYTE ]
  54         ! [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
  55         [ array>> ] tri
  56         glDrawPixels
  57     ] with-translation ;
  58
  59 M: png-gadget graft* ( gadget -- )
  60     drop ;
  61
  62 M: png-gadget ungraft* ( gadget -- )
  63     png>> surface>> cairo_destroy ;
  64
  65 ! "resource:misc/icons/Factor_1x16.png" USE: cairo.png <png-gadget> gadget.