Fix text rendering for fonts where the image bounds exceed the metric bounds, such as Zapfino and Arabic fonts

basis/core-graphics/core-graphics-tests.factor

@@ -3,4 +3,6 @@
 USING: tools.test core-graphics kernel images ;
 IN: core-graphics.tests
 
-[ t ] [ { 100 200 } [ drop ] make-bitmap-image image? ] unit-test
+[ t ] [ { 100 200 } [ drop ] make-bitmap-image image? ] unit-test
+
+[ ] [ dummy-context drop ] unit-test

basis/core-graphics/core-graphics.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.destructors alien.syntax accessors
+USING: alien alien.c-types alien.destructors alien.syntax accessors
 destructors fry kernel math math.bitwise sequences libc colors
 images core-graphics.types core-foundation.utilities ;
 IN: core-graphics
@@ -117,8 +117,8 @@ FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
 : bitmap-color-space ( -- color-space )
     CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;
 
-: <CGBitmapContext> ( dim -- context )
-    [ malloc-bitmap-data ] [ first2 8 ] [ first 4 * ] tri
+: <CGBitmapContext> ( data dim -- context )
+    [ first2 8 ] [ first 4 * ] bi
     bitmap-color-space bitmap-flags CGBitmapContextCreate
     [ "CGBitmapContextCreate failed" throw ] unless* ;
 
@@ -134,8 +134,13 @@ FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
 
 PRIVATE>
 
+: dummy-context ( -- context )
+    \ dummy-context [
+        [ 4 malloc { 1 1 } <CGBitmapContext> ] with-destructors
+    ] initialize-alien ;
+
 : make-bitmap-image ( dim quot -- image )
     [
-        [ [ <CGBitmapContext> &CGContextRelease ] keep ] dip
+        [ [ [ malloc-bitmap-data ] keep <CGBitmapContext> &CGContextRelease ] keep ] dip
         [ nip call ] [ drop [ bitmap-data ] keep <bitmap-image> ] 3bi
     ] with-destructors ; inline

basis/core-graphics/types/types.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel layouts math ;
+USING: alien.c-types alien.syntax kernel layouts
+math math.rectangles arrays ;
 IN: core-graphics.types
 
 << cell 4 = "float" "double" ? "CGFloat" typedef >>
@@ -33,6 +34,17 @@ C-STRUCT: CGRect
     { "CGPoint" "origin" }
     { "CGSize"  "size"   } ;
 
+: CGPoint>loc ( CGPoint -- loc )
+    [ CGPoint-x ] [ CGPoint-y ] bi 2array ;
+
+: CGSize>dim ( CGSize -- dim )
+    [ CGSize-w ] [ CGSize-h ] bi 2array ;
+
+: CGRect>rect ( CGRect -- rect )
+    [ CGRect-origin CGPoint>loc ]
+    [ CGRect-size CGSize>dim ]
+    bi <rect> ; inline
+
 : CGRect-x ( CGRect -- x )
     CGRect-origin CGPoint-x ; inline
 : CGRect-y ( CGRect -- y )

basis/core-text/core-text.factor

@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays alien alien.c-types alien.syntax kernel destructors
 accessors fry words hashtables strings sequences memoize assocs math
-math.functions locals init namespaces combinators fonts colors cache
-core-foundation core-foundation.strings core-foundation.attributed-strings
-core-foundation.utilities core-graphics core-graphics.types
-core-text.fonts core-text.utilities ;
+math.vectors math.rectangles math.functions locals init namespaces
+combinators fonts colors cache core-foundation core-foundation.strings
+core-foundation.attributed-strings core-foundation.utilities
+core-graphics core-graphics.types core-text.fonts core-text.utilities ;
 IN: core-text
 
 TYPEDEF: void* CTLineRef
@@ -46,7 +46,7 @@ ERROR: not-a-string object ;
         CTLineCreateWithAttributedString
     ] with-destructors ;
 
-TUPLE: line font line metrics image disposed ;
+TUPLE: line font line metrics image loc dim disposed ;
 
 : compute-line-metrics ( open-font line -- line-metrics )
     [
@@ -65,7 +65,7 @@ TUPLE: line font line metrics image disposed ;
     } spread
     dup compute-height ;
 
