Get text styles working with core-text binding

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

@@ -6,19 +6,19 @@ arrays kernel generalizations math accessors
 combinators hashtables ;
 IN: core-text.tests
 
-: test-font ( -- object )
-    "Helvetica" kCTFontNameAttribute associate <CTFont> ;
+: test-font ( name -- object )
+    kCTFontFamilyNameAttribute associate <CTFont> ;
 
-[ ] [ test-font CFRelease ] unit-test
+[ ] [ "Helvetica" test-font CFRelease ] unit-test
 
 [ ] [
     [
-        kCTFontAttributeName test-font &CFRelease 2array 1array
+        kCTFontAttributeName "Helvetica" test-font &CFRelease 2array 1array
         <CFDictionary> &CFRelease drop
     ] with-destructors
 ] unit-test
 
-: test-typographic-bounds ( string -- ? )
+: test-typographic-bounds ( string font -- ? )
     [
         test-font &CFRelease <CTLine> &CFRelease
         line-typographic-bounds {
@@ -29,6 +29,8 @@ IN: core-text.tests
         } cleave and and and
     ] with-destructors ;
 
-[ t ] [ "Hello world" test-typographic-bounds ] unit-test
+[ t ] [ "Hello world" "Helvetica" test-typographic-bounds ] unit-test
 
-[ t ] [ "日本語" test-typographic-bounds ] unit-test
+[ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test
+
+[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test

basis/core-text/core-text.factor

@@ -21,6 +21,15 @@ 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
@@ -88,6 +97,14 @@ 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 -- line )
     [
         kCTFontAttributeName associate <CFAttributedString> &CFRelease

basis/ui/cocoa/text/text.factor

@@ -2,9 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors alien core-graphics.types core-text kernel
 hashtables namespaces sequences ui.gadgets.worlds ui.render
-opengl opengl.gl destructors combinators combinators.smart
-core-foundation core-foundation.dictionaries core-foundation.numbers
-core-foundation.strings io.styles memoize ;
+opengl opengl.gl destructors combinators core-foundation
+core-foundation.strings io.styles memoize math ;
 IN: ui.cocoa.text
 
 SINGLETON: core-text-renderer
@@ -16,43 +15,33 @@ CONSTANT: font-names
         { "serif" "Times" }
     }
 
-: (bold) ( -- ) 1.0 kCTFontWeightTrait set ;
+: font-name ( string -- string' )
+    font-names at-default ;
 
-: (italic) ( -- ) 1.0 kCTFontSlantTrait set ;
+: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
 
-: font-traits ( style -- dictionary )
-    [
-        {
-            { plain [ ] }
-            { bold [ (bold) ] }
-            { italic [ (italic) ] }
-            { bold-italic [ (bold) (italic) ] }
-        } case
-    ] H{ } make-assoc ;
+: (italic) ( x -- y ) kCTFontItalicTrait bitor ; inline
 
-: font-name-attr ( name -- )
-    font-names at-default kCTFontNameAttribute set ;
+: font-traits ( style -- mask )
+    [ 0 ] dip {
+        { plain [ ] }
+        { bold [ (bold) ] }
+        { italic [ (italic) ] }
+        { bold-italic [ (bold) (italic) ] }
+    } case ;
 
-: font-traits-attr ( style -- )
-    font-traits kCTFontTraitsAttribute set ;
-
-: font-size-attr ( size -- )
-    kCTFontSizeAttribute set ;
-
-: font-attrs ( font -- dictionary )
-    [
-        [
-            [
-                [ font-name-attr ]
-                [ font-traits-attr ]
-                [ font-size-attr ]
-                tri*
-            ] input<sequence
-        ] H{ } make-assoc
-    ] with-destructors ;
+: 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 )
-    font-attrs <CTFont> ;
+    [
+        [
+            [ first font-name <CFString> &CFRelease ] [ third ] bi
+            f CTFontCreateWithName
+        ] [ second ] bi apply-font-traits
+    ] with-destructors ;
 
 M: core-text-renderer open-font
     dup alien? [ cache-font ] unless ;