basis/ui/text/freetype/freetype.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien alien.accessors alien.c-types arrays io kernel libc
   4 math math.vectors namespaces opengl opengl.gl opengl.sprites assocs
   5 sequences io.files continuations freetype
   6 ui.gadgets.worlds ui.text ui.text.private ui.backend
   7 byte-arrays accessors locals specialized-arrays.direct.uchar
   8 combinators.smart ;
   9 IN: ui.text.freetype
  10
  11 SINGLETON: freetype-renderer
  12
  13 SYMBOL: open-fonts
  14
  15 : freetype-error ( n -- )
  16     zero? [ "FreeType error" throw ] unless ;
  17
  18 DEFER: freetype
  19
  20 : init-freetype ( -- )
  21     global [
  22         f <void*> dup FT_Init_FreeType freetype-error
  23         *void* \ freetype set
  24         H{ } clone open-fonts set
  25     ] bind ;
  26
  27 : freetype ( -- alien )
  28     \ freetype get-global expired? [ init-freetype ] when
  29     \ freetype get-global ;
  30
  31 TUPLE: freetype-font < identity-tuple
  32 ascent descent height handle widths ;
  33
  34 M: freetype-font hashcode* drop freetype-font hashcode* ;
  35
  36 : close-font ( font -- ) handle>> FT_Done_Face ;
  37
  38 : close-freetype ( -- )
  39     global [
  40         open-fonts [ [ drop close-font ] assoc-each f ] change
  41         freetype [ FT_Done_FreeType f ] change
  42     ] bind ;
  43
  44 M: freetype-renderer free-fonts ( world -- )
  45     values [ second free-sprites ] each ;
  46
  47 : ttf-name ( font -- name )
  48     [ [ name>> ] [ bold?>> ] [ italic?>> ] tri ] output>array H{
  49         { { "monospace" f f } "VeraMono" }
  50         { { "monospace" t f } "VeraMoBd" }
  51         { { "monospace" t t } "VeraMoBI" }
  52         { { "monospace" f t } "VeraMoIt" }
  53         { { "sans-serif" f f } "Vera" }
  54         { { "sans-serif" t f } "VeraBd" }
  55         { { "sans-serif" t t } "VeraBI" }
  56         { { "sans-serif" f t } "VeraIt" }
  57         { { "serif" f f } "VeraSe" }
  58         { { "serif" t f } "VeraSeBd" }
  59         { { "serif" t t } "VeraBI" }
  60         { { "serif" f t } "VeraIt" }
  61     } at ;
  62
  63 : ttf-path ( name -- string )
  64     "resource:fonts/" ".ttf" surround ;
  65
  66 : (open-face) ( path length -- face )
  67     #! We use FT_New_Memory_Face, not FT_New_Face, since
  68     #! FT_New_Face only takes an ASCII path name and causes
  69     #! problems on localized versions of Windows
  70     [ freetype ] 2dip 0 f <void*> [
  71         FT_New_Memory_Face freetype-error
  72     ] keep *void* ;
  73
  74 : open-face ( font -- face )
  75     ttf-name ttf-path malloc-file-contents (open-face) ;
  76
  77 SYMBOL: dpi
  78
  79 72 dpi set-global
  80
  81 : ft-floor ( m -- n ) -6 shift ; inline
  82
  83 : ft-ceil ( m -- n ) 63 + -64 bitand -6 shift ; inline
  84
  85 : font-units>pixels ( n font -- n )
  86     face-size face-size-y-scale FT_MulFix ;
  87
  88 : init-ascent ( font face -- font )
  89     dup face-y-max swap font-units>pixels >>ascent ; inline
  90
  91 : init-descent ( font face -- font )
  92     dup face-y-min swap font-units>pixels >>descent ; inline
  93
  94 : init-font ( font -- font )
  95     dup handle>> init-ascent
  96     dup handle>> init-descent
  97     dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
  98
  99 : set-char-size ( open-font size -- open-font )
 100     [ dup handle>> 0 ] dip
 101     6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
 102
 103 : <freetype-font> ( font -- open-font )
 104     freetype-font new
 105         H{ } clone >>widths
 106         over open-face >>handle
 107         swap size>> set-char-size
 108         init-font ;
 109
 110 M: freetype-renderer open-font ( font -- open-font )
 111     dup freetype-font? [
 112         freetype drop open-fonts get [ <freetype-font> ] cache
 113     ] unless ;
 114
 115 : load-glyph ( font char -- glyph )
 116     [ handle>> dup ] dip 0 FT_Load_Char
 117     freetype-error face-glyph ;
 118
 119 : char-width ( open-font char -- w )
 120     over widths>> [
 121         dupd load-glyph glyph-hori-advance ft-ceil
 122     ] cache nip ;
 123
 124 M: freetype-renderer string-width ( open-font string -- w )
 125     [ [ 0 ] dip ] dip [ char-width + ] with each ;
 126
 127 M: freetype-renderer string-height ( open-font string -- h )
 128     drop height>> ;
 129
 130 : glyph-size ( glyph -- dim )
 131     [ glyph-hori-advance ft-ceil ]
 132     [ glyph-height ft-ceil ]
 133     bi 2array ;
 134
 135 : render-glyph ( font char -- bitmap )
 136     load-glyph dup
 137     FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
 138
 139 :: copy-pixel ( i j bitmap texture -- i j )
 140     255 j texture set-nth
 141     i bitmap nth j 1 + texture set-nth
 142     i 1 + j 2 + ; inline
 143
 144 :: (copy-row) ( i j bitmap texture end -- )
 145     i end < [
 146         i j bitmap texture copy-pixel
 147             bitmap texture end (copy-row)
 148     ] when ; inline recursive
 149
 150 :: copy-row ( i j bitmap texture width width2 -- i j )
 151     i j bitmap texture i width + (copy-row)
 152     i width +
 153     j width2 + ; inline
 154
 155 :: copy-bitmap ( glyph texture -- )
 156     [let* | bitmap [ glyph glyph-bitmap-buffer ]
 157             rows [ glyph glyph-bitmap-rows ]
 158             width [ glyph glyph-bitmap-width ]
 159             width2 [ width next-power-of-2 2 * ] |
 160         bitmap [
 161             bitmap rows width * <direct-uchar-array> :> bitmap'
 162             0 0
 163             rows [ bitmap' texture width width2 copy-row ] times
 164             2drop
 165         ] when
 166     ] ;
 167
 168 : bitmap>texture ( glyph sprite -- id )
 169     tuck dim2>> product 2 * <byte-array>
 170     [ copy-bitmap ] keep [ dim2>> ] dip
 171     GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE make-texture ;
 172
 173 : glyph-texture-loc ( glyph font -- loc )
 174     [ drop glyph-hori-bearing-x ft-floor ]
 175     [ ascent>> swap glyph-hori-bearing-y - ft-floor ]
 176     2bi 2array ;
 177
 178 : glyph-texture-size ( glyph -- dim )
 179     [ glyph-bitmap-width next-power-of-2 ]
 180     [ glyph-bitmap-rows next-power-of-2 ]
 181     bi 2array ;
 182
 183 : <char-sprite> ( open-font char -- sprite )
 184     over [ render-glyph dup ] dip glyph-texture-loc
 185     over glyph-size pick glyph-texture-size <sprite>
 186     [ bitmap>texture ] keep [ init-sprite ] keep ;
 187
 188 :: char-sprite ( open-font sprites char -- sprite )
 189     char sprites [ open-font swap <char-sprite> ] cache ;
 190
 191 : draw-char ( open-font sprites char loc -- )
 192     GL_MODELVIEW [
 193         0 0 glTranslated
 194         char-sprite dlist>> glCallList
 195     ] do-matrix ;
 196
 197 : char-widths ( open-font string -- widths )
 198     [ char-width ] with { } map-as ;
 199
 200 : scan-sums ( seq -- seq' )
 201     0 [ + ] accumulate nip ;
 202
 203 :: (draw-string) ( open-font sprites string loc -- )
 204     GL_TEXTURE_2D [
 205         loc [
 206             string open-font string char-widths scan-sums [
 207                 [ open-font sprites ] 2dip draw-char
 208             ] 2each
 209         ] with-translation
 210     ] do-enabled ;
 211
 212 : font-sprites ( font world -- open-font sprites )
 213     fonts>> [ open-font H{ } clone 2array ] cache first2 ;
 214
 215 M: freetype-renderer draw-string ( font string loc -- )
 216     [ world get font-sprites ] 2dip (draw-string) ;
 217
 218 : run-char-widths ( open-font string -- widths )
 219     char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
 220
 221 M: freetype-renderer x>offset ( x font string -- n )
 222     [ open-font ] dip
 223     [ run-char-widths [ <= ] with find drop ] keep swap
 224     [ ] [ length ] ?if ;
 225
 226 M:: freetype-renderer offset>x ( n font string -- x )
 227     font open-font string n head string-width ;
 228
 229 freetype-renderer font-renderer set-global