opengl.textures: clean up code, only create power-of-2 textures, make API nicer

basis/opengl/textures/textures-tests.factor

@@ -1,4 +1,51 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test opengl.textures ;
+USING: tools.test opengl.textures opengl.textures.private
+images kernel namespaces ;
 IN: opengl.textures.tests
+
+[ ] [
+    { 3 5 }
+    RGB
+    B{
+        1 2 3 4 5 6 7 8 9
+        10 11 12 13 14 15 16 17 18
+        19 20 21 22 23 24 25 26 27
+        28 29 30 31 32 33 34 35 36
+        37 38 39 40 41 42 43 44 45
+    } image boa "image" set
+] unit-test
+
+[
+    T{ image
+        { dim { 4 8 } }
+        { component-order RGB }
+        { bitmap
+          B{
+              1 2 3 4 5 6 7 8 9 0 0 0
+              10 11 12 13 14 15 16 17 18 0 0 0
+              19 20 21 22 23 24 25 26 27 0 0 0
+              28 29 30 31 32 33 34 35 36 0 0 0
+              37 38 39 40 41 42 43 44 45 0 0 0
+              0 0 0 0 0 0 0 0 0 0 0 0
+              0 0 0 0 0 0 0 0 0 0 0 0
+              0 0 0 0 0 0 0 0 0 0 0 0
+          }
+        }
+    }
+] [
+    "image" get power-of-2-image
+] unit-test
+
+[
+    T{ image
+       { dim { 0 0 } }
+       { component-order R32G32B32 }
+       { bitmap B{ } } }
+] [
+    T{ image
+       { dim { 0 0 } }
+       { component-order R32G32B32 }
+       { bitmap B{ } }
+    } power-of-2-image
+] unit-test

basis/opengl/textures/textures.factor

@@ -1,58 +1,17 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs cache colors.constants destructors fry
+USING: accessors assocs cache colors.constants destructors fry kernel
-kernel opengl opengl.gl combinators images endian
+opengl opengl.gl combinators images grouping specialized-arrays.float
-specialized-arrays.float locals sequences ;
+locals sequences math math.vectors generalizations ;
 IN: opengl.textures
 
-: init-texture ( -- )
+: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
-    GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
-    GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
-    GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameterf
-    GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameterf ;
 
-: rect-texture-coords ( -- )
+: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
-    float-array{ 0 0 1 0 1 1 0 1 } gl-texture-coord-pointer ;
 
-: gen-texture ( -- id )
+TUPLE: texture texture-coords texture display-list disposed ;
-    [ glGenTextures ] (gen-gl-object) ;
 
-:: make-texture ( dim pixmap format type -- id )
+<PRIVATE
-    gen-texture [
-        GL_TEXTURE_BIT [
-            GL_TEXTURE_2D swap glBindTexture
-            GL_TEXTURE_2D
-            0
-            GL_RGBA
-            dim first2
-            0
-            format
-            type
-            pixmap
-            glTexImage2D
-        ] do-attribs
-    ] keep ;
-
-: draw-textured-rect ( dim texture -- )
-    GL_TEXTURE_2D [
-        GL_TEXTURE_BIT [
-            GL_TEXTURE_COORD_ARRAY [
-                COLOR: white gl-color
-                GL_TEXTURE_2D swap glBindTexture
-                init-texture rect-texture-coords
-                fill-rect-vertices (gl-fill-rect)
-                GL_TEXTURE_2D 0 glBindTexture
-            ] do-enabled-client-state
-        ] do-attribs
-    ] do-enabled ;
-
-: delete-texture ( id -- )
-    [ glDeleteTextures ] (delete-gl-object) ;
-
-TUPLE: texture texture display-list disposed ;
-
-: make-texture-display-list ( dim texture -- dlist )
-    GL_COMPILE [ draw-textured-rect ] make-dlist ;
 
 GENERIC: component-order>format ( component-order -- format type )
 
@@ -60,15 +19,88 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
 M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
 M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8 ;
 
