unmaintained/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     [ cache-key* refcounts get [ [ 0 ] unless* ] ] dip compose change-at ;
  27
  28 TUPLE: cache-entry tex dims ;
  29 C: <entry> cache-entry
  30
  31 : make-entry ( gadget -- entry )
  32     dup render* <entry>
  33     [ swap cache-key* textures get set-at ] keep ;
  34
  35 : get-entry ( gadget -- {texture,dims} )
  36     dup cache-key* textures get at
  37     [ ] [ make-entry ] ?if ;
  38
  39 : get-dims ( gadget -- dims )
  40     get-entry dims>> ;
  41
  42 : get-texture ( gadget -- texture )
  43     get-entry tex>> ;
  44
  45 : release-texture ( gadget -- )
  46     cache-key* textures get delete-at*
  47     [ tex>> delete-texture ] [ drop ] if ;
  48
  49 : clear-textures ( -- )
  50     textures get values [ tex>> delete-texture ] each
  51     H{ } clone textures set-global
  52     H{ } clone refcounts set-global ;
  53
  54 M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
  55
  56 M: texture-gadget ungraft* ( gadget -- )
  57     dup [ 1- ] refcount-change
  58     dup cache-key* refcounts get at
  59     zero? [ release-texture ] [ drop ] if ;
  60
  61 : 2^-ceil ( x -- y )
  62     dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
  63
  64 : 2^-bounds ( dim -- dim' )
  65     [ 2^-ceil ] map ; foldable flushable
  66
  67 :: (render-bytes) ( dims bytes format texture -- )
  68     GL_ENABLE_BIT [
  69         GL_TEXTURE_2D glEnable
  70         GL_TEXTURE_2D texture glBindTexture
  71         GL_TEXTURE_2D
  72         0
  73         GL_RGBA
  74         dims 2^-bounds first2
  75         0
  76         format
  77         GL_UNSIGNED_BYTE
  78         bytes
  79         glTexImage2D
  80         init-texture
  81         GL_TEXTURE_2D 0 glBindTexture
  82     ] do-attribs ;
  83
  84 : render-bytes ( dims bytes format -- texture )
  85     gen-texture [ (render-bytes) ] keep ;
  86
  87 : render-bytes* ( dims bytes format -- texture dims )
  88     pick [ render-bytes ] dip ;
  89
  90 :: four-corners ( dim -- )
  91     [let* | w [ dim first ]
  92             h [ dim second ]
  93             dim' [ dim dup 2^-bounds [ /f ] 2map ]
  94             w' [ dim' first ]
  95             h' [ dim' second ] |
  96         0  0  glTexCoord2d 0 0 glVertex2d
  97         0  h' glTexCoord2d 0 h glVertex2d
  98         w' h' glTexCoord2d w h glVertex2d
  99         w' 0  glTexCoord2d w 0 glVertex2d
 100     ] ;
 101
 102 M: texture-gadget draw-gadget* ( gadget -- )
 103     origin get [
 104         GL_ENABLE_BIT [
 105             white gl-color
 106             1.0 -1.0 glPixelZoom
 107             GL_TEXTURE_2D glEnable
 108             GL_TEXTURE_2D over get-texture glBindTexture
 109             GL_QUADS [
 110                 get-dims four-corners
 111             ] do-state
 112             GL_TEXTURE_2D 0 glBindTexture
 113         ] do-attribs
 114     ] with-translation ;
 115
 116 M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;