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 opengl.demo-support accessors kernel opengl ui.gadgets
   5 fry assocs
   6 destructors sequences ui.render colors ;
   7 IN: opengl.gadgets
   8
   9 TUPLE: texture-gadget < 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 : clear-textures ( -- )
  51     textures get values [ tex>> delete-texture ] each
  52     H{ } clone textures set-global
  53     H{ } clone refcounts set-global ;
  54
  55 M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
  56
  57 M: texture-gadget ungraft* ( gadget -- )
  58     dup [ 1- ] refcount-change
  59     dup cache-key* refcounts get at
  60     zero? [ release-texture ] [ drop ] if ;
  61
  62 : 2^-ceil ( x -- y )
  63     dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
  64
  65 : 2^-bounds ( dim -- dim' )
  66     [ 2^-ceil ] map ; foldable flushable
  67
  68 :: (render-bytes) ( dims bytes format texture -- )
  69     GL_ENABLE_BIT [
  70         GL_TEXTURE_2D glEnable
  71         GL_TEXTURE_2D texture glBindTexture
  72         GL_TEXTURE_2D
  73         0
  74         GL_RGBA
  75         dims 2^-bounds first2
  76         0
  77         format
  78         GL_UNSIGNED_BYTE
  79         bytes
  80         glTexImage2D
  81         init-texture
  82         GL_TEXTURE_2D 0 glBindTexture
  83     ] do-attribs ;
  84
  85 : render-bytes ( dims bytes format -- texture )
  86     gen-texture [ (render-bytes) ] keep ;
  87
  88 : render-bytes* ( dims bytes format -- texture dims )
  89     pick >r render-bytes r> ;
  90
  91 :: four-corners ( dim -- )
  92     [let* | w [ dim first ]
  93             h [ dim second ]
  94             dim' [ dim dup 2^-bounds [ /f ] 2map ]
  95             w' [ dim' first ]
  96             h' [ dim' second ] |
  97         0  0  glTexCoord2d 0 0 glVertex2d
  98         0  h' glTexCoord2d 0 h glVertex2d
  99         w' h' glTexCoord2d w h glVertex2d
 100         w' 0  glTexCoord2d w 0 glVertex2d
 101     ] ;
 102
 103 M: texture-gadget draw-gadget* ( gadget -- )
 104     origin get [
 105         GL_ENABLE_BIT [
 106             white gl-color
 107             1.0 -1.0 glPixelZoom
 108             GL_TEXTURE_2D glEnable
 109             GL_TEXTURE_2D over get-texture glBindTexture
 110             GL_QUADS [
 111                 get-dims four-corners
 112             ] do-state
 113             GL_TEXTURE_2D 0 glBindTexture
 114         ] do-attribs
 115     ] with-translation ;
 116
 117 M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;