Add foreground and background color slots to font tuple

basis/core-text/core-text.factor

@@ -1,73 +1,15 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays alien alien.c-types alien.syntax kernel
-destructors words parser accessors fry words hashtables
+destructors accessors fry words hashtables
 sequences memoize assocs math math.functions locals init
-namespaces combinators colors core-foundation
+namespaces combinators fonts colors core-foundation
 core-foundation.strings core-foundation.attributed-strings
-core-foundation.utilities core-graphics core-graphics.types ;
+core-foundation.utilities core-graphics core-graphics.types
+core-text.fonts core-text.utilities ;
 IN: core-text
 
 TYPEDEF: void* CTLineRef
-TYPEDEF: void* CTFontRef
-TYPEDEF: void* CTFontDescriptorRef
-
-<<
-
-: C-GLOBAL:
-    CREATE-WORD
-    dup name>> '[ _ f dlsym *void* ]
-    (( -- value )) define-declared ; parsing
-
->>
-
-! CTFontSymbolicTraits
-: kCTFontItalicTrait ( -- n ) 0 2^ ; inline
-: kCTFontBoldTrait ( -- n ) 1 2^ ; inline
-: kCTFontExpandedTrait ( -- n ) 5 2^ ; inline
-: kCTFontCondensedTrait ( -- n ) 6 2^ ; inline
-: kCTFontMonoSpaceTrait ( -- n ) 10 2^ ; inline
-: kCTFontVerticalTrait ( -- n ) 11 2^ ; inline
-: kCTFontUIOptimizedTrait ( -- n ) 12 2^ ; inline
-
-C-GLOBAL: kCTFontSymbolicTrait
-C-GLOBAL: kCTFontWeightTrait
-C-GLOBAL: kCTFontWidthTrait
-C-GLOBAL: kCTFontSlantTrait
-
-C-GLOBAL: kCTFontNameAttribute
-C-GLOBAL: kCTFontDisplayNameAttribute
-C-GLOBAL: kCTFontFamilyNameAttribute
-C-GLOBAL: kCTFontStyleNameAttribute
-C-GLOBAL: kCTFontTraitsAttribute
-C-GLOBAL: kCTFontVariationAttribute
-C-GLOBAL: kCTFontSizeAttribute
-C-GLOBAL: kCTFontMatrixAttribute
-C-GLOBAL: kCTFontCascadeListAttribute
-C-GLOBAL: kCTFontCharacterSetAttribute
-C-GLOBAL: kCTFontLanguagesAttribute
-C-GLOBAL: kCTFontBaselineAdjustAttribute
-C-GLOBAL: kCTFontMacintoshEncodingsAttribute
-C-GLOBAL: kCTFontFeaturesAttribute
-C-GLOBAL: kCTFontFeatureSettingsAttribute
-C-GLOBAL: kCTFontFixedAdvanceAttribute
-C-GLOBAL: kCTFontOrientationAttribute
-
-FUNCTION: CTFontDescriptorRef CTFontDescriptorCreateWithAttributes (
-   CFDictionaryRef attributes
-) ;
-
-FUNCTION: CTFontRef CTFontCreateWithName (
-   CFStringRef name,
-   CGFloat size,
-   CGAffineTransform* matrix
-) ;
-
-FUNCTION: CTFontRef CTFontCreateWithFontDescriptor (
-   CTFontDescriptorRef descriptor,
-   CGFloat size,
-   CGAffineTransform* matrix
-) ;
 
 C-GLOBAL: kCTFontAttributeName
 C-GLOBAL: kCTKernAttributeName
