basis/core-text/core-text.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays alien alien.c-types alien.syntax kernel
   4 destructors words parser accessors fry words hashtables
   5 sequences memoize assocs math math.functions locals init
   6 namespaces combinators colors core-foundation
   7 core-foundation.strings core-foundation.attributed-strings
   8 core-foundation.utilities core-graphics core-graphics.types ;
   9 IN: core-text
  10
  11 TYPEDEF: void* CTLineRef
  12 TYPEDEF: void* CTFontRef
  13 TYPEDEF: void* CTFontDescriptorRef
  14
  15 <<
  16
  17 : C-GLOBAL:
  18     CREATE-WORD
  19     dup name>> '[ _ f dlsym *void* ]
  20     (( -- value )) define-declared ; parsing
  21
  22 >>
  23
  24 ! CTFontSymbolicTraits
  25 : kCTFontItalicTrait ( -- n ) 0 2^ ; inline
  26 : kCTFontBoldTrait ( -- n ) 1 2^ ; inline
  27 : kCTFontExpandedTrait ( -- n ) 5 2^ ; inline
  28 : kCTFontCondensedTrait ( -- n ) 6 2^ ; inline
  29 : kCTFontMonoSpaceTrait ( -- n ) 10 2^ ; inline
  30 : kCTFontVerticalTrait ( -- n ) 11 2^ ; inline
  31 : kCTFontUIOptimizedTrait ( -- n ) 12 2^ ; inline
  32
  33 C-GLOBAL: kCTFontSymbolicTrait
  34 C-GLOBAL: kCTFontWeightTrait
  35 C-GLOBAL: kCTFontWidthTrait
  36 C-GLOBAL: kCTFontSlantTrait
  37
  38 C-GLOBAL: kCTFontNameAttribute
  39 C-GLOBAL: kCTFontDisplayNameAttribute
  40 C-GLOBAL: kCTFontFamilyNameAttribute
  41 C-GLOBAL: kCTFontStyleNameAttribute
  42 C-GLOBAL: kCTFontTraitsAttribute
  43 C-GLOBAL: kCTFontVariationAttribute
  44 C-GLOBAL: kCTFontSizeAttribute
  45 C-GLOBAL: kCTFontMatrixAttribute
  46 C-GLOBAL: kCTFontCascadeListAttribute
  47 C-GLOBAL: kCTFontCharacterSetAttribute
  48 C-GLOBAL: kCTFontLanguagesAttribute
  49 C-GLOBAL: kCTFontBaselineAdjustAttribute
  50 C-GLOBAL: kCTFontMacintoshEncodingsAttribute
  51 C-GLOBAL: kCTFontFeaturesAttribute
  52 C-GLOBAL: kCTFontFeatureSettingsAttribute
  53 C-GLOBAL: kCTFontFixedAdvanceAttribute
  54 C-GLOBAL: kCTFontOrientationAttribute
  55
  56 FUNCTION: CTFontDescriptorRef CTFontDescriptorCreateWithAttributes (
  57    CFDictionaryRef attributes
  58 ) ;
  59
  60 FUNCTION: CTFontRef CTFontCreateWithName (
  61    CFStringRef name,
  62    CGFloat size,
  63    CGAffineTransform* matrix
  64 ) ;
  65
  66 FUNCTION: CTFontRef CTFontCreateWithFontDescriptor (
  67    CTFontDescriptorRef descriptor,
  68    CGFloat size,
  69    CGAffineTransform* matrix
  70 ) ;
  71
  72 C-GLOBAL: kCTFontAttributeName
  73 C-GLOBAL: kCTKernAttributeName
  74 C-GLOBAL: kCTLigatureAttributeName
  75 C-GLOBAL: kCTForegroundColorAttributeName
  76 C-GLOBAL: kCTParagraphStyleAttributeName
  77 C-GLOBAL: kCTUnderlineStyleAttributeName
  78 C-GLOBAL: kCTVerticalFormsAttributeName
  79 C-GLOBAL: kCTGlyphInfoAttributeName
  80
  81 FUNCTION: CTLineRef CTLineCreateWithAttributedString ( CFAttributedStringRef string ) ;
  82
  83 FUNCTION: void CTLineDraw ( CTLineRef line, CGContextRef context ) ;
  84
  85 FUNCTION: CGFloat CTLineGetOffsetForStringIndex ( CTLineRef line, CFIndex charIndex, CGFloat* secondaryOffset ) ;
  86
  87 FUNCTION: CFIndex CTLineGetStringIndexForPosition ( CTLineRef line, CGPoint position ) ;
  88
  89 FUNCTION: double CTLineGetTypographicBounds ( CTLineRef line, CGFloat* ascent, CGFloat* descent, CGFloat* leading ) ;
  90
  91 FUNCTION: CGRect CTLineGetImageBounds ( CTLineRef line, CGContextRef context ) ;
  92
  93 FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
  94    CTFontRef font,
  95    CGFloat size,
  96    CGAffineTransform* matrix,
  97    uint32_t symTraitValue,
  98    uint32_t symTraitMask
  99 ) ;
 100
 101 : <CTLine> ( string font color -- line )
 102     [
 103         [
 104             kCTForegroundColorAttributeName set
 105             kCTFontAttributeName set
 106         ] H{ } make-assoc <CFAttributedString> &CFRelease
 107         CTLineCreateWithAttributedString
 108     ] with-destructors ;
 109
 110 TUPLE: line font line bounds dim bitmap age refs disposed ;
 111
 112 TUPLE: typographic-bounds width ascent descent leading ;
 113
 114 : line-typographic-bounds ( line -- typographic-bounds )
 115     0 <CGFloat> 0 <CGFloat> 0 <CGFloat>
 116     [ CTLineGetTypographicBounds ] 3keep [ *CGFloat ] tri@
 117     typographic-bounds boa ;
 118
 119 : bounds>dim ( bounds -- dim )
 120     [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
 121     [ ceiling >fixnum ]
 122     bi@ 2array ;
 123
 124 :: <line> ( string font foreground background -- line )
 125     [
 126         [let* | font [ font CFRetain |CFRelease ]
 127                 line [ string font foreground <CTLine> |CFRelease ]
 128                 bounds [ line line-typographic-bounds ]
 129                 dim [ bounds bounds>dim ] |
 130             dim [
 131                 {
 132                     [ background >rgba-components CGContextSetRGBFillColor ]
 133                     [ 0 0 dim first2 <CGRect> CGContextFillRect ]
 134                     [ 0 bounds descent>> CGContextSetTextPosition ]
 135                     [ line swap CTLineDraw ]
 136                 } cleave
 137             ] with-bitmap-context
 138             [ font line bounds dim ] dip 0 0 f
 139         ]
 140         line boa
 141     ] with-destructors ;
 142
 143 M: line dispose* [ font>> CFRelease ] [ line>> CFRelease ] bi ;
 144
 145 : ref/unref-line ( line n -- )
 146     '[ _ + ] change-refs 0 >>age drop ;
 147
 148 : ref-line ( line -- ) 1 ref/unref-line ;
 149 : unref-line ( line -- ) -1 ref/unref-line ;
 150
 151 SYMBOL: cached-lines
 152
 153 : cached-line ( string font -- line )
 154     black white 4array cached-lines get [ first4 <line> ] cache ;
 155
 156 CONSTANT: max-line-age 10
 157
 158 : age ( obj -- ? )
 159     [ 1+ ] change-age age>> max-line-age >= ;
 160
 161 : age-line ( line -- ? )
 162     #! Outputs t whether the line is dead.
 163     dup refs>> 0 = [ age ] [ drop f ] if ;
 164
 165 : age-assoc ( assoc quot -- assoc' )
 166     '[ nip @ ] assoc-partition
 167     [ values dispose-each ] dip ;
 168
 169 : age-lines ( -- )
 170     cached-lines global [ [ age-line ] age-assoc ] change-at ;
 171
 172 [ H{ } clone cached-lines set-global ] "core-text" add-init-hook