unmaintained: New home for misfit Factor vocabularies.

[factor-unmaintained.git] / opengl-gadgets / gadgets.factor

diff --git a/opengl-gadgets/gadgets.factor b/opengl-gadgets/gadgets.factor
new file mode 100644 (file)
index 0000000..70d7758
--- /dev/null
+++ b/opengl-gadgets/gadgets.factor
@@ -0,0 +1,116 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: locals math.functions math namespaces
+opengl.gl opengl.demo-support accessors kernel opengl ui.gadgets
+fry assocs
+destructors sequences ui.render colors ;
+IN: opengl.gadgets
+
+TUPLE: texture-gadget < gadget ;
+
+GENERIC: render* ( gadget -- texture dims )
+GENERIC: cache-key* ( gadget -- key )
+
+M: texture-gadget cache-key* ;
+
+SYMBOL: textures
+SYMBOL: refcounts
+
+: init-cache ( symbol -- )
+    dup get [ drop ] [ H{ } clone swap set-global ] if ;
+
+textures init-cache
+refcounts init-cache
+
+: refcount-change ( gadget quot -- )
+    [ cache-key* refcounts get [ [ 0 ] unless* ] ] dip compose change-at ;
+
+TUPLE: cache-entry tex dims ;
+C: <entry> cache-entry
+
+: make-entry ( gadget -- entry )
+    dup render* <entry>
+    [ swap cache-key* textures get set-at ] keep ;
+
+: get-entry ( gadget -- {texture,dims} )
+    dup cache-key* textures get at
+    [ ] [ make-entry ] ?if ;
+
+: get-dims ( gadget -- dims )
+    get-entry dims>> ;
+
+: get-texture ( gadget -- texture )
+    get-entry tex>> ;
+
+: release-texture ( gadget -- )
+    cache-key* textures get delete-at*
+    [ tex>> delete-texture ] [ drop ] if ;
+
+: clear-textures ( -- )
+    textures get values [ tex>> delete-texture ] each
+    H{ } clone textures set-global
+    H{ } clone refcounts set-global ;
+
+M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
+
+M: texture-gadget ungraft* ( gadget -- )
+    dup [ 1- ] refcount-change
+    dup cache-key* refcounts get at
+    zero? [ release-texture ] [ drop ] if ;
+
+: 2^-ceil ( x -- y )
+    dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
+
+: 2^-bounds ( dim -- dim' )
+    [ 2^-ceil ] map ; foldable flushable
+
+:: (render-bytes) ( dims bytes format texture -- )
+    GL_ENABLE_BIT [
+        GL_TEXTURE_2D glEnable
+        GL_TEXTURE_2D texture glBindTexture
+        GL_TEXTURE_2D
+        0
+        GL_RGBA
+        dims 2^-bounds first2
+        0
+        format
+        GL_UNSIGNED_BYTE
+        bytes
+        glTexImage2D
+        init-texture
+        GL_TEXTURE_2D 0 glBindTexture
+    ] do-attribs ;
+
+: render-bytes ( dims bytes format -- texture )
+    gen-texture [ (render-bytes) ] keep ;
+
+: render-bytes* ( dims bytes format -- texture dims )
+    pick [ render-bytes ] dip ;
+
+:: four-corners ( dim -- )
+    [let* | w [ dim first ]
+            h [ dim second ]
+            dim' [ dim dup 2^-bounds [ /f ] 2map ]
+            w' [ dim' first ]
+            h' [ dim' second ] |
+        0  0  glTexCoord2d 0 0 glVertex2d
+        0  h' glTexCoord2d 0 h glVertex2d
+        w' h' glTexCoord2d w h glVertex2d
+        w' 0  glTexCoord2d w 0 glVertex2d
+    ] ;
+
+M: texture-gadget draw-gadget* ( gadget -- )
+    origin get [
+        GL_ENABLE_BIT [
+            white gl-color
+            1.0 -1.0 glPixelZoom
+            GL_TEXTURE_2D glEnable
+            GL_TEXTURE_2D over get-texture glBindTexture
+            GL_QUADS [
+                get-dims four-corners
+            ] do-state
+            GL_TEXTURE_2D 0 glBindTexture
+        ] do-attribs
+    ] with-translation ;
+
+M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;