diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index fd8adc4e78..9f1e77758c 100644 --- a/basis/core-text/core-text.factor +++ b/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 ( - CTFontRef font, - CGFloat size, - CGAffineTransform* matrix, - uint32_t symTraitValue, - uint32_t symTraitMask -) ; - -: ( string font color -- line ) +: ( string open-font color -- line ) [ [ kCTForegroundColorAttributeName set @@ -121,21 +55,21 @@ TUPLE: typographic-bounds width ascent descent leading ; [ ceiling >fixnum ] bi@ 2array ; -:: ( string font foreground background -- line ) +:: ( string font -- line ) [ - [let* | font [ font CFRetain |CFRelease ] - line [ string font foreground |CFRelease ] + [let* | open-font [ font cache-font CFRetain |CFRelease ] + line [ string open-font font foreground>> |CFRelease ] bounds [ line line-typographic-bounds ] dim [ bounds bounds>dim ] | dim [ { - [ background >rgba-components CGContextSetRGBFillColor ] + [ font background>> >rgba-components CGContextSetRGBFillColor ] [ 0 0 dim first2 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 ] cache ; + cached-lines get [ ] 2cache ; CONSTANT: max-line-age 10 diff --git a/basis/core-text/fonts/authors.txt b/basis/core-text/fonts/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/core-text/fonts/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/core-text/fonts/fonts-tests.factor b/basis/core-text/fonts/fonts-tests.factor new file mode 100644 index 0000000000..45fa2bcdc0 --- /dev/null +++ b/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 diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor new file mode 100644 index 0000000000..2cc533a500 --- /dev/null +++ b/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 &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 diff --git a/basis/core-text/utilities/authors.txt b/basis/core-text/utilities/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/core-text/utilities/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/core-text/utilities/utilities-tests.factor b/basis/core-text/utilities/utilities-tests.factor new file mode 100644 index 0000000000..65914a3fcd --- /dev/null +++ b/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 diff --git a/basis/core-text/utilities/utilities.factor b/basis/core-text/utilities/utilities.factor new file mode 100644 index 0000000000..59c033f3a4 --- /dev/null +++ b/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 diff --git a/basis/fonts/authors.txt b/basis/fonts/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/fonts/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/fonts/fonts-docs.factor b/basis/fonts/fonts-docs.factor new file mode 100644 index 0000000000..bfd67d8fbf --- /dev/null +++ b/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: +{ $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 } +"Modifying fonts:" +{ $subsection font-with-foreground } +{ $subsection font-with-background } +"Useful constants:" +{ $subsection monospace-font } +{ $subsection sans-serif-font } +{ $subsection serif-font } ; + +ABOUT: "fonts" diff --git a/basis/fonts/fonts-tests.factor b/basis/fonts/fonts-tests.factor new file mode 100644 index 0000000000..25856e0cd8 --- /dev/null +++ b/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 diff --git a/basis/fonts/fonts.factor b/basis/fonts/fonts.factor new file mode 100644 index 0000000000..4cec03b949 --- /dev/null +++ b/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 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 ) + + "serif" >>name + 12 >>size ; foldable + +: sans-serif-font ( -- font ) + + "sans-serif" >>name + 12 >>size ; foldable + +: monospace-font ( -- font ) + + "monospace" >>name + 12 >>size ; foldable \ No newline at end of file diff --git a/basis/ui/gadgets/editors/editors-docs.factor b/basis/ui/gadgets/editors/editors-docs.factor index 4a5f683ae0..a17642ca45 100644 --- a/basis/ui/gadgets/editors/editors-docs.factor +++ b/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 diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 4699cdc5e6..32e124afd7 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/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 ] - [ 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 ; diff --git a/basis/ui/gadgets/grid-lines/grid-lines-docs.factor b/basis/ui/gadgets/grid-lines/grid-lines-docs.factor index 0838f1ded7..73eaca13f0 100644 --- a/basis/ui/gadgets/grid-lines/grid-lines-docs.factor +++ b/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" } "." } ; diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index ea7394b6f3..5f7ceecfb5 100644 --- a/basis/ui/gadgets/labels/labels.factor +++ b/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 - 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