+: power-of-2-bitmap ( rows dim size -- bitmap dim )
+    '[
+        [ [ [ _ group ] map ] dip first '[ _ over peek pad-tail concat ] map ]
+        [ second over peek pad-tail ] bi
+        concat
+    ] keep ;
+
+: image-rows ( image -- rows )
+    [ bitmap>> ]
+    [ dim>> first ]
+    [ component-order>> bytes-per-component ]
+    tri * group ; inline
+
+: power-of-2-image ( image -- image )
+    dup dim>> [ 0 = ] all? [
+        clone dup
+        [ image-rows ]
+        [ dim>> [ next-power-of-2 ] map ]
+        [ component-order>> bytes-per-component ] tri
+        power-of-2-bitmap
+        [ >>bitmap ] [ >>dim ] bi*
+    ] unless ;
+
+:: make-texture ( image -- id )
+    gen-texture [
+        GL_TEXTURE_BIT [
+            GL_TEXTURE_2D swap glBindTexture
+            GL_TEXTURE_2D
+            0
+            GL_RGBA
+            image dim>> first2
+            0
+            image component-order>> component-order>format
+            image bitmap>>
+            glTexImage2D
+        ] do-attribs
+    ] keep ;
+
+: init-texture ( -- )
+    GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
+
+: draw-textured-rect ( dim texture -- )
+    GL_TEXTURE_2D [
+        GL_TEXTURE_BIT [
+            GL_TEXTURE_COORD_ARRAY [
+                COLOR: white gl-color
+                [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
+                [ init-texture texture-coords>> gl-texture-coord-pointer ] bi
+                fill-rect-vertices (gl-fill-rect)
+                GL_TEXTURE_2D 0 glBindTexture
+            ] do-enabled-client-state
+        ] do-attribs
+    ] do-enabled ;
+
+: texture-coords ( dim -- coords )
+    [ dup next-power-of-2 /f ] map
+    { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
+    float-array{ } join ;
+
+: make-texture-display-list ( dim texture -- dlist )
+    GL_COMPILE [ draw-textured-rect ] make-dlist ;
+
+PRIVATE>
+
 : <texture> ( image -- texture )
-    [
+    dup dim>> { 0 0 } = [ drop texture new ] [
         [ dim>> ]
-        [ bitmap>> ]
+        [ dim>> texture-coords ]
-        [ component-order>> component-order>format ]
+        [ power-of-2-image make-texture ] tri
-        tri make-texture
+        f f texture boa
-    ] [ dim>> ] bi
+        [ nip ] [ make-texture-display-list ] 2bi >>display-list
-    over make-texture-display-list f texture boa ;
+    ] if ;
 
 M: texture dispose*
-    [ texture>> delete-texture ]
+    [ texture>> [ delete-texture ] when* ]
-    [ display-list>> delete-dlist ] bi ;
+    [ display-list>> [ delete-dlist ] when* ] bi ;
+
+: draw-texture ( texture -- )
+    display-list>> [ glCallList ] when* ;
+
+: draw-scaled-texture ( dim texture -- )
+    dup texture>> [ draw-textured-rect ] [ 2drop ] if ;

basis/ui/images/images.factor

@@ -22,10 +22,10 @@ PRIVATE>
     world get image-texture-cache [ cached-image <texture> ] cache ;
 
 : draw-image ( image-name -- )
-    rendered-image display-list>> glCallList ;
+    rendered-image draw-texture ;
 
 : draw-scaled-image ( dim image-name -- )
-    rendered-image texture>> draw-textured-rect ;
+    rendered-image draw-scaled-texture ;
 
 : image-dim ( image-name -- dim )
     cached-image dim>> ;

basis/ui/text/core-text/core-text.factor

@@ -5,7 +5,7 @@ core-text.fonts kernel hashtables namespaces sequences
 ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl
 opengl.textures destructors combinators core-foundation
 core-foundation.strings math math.vectors init colors colors.constants
-cache arrays ;
+cache arrays images ;
 IN: ui.text.core-text
 
 SINGLETON: core-text-renderer
@@ -23,10 +23,12 @@ M: core-text-renderer finish-text-rendering
     cached-lines get purge-cache ;
 
 : rendered-line ( font string -- texture )
-    world get text-handle>> [ cached-line image>> <texture> ] 2cache ;
+    world get text-handle>>
+    [ cached-line image>> <texture> ]
+    2cache ;
 
 M: core-text-renderer draw-string ( font string -- )
-    rendered-line display-list>> glCallList ;
+    rendered-line draw-texture ;
 
 M: core-text-renderer x>offset ( x font string -- n )
     [ 2drop 0 ] [