steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add foreground and background color slots to font tuple

db4
Slava Pestov 2009-01-30 03:36:39 -06:00
parent 0a0431e6ab
commit 990c99a97e
27 changed files with 309 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
basis/core-text/core-text.factor
View File

@ -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 (
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
@ -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 ]
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 ;
@ -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

1
basis/core-text/fonts/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/core-text/fonts/fonts-tests.factor Normal file
View File

@ -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

102
basis/core-text/fonts/fonts.factor Normal file
View File

@ -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

1
basis/core-text/utilities/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/core-text/utilities/utilities-tests.factor Normal file
View File

@ -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

9
basis/core-text/utilities/utilities.factor Normal file
View File

@ -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

1
basis/fonts/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

39
basis/fonts/fonts-docs.factor Normal file
View File

@ -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"

4
basis/fonts/fonts-tests.factor Normal file
View File

@ -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

47
basis/fonts/fonts.factor Normal file
View File

@ -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

2
basis/ui/gadgets/editors/editors-docs.factor
View File

@ -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

6
basis/ui/gadgets/editors/editors.factor
View File

@ -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 ]
[ 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 ;

5
basis/ui/gadgets/grid-lines/grid-lines-docs.factor
View File

@ -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" } "." } ;

14
basis/ui/gadgets/labels/labels.factor
View File

@ -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
black >>color ; inline
sans-serif-font >>font ; 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 ] bi ;
[ font>> ] [ text>> ] bi origin get draw-text ;
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
black solid-interior ;
sans-serif-font reverse-video-font >>font ;
GENERIC: >label ( obj -- gadget )
M: string >label <label> ;

40
basis/ui/gadgets/panes/panes.factor
View File

@ -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 )
[ 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 ]
[
[ <font> ] dip
{
[ 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 ]
tri* ;
[ 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

2
basis/ui/gadgets/tables/tables.factor
View File

@ -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

4
basis/ui/gadgets/theme/theme.factor
View File

@ -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 } }

16
basis/ui/render/render-docs.factor
View File

@ -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"

59
basis/ui/text/core-text/core-text.factor
View File

@ -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
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 [
@ -82,8 +46,9 @@ M: rendered-line dispose*
[ 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 ;
@ -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 -- )

13
basis/ui/text/freetype/freetype-docs.factor
View File

@ -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" } } }
{ $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." } ;

14
basis/ui/text/freetype/freetype.factor
View File

@ -107,10 +107,8 @@ SYMBOL: dpi
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
@ -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 )
[ [ 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 ]

17
basis/ui/text/text-docs.factor
View File

@ -1,14 +1,8 @@
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." } ;
@ -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 }

23
basis/ui/text/text.factor
View File

@ -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 ( open-font string -- h )
HOOK: string-height font-renderer ( 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*
[ 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 ;
@ -64,7 +58,6 @@ M: sequence draw-text
[
[
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 ;

2
basis/ui/tools/inspector/inspector.factor
View File

@ -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

2
basis/ui/tools/listener/completion/completion.factor
View File

@ -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 ;

2
basis/ui/ui-docs.factor
View File

@ -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