factor: trim using lists

[factor.git] / basis / core-text / fonts / fonts.factor

diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor
index 2cc533a500eabe53219c644c06e190506039859c..a91a52bf04a65017a390a086a464868dea975067 100644 (file)
--- a/basis/core-text/fonts/fonts.factor
+++ b/basis/core-text/fonts/fonts.factor
@@ -1,8 +1,9 @@
 ! 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 ;
+USING: accessors alien.c-types alien.syntax assocs combinators
+core-foundation core-foundation.dictionaries
+core-foundation.strings core-graphics.types destructors fonts
+init kernel math memoize unix.types ;
 IN: core-text.fonts
 
 TYPEDEF: void* CTFontRef
@@ -17,44 +18,44 @@ TYPEDEF: void* CTFontDescriptorRef
 : 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
+C-GLOBAL: CFStringRef kCTFontSymbolicTrait
+C-GLOBAL: CFStringRef kCTFontWeightTrait
+C-GLOBAL: CFStringRef kCTFontWidthTrait
+C-GLOBAL: CFStringRef kCTFontSlantTrait
+
+C-GLOBAL: CFStringRef kCTFontNameAttribute
+C-GLOBAL: CFStringRef kCTFontDisplayNameAttribute
+C-GLOBAL: CFStringRef kCTFontFamilyNameAttribute
+C-GLOBAL: CFStringRef kCTFontStyleNameAttribute
+C-GLOBAL: CFStringRef kCTFontTraitsAttribute
+C-GLOBAL: CFStringRef kCTFontVariationAttribute
+C-GLOBAL: CFStringRef kCTFontSizeAttribute
+C-GLOBAL: CFStringRef kCTFontMatrixAttribute
+C-GLOBAL: CFStringRef kCTFontCascadeListAttribute
+C-GLOBAL: CFStringRef kCTFontCharacterSetAttribute
+C-GLOBAL: CFStringRef kCTFontLanguagesAttribute
+C-GLOBAL: CFStringRef kCTFontBaselineAdjustAttribute
+C-GLOBAL: CFStringRef kCTFontMacintoshEncodingsAttribute
+C-GLOBAL: CFStringRef kCTFontFeaturesAttribute
+C-GLOBAL: CFStringRef kCTFontFeatureSettingsAttribute
+C-GLOBAL: CFStringRef kCTFontFixedAdvanceAttribute
+C-GLOBAL: CFStringRef 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,
@@ -62,41 +63,62 @@ FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
    CGAffineTransform* matrix,
    uint32_t symTraitValue,
    uint32_t symTraitMask
-) ;
+)
+
+FUNCTION: CGFloat CTFontGetAscent ( CTFontRef font )
+
+FUNCTION: CGFloat CTFontGetDescent ( CTFontRef font )
+
+FUNCTION: CGFloat CTFontGetLeading ( CTFontRef font )
+
+FUNCTION: CGFloat CTFontGetCapHeight ( CTFontRef font )
+
+FUNCTION: CGFloat CTFontGetXHeight ( CTFontRef font )
 
 CONSTANT: font-names
     H{
-        { "monospace" "Monaco" }
-        { "sans-serif" "Lucida Grande" }
+        { "monospace" "Menlo" }
+        { "sans-serif" "LucidaGrande" }
         { "serif" "Times" }
     }
 
 : font-name ( string -- string' )
-    font-names at-default ;
-
-: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
-
-: (italic) ( x -- y ) kCTFontItalicTrait bitor ; inline
+    font-names ?at drop ;
 
 : font-traits ( font -- n )
     [ 0 ] dip
-    [ bold?>> [ (bold) ] when ]
-    [ italic?>> [ (italic) ] when ] bi ;
+    [ bold?>> [ kCTFontBoldTrait bitor ] when ]
+    [ italic?>> [ kCTFontItalicTrait bitor ] 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 )
+MEMO:: (cache-font) ( name size traits -- open-font )
     [
-        [
-            [ name>> font-name <CFString> &CFRelease ] [ size>> ] bi
-            f CTFontCreateWithName
-        ] keep apply-font-traits
+        name font-name <CFString> &CFRelease
+        size f CTFontCreateWithName dup
+        0.0 f traits dup CTFontCreateCopyWithSymbolicTraits
+        [ [ CFRelease ] dip ] when*
     ] with-destructors ;
 
 : cache-font ( font -- open-font )
-    clone f >>foreground f >>background (cache-font) ;
-
-[ \ (cache-font) reset-memoized ] "core-text.fonts" add-init-hook
+    [ name>> ] [ size>> ] [ font-traits ] tri (cache-font) ;
+
+: cache-font@2x ( font -- open-font )
+    [ name>> ] [ size>> 2 * ] [ font-traits ] tri (cache-font) ;
+
+MEMO: (cache-font-metrics) ( name size traits -- metrics )
+    [ metrics new ] 3dip
+    (cache-font) {
+        [ CTFontGetAscent >>ascent ]
+        [ CTFontGetDescent >>descent ]
+        [ CTFontGetLeading >>leading ]
+        [ CTFontGetCapHeight >>cap-height ]
+        [ CTFontGetXHeight >>x-height ]
+    } cleave
+    compute-height ;
+
+: cache-font-metrics ( font -- metrics )
+    [ name>> ] [ size>> ] [ font-traits ] tri (cache-font-metrics) ;
+
+[
+    \ (cache-font) reset-memoized
+    \ (cache-font-metrics) reset-memoized
+] "core-text.fonts" add-startup-hook