Debugging Core Text, get colored text working and fix memory management issue

basis/cocoa/cocoa-tests.factor

@@ -1,7 +1,7 @@
 IN: cocoa.tests
 USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
 compiler kernel namespaces cocoa.classes tools.test memory
-compiler.units math ;
+compiler.units math core-graphics.types ;
 
 CLASS: {
     { +superclass+ "NSObject" }
@@ -15,15 +15,15 @@ CLASS: {
 
 : test-foo
     Foo -> alloc -> init
-    dup 1.0 2.0 101.0 102.0 <NSRect> -> foo:
+    dup 1.0 2.0 101.0 102.0 <CGRect> -> foo:
     -> release ;
 
 test-foo
 
-[ 1.0 ] [ "x" get NSRect-x ] unit-test
+[ 1.0 ] [ "x" get CGRect-x ] unit-test
-[ 2.0 ] [ "x" get NSRect-y ] unit-test
+[ 2.0 ] [ "x" get CGRect-y ] unit-test
-[ 101.0 ] [ "x" get NSRect-w ] unit-test
+[ 101.0 ] [ "x" get CGRect-w ] unit-test
-[ 102.0 ] [ "x" get NSRect-h ] unit-test
+[ 102.0 ] [ "x" get CGRect-h ] unit-test
 
 CLASS: {
     { +superclass+ "NSObject" }
@@ -41,10 +41,10 @@ Bar [
     -> release
 ] compile-call
 
-[ 1.0 ] [ "x" get NSRect-x ] unit-test
+[ 1.0 ] [ "x" get CGRect-x ] unit-test
-[ 2.0 ] [ "x" get NSRect-y ] unit-test
+[ 2.0 ] [ "x" get CGRect-y ] unit-test
-[ 101.0 ] [ "x" get NSRect-w ] unit-test
+[ 101.0 ] [ "x" get CGRect-w ] unit-test
-[ 102.0 ] [ "x" get NSRect-h ] unit-test
+[ 102.0 ] [ "x" get CGRect-h ] unit-test
 
 ! Make sure that we can add methods
 CLASS: {
@@ -52,7 +52,7 @@ CLASS: {
     { +name+ "Bar" }
 } {
     "bar"
-    "NSRect"
+    "CGRect"
     { "id" "SEL" }
     [ 2drop test-foo "x" get ]
 } {

basis/cocoa/enumeration/enumeration.factor

@@ -8,12 +8,11 @@ IN: cocoa.enumeration
 : NS-EACH-BUFFER-SIZE 16 ; inline
 
 : with-enumeration-buffers ( quot -- )
-    [
+    '[
-        [
         "NSFastEnumerationState" malloc-object &free
-            NS-EACH-BUFFER-SIZE "id" heap-size * malloc-object &free
+        NS-EACH-BUFFER-SIZE "id" malloc-array &free
         NS-EACH-BUFFER-SIZE
-        ] dip call
+        @
     ] with-destructors ; inline
 
 :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )

basis/cocoa/plists/plists-tests.factor

@@ -0,0 +1,10 @@
+IN: cocoa.plists.tests
+USING: tools.test cocoa.plists colors kernel hashtables
+core-foundation.utilities core-foundation destructors
+assocs cocoa.enumeration ;
+
+[
+    [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
+    [ V{ "A" } ] [ { "A" } >cf &CFRelease plist> ] unit-test
+    [ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
+] with-destructors

basis/cocoa/plists/plists.factor

@@ -32,7 +32,7 @@ DEFER: plist>
     [ plist> ] NSFastEnumeration-map ;
 
 : (plist-NSDictionary>) ( NSDictionary -- hashtable )
-    dup [ [ -> valueForKey: ] keep swap [ plist> ] bi@ 2array ] with
+    dup [ tuck -> valueForKey: [ plist> ] bi@ 2array ] with
     NSFastEnumeration-map >hashtable ;
 
 : (read-plist) ( NSData -- id )

basis/colors/colors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2009 Slava Pestov.
 ! Copyright (C) 2008 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors ;
+USING: kernel accessors combinators ;
 IN: colors
 
 TUPLE: color ;
@@ -18,6 +18,9 @@ M: color red>> ( color -- red   ) >rgba red>> ;
 M: color green>> ( color -- green ) >rgba green>> ;
 M: color blue>> ( color -- blue  ) >rgba blue>> ;
 
+: >rgba-components ( object -- r g b a )
+    >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
+
 CONSTANT: black T{ rgba f 0.0 0.0 0.0 1.0 }
 CONSTANT: blue T{ rgba f 0.0 0.0 1.0 1.0 }
 CONSTANT: cyan T{ rgba f 0 0.941 0.941 1 }

basis/core-foundation/dictionaries/dictionaries.factor

@@ -27,6 +27,6 @@ FUNCTION: void* CFDictionaryGetValue (
     [ kCFAllocatorDefault ] dip
     unzip [ >void*-array ] bi@
     [ [ underlying>> ] bi@ ] [ nip length ] 2bi
-    &: kCFTypeDictionaryCallBacks
+    &: kCFTypeDictionaryKeyCallBacks
-    &: kCFTypeDictionaryValueCallbacks
+    &: kCFTypeDictionaryValueCallBacks
     CFDictionaryCreate ;

basis/core-graphics/core-graphics.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.destructors alien.syntax
-destructors fry kernel math sequences libc
+destructors fry kernel math sequences libc colors
-core-graphics.types ;
+core-graphics.types core-foundation.utilities ;
 IN: core-graphics
 
 ! CGImageAlphaInfo
@@ -25,6 +25,18 @@ kCGImageAlphaNoneSkipFirst ;
 : kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline
 : kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline
 
+FUNCTION: CGColorRef CGColorCreateGenericRGB (
+   CGFloat red,
+   CGFloat green,
+   CGFloat blue,
+   CGFloat alpha
+) ;
+
+: <CGColor> ( color -- CGColor )
+    >rgba-components CGColorCreateGenericRGB ;
+
+M: color (>cf) <CGColor> ;
+
 FUNCTION: CGColorSpaceRef CGColorSpaceCreateDeviceRGB ( ) ;
 
 FUNCTION: CGContextRef CGBitmapContextCreate (

basis/core-graphics/types/types.factor

@@ -69,6 +69,7 @@ C-STRUCT: CGAffineTransform
     { "CGFloat" "tx" }
     { "CGFloat" "ty" } ;
 
+TYPEDEF: void* CGColorRef
 TYPEDEF: void* CGColorSpaceRef
 TYPEDEF: void* CGContextRef
 TYPEDEF: uint CGBitmapInfo

basis/core-text/core-text-tests.factor

@@ -3,11 +3,12 @@
 USING: tools.test core-text core-foundation
 core-foundation.dictionaries destructors
 arrays kernel generalizations math accessors
-combinators hashtables ;
+core-foundation.utilities
+combinators hashtables colors ;
 IN: core-text.tests
 
-: test-font ( name -- object )
+: test-font ( name -- font )
-    kCTFontFamilyNameAttribute associate <CTFont> ;
+    [ >cf &CFRelease 0.0 f CTFontCreateWithName ] with-destructors ;
 
 [ ] [ "Helvetica" test-font CFRelease ] unit-test
 
@@ -20,7 +21,7 @@ IN: core-text.tests
 
 : test-typographic-bounds ( string font -- ? )
     [
-        test-font &CFRelease <CTLine> &CFRelease
+        test-font &CFRelease white <CTLine> &CFRelease
         line-typographic-bounds {
             [ width>> float? ]
             [ ascent>> float? ]

basis/core-text/core-text.factor

@@ -3,7 +3,7 @@
 USING: arrays alien alien.c-types alien.syntax kernel
 destructors words parser accessors fry words hashtables
 sequences memoize assocs math math.functions locals init
-core-foundation core-foundation.strings
+namespaces colors core-foundation core-foundation.strings
 core-foundation.attributed-strings core-foundation.utilities
 core-graphics core-graphics.types ;
 IN: core-text
@@ -69,13 +69,6 @@ FUNCTION: CTFontRef CTFontCreateWithFontDescriptor (
    CGAffineTransform* matrix
 ) ;
 
-: <CTFont> ( attrs -- font )
-    [
-        >cf &CFRelease
-        CTFontDescriptorCreateWithAttributes &CFRelease
-        0.0 f CTFontCreateWithFontDescriptor
-    ] with-destructors ;
-
 C-GLOBAL: kCTFontAttributeName
 C-GLOBAL: kCTKernAttributeName
 C-GLOBAL: kCTLigatureAttributeName
@@ -105,9 +98,12 @@ FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
    uint32_t symTraitMask
 ) ;
 
-: <CTLine> ( string font -- line )
+: <CTLine> ( string font color -- line )
     [
-        kCTFontAttributeName associate <CFAttributedString> &CFRelease
+        [
+            kCTForegroundColorAttributeName set
+            kCTFontAttributeName set
+        ] H{ } make-assoc <CFAttributedString> &CFRelease
         CTLineCreateWithAttributedString
     ] with-destructors ;
 
@@ -132,17 +128,14 @@ TUPLE: line string font line bounds dim bitmap age disposed ;
 : <line> ( string font -- line )
     [
         CFRetain |CFRelease
-        2dup <CTLine> |CFRelease
+        2dup white <CTLine> |CFRelease
         dup line-typographic-bounds
         dup bounds>dim 3dup [ draw-line ] with-bitmap-context
         0 f line boa
     ] with-destructors ;
 
 M: line dispose*
-    [
+    [ font>> ] [ line>> ] bi 2array dispose-each ;
-        [ font>> &CFRelease drop ]
-        [ line>> &CFRelease drop ] bi
-    ] with-destructors ;
 
 <PRIVATE
 

basis/opengl/opengl.factor

@@ -10,12 +10,9 @@ generalizations locals fry specialized-arrays.float
 specialized-arrays.uint ;
 IN: opengl
 
-: color>raw ( object -- r g b a )
+: gl-color ( color -- ) >rgba-components glColor4d ; inline
-    >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
 
-: gl-color ( color -- ) color>raw glColor4d ; inline
+: gl-clear-color ( color -- ) >rgba-components glClearColor ;
-
-: gl-clear-color ( color -- ) color>raw glClearColor ;
 
 : gl-clear ( color -- )
     gl-clear-color GL_COLOR_BUFFER_BIT glClear ;

basis/ui/cocoa/text/text.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors alien core-graphics.types core-text kernel
-hashtables namespaces sequences ui.gadgets.worlds ui.render
+hashtables namespaces sequences ui.gadgets.worlds ui.text
-opengl opengl.gl destructors combinators core-foundation
+ui.text.private opengl opengl.gl destructors combinators core-foundation
-core-foundation.strings io.styles memoize math ;
+core-foundation.strings io.styles memoize math math.vectors ;
 IN: ui.cocoa.text
 
 SINGLETON: core-text-renderer
@@ -46,14 +46,8 @@ MEMO: cache-font ( font -- open-font )
 M: core-text-renderer open-font
     dup alien? [ cache-font ] unless ;
 
-: string-dim ( open-font string -- dim )
+M: core-text-renderer string-dim
-    swap cached-line dim>> ;
+    [ " " string-dim { 0 1 } v* ] [ swap cached-line dim>> ] if-empty ;
-
-M: core-text-renderer string-width ( open-font string -- w )
-    string-dim first ;
- 
-M: core-text-renderer string-height ( open-font string -- h )
-    [ " " ] when-empty string-dim second ;
 
 TUPLE: line-texture line texture age disposed ;
 
@@ -82,7 +76,13 @@ M: core-text-renderer draw-string ( font string loc -- )
     [ swap open-font line-texture draw-line-texture ] with-translation ;
 
 M: core-text-renderer x>offset ( x font string -- n )
-    swap open-font cached-line line>> swap 0 <CGPoint> CTLineGetStringIndexForPosition ;
+    [ 2drop 0 ] [
+        swap open-font cached-line line>>
+        swap 0 <CGPoint> CTLineGetStringIndexForPosition
+    ] if-empty ;
+
+M: core-text-renderer offset>x ( n font string -- x )
+    swap open-font cached-line line>> swap f CTLineGetOffsetForStringIndex ;
 
 M: core-text-renderer free-fonts ( fonts -- )
     values dispose-each ;

basis/ui/freetype/freetype.factor

@@ -3,7 +3,7 @@
 USING: alien alien.accessors alien.c-types arrays io kernel libc
 math math.vectors namespaces opengl opengl.gl opengl.sprites assocs
 sequences io.files io.styles continuations freetype
-ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
+ui.gadgets.worlds ui.text ui.text.private ui.backend byte-arrays accessors
 locals specialized-arrays.direct.uchar ;
 IN: ui.freetype
 
@@ -222,4 +222,7 @@ M: freetype-renderer x>offset ( x font string -- n )
     [ run-char-widths [ <= ] with find drop ] keep swap
     [ ] [ length ] ?if ;
 
+M:: freetype-renderer offset>x ( n font string -- x )
+    font open-font string n head string-width ;
+
 freetype-renderer font-renderer set-global

basis/ui/gadgets/editors/editors.factor

@@ -6,8 +6,8 @@ math.vectors sorting colors combinators assocs math.order fry
 calendar alarms continuations ui.clipboards ui.commands
 ui.gadgets ui.gadgets.borders ui.gadgets.buttons
 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
-ui.gadgets.menus ui.gadgets.wrappers ui.render ui.gestures
+ui.gadgets.menus ui.gadgets.wrappers ui.render ui.text
-math.geometry.rect ;
+ui.gestures math.geometry.rect ;
 IN: ui.gadgets.editors
 
 TUPLE: editor < gadget
@@ -132,10 +132,8 @@ M: editor ungraft*
 : unfocus-editor ( editor -- )
     [ stop-blinking ] [ f >>focused? relayout-1 ] bi ;
 
-: offset>x ( col# line# editor -- x )
+: loc>x ( loc editor -- x )
-    [ editor-line ] keep font>> spin head text-width ;
+    [ first2 swap ] dip [ editor-line ] [ font>> ] bi swap offset>x ;
-
-: loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ;
 
 : line>y ( lines# editor -- y )
     line-height * ;
@@ -224,7 +222,7 @@ M: editor ungraft*
 
 : draw-selected-line ( start end n -- )
     [ start/end-on-line ] keep
-    tuck [ editor get offset>x ] 2bi@
+    tuck [ swap 2array editor get loc>x ] 2bi@
     (draw-selection) ;
 
 : draw-selection ( -- )

basis/ui/gadgets/labels/labels.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays hashtables io kernel math namespaces
 make opengl sequences strings splitting ui.gadgets
-ui.gadgets.tracks ui.gadgets.theme ui.render colors models ;
+ui.gadgets.tracks ui.gadgets.theme ui.render
+ui.text colors models ;
 IN: ui.gadgets.labels
 
 ! A label gadget draws a string.

basis/ui/gadgets/tables/tables.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays colors fry io.styles kernel math
 math.geometry.rect math.order math.vectors namespaces opengl
 sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
-ui.gadgets.worlds ui.gadgets.theme ui.gestures ui.render
+ui.gadgets.worlds ui.gadgets.theme ui.gestures ui.render ui.text
 ui.gadgets.menus models math.ranges sequences combinators ;
 IN: ui.gadgets.tables
 

basis/ui/gadgets/worlds/worlds-docs.factor

@@ -1,5 +1,6 @@
-USING: ui.gadgets ui.render ui.gestures ui.backend help.markup
+USING: ui.gadgets ui.render ui.text ui.text.private
-help.syntax models opengl opengl.sprites strings ;
+ui.gestures ui.backend help.markup help.syntax
+models opengl opengl.sprites strings ;
 IN: ui.gadgets.worlds
 
 HELP: user-input

basis/ui/render/render-docs.factor

@@ -60,45 +60,6 @@ HELP: <polygon-gadget>
 { $values { "color" "a color specifier" } { "points" "a sequence of points" } { "gadget" "a new " { $link gadget } } }
 { $description "Creates a gadget which is drawn as a solid filled polygon. The gadget's size is the minimum bounding box containing all the points of the polygon." } ;
 
-HELP: open-font
-{ $values { "font" "a font specifier" } { "open-font" object } }
-{ $description "Loads a font if it has not already been loaded, otherwise outputs the existing font." }
-{ $errors "Throws an error if the font does not exist." } ;
-
-HELP: string-width
-{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "w" "a positive integer" } }
-{ $description "Outputs the width of a string." }
-{ $notes "This is a low-level word; use " { $link text-width } " instead." } ;
-
-HELP: text-width
-{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "w" "a positive integer" } }
-{ $description "Outputs the width of a piece of text." } ;
-
-HELP: string-height
-{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "h" "a positive integer" } }
-{ $description "Outputs the height of a string." }
-{ $notes "This is a low-level word; use " { $link text-height } " instead." } ;
-
-HELP: text-height
-{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "h" "a positive integer" } }
-{ $description "Outputs the height of a piece of text." } ;
-
-HELP: text-dim
-{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "dim" "a pair of integers" } }
-{ $description "Outputs the dimensions of a piece of text, which is either a single-line string or an array of lines." } ;
-
-HELP: draw-string
-{ $values { "font" "a font specifier" } { "string" string } { "loc" "a pair of integers" } }
-{ $description "Draws a line of text." } ;
-
-HELP: draw-text
-{ $values { "font" "a font specifier" } { "text" "a string or an array of strings" } { "loc" "a pair of integers" } }
-{ $description "Draws a piece of text." } ;
-
-HELP: x>offset
-{ $values { "x" real } { "font" "a font specifier" } { "string" string } { "n" integer } }
-{ $description "Outputs the string index closest to the given x co-ordinate." } ;
-
 ARTICLE: "gadgets-polygons" "Polygon gadgets"
 "A polygon gadget renders a simple shaded polygon."
 { $subsection <polygon-gadget> }
@@ -134,21 +95,6 @@ $nl
 { $subsection polygon }
 "Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
 
-ARTICLE: "text-rendering" "Rendering text"
-"Unlike OpenGL, Factor's FreeType binding only includes the bare essentials, and there is rarely any need to directly call words in the " { $vocab-link "freetype" } " vocabulary directly. Instead, the UI provides high-level wrappers."
-$nl
-"Measuring text:"
-{ $subsection text-dim }
-{ $subsection text-width }
-{ $subsection text-height }
-"Rendering text:"
-{ $subsection draw-text }
-"Low-level text protocol for UI backends:"
-{ $subsection open-font }
-{ $subsection string-width }
-{ $subsection string-height }
-{ $subsection draw-string } ;
-
 ARTICLE: "ui-paint-coord" "The UI co-ordinate system"
 "The UI uses a co-ordinate system where the y axis is oriented down. The OpenGL " { $link GL_MODELVIEW } " matrix is not saved or restored when rendering a gadget. Instead, the origin of the gadget relative to the OpenGL context is stored in a variable:"
 { $subsection origin }

basis/ui/render/render.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types arrays hashtables io kernel
 math namespaces opengl opengl.gl opengl.glu sequences strings
@@ -191,54 +191,13 @@ M: polygon draw-interior
     [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
     tri ;
 
-: arrow-up    { { 3 0 } { 6 6 } { 0 6 } } ;
+CONSTANT: arrow-up    { { 3 0 } { 6 6 } { 0 6 } }
-: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
+CONSTANT: arrow-right { { 0 0 } { 6 3 } { 0 6 } }
-: arrow-down  { { 0 0 } { 6 0 } { 3 6 } } ;
+CONSTANT: arrow-down  { { 0 0 } { 6 0 } { 3 6 } }
-: arrow-left  { { 0 3 } { 6 0 } { 6 6 } } ;
+CONSTANT: arrow-left  { { 0 3 } { 6 0 } { 6 6 } }
-: close-box   { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ;
+CONSTANT: close-box   { { 0 0 } { 6 0 } { 6 6 } { 0 6 } }
 
 : <polygon-gadget> ( color points -- gadget )
     dup max-dim
     [ <polygon> <gadget> ] dip >>dim
     swap >>interior ;
-
-! Font rendering
-SYMBOL: font-renderer
-
-HOOK: open-font font-renderer ( font -- open-font )
-
-HOOK: string-width font-renderer ( open-font string -- w )
-
-HOOK: string-height font-renderer ( open-font string -- h )
-
-HOOK: draw-string font-renderer ( font string loc -- )
-
-HOOK: x>offset font-renderer ( x font string -- n )
-
-HOOK: free-fonts font-renderer ( world -- )
-
-: text-height ( font text -- h )
-    [ open-font ] dip
-    dup string? [ string-height ] [
-        [ string-height ] with sigma
-    ] if ;
-
-: text-width ( font text -- w )
-    [ open-font ] dip
-    dup string? [ string-width ] [
-        [ 0 ] 2dip [ string-width max ] with each
-    ] if ;
-
-: text-dim ( font text -- dim )
-    [ text-width ] [ text-height ] 2bi 2array ;
-
-: draw-text ( font text loc -- )
-    over string? [ draw-string ] [
-        [
-            [
-                2dup { 0 0 } draw-string
-                [ open-font ] dip string-height
-                0.0 swap 0.0 glTranslated
-            ] with each
-        ] with-translation
-    ] if ;

basis/ui/text/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/ui/text/text-docs.factor

@@ -0,0 +1,72 @@
+IN: ui.text
+USING: help.markup help.syntax kernel ui.text.private strings math ;
+
+HELP: open-font
+{ $values { "font" "a font specifier" } { "open-font" object } }
+{ $contract "Loads a font if it has not already been loaded, otherwise outputs the existing font." }
+{ $errors "Throws an error if the font does not exist." }
+{ $notes "This word should not be called by user code. All high-level text rendering words will call " { $link open-font } " automatically." } ;
+
+HELP: string-width
+{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "w" "a positive integer" } }
+{ $contract "Outputs the width of a string." }
+{ $notes "This is a low-level word; use " { $link text-width } " instead." } ;
+
+HELP: text-width
+{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "w" "a positive integer" } }
+{ $description "Outputs the width of a piece of text." } ;
+
+HELP: string-height
+{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "h" "a positive integer" } }
+{ $contract "Outputs the height of a string." }
+{ $notes "This is a low-level word; use " { $link text-height } " instead." } ;
+
+HELP: text-height
+{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "h" "a positive integer" } }
+{ $description "Outputs the height of a piece of text." } ;
+
+HELP: string-dim
+{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "dim" "a pair of integers" } }
+{ $contract "Outputs the dimensions of a string." }
+{ $notes "This is a low-level word; use " { $link text-dim } " instead." } ;
+
+HELP: text-dim
+{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "dim" "a pair of integers" } }
+{ $description "Outputs the dimensions of a piece of text, which is either a single-line string or an array of lines." } ;
+
+HELP: draw-string
+{ $values { "font" "a font specifier" } { "string" string } { "loc" "a pair of integers" } }
+{ $contract "Draws a line of text." } ;
+
+HELP: draw-text
+{ $values { "font" "a font specifier" } { "text" "a string or an array of strings" } { "loc" "a pair of integers" } }
+{ $description "Draws a piece of text." } ;
+
+HELP: x>offset
+{ $values { "x" real } { "font" "a font specifier" } { "string" string } { "n" integer } }
+{ $contract "Outputs the string index closest to the given x co-ordinate." } ;
+
+HELP: offset>x
+{ $values { "n" integer } { "font" "a font specifier" } { "string" string } { "x" real } }
+{ $contract "Outputs the x co-ordinate of the character at the given index." } ;
+
+ARTICLE: "text-rendering" "Rendering text"
+"The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11."
+$nl
+"Measuring text:"
+{ $subsection text-dim }
+{ $subsection text-width }
+{ $subsection text-height }
+"Converting screen locations to string offsets, and vice versa:"
+{ $subsection x>offset }
+{ $subsection offset>x }
+"Rendering text:"
+{ $subsection draw-text }
+"Low-level text protocol for UI backends:"
+{ $subsection open-font }
+{ $subsection string-width }
+{ $subsection string-height }
+{ $subsection string-dim }
+{ $subsection draw-string } ;
+
+ABOUT: "text-rendering"

basis/ui/text/text-tests.factor

@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.text ;
+IN: ui.text.tests

basis/ui/text/text.factor

@@ -0,0 +1,62 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays sequences math math.order opengl opengl.gl strings ;
+IN: ui.text
+
+<PRIVATE
+
+SYMBOL: font-renderer
+
+HOOK: open-font font-renderer ( font -- open-font )
+
+HOOK: string-dim font-renderer ( open-font string -- dim )
+
+HOOK: string-width font-renderer ( open-font string -- w )
+
+HOOK: string-height font-renderer ( open-font string -- h )
+
+M: object string-dim [ string-width ] [ string-height ] 2bi 2array ;
+
+M: object string-width string-dim first ;
+
+M: object string-height string-dim second ;
+
+HOOK: draw-string font-renderer ( font string loc -- )
+
+HOOK: free-fonts font-renderer ( world -- )
+
+: combine-text-dim ( dim1 dim2 -- dim3 )
+    [ [ first ] bi@ max ]
+    [ [ second ] bi@ + ]
+    2bi 2array ;
+
+PRIVATE>
+
+HOOK: x>offset font-renderer ( x font string -- n )
+
+HOOK: offset>x font-renderer ( n font string -- x )
+
+GENERIC: text-dim ( font text -- dim )
+
+M: string text-dim [ open-font ] dip string-dim ;
+
+M: sequence text-dim
+    [ { 0 0 } ] [ open-font ] [ ] tri*
+    [ string-dim combine-text-dim ] with each ;
+
+: text-width ( font text -- w ) text-dim first ;
+
+: text-height ( font text -- h ) text-dim second ;
+
+GENERIC# draw-text 1 ( font text loc -- )
+
+M: string draw-text draw-string ;
+
+M: sequence draw-text
+    [
+        [
+            2dup { 0 0 } draw-string
+            [ open-font ] dip string-height
+            0.0 swap 0.0 glTranslated
+        ] with each
+    ] with-translation ;

basis/ui/ui.factor

@@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces make
 dlists deques sequences threads sequences words continuations
 init combinators hashtables concurrency.flags sets accessors
 calendar fry ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
-ui.gestures ui.backend ui.render ;
+ui.gestures ui.backend ui.render ui.text ui.text.private ;
 IN: ui
 
 ! Assoc mapping aliens to gadgets