@@ -90,15 +32,7 @@ FUNCTION: double CTLineGetTypographicBounds ( CTLineRef line, CGFloat* ascent, C
 
 FUNCTION: CGRect CTLineGetImageBounds ( CTLineRef line, CGContextRef context ) ;
 
-FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
+: <CTLine> ( string open-font color -- line )
-   CTFontRef font,
-   CGFloat size,
-   CGAffineTransform* matrix,
-   uint32_t symTraitValue,
-   uint32_t symTraitMask
-) ;
-
-: <CTLine> ( string font color -- line )
     [
         [
             kCTForegroundColorAttributeName set
@@ -121,21 +55,21 @@ TUPLE: typographic-bounds width ascent descent leading ;
     [ ceiling >fixnum ]
     bi@ 2array ;
 
-:: <line> ( string font foreground background -- line )
+:: <line> ( string font -- line )
     [
-        [let* | font [ font CFRetain |CFRelease ]
+        [let* | open-font [ font cache-font CFRetain |CFRelease ]
-                line [ string font foreground <CTLine> |CFRelease ]
+                line [ string open-font font foreground>> <CTLine> |CFRelease ]
                 bounds [ line line-typographic-bounds ]
                 dim [ bounds bounds>dim ] |
             dim [
                 {
-                    [ background >rgba-components CGContextSetRGBFillColor ]
+                    [ font background>> >rgba-components CGContextSetRGBFillColor ]
                     [ 0 0 dim first2 <CGRect> CGContextFillRect ]
                     [ 0 bounds descent>> CGContextSetTextPosition ]
                     [ line swap CTLineDraw ]
                 } cleave
             ] with-bitmap-context
-            [ font line bounds dim ] dip 0 0 f
+            [ open-font line bounds dim ] dip 0 0 f
         ]
         line boa
     ] with-destructors ;
@@ -151,7 +85,7 @@ M: line dispose* [ font>> CFRelease ] [ line>> CFRelease ] bi ;
 SYMBOL: cached-lines
 
 : cached-line ( string font -- line )
-    black white 4array cached-lines get [ first4 <line> ] cache ;
+    cached-lines get [ <line> ] 2cache ;
 
 CONSTANT: max-line-age 10
 

basis/core-text/fonts/authors.txt

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

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

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

basis/core-text/fonts/fonts.factor

@@ -0,0 +1,102 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.syntax assocs core-foundation
+core-foundation.strings core-text.utilities destructors init
+kernel math memoize ;
+IN: core-text.fonts
+
+TYPEDEF: void* CTFontRef
+TYPEDEF: void* CTFontDescriptorRef
+
+! CTFontSymbolicTraits
+: kCTFontItalicTrait ( -- n ) 0 2^ ; inline
+: kCTFontBoldTrait ( -- n ) 1 2^ ; inline
+: kCTFontExpandedTrait ( -- n ) 5 2^ ; inline
+: kCTFontCondensedTrait ( -- n ) 6 2^ ; inline
+: kCTFontMonoSpaceTrait ( -- n ) 10 2^ ; inline
+: kCTFontVerticalTrait ( -- n ) 11 2^ ; inline
+: kCTFontUIOptimizedTrait ( -- n ) 12 2^ ; inline
+
+C-GLOBAL: kCTFontSymbolicTrait
+C-GLOBAL: kCTFontWeightTrait
+C-GLOBAL: kCTFontWidthTrait
+C-GLOBAL: kCTFontSlantTrait
+
+C-GLOBAL: kCTFontNameAttribute
+C-GLOBAL: kCTFontDisplayNameAttribute
+C-GLOBAL: kCTFontFamilyNameAttribute
+C-GLOBAL: kCTFontStyleNameAttribute
+C-GLOBAL: kCTFontTraitsAttribute
+C-GLOBAL: kCTFontVariationAttribute
+C-GLOBAL: kCTFontSizeAttribute
+C-GLOBAL: kCTFontMatrixAttribute
+C-GLOBAL: kCTFontCascadeListAttribute
+C-GLOBAL: kCTFontCharacterSetAttribute
+C-GLOBAL: kCTFontLanguagesAttribute
+C-GLOBAL: kCTFontBaselineAdjustAttribute
+C-GLOBAL: kCTFontMacintoshEncodingsAttribute
+C-GLOBAL: kCTFontFeaturesAttribute
+C-GLOBAL: kCTFontFeatureSettingsAttribute
+C-GLOBAL: kCTFontFixedAdvanceAttribute
+C-GLOBAL: kCTFontOrientationAttribute
+
+FUNCTION: CTFontDescriptorRef CTFontDescriptorCreateWithAttributes (
+   CFDictionaryRef attributes
+) ;
+
+FUNCTION: CTFontRef CTFontCreateWithName (
+   CFStringRef name,
+   CGFloat size,
+   CGAffineTransform* matrix
+) ;
+
+FUNCTION: CTFontRef CTFontCreateWithFontDescriptor (
+   CTFontDescriptorRef descriptor,
+   CGFloat size,
+   CGAffineTransform* matrix
+) ;
+
+FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
+   CTFontRef font,
+   CGFloat size,
+   CGAffineTransform* matrix,
+   uint32_t symTraitValue,
+   uint32_t symTraitMask
+) ;
+
+CONSTANT: font-names
+    H{
+        { "monospace" "Monaco" }
+        { "sans-serif" "Lucida Grande" }
+        { "serif" "Times" }
+    }
+
+: font-name ( string -- string' )
+    font-names at-default ;
+
+: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
+
+: (italic) ( x -- y ) kCTFontItalicTrait bitor ; inline
+
+: font-traits ( font -- n )
+    [ 0 ] dip
+    [ bold?>> [ (bold) ] when ]
+    [ italic?>> [ (italic) ] when ] bi ;
+
+: apply-font-traits ( font style -- font' )
+    [ drop ] [ [ 0.0 f ] dip font-traits dup ] 2bi
+    CTFontCreateCopyWithSymbolicTraits
+    dup [ [ CFRelease ] dip ] [ drop ] if ;
+
+MEMO: (cache-font) ( font -- open-font )
+    [
+        [
+            [ name>> font-name <CFString> &CFRelease ] [ size>> ] bi
+            f CTFontCreateWithName
+        ] keep apply-font-traits
+    ] with-destructors ;
+
+: cache-font ( font -- open-font )
+    clone f >>foreground f >>background (cache-font) ;
+
+[ \ (cache-font) reset-memoized ] "core-text.fonts" add-init-hook

basis/core-text/utilities/authors.txt

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

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

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

basis/core-text/utilities/utilities.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words parser alien alien.c-types kernel fry ;
+IN: core-text.utilities
+
+: C-GLOBAL:
+    CREATE-WORD
+    dup name>> '[ _ f dlsym *void* ]
+    (( -- value )) define-declared ; parsing

basis/fonts/authors.txt

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

basis/fonts/fonts-docs.factor

@@ -0,0 +1,39 @@
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel colors ;
+IN: fonts
+
+HELP: <font>
+{ $values { "font" font } }
+{ $description "Creates a new font." } ;
+
+HELP: font
+{ $class-description "The class of fonts." } ;
+
+HELP: font-with-background
+{ $values
+     { "font" font } { "color" color }
+     { "font'" font }
+}
+{ $description "Creates a new font equal to the given font, except with a different " { $slot "background" } " slot." } ;
+
+HELP: font-with-foreground
+{ $values
+     { "font" font } { "color" color }
+     { "font'" font }
+}
+{ $description "Creates a new font equal to the given font, except with a different " { $slot "foreground" } " slot." } ;
+
+ARTICLE: "fonts" "Fonts"
+"The " { $vocab-link "fonts" } " vocabulary implements a data type for fonts that other vocabularies, for example " { $link "ui" } ", can use. A font combines a font name, size, style, and color information into a single object."
+{ $subsection font }
+{ $subsection <font> }
+"Modifying fonts:"
+{ $subsection font-with-foreground }
+{ $subsection font-with-background }
+"Useful constants:"
+{ $subsection monospace-font }
+{ $subsection sans-serif-font }
+{ $subsection serif-font } ;
+
+ABOUT: "fonts"

basis/fonts/fonts-tests.factor

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

basis/fonts/fonts.factor

@@ -0,0 +1,47 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel colors accessors combinators ;
+IN: fonts
+
+TUPLE: font name size bold? italic? foreground background ;
+
+: <font> ( -- font )
+    font new
+        black >>foreground
+        white >>background ; inline
+
+: font-with-foreground ( font color -- font' )
+    [ clone ] dip >>foreground ; inline
+
+: font-with-background ( font color -- font' )
+    [ clone ] dip >>background ; inline
+
+: reverse-video-font ( font -- font )
+    clone dup
+    [ foreground>> ] [ background>> ] bi
+    [ >>background ] [ >>foreground ] bi* ;
+
+: derive-font ( base font -- font' )
+    [ clone ] dip over {
+        [ [ name>> ] either? >>name ]
+        [ [ size>> ] either? >>size ]
+        [ [ bold?>> ] either? >>bold? ]
+        [ [ italic?>> ] either? >>italic? ]
+        [ [ foreground>> ] either? >>foreground ]
+        [ [ background>> ] either? >>background ]
+    } 2cleave ;
+
+: serif-font ( -- font )
+    <font>
+        "serif" >>name
+        12 >>size ; foldable
+
+: sans-serif-font ( -- font )
+    <font>
+        "sans-serif" >>name
+        12 >>size ; foldable
+
+: monospace-font ( -- font )
+    <font>
+        "monospace" >>name
+        12 >>size ; foldable

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

@@ -1,6 +1,6 @@
 USING: documents help.markup help.syntax ui.gadgets
 ui.gadgets.scrollers models strings ui.commands
-ui.text colors ;
+ui.text colors fonts ;
 IN: ui.gadgets.editors
 
 HELP: editor

basis/ui/gadgets/editors/editors.factor

@@ -7,7 +7,7 @@ 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.text ui.gestures math.geometry.rect
-splitting unicode.categories ;
+splitting unicode.categories fonts ;
 IN: ui.gadgets.editors
 
 TUPLE: editor < gadget
@@ -534,8 +534,8 @@ TUPLE: multiline-editor < editor ;
 
 : join-lines ( string -- string' )
     "\n" split
-    [ rest-slice [ [ blank? ] trim-left-slice ] change-each ]
+    [ rest-slice [ [ blank? ] trim-head-slice ] change-each ]
-    [ but-last-slice [ [ blank? ] trim-right-slice ] change-each ]
+    [ but-last-slice [ [ blank? ] trim-tail-slice ] change-each ]
     [ " " join ]
     tri ;
 

basis/ui/gadgets/grid-lines/grid-lines-docs.factor

@@ -1,6 +1,7 @@
 USING: ui.gadgets help.markup help.syntax ui.gadgets.grids
-ui.render ;
+ui.render colors ;
 IN: ui.gadgets.grid-lines
 
 HELP: grid-lines
-{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $snippet "color" } " slot." } ;
+{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is an instance of " { $link color } ", stored in the " { $snippet "color" } " slot." }
+{ $notes "See " { $link "colors" } "." } ;

basis/ui/gadgets/labels/labels.factor

@@ -2,12 +2,12 @@
 ! 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
+ui.gadgets.tracks fonts ui.render
 ui.text colors models ;
 IN: ui.gadgets.labels
 
 ! A label gadget draws a string.
-TUPLE: label < gadget text font color ;
+TUPLE: label < gadget text font ;
 
 : label-string ( label -- string )
     text>> dup string? [ "\n" join ] unless ; inline
@@ -16,8 +16,7 @@ TUPLE: label < gadget text font color ;
     [ CHAR: \n over memq? [ string-lines ] when ] dip (>>text) ; inline
 
 : label-theme ( gadget -- gadget )
-    sans-serif-font >>font
+    sans-serif-font >>font ; inline
-    black >>color ; inline
 
 : new-label ( string class -- label )
     new-gadget
@@ -31,8 +30,7 @@ M: label pref-dim*
     [ font>> ] [ text>> ] bi text-dim ;
 
 M: label draw-gadget*
-    [ color>> gl-color ]
+    [ font>> ] [ text>> ] bi origin get draw-text ;
-    [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
 
 M: label gadget-text* label-string % ;
 
@@ -46,12 +44,10 @@ M: label-control model-changed
         swap >>model ;
 
 : text-theme ( gadget -- gadget )
-    black >>color
     monospace-font >>font ;
 
 : reverse-video-theme ( label -- label )
-    white >>color
+    sans-serif-font reverse-video-font >>font ;
-    black solid-interior ;
 
 GENERIC: >label ( obj -- gadget )
 M: string >label <label> ;

basis/ui/gadgets/panes/panes.factor

@@ -4,12 +4,12 @@ USING: arrays hashtables io kernel namespaces sequences
 io.styles strings quotations math opengl combinators memoize
 math.vectors sorting splitting assocs classes.tuple models
 continuations destructors accessors math.geometry.rect fry
-ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+fonts ui.gadgets ui.gadgets.borders ui.gadgets.buttons
 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
 ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
 ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
 ui.text ui.gadgets.presentations ui.gadgets.grids
-ui.gadgets.grid-lines ;
+ui.gadgets.grid-lines colors ;
 IN: ui.gadgets.panes
 
 TUPLE: pane < pack
@@ -179,21 +179,13 @@ M: pane-stream make-span-stream
 
 ! Character styles
 
-: apply-style ( style gadget key quot -- style gadget )
+MEMO: specified-font ( assoc -- font )
-    [ pick at ] dip when* ; inline
-
-: apply-foreground-style ( style gadget -- style gadget )
-    foreground [ >>color ] apply-style ;
-
-: apply-background-style ( style gadget -- style gadget )
-    background [ solid-interior ] apply-style ;
-
-MEMO: specified-font ( font style size -- font )
     #! We memoize here to avoid creating lots of duplicate font objects.
-    [ <font> ] 3dip
+    [ <font> ] dip
-    [ "monospace" or >>name ]
-    [
     {
+        [ font-name swap at "monospace" or >>name ]
+        [
+            font-style swap at {
                 { f [ ] }
                 { plain [ ] }
                 { bold [ t >>bold? ] }
@@ -201,22 +193,22 @@ MEMO: specified-font ( font style size -- font )
                 { bold-italic [ t >>bold? t >>italic? ] }
             } case
         ]
-    [ 12 or >>size ]
+        [ font-size swap at 12 or >>size ]
-    tri* ;
+        [ foreground swap at black or >>foreground ]
+        [ background swap at white or >>background ]
+    } cleave ;
 
 : apply-font-style ( style gadget -- style gadget )
-    over
+    { font-name font-style font-size foreground background }
-    [ font-name swap at ]
+    pick extract-keys specified-font >>font ;
-    [ font-style swap at ]
+
-    [ font-size swap at ]
+: apply-style ( style gadget key quot -- style gadget )
-    tri specified-font >>font ;
+    [ pick at ] dip when* ; inline
 
 : apply-presentation-style ( style gadget -- style gadget )
     presented [ <presentation> ] apply-style ;
 
 : style-label ( style gadget -- gadget )
-    apply-foreground-style
-    apply-background-style
     apply-font-style
     apply-presentation-style
     nip ; inline

basis/ui/gadgets/tables/tables.factor

@@ -4,7 +4,7 @@ USING: accessors arrays colors fry 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.text
-ui.gadgets.menus models math.ranges sequences combinators ;
+ui.gadgets.menus models math.ranges sequences combinators fonts ;
 IN: ui.gadgets.tables
 
 ! Row rendererer protocol

basis/ui/gadgets/theme/theme.factor

@@ -57,7 +57,3 @@ IN: ui.gadgets.theme
         T{ gray f 0.43 1.0 }
         T{ gray f 0.5  1.0 }
     } <gradient> ;
-
-CONSTANT: sans-serif-font T{ font { name "sans-serif" } { size 12 } }
-
-CONSTANT: monospace-font T{ font { name "monospace" } { size 12 } }

basis/ui/render/render-docs.factor

@@ -1,6 +1,6 @@
 USING: ui.gadgets ui.gestures help.markup help.syntax
 kernel classes strings opengl opengl.gl models
-math.geometry.rect math ;
+math.geometry.rect math colors ;
 IN: ui.render
 
 HELP: gadget
@@ -39,25 +39,27 @@ HELP: draw-boundary
 { $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
 
 HELP: solid
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $snippet "color" } " slot stores a color specifier." } ;
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $snippet "color" } " slot stores an instance of " { $link color } "." }
+{ $notes "See " { $link "colors" } "." } ;
 
 HELP: gradient
-{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $snippet "colors" } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." } ;
+{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $snippet "colors" } " slot stores a sequence of " { $link color } " instances, and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." }
+{ $notes "See " { $link "colors" } "." } ;
 
 HELP: polygon
 { $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
     { $list
-        { { $snippet "color" } " - a color specifier" }
+        { { $snippet "color" } " - a " { $link color } }
         { { $snippet "points" } " - a sequence of points" }
     }
 } ;
 
 HELP: <polygon>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "polygon" polygon } }
+{ $values { "color" color } { "points" "a sequence of points" } { "polygon" polygon } }
 { $description "Creates a new instance of " { $link polygon } "." } ;
 
 HELP: <polygon-gadget>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "gadget" "a new " { $link gadget } } }
+{ $values { "color" color } { "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." } ;
 
 ARTICLE: "gadgets-polygons" "Polygon gadgets"
@@ -102,4 +104,4 @@ ARTICLE: "ui-paint-coord" "The UI co-ordinate system"
 $nl
 "Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $slot "clipped?" } " slot to " { $link t } " in the gadget's constructor." ;
 
-ABOUT: "ui-paint-custom"
+ABOUT: "ui-paint"

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

@@ -1,56 +1,20 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors alien core-graphics.types core-text kernel
+USING: assocs accessors alien core-graphics.types core-text
-hashtables namespaces sequences ui.gadgets.worlds ui.text
+core-text.fonts kernel hashtables namespaces sequences
-ui.text.private opengl opengl.gl destructors combinators core-foundation
+ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl destructors
-core-foundation.strings memoize math math.vectors init colors ;
+combinators core-foundation core-foundation.strings memoize math
+math.vectors init colors ;
 IN: ui.text.core-text
 
 SINGLETON: core-text-renderer
 
-CONSTANT: font-names
-    H{
-        { "monospace" "Monaco" }
-        { "sans-serif" "Helvetica" }
-        { "serif" "Times" }
-    }
-
-: font-name ( string -- string' )
-    font-names at-default ;
-
-: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
-
-: (italic) ( x -- y ) kCTFontItalicTrait bitor ; inline
-
-: font-traits ( font -- n )
-    [ 0 ] dip
-    [ bold?>> [ (bold) ] when ]
-    [ italic?>> [ (italic) ] when ] bi ;
-
-: apply-font-traits ( font style -- font' )
-    [ drop ] [ [ 0.0 f ] dip font-traits dup ] 2bi
-    CTFontCreateCopyWithSymbolicTraits
-    dup [ [ CFRelease ] dip ] [ drop ] if ;
-
-MEMO: cache-font ( font -- open-font )
-    [
-        [
-            [ name>> font-name <CFString> &CFRelease ] [ size>> ] bi
-            f CTFontCreateWithName
-        ] keep apply-font-traits
-    ] with-destructors ;
-
-[ \ cache-font reset-memoized ] "ui.text.core-text" add-init-hook
-
-M: core-text-renderer open-font
-    dup alien? [ cache-font ] unless ;
-
 M: core-text-renderer string-dim
     [ " " string-dim { 0 1 } v* ] [ swap cached-line dim>> ] if-empty ;
 
 TUPLE: rendered-line line texture display-list age disposed ;
 
-: make-line-display-list ( rendered-line texture -- dlist )
+: make-line-display-list ( line texture -- dlist )
     GL_COMPILE [
         GL_TEXTURE_2D [
             GL_TEXTURE_BIT [
@@ -82,8 +46,9 @@ M: rendered-line dispose*
     [ texture>> delete-texture ]
     [ display-list>> delete-dlist ] tri ;
 
-: rendered-line ( string open-font -- line-display-list )
+: rendered-line ( string font -- rendered-line )
-    world get fonts>> [ cached-line <rendered-line> ] 2cache 0 >>age ;
+    world get fonts>>
+    [ cached-line <rendered-line> ] 2cache 0 >>age ;
 
 : age-rendered-lines ( world -- )
     [ [ age ] age-assoc ] change-fonts drop ;
@@ -93,18 +58,18 @@ M: core-text-renderer finish-text-rendering
 
 M: core-text-renderer draw-string ( font string loc -- )
     [
-        swap open-font rendered-line
+        swap rendered-line
         display-list>> glCallList
     ] with-translation ;
 
 M: core-text-renderer x>offset ( x font string -- n )
     [ 2drop 0 ] [
-        swap open-font cached-line line>>
+        swap 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
+    swap cached-line line>> swap f
     CTLineGetOffsetForStringIndex ;
 
 M: core-text-renderer free-fonts ( fonts -- )

basis/ui/text/freetype/freetype-docs.factor

@@ -22,25 +22,24 @@ HELP: close-freetype
 { $notes "Do not call this word if you are using the UI." } ;
 
 HELP: open-face
-{ $values { "font" font } { "face" "alien pointer to an " { $snippet "FT_Face" } } }
+{ $values { "font" freetype-font } { "face" "alien pointer to an " { $snippet "FT_Face" } } }
-{ $description "Loads a TrueType font with the requested logical font name and style." }
+{ $description "Loads a TrueType font with the requested logical font name and style." } ;
-{ $notes "This is a low-level word. Call " { $link open-font } " instead." } ;
 
 HELP: render-glyph
-{ $values  { "font" font } { "char" "a non-negative integer" } { "bitmap" alien } }
+{ $values  { "font" freetype-font } { "char" "a non-negative integer" } { "bitmap" alien } }
 { $description "Renders a character and outputs a pointer to the bitmap." } ;
 
 HELP: <char-sprite>
-{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
+{ $values { "font" freetype-font } { "char" "a non-negative integer" } { "sprite" sprite } }
 { $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
 
 HELP: (draw-string)
-{ $values { "open-font" font } { "sprites" "a vector of " { $link sprite } " instances" } { "string" string } { "loc" "a pair of integers" } }
+{ $values { "font" freetype-font } { "sprites" "a vector of " { $link sprite } " instances" } { "string" string } { "loc" "a pair of integers" } }
 { $description "Draws a line of text." }
 { $notes "This is a low-level word, UI code should use " { $link draw-string } " or " { $link draw-text } " instead." }
 { $side-effects "sprites" } ;
 
 HELP: run-char-widths
-{ $values { "open-font" font } { "string" string } { "widths" "a sequence of integers" } }
+{ $values { "font" freetype-font } { "string" string } { "widths" "a sequence of integers" } }
 { $description "Outputs a sequence of x co-ordinates of the midpoint of each character in the string." }
 { $notes "This word is used to convert x offsets to document locations, for example when the user moves the caret by clicking the mouse." } ;

basis/ui/text/freetype/freetype.factor

@@ -107,10 +107,8 @@ SYMBOL: dpi
         swap size>> set-char-size
         init-font ;
 
-M: freetype-renderer open-font ( font -- open-font )
+: open-font ( font -- open-font )
-    dup freetype-font? [
+    freetype drop open-fonts get [ <freetype-font> ] cache ;
-        freetype drop open-fonts get [ <freetype-font> ] cache
-    ] unless ;
 
 : load-glyph ( font char -- glyph )
     [ handle>> dup ] dip 0 FT_Load_Char
@@ -121,11 +119,11 @@ M: freetype-renderer open-font ( font -- open-font )
         dupd load-glyph glyph-hori-advance ft-ceil
     ] cache nip ;
 
-M: freetype-renderer string-width ( open-font string -- w )
+M: freetype-renderer string-width ( font string -- w )
-    [ [ 0 ] dip ] dip [ char-width + ] with each ;
+    [ [ 0 ] dip open-font ] dip [ char-width + ] with each ;
 
-M: freetype-renderer string-height ( open-font string -- h )
+M: freetype-renderer string-height ( font string -- h )
-    drop height>> ;
+    drop open-font height>> ;
 
 : glyph-size ( glyph -- dim )
     [ glyph-hori-advance ft-ceil ]

basis/ui/text/text-docs.factor

@@ -1,14 +1,8 @@
 IN: ui.text
-USING: help.markup help.syntax kernel ui.text.private strings math ;
+USING: help.markup help.syntax kernel ui.text.private strings math fonts ;
-
-HELP: open-font
-{ $values { "font" font } { "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" } }
+{ $values { "font" 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." } ;
 
@@ -17,7 +11,7 @@ HELP: text-width
 { $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" } }
+{ $values { "font" 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." } ;
 
@@ -26,7 +20,7 @@ HELP: text-height
 { $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" } }
+{ $values { "font" 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." } ;
 
@@ -52,7 +46,7 @@ HELP: offset>x
 
 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
+{ $subsection "fonts" }
 "Measuring text:"
 { $subsection text-dim }
 { $subsection text-width }
@@ -63,7 +57,6 @@ $nl
 "Rendering text:"
 { $subsection draw-text }
 "Low-level text protocol for UI backends:"
-{ $subsection open-font }
 { $subsection string-width }
 { $subsection string-height }
 { $subsection string-dim }

basis/ui/text/text.factor

@@ -1,12 +1,9 @@
 ! 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 ;
+USING: kernel arrays sequences math math.order opengl opengl.gl
+strings fonts colors ;
 IN: ui.text
 
-TUPLE: font name size bold? italic? ;
-
-: <font> ( -- font ) font new ; inline
-
 <PRIVATE
 
 SYMBOL: font-renderer
@@ -15,13 +12,11 @@ HOOK: finish-text-rendering font-renderer ( world -- )
 
 M: object finish-text-rendering drop ;
 
-HOOK: open-font font-renderer ( font -- open-font )
+HOOK: string-dim font-renderer ( font string -- dim )
 
-HOOK: string-dim font-renderer ( open-font string -- dim )
+HOOK: string-width font-renderer ( font string -- w )
 
-HOOK: string-width font-renderer ( open-font string -- w )
+HOOK: string-height font-renderer ( font string -- h )
-
-HOOK: string-height font-renderer ( open-font string -- h )
 
 M: object string-dim [ string-width ] [ string-height ] 2bi 2array ;
 
@@ -46,11 +41,10 @@ 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: string text-dim string-dim ;
 
 M: sequence text-dim
-    [ { 0 0 } ] [ open-font ] [ ] tri*
+    [ { 0 0 } ] 2dip [ string-dim combine-text-dim ] with each ;
-    [ string-dim combine-text-dim ] with each ;
 
 : text-width ( font text -- w ) text-dim first ;
 
@@ -64,7 +58,6 @@ M: sequence draw-text
     [
         [
             2dup { 0 0 } draw-string
-            [ open-font ] dip string-height
+            0.0 swap string-height 0.0 glTranslated
-            0.0 swap 0.0 glTranslated
         ] with each
     ] with-translation ;

basis/ui/tools/inspector/inspector.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors inspector namespaces kernel models fry
 models.filter prettyprint sequences mirrors assocs classes
-io io.styles arrays hashtables math.order sorting refs
+io io.styles arrays hashtables math.order sorting refs fonts
 ui.tools.browser ui.commands ui.operations ui.gadgets ui.gadgets.panes
 ui.gadgets.scrollers ui.gadgets.slots ui.gadgets.tracks
 ui.gestures ui.gadgets.buttons ui.gadgets.tables

basis/ui/tools/listener/completion/completion.factor

@@ -4,7 +4,7 @@ USING: accessors arrays assocs calendar colors documents
 documents.elements fry kernel words sets splitting math math.vectors
 models.delay models.filter combinators.short-circuit parser present
 sequences tools.completion generic generic.standard.engines.tuple
-ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.glass
+fonts ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.glass
 ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.theme
 ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.render
 ui.tools.listener.history ;

basis/ui/ui-docs.factor

@@ -1,7 +1,7 @@
 USING: help.markup help.syntax strings quotations debugger
 namespaces ui.backend ui.gadgets ui.gadgets.worlds
 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids
-math.geometry.rect colors ui.text ;
+math.geometry.rect colors ui.text fonts ;
 IN: ui
 
 HELP: windows