! 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
FUNCTION: CGRect CTLineGetImageBounds ( CTLineRef line, CGContextRef context ) ;
-FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
- CTFontRef font,
- CGFloat size,
- CGAffineTransform* matrix,
- uint32_t symTraitValue,
- uint32_t symTraitMask
-) ;
-
-: <CTLine> ( string font color -- line )
+: <CTLine> ( string open-font color -- line )
[
[
kCTForegroundColorAttributeName set
[ ceiling >fixnum ]
bi@ 2array ;
-:: <line> ( string font foreground background -- line )
+:: <line> ( string font -- line )
[
- [let* | font [ font CFRetain |CFRelease ]
- line [ string font foreground <CTLine> |CFRelease ]
+ [let* | open-font [ font cache-font CFRetain |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 ;
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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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"
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test fonts ;
+IN: fonts.tests
--- /dev/null
+! 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
\ No newline at end of file
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
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
: join-lines ( string -- string' )
"\n" split
- [ rest-slice [ [ blank? ] trim-left-slice ] change-each ]
- [ but-last-slice [ [ blank? ] trim-right-slice ] change-each ]
+ [ rest-slice [ [ blank? ] trim-head-slice ] change-each ]
+ [ but-last-slice [ [ blank? ] trim-tail-slice ] change-each ]
[ " " join ]
tri ;
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" } "." } ;
! 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
[ CHAR: \n over memq? [ string-lines ] when ] dip (>>text) ; inline
: label-theme ( gadget -- gadget )
- sans-serif-font >>font
- black >>color ; inline
+ sans-serif-font >>font ; inline
: new-label ( string class -- label )
new-gadget
[ font>> ] [ text>> ] bi text-dim ;
M: label draw-gadget*
- [ color>> gl-color ]
- [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
+ [ font>> ] [ text>> ] bi origin get draw-text ;
M: label gadget-text* label-string % ;
swap >>model ;
: text-theme ( gadget -- gadget )
- black >>color
monospace-font >>font ;
: reverse-video-theme ( label -- label )
- white >>color
- black solid-interior ;
+ sans-serif-font reverse-video-font >>font ;
GENERIC: >label ( obj -- gadget )
M: string >label <label> ;
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
! Character styles
-: apply-style ( style gadget key quot -- style gadget )
- [ 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 )
+MEMO: specified-font ( assoc -- font )
#! We memoize here to avoid creating lots of duplicate font objects.
- [ <font> ] 3dip
- [ "monospace" or >>name ]
- [
- {
- { f [ ] }
- { plain [ ] }
- { bold [ t >>bold? ] }
- { italic [ t >>italic? ] }
- { bold-italic [ t >>bold? t >>italic? ] }
- } case
- ]
- [ 12 or >>size ]
- tri* ;
+ [ <font> ] dip
+ {
+ [ font-name swap at "monospace" or >>name ]
+ [
+ font-style swap at {
+ { f [ ] }
+ { plain [ ] }
+ { bold [ t >>bold? ] }
+ { italic [ t >>italic? ] }
+ { bold-italic [ t >>bold? t >>italic? ] }
+ } case
+ ]
+ [ font-size swap at 12 or >>size ]
+ [ foreground swap at black or >>foreground ]
+ [ background swap at white or >>background ]
+ } cleave ;
: apply-font-style ( style gadget -- style gadget )
- over
- [ font-name swap at ]
- [ font-style swap at ]
- [ font-size swap at ]
- tri specified-font >>font ;
+ { font-name font-style font-size foreground background }
+ pick extract-keys specified-font >>font ;
+
+: apply-style ( style gadget key quot -- style gadget )
+ [ 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
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
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 } }
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
{ $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"
$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"
! 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.text
-ui.text.private opengl opengl.gl destructors combinators core-foundation
-core-foundation.strings memoize math math.vectors init colors ;
+USING: assocs accessors alien core-graphics.types core-text
+core-text.fonts kernel hashtables namespaces sequences
+ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl destructors
+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 [
[ texture>> delete-texture ]
[ display-list>> delete-dlist ] tri ;
-: rendered-line ( string open-font -- line-display-list )
- world get fonts>> [ cached-line <rendered-line> ] 2cache 0 >>age ;
+: rendered-line ( string font -- rendered-line )
+ world get fonts>>
+ [ cached-line <rendered-line> ] 2cache 0 >>age ;
: age-rendered-lines ( world -- )
[ [ age ] age-assoc ] change-fonts drop ;
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 -- )
{ $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" } } }
-{ $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." } ;
+{ $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." } ;
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." } ;
swap size>> set-char-size
init-font ;
-M: freetype-renderer open-font ( font -- open-font )
- dup freetype-font? [
- freetype drop open-fonts get [ <freetype-font> ] cache
- ] unless ;
+: open-font ( font -- open-font )
+ freetype drop open-fonts get [ <freetype-font> ] cache ;
: load-glyph ( font char -- glyph )
[ handle>> dup ] dip 0 FT_Load_Char
dupd load-glyph glyph-hori-advance ft-ceil
] cache nip ;
-M: freetype-renderer string-width ( open-font string -- w )
- [ [ 0 ] dip ] dip [ char-width + ] with each ;
+M: freetype-renderer string-width ( font string -- w )
+ [ [ 0 ] dip open-font ] dip [ char-width + ] with each ;
-M: freetype-renderer string-height ( open-font string -- h )
- drop height>> ;
+M: freetype-renderer string-height ( font string -- h )
+ drop open-font height>> ;
: glyph-size ( glyph -- dim )
[ glyph-hori-advance ft-ceil ]
IN: ui.text
-USING: help.markup help.syntax kernel ui.text.private strings math ;
-
-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." } ;
+USING: help.markup help.syntax kernel ui.text.private strings math fonts ;
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." } ;
{ $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." } ;
{ $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." } ;
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 }
"Rendering text:"
{ $subsection draw-text }
"Low-level text protocol for UI backends:"
-{ $subsection open-font }
{ $subsection string-width }
{ $subsection string-height }
{ $subsection string-dim }
! 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
M: object finish-text-rendering drop ;
-HOOK: open-font font-renderer ( font -- open-font )
-
-HOOK: string-dim font-renderer ( open-font string -- dim )
+HOOK: string-dim font-renderer ( font string -- dim )
-HOOK: string-width font-renderer ( open-font string -- w )
+HOOK: string-width font-renderer ( font string -- w )
-HOOK: string-height font-renderer ( open-font string -- h )
+HOOK: string-height font-renderer ( font string -- h )
M: object string-dim [ string-width ] [ string-height ] 2bi 2array ;
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*
- [ string-dim combine-text-dim ] with each ;
+ [ { 0 0 } ] 2dip [ string-dim combine-text-dim ] with each ;
: text-width ( font text -- w ) text-dim first ;
[
[
2dup { 0 0 } draw-string
- [ open-font ] dip string-height
- 0.0 swap 0.0 glTranslated
+ 0.0 swap string-height 0.0 glTranslated
] with each
] with-translation ;
\ No newline at end of file
! 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
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 ;
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