Add textures without alpha channels, cropping; update usages of <texture>; don't ignore trailing in x>offset

basis/images/images.factor

@@ -1,11 +1,13 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel ;
+USING: combinators kernel accessors ;
 IN: images
 
 SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
 R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
 
+UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
+
 : bytes-per-pixel ( component-order -- n )
     {
         { L [ 1 ] }
@@ -29,4 +31,6 @@ TUPLE: image dim component-order upside-down? bitmap ;
 
 : <image> ( -- image ) image new ; inline
 
+: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
+
 GENERIC: load-image* ( path tuple -- image )

basis/opengl/textures/textures.factor

@@ -3,7 +3,7 @@
 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
-math.matrices generalizations fry columns ;
+math.matrices generalizations fry columns arrays ;
 IN: opengl.textures
 
 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
@@ -25,7 +25,7 @@ GENERIC: draw-scaled-texture ( dim texture -- )
 
 <PRIVATE
 
-TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
+TUPLE: single-texture image loc dim texture-coords texture display-list disposed ;
 
 : repeat-last ( seq n -- seq' )
     over peek pad-tail concat ;
@@ -45,7 +45,7 @@ TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
     tri * group ; inline
 
 : power-of-2-image ( image -- image )
-    dup dim>> [ 0 = ] all? [
+    dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [
         clone dup
         [ image-rows ]
         [ dim>> [ next-power-of-2 ] map ]
@@ -93,26 +93,30 @@ TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
 
 : draw-textured-rect ( dim texture -- )
     [
-        (draw-textured-rect)
-        GL_TEXTURE_2D 0 glBindTexture
+        [ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
+        [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
+        [ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
+        tri
     ] with-texturing ;
 
-: texture-coords ( dim -- coords )
-    [ dup next-power-of-2 /f ] map
-    { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
+: texture-coords ( texture -- coords )
+    [
+        [ dim>> ] [ image>> dim>> ] bi v/
+        { { 0 0 } { 1 0 } { 1 1 } { 0 1 } }
+        [ v* ] with map
+    ] keep
+    image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when
     float-array{ } join ;
 
 : make-texture-display-list ( texture -- dlist )
     GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
 
-: <single-texture> ( image loc -- texture )
-   single-texture new swap >>loc
-    swap
-    [ dim>> >>dim ] keep
-    [ dim>> product 0 = ] keep '[
-        _
-        [ dim>> texture-coords >>texture-coords ]
-        [ power-of-2-image make-texture >>texture ] bi
+: <single-texture> ( image loc dim -- texture )
+    [ power-of-2-image ] 2dip
+    single-texture new swap >>dim swap >>loc swap >>image
+    dup image>> dim>> product 0 = [
+        dup texture-coords >>texture-coords
+        dup image>> make-texture >>texture
         dup make-texture-display-list >>display-list
     ] unless ;
 
@@ -134,19 +138,20 @@ TUPLE: multi-texture grid display-list loc disposed ;
 
 : <texture-grid> ( image-grid loc -- grid )
     [ dup image-locs ] dip
-    '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
+    '[ [ _ v+ over dim>> <single-texture> |dispose ] 2map ] 2map ;
 
 : draw-textured-grid ( grid -- )
     [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
 
+: grid-has-alpha? ( grid -- ? )
+    first first image>> has-alpha? ;
+
 : make-textured-grid-display-list ( grid -- dlist )
     GL_COMPILE [
         [
-            [
-                [
-                    [ dim>> ] keep (draw-textured-rect)
-                ] each
-            ] each
+            [ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
+            [ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ]
+            [ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
             GL_TEXTURE_2D 0 glBindTexture
         ] with-texturing
     ] make-dlist ;
@@ -164,11 +169,14 @@ M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
 
 M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
 
-CONSTANT: max-texture-size { 256 256 }
+CONSTANT: max-texture-size { 512 512 }
 
 PRIVATE>
 
-: <texture> ( image loc -- texture )
-    over dim>> max-texture-size [ <= ] 2all?
+: small-texture? ( dim -- ? )
+    max-texture-size [ <= ] 2all? ;
+
+: <texture> ( image loc dim -- texture )
+    pick dim>> small-texture?
     [ <single-texture> ]
-    [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
+    [ drop [ 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 } <texture> ] cache ;
+    [ cached-image [ { 0 0 } ] keep dim>> <texture> ] cache ;
 
 : draw-image ( image-name -- )
     rendered-image draw-texture ;

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

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

basis/ui/text/pango/pango.factor

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

basis/ui/text/uniscribe/summary.txt

@@ -1 +1 @@
-UI text rendering implementation using MS Windows Uniscribe library
+UI text rendering implementation using the MS Windows Uniscribe library

basis/ui/text/uniscribe/uniscribe.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs cache kernel math.vectors sequences
+USING: accessors assocs cache kernel math math.vectors sequences fonts
 namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds 
 windows.uniscribe ;
 IN: ui.text.uniscribe
@@ -16,15 +16,16 @@ M: uniscribe-renderer flush-layout-cache
 
 : rendered-script-string ( font string -- texture )
     world get world-text-handle
-    [ cached-script-string [ image>> ] [ text-position vneg ] bi <texture> ]
+    [ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi <texture> ]
     2cache ;
 
 M: uniscribe-renderer draw-string ( font string -- )
-    [ drop ] [ rendered-script-string draw-texture ] if-empty ;
+    dup dup selection? [ string>> ] when empty?
+    [ 2drop ] [ rendered-script-string draw-texture ] if ;
 
 M: uniscribe-renderer x>offset ( x font string -- n )
     [ 2drop 0 ] [
-        cached-script-string x>line-offset drop
+        cached-script-string x>line-offset 0 = [ 1+ ] unless
     ] if-empty ;
 
 M: uniscribe-renderer offset>x ( n font string -- x )