opengl.textures: pad image up to a power of 2 using glTexSubImage2D instead of doing it in Factor code

basis/opengl/textures/textures.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs cache colors.constants destructors fry kernel
 opengl opengl.gl combinators images images.tesselation grouping
-specialized-arrays.float locals sequences math math.vectors
+specialized-arrays.float sequences math math.vectors
-math.matrices generalizations fry columns arrays ;
+math.matrices generalizations fry arrays ;
 IN: opengl.textures
 
 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
@@ -19,61 +19,42 @@ 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_BYTE ;
 M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
 
-GENERIC: draw-texture ( texture -- )
+SLOT: display-list
+
+: draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
 
 GENERIC: draw-scaled-texture ( dim texture -- )
 
 <PRIVATE
 
-TUPLE: single-texture image loc dim texture-coords texture display-list disposed ;
+TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
 
-: repeat-last ( seq n -- seq' )
+: (tex-image) ( image -- )
-    over peek pad-tail concat ;
+    [ GL_TEXTURE_2D 0 GL_RGBA ] dip
+    [ dim>> first2 [ next-power-of-2 ] bi@ 0 ]
+    [ component-order>> component-order>format f ] bi
+    glTexImage2D ;
 
-: power-of-2-bitmap ( rows dim size -- bitmap dim )
+: (tex-sub-image) ( image -- )
-    '[
+    [ GL_TEXTURE_2D 0 0 0 ] dip
-        first2
+    [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
-        [ [ _ ] dip '[ _ group _ repeat-last ] map ]
+    glTexSubImage2D ;
-        [ repeat-last ]
-        bi*
-    ] keep ;
 
-: image-rows ( image -- rows )
+: make-texture ( image -- id )
-    [ bitmap>> ]
+    #! We use glTexSubImage2D to work around the power of 2 texture size
-    [ dim>> first ]
+    #! limitation
-    [ component-order>> bytes-per-pixel ]
-    tri * group ; inline
-
-: power-of-2-image ( image -- image )
-    dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [
-        clone dup
-        [ image-rows ]
-        [ dim>> [ next-power-of-2 ] map ]
-        [ component-order>> bytes-per-pixel ] 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
+            [ (tex-image) ] [ (tex-sub-image) ] bi
-            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_MAG_FILTER GL_NEAREST glTexParameteri
-    GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
-    GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri
-    GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
 
 : with-texturing ( quot -- )
     GL_TEXTURE_2D [
@@ -101,7 +82,7 @@ TUPLE: single-texture image loc dim texture-coords texture display-list disposed
 
 : texture-coords ( texture -- coords )
     [
-        [ dim>> ] [ image>> dim>> ] bi v/
+        [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/
         { { 0 0 } { 1 0 } { 1 1 } { 0 1 } }
         [ v* ] with map
     ] keep
@@ -111,9 +92,8 @@ TUPLE: single-texture image loc dim texture-coords texture display-list disposed
 : make-texture-display-list ( texture -- dlist )
     GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
 
-: <single-texture> ( image loc dim -- texture )
+: <single-texture> ( image loc -- texture )
-    [ power-of-2-image ] 2dip
+    single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi
-    single-texture new swap >>dim swap >>loc swap >>image
     dup image>> dim>> product 0 = [
         dup texture-coords >>texture-coords
         dup image>> make-texture >>texture
@@ -124,21 +104,19 @@ M: single-texture dispose*
     [ texture>> [ delete-texture ] when* ]
     [ display-list>> [ delete-dlist ] when* ] bi ;
 
-M: single-texture draw-texture display-list>> [ glCallList ] when* ;
-
 M: single-texture draw-scaled-texture
     dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
 
 TUPLE: multi-texture grid display-list loc disposed ;
 
 : image-locs ( image-grid -- loc-grid )
-    [ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
+    [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi
     [ 0 [ + ] accumulate nip ] bi@
     cross-zip flip ;
 
 : <texture-grid> ( image-grid loc -- grid )
     [ dup image-locs ] dip
-    '[ [ _ v+ over dim>> <single-texture> |dispose ] 2map ] 2map ;
+    '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
 
 : draw-textured-grid ( grid -- )
     [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
@@ -165,18 +143,13 @@ TUPLE: multi-texture grid display-list loc disposed ;
         f multi-texture boa
     ] with-destructors ;
 
-M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
-
 M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
 
 CONSTANT: max-texture-size { 512 512 }
 
 PRIVATE>
 
-: small-texture? ( dim -- ? )
+: <texture> ( image loc -- texture )
-    max-texture-size [ <= ] 2all? ;
+    over dim>> max-texture-size [ <= ] 2all?
-
-: <texture> ( image loc dim -- texture )
-    pick dim>> small-texture?
     [ <single-texture> ]
-    [ drop [ max-texture-size tesselate ] dip <multi-texture> ] if ;
+    [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;

basis/ui/images/images.factor

@@ -20,7 +20,7 @@ PRIVATE>
 
 : rendered-image ( path -- texture )
     world get image-texture-cache
-    [ cached-image [ { 0 0 } ] keep dim>> <texture> ] cache ;
+    [ cached-image { 0 0 } <texture> ] cache ;
 
 : draw-image ( image-name -- )
     rendered-image draw-texture ;

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

@@ -20,9 +20,7 @@ M: core-text-renderer flush-layout-cache
 
 : rendered-line ( font string -- texture )
     world get world-text-handle [
-        cached-line
+        cached-line [ image>> ] [ loc>> ] bi <texture>
-        [ image>> ] [ loc>> ] [ image>> dim>> ] tri
-        <texture>
     ] 2cache ;
 
 M: core-text-renderer draw-string ( font string -- )

basis/ui/text/pango/pango.factor

@@ -16,9 +16,7 @@ M: pango-renderer flush-layout-cache
 
 : rendered-layout ( font string -- texture )
     world get world-text-handle [
-        cached-layout
+        cached-layout [ image>> ] [ text-position vneg ] bi <texture>
-        [ image>> ] [ text-position vneg ] [ image>> dim>> ] tri
-        <texture>
     ] 2cache ;
 
 M: pango-renderer draw-string ( font string -- )

basis/ui/text/uniscribe/uniscribe.factor

@@ -16,7 +16,7 @@ M: uniscribe-renderer flush-layout-cache
 
 : rendered-script-string ( font string -- texture )
     world get world-text-handle
-    [ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi <texture> ]
+    [ cached-script-string image>> { 0 0 } <texture> ]
     2cache ;
 
 M: uniscribe-renderer draw-string ( font string -- )

basis/windows/uniscribe/uniscribe.factor

@@ -71,11 +71,8 @@ TUPLE: script-string font string metrics ssa size image disposed ;
 : draw-script-string ( dc script-string -- )
     [ font>> set-dc-colors ] keep (draw-script-string) ;
 
-: script-string-bitmap-size ( script-string -- dim )
-    size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
-
 :: make-script-string-image ( dc script-string -- image )
-    script-string script-string-bitmap-size dc
+    script-string size>> dc
     [ dc script-string draw-script-string ] make-bitmap-image ;
 
 : set-dc-font ( dc font -- )