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 5c57034632ea973d43a023f0e3a3d4e1ca2ce985..a91a52bf04a65017a390a086a464868dea975067 100644 (file)
--- a/basis/core-text/fonts/fonts.factor
+++ b/basis/core-text/fonts/fonts.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.syntax assocs core-foundation
-core-foundation.dictionaries core-foundation.strings
-core-graphics.types destructors init
-kernel math memoize fonts combinators unix.types ;
+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
@@ -43,19 +43,19 @@ 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,
@@ -63,55 +63,49 @@ FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
    CGAffineTransform* matrix,
    uint32_t symTraitValue,
    uint32_t symTraitMask
-) ;
+)
 
-FUNCTION: CGFloat CTFontGetAscent ( CTFontRef font ) ;
+FUNCTION: CGFloat CTFontGetAscent ( CTFontRef font )
 
-FUNCTION: CGFloat CTFontGetDescent ( CTFontRef font ) ;
+FUNCTION: CGFloat CTFontGetDescent ( CTFontRef font )
 
-FUNCTION: CGFloat CTFontGetLeading ( CTFontRef font ) ;
+FUNCTION: CGFloat CTFontGetLeading ( CTFontRef font )
 
-FUNCTION: CGFloat CTFontGetCapHeight ( CTFontRef font ) ;
+FUNCTION: CGFloat CTFontGetCapHeight ( CTFontRef font )
 
-FUNCTION: CGFloat CTFontGetXHeight ( 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 drop ;
 
-: (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 ;
+    [ 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 )
-    strip-font-colors (cache-font) ;
+    [ 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) ( font -- metrics )
-    [ metrics new ] dip
+MEMO: (cache-font-metrics) ( name size traits -- metrics )
+    [ metrics new ] 3dip
     (cache-font) {
         [ CTFontGetAscent >>ascent ]
         [ CTFontGetDescent >>descent ]
@@ -122,9 +116,9 @@ MEMO: (cache-font-metrics) ( font -- metrics )
     compute-height ;
 
 : cache-font-metrics ( font -- metrics )
-    strip-font-colors (cache-font-metrics) ;
+    [ name>> ] [ size>> ] [ font-traits ] tri (cache-font-metrics) ;
 
 [
     \ (cache-font) reset-memoized
     \ (cache-font-metrics) reset-memoized
-] "core-text.fonts" add-init-hook
+] "core-text.fonts" add-startup-hook