-: bounds>dim ( bounds -- dim )
+: metrics>dim ( bounds -- dim )
     [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
     [ ceiling >integer ]
     bi@ 2array ;
@@ -80,30 +80,48 @@ TUPLE: line font line metrics image disposed ;
     [ f CTLineGetOffsetForStringIndex round ] bi-curry@ bi
     [ drop nip 0 ] [ swap - swap second ] 3bi <CGRect> ;
 
-:: fill-selection-background ( context dim line string -- )
+:: fill-selection-background ( context loc dim line string -- )
     string selection? [
         context string color>> >rgba-components CGContextSetRGBFillColor
-        context dim line string selection-rect CGContextFillRect
+        context dim line string selection-rect
+        dup CGRect-x loc first - over set-CGRect-x
+        CGContextFillRect
     ] when ;
 
-: set-text-position ( context metrics -- )
-    [ 0 ] dip descent>> ceiling CGContextSetTextPosition ;
+: line-rect ( line -- rect )
+    dummy-context CTLineGetImageBounds ;
+
+: set-text-position ( context loc -- )
+    first2 [ neg ] bi@ CGContextSetTextPosition ;
+
+:: line-loc ( metrics loc dim -- loc )
+    loc first
+    metrics ascent>> ceiling dim second loc second + - 2array ;
 
 :: <line> ( font string -- line )
     [
         [let* | open-font [ font cache-font CFRetain |CFRelease ]
                 line [ string open-font font foreground>> <CTLine> |CFRelease ]
-                metrics [ open-font line compute-line-metrics ]
-                dim [ metrics bounds>dim ] |
+
+                rect [ line line-rect ]
+                (loc) [ rect CGRect-origin CGPoint>loc ]
+                (dim) [ rect CGRect-size CGSize>dim ]
+                (ext) [ (loc) (dim) v+ ]
+                loc [ (loc) [ floor ] map ]
+                ext [ (loc) (dim) [ + ceiling ] 2map ]
+                dim [ ext loc [ - >integer ] 2map ]
+                metrics [ open-font line compute-line-metrics ] |
             open-font line metrics
             dim [
                 {
                     [ font dim fill-background ]
-                    [ dim line string fill-selection-background ]
-                    [ metrics set-text-position ]
+                    [ loc dim line string fill-selection-background ]
+                    [ loc set-text-position ]
                     [ [ line ] dip CTLineDraw ]
                 } cleave
             ] make-bitmap-image
+            metrics loc dim line-loc
+            metrics metrics>dim
         ]
         f line boa
     ] with-destructors ;

basis/opengl/textures/textures.factor

@@ -9,7 +9,7 @@ IN: opengl.textures
 
 : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
 
-TUPLE: texture texture-coords texture display-list disposed ;
+TUPLE: texture loc dim texture-coords texture display-list disposed ;
 
 <PRIVATE
 
@@ -72,10 +72,12 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8 ;
         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
+                dup loc>> [
+                    [ [ 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
+                ] with-translation
             ] do-enabled-client-state
         ] do-attribs
     ] do-enabled ;
@@ -85,19 +87,21 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8 ;
     { { 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 ;
+: make-texture-display-list ( texture -- dlist )
+    GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
 
 PRIVATE>
 
-: <texture> ( image -- texture )
-    dup dim>> { 0 0 } = [ drop texture new ] [
-        [ dim>> ]
-        [ dim>> texture-coords ]
-        [ power-of-2-image make-texture ] tri
-        f f texture boa
-        [ nip ] [ make-texture-display-list ] 2bi >>display-list
-    ] if ;
+: <texture> ( image loc -- texture )
+    texture new swap >>loc
+    swap
+    [ dim>> >>dim ] keep
+    [ dim>> { 0 0 } = ] keep '[
+        _
+        [ dim>> texture-coords >>texture-coords ]
+        [ power-of-2-image make-texture >>texture ] bi
+        dup make-texture-display-list >>display-list
+    ] unless ;
 
 M: texture dispose*
     [ texture>> [ delete-texture ] when* ]

basis/ui/gadgets/editors/editors.factor

@@ -169,11 +169,12 @@ TUPLE: selected-line start end first? last? ;
         '[ [ _ _ ] keep _ start/end-on-line 2array ] H{ } map>assoc
     ] [ drop f ] if ;
 
