extra/opengl/gadgets/gadgets.factor

   1 ! Copyright (C) 2008 Matthew Willis.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: locals math.functions math namespaces
   4 opengl.gl accessors kernel opengl ui.gadgets
   5 fry assocs
   6 destructors sequences ui.render colors ;
   7 IN: opengl.gadgets
   8
   9 TUPLE: texture-gadget ;
  10
  11 GENERIC: render* ( gadget -- texture dims )
  12 GENERIC: cache-key* ( gadget -- key )
  13
  14 M: texture-gadget cache-key* ;
  15
  16 SYMBOL: textures
  17 SYMBOL: refcounts
  18
  19 : init-cache ( symbol -- )
  20     dup get [ drop ] [ H{ } clone swap set-global ] if ;
  21
  22 textures init-cache
  23 refcounts init-cache
  24
  25 : refcount-change ( gadget quot -- )
  26     >r cache-key* refcounts get
  27     [ [ 0 ] unless* ] r> compose change-at ;
  28
  29 TUPLE: cache-entry tex dims ;
  30 C: <entry> cache-entry
  31
  32 : make-entry ( gadget -- entry )
  33     dup render* <entry>
  34     [ swap cache-key* textures get set-at ] keep ;
  35
  36 : get-entry ( gadget -- {texture,dims} )
  37     dup cache-key* textures get at
  38     [ nip ] [ make-entry ] if* ;
  39
  40 : get-dims ( gadget -- dims )
  41     get-entry dims>> ;
  42
  43 : get-texture ( gadget -- texture )
  44     get-entry tex>> ;
  45
  46 : release-texture ( gadget -- )
  47     cache-key* textures get delete-at*
  48     [ tex>> delete-texture ] [ drop ] if ;
  49
  50 M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
  51
  52 M: texture-gadget ungraft* ( gadget -- )
  53     dup [ 1- ] refcount-change
  54     dup cache-key* refcounts get at
  55     zero? [ release-texture ] [ drop ] if ;
  56
  57 : 2^-ceil ( x -- y )
  58     dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
  59
  60 : 2^-bounds ( dim -- dim' )
  61     [ 2^-ceil ] map ; foldable flushable
  62
  63 :: (render-bytes) ( dims bytes format texture -- )
  64     GL_ENABLE_BIT [
  65         GL_TEXTURE_2D glEnable
  66         GL_TEXTURE_2D texture glBindTexture
  67         GL_TEXTURE_2D
  68         0
  69         GL_RGBA
  70         dims 2^-bounds first2
  71         0
  72         format
  73         GL_UNSIGNED_BYTE
  74         bytes
  75         glTexImage2D
  76         init-texture
  77         GL_TEXTURE_2D 0 glBindTexture
  78     ] do-attribs ;
  79
  80 : render-bytes ( dims bytes format -- texture )
  81     gen-texture [ (render-bytes) ] keep ;
  82
  83 : render-bytes* ( dims bytes format -- texture dims )
  84     pick >r render-bytes r> ;
  85
  86 :: four-corners ( dim -- )
  87     [let* | w [ dim first ]
  88             h [ dim second ]
  89             dim' [ dim dup 2^-bounds [ /f ] 2map ]
  90             w' [ dim' first ]
  91             h' [ dim' second ] |
  92         0  0  glTexCoord2d 0 0 glVertex2d
  93         0  h' glTexCoord2d 0 h glVertex2d
  94         w' h' glTexCoord2d w h glVertex2d
  95         w' 0  glTexCoord2d w 0 glVertex2d
  96     ] ;
  97
  98 M: texture-gadget draw-gadget* ( gadget -- )
  99     origin get [
 100         GL_ENABLE_BIT [
 101             white gl-color
 102             1.0 -1.0 glPixelZoom
 103             GL_TEXTURE_2D glEnable
 104             GL_TEXTURE_2D over get-texture glBindTexture
 105             GL_QUADS [
 106                 get-dims four-corners
 107             ] do-state
 108             GL_TEXTURE_2D 0 glBindTexture
 109         ] do-attribs
 110     ] with-translation ;
 111
 112 M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;