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.data alien.syntax kernel
   4 destructors accessors fry words hashtables strings sequences
   5 memoize assocs math math.order math.vectors math.rectangles
   6 math.functions locals init namespaces combinators fonts colors
   7 cache core-foundation core-foundation.strings
   8 core-foundation.attributed-strings core-foundation.utilities
   9 core-graphics core-graphics.types core-text.fonts ;
  10 IN: core-text
  11
  12 TYPEDEF: void* CTLineRef
  13
  14 C-GLOBAL: CFStringRef kCTFontAttributeName
  15 C-GLOBAL: CFStringRef kCTKernAttributeName
  16 C-GLOBAL: CFStringRef kCTLigatureAttributeName
  17 C-GLOBAL: CFStringRef kCTForegroundColorAttributeName
  18 C-GLOBAL: CFStringRef kCTParagraphStyleAttributeName
  19 C-GLOBAL: CFStringRef kCTUnderlineStyleAttributeName
  20 C-GLOBAL: CFStringRef kCTVerticalFormsAttributeName
  21 C-GLOBAL: CFStringRef kCTGlyphInfoAttributeName
  22
  23 FUNCTION: CTLineRef CTLineCreateWithAttributedString ( CFAttributedStringRef string ) ;
  24
  25 FUNCTION: void CTLineDraw ( CTLineRef line, CGContextRef context ) ;
  26
  27 FUNCTION: CGFloat CTLineGetOffsetForStringIndex ( CTLineRef line, CFIndex charIndex, CGFloat* secondaryOffset ) ;
  28
  29 FUNCTION: CFIndex CTLineGetStringIndexForPosition ( CTLineRef line, CGPoint position ) ;
  30
  31 FUNCTION: double CTLineGetTypographicBounds ( CTLineRef line, CGFloat* ascent, CGFloat* descent, CGFloat* leading ) ;
  32
  33 FUNCTION: CGRect CTLineGetImageBounds ( CTLineRef line, CGContextRef context ) ;
  34
  35 ERROR: not-a-string object ;
  36
  37 : <CTLine> ( string open-font color -- line )
  38     [
  39         [
  40             dup selection? [ string>> ] when
  41             dup string? [ not-a-string ] unless
  42         ] 2dip
  43         [
  44             kCTForegroundColorAttributeName set
  45             kCTFontAttributeName set
  46         ] H{ } make-assoc <CFAttributedString> &CFRelease
  47         CTLineCreateWithAttributedString
  48     ] with-destructors ;
  49
  50 TUPLE: line < disposable line metrics image loc dim rendered-line ;
  51
  52 TUPLE: rendered-line font string loc dim ;
  53 C: <rendered-line> rendered-line
  54
  55 : typographic-bounds ( line -- width ascent descent leading )
  56     { CGFloat CGFloat CGFloat }
  57     [ CTLineGetTypographicBounds ] with-out-parameters ; inline
  58
  59 : store-typographic-bounds ( metrics width ascent descent leading -- metrics )
  60     {
  61         [ >>width ]
  62         [ >>ascent ]
  63         [ >>descent ]
  64         [ >>leading ]
  65     } spread ; inline
  66
  67 : compute-font-metrics ( metrics font -- metrics )
  68     [ CTFontGetCapHeight >>cap-height ]
  69     [ CTFontGetXHeight >>x-height ]
  70     bi ; inline
  71
  72 : compute-line-metrics ( open-font line -- line-metrics )
  73     [ metrics new ] 2dip
  74     [ compute-font-metrics ]
  75     [ typographic-bounds store-typographic-bounds ] bi*
  76     compute-height ;
  77
  78 : metrics>dim ( bounds -- dim )
  79     [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
  80     [ ceiling >integer ]
  81     bi@ 2array ;
  82
  83 : fill-background ( context font dim -- )
  84     [ background>> >rgba-components CGContextSetRGBFillColor ]
  85     [ [ 0 0 ] dip first2 <CGRect> CGContextFillRect ]
  86     bi-curry* bi ;
  87
  88 : selection-rect ( dim line selection -- rect )
  89     [ start>> ] [ end>> ] bi
  90     [ f CTLineGetOffsetForStringIndex round ] bi-curry@ bi
  91     [ drop nip 0 ] [ swap - swap second ] 3bi <CGRect> ;
  92
  93 : CGRect-translate-x ( CGRect x -- CGRect' )
  94     [ dup CGRect-x ] dip - over set-CGRect-x ;
  95
  96 :: fill-selection-background ( context loc dim line string -- )
  97     string selection? [
  98         context string color>> >rgba-components CGContextSetRGBFillColor
  99         context dim line string selection-rect
 100         loc first CGRect-translate-x
 101         CGContextFillRect
 102     ] when ;
 103
 104 : line-rect ( line -- rect )
 105     dummy-context CTLineGetImageBounds ;
 106
 107 : set-text-position ( context loc -- )
 108     first2 [ neg ] bi@ CGContextSetTextPosition ;
 109
 110 :: line-loc ( metrics loc dim -- loc )
 111     loc first
 112     metrics ascent>> ceiling dim second loc second + - 2array ;
 113
 114 :: <line> ( font string -- line )
 115     [
 116         line new-disposable
 117
 118         font cache-font :> open-font
 119         string open-font font foreground>> <CTLine> |CFRelease :> line
 120
 121         line line-rect :> rect
 122         rect origin>> CGPoint>loc :> (loc)
 123         rect size>> CGSize>dim :> (dim)
 124         (loc) (dim) v+ :> (ext)
 125         (loc) [ floor ] map :> loc
 126         (loc) (dim) [ + ceiling ] 2map :> ext
 127         ext loc [ - >integer 1 max ] 2map :> dim
 128         open-font line compute-line-metrics :> metrics
 129
 130         line >>line
 131
 132         font string loc dim <rendered-line> >>rendered-line
 133
 134         metrics >>metrics
 135
 136         metrics loc dim line-loc >>loc
 137
 138         metrics metrics>dim >>dim
 139     ] with-destructors ;
 140
 141 :: render ( line -- line image )
 142     line line>> :> ctline
 143     line rendered-line>> string>> :> string
 144     line rendered-line>> font>> :> font
 145     line rendered-line>> loc>> :> loc
 146     line rendered-line>> dim>> :> dim
 147
 148     line dim [
 149         {
 150             [ font dim fill-background ]
 151             [ loc dim ctline string fill-selection-background ]
 152             [ loc set-text-position ]
 153             [ [ ctline ] dip CTLineDraw ]
 154         } cleave
 155     ] make-bitmap-image ;
 156
 157 : line>image ( line -- image )
 158     dup image>> [ render >>image ] unless image>> ;
 159
 160 M: line dispose* line>> CFRelease ;
 161
 162 SYMBOL: cached-lines
 163
 164 : cached-line ( font string -- line )
 165     cached-lines get [ <line> ] 2cache ;
 166
 167 [ <cache-assoc> cached-lines set-global ] "core-text" add-startup-hook