-:: draw-empty-selection ( line pair editor -- )
-    editor font>> :> font
-    pair first font line offset>x 0 2array [
+:: draw-selection ( line pair editor -- )
+    pair [ editor font>> line offset>x ] map :> pair
+    pair first 0 2array [
         editor selection-color>> gl-color
-        1 font font-metrics height>> 2array gl-fill-rect
+        pair second pair first - round 1 max
+        editor line-height 2array gl-fill-rect
     ] with-translation ;
 
 : draw-unselected-line ( line editor -- )
@@ -181,10 +182,13 @@ TUPLE: selected-line start end first? last? ;
 
 : draw-selected-line ( line pair editor -- )
     over all-equal? [
-        [ nip draw-unselected-line ] [ draw-empty-selection ] 3bi
+        [ nip draw-unselected-line ] [ draw-selection ] 3bi
     ] [
-        [ [ first2 ] [ selection-color>> ] bi* <selection> ] keep
-        draw-unselected-line
+        [ draw-selection ]
+        [
+            [ [ first2 ] [ selection-color>> ] bi* <selection> ] keep
+            draw-unselected-line
+        ] 3bi
     ] if ;
 
 M: editor draw-line ( line index editor -- )
@@ -197,7 +201,8 @@ M: editor draw-gadget*
     ] with-variable ;
 
 M: editor pref-dim*
-    [ font>> ] [ control-value ] bi text-dim ;
+    ! Add some space for the caret.
+    [ font>> ] [ control-value ] bi text-dim { 1 0 } v+ ;
 
 M: editor baseline font>> font-metrics ascent>> ;
 

basis/ui/gadgets/line-support/line-support.factor

@@ -21,7 +21,7 @@ M: line-gadget line-leading font>> font-metrics leading>> ;
 
 GENERIC: line-height ( gadget -- n )
 
-M: line-gadget line-height font>> font-metrics height>> ;
+M: line-gadget line-height font>> font-metrics height>> ceiling ;
 
 : y>line ( y gadget -- n ) line-height /i ;
 

basis/ui/gadgets/panes/panes.factor

@@ -213,8 +213,12 @@ MEMO: specified-font ( assoc -- font )
 : apply-image-style ( style gadget -- style gadget )
     image [ nip <image-name> <icon> ] apply-style ;
 
+: apply-background-style ( style gadget -- style gadget )
+    background [ <solid> >>interior ] apply-style ;
+
 : style-label ( style gadget -- gadget )
     apply-font-style
+    apply-background-style
     apply-presentation-style
     apply-image-style
     nip ; inline

basis/ui/images/images.factor

@@ -19,7 +19,8 @@ MEMO: cached-image ( image-name -- image ) path>> load-image ;
 PRIVATE>
 
 : rendered-image ( path -- texture )
-    world get image-texture-cache [ cached-image <texture> ] cache ;
+    world get image-texture-cache
+    [ cached-image { 0 0 } <texture> ] cache ;
 
 : draw-image ( image-name -- )
     rendered-image draw-texture ;

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

@@ -15,7 +15,7 @@ M: core-text-renderer init-text-rendering
 
 M: core-text-renderer string-dim
     [ " " string-dim { 0 1 } v* ]
-    [ cached-line image>> dim>> ]
+    [ cached-line dim>> ]
     if-empty ;
 
 M: core-text-renderer finish-text-rendering
@@ -24,7 +24,7 @@ M: core-text-renderer finish-text-rendering
 
 : rendered-line ( font string -- texture )
     world get text-handle>>
-    [ cached-line image>> <texture> ]
+    [ cached-line [ image>> ] [ loc>> ] bi <texture> ]
     2cache ;
 
 M: core-text-renderer draw-string ( font string -- )