basis/ui/freetype/freetype.factor

   1 ! Copyright (C) 2005, 2008 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 prettyprint assocs
   5 sequences io.files io.styles continuations freetype
   6 ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
   7 locals ;
   8
   9 IN: ui.freetype
  10
  11 TUPLE: 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: font < identity-tuple
  32 ascent descent height handle widths ;
  33
  34 M: font hashcode* drop 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     [ handle>> select-gl-context ]
  46     [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
  47
  48 : ttf-name ( font style -- name )
  49     2array H{
  50         { { "monospace" plain        } "VeraMono" }
  51         { { "monospace" bold         } "VeraMoBd" }
  52         { { "monospace" bold-italic  } "VeraMoBI" }
  53         { { "monospace" italic       } "VeraMoIt" }
  54         { { "sans-serif" plain       } "Vera"     }
  55         { { "sans-serif" bold        } "VeraBd"   }
  56         { { "sans-serif" bold-italic } "VeraBI"   }
  57         { { "sans-serif" italic      } "VeraIt"   }
  58         { { "serif" plain            } "VeraSe"   }
  59         { { "serif" bold             } "VeraSeBd" }
  60         { { "serif" bold-italic      } "VeraBI"   }
  61         { { "serif" italic           } "VeraIt"   }
  62     } at ;
  63
  64 : ttf-path ( name -- string )
  65     "resource:fonts/" swap ".ttf" 3append ;
  66
  67 : (open-face) ( path length -- face )
  68     #! We use FT_New_Memory_Face, not FT_New_Face, since
  69     #! FT_New_Face only takes an ASCII path name and causes
  70     #! problems on localized versions of Windows
  71     [ freetype ] 2dip 0 f <void*> [
  72         FT_New_Memory_Face freetype-error
  73     ] keep *void* ;
  74
  75 : open-face ( font style -- face )
  76     ttf-name ttf-path malloc-file-contents (open-face) ;
  77
  78 SYMBOL: dpi
  79
  80 72 dpi set-global
  81
  82 : ft-floor -6 shift ; inline
  83
  84 : ft-ceil 63 + -64 bitand -6 shift ; inline
  85
  86 : font-units>pixels ( n font -- n )
  87     face-size face-size-y-scale FT_MulFix ;
  88
  89 : init-ascent ( font face -- font )
  90     dup face-y-max swap font-units>pixels >>ascent ; inline
  91
  92 : init-descent ( font face -- font )
  93     dup face-y-min swap font-units>pixels >>descent ; inline
  94
  95 : init-font ( font -- font )
  96     dup handle>> init-ascent
  97     dup handle>> init-descent
  98     dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
  99
 100 : set-char-size ( handle size -- )
 101     0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
 102
 103 : <font> ( handle -- font )
 104     font new
 105         H{ } clone >>widths
 106         over first2 open-face >>handle
 107         dup handle>> rot third set-char-size
 108         init-font ;
 109
 110 M: freetype-renderer open-font ( font -- open-font )
 111     freetype drop open-fonts get [ <font> ] cache ;
 112
 113 : load-glyph ( font char -- glyph )
 114     >r handle>> dup r> 0 FT_Load_Char
 115     freetype-error face-glyph ;
 116
 117 : char-width ( open-font char -- w )
 118     over widths>> [
 119         dupd load-glyph glyph-hori-advance ft-ceil
 120     ] cache nip ;
 121
 122 M: freetype-renderer string-width ( open-font string -- w )
 123     0 -rot [ char-width + ] with each ;
 124
 125 M: freetype-renderer string-height ( open-font string -- h )
 126     drop height>> ;
 127
 128 : glyph-size ( glyph -- dim )
 129     dup glyph-hori-advance ft-ceil
 130     swap glyph-height ft-ceil 2array ;
 131
 132 : render-glyph ( font char -- bitmap )
 133     load-glyph dup
 134     FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
 135
 136 :: copy-pixel ( i j bitmap texture -- i j )
 137     255 j texture set-char-nth
 138     i bitmap char-nth j 1 + texture set-char-nth
 139     i 1 + j 2 + ; inline
 140
 141 :: (copy-row) ( i j bitmap texture end -- )
 142     i end < [
 143         i j bitmap texture copy-pixel
 144             bitmap texture end (copy-row)
 145     ] when ; inline recursive
 146
 147 :: copy-row ( i j bitmap texture width width2 -- i j )
 148     i j bitmap texture i width + (copy-row)
 149     i width +
 150     j width2 + ; inline
 151
 152 :: copy-bitmap ( glyph texture -- )
 153     [let* | bitmap [ glyph glyph-bitmap-buffer ]
 154             rows [ glyph glyph-bitmap-rows ]
 155             width [ glyph glyph-bitmap-width ]
 156             width2 [ width next-power-of-2 2 * ] |
 157         0 0
 158         rows [ bitmap texture width width2 copy-row ] times
 159         2drop
 160     ] ;
 161
 162 : bitmap>texture ( glyph sprite -- id )
 163     tuck sprite-size2 * 2 * [
 164         [ copy-bitmap ] keep gray-texture
 165     ] with-malloc ;
 166
 167 : glyph-texture-loc ( glyph font -- loc )
 168     over glyph-hori-bearing-x ft-floor -rot
 169     ascent>> swap glyph-hori-bearing-y - ft-floor 2array ;
 170
 171 : glyph-texture-size ( glyph -- dim )
 172     [ glyph-bitmap-width next-power-of-2 ]
 173     [ glyph-bitmap-rows next-power-of-2 ]
 174     bi 2array ;
 175
 176 : <char-sprite> ( open-font char -- sprite )
 177     over >r render-glyph dup r> glyph-texture-loc
 178     over glyph-size pick glyph-texture-size <sprite>
 179     [ bitmap>texture ] keep [ init-sprite ] keep ;
 180
 181 :: char-sprite ( open-font sprites char -- sprite )
 182     char sprites [ open-font swap <char-sprite> ] cache ;
 183
 184 : draw-char ( open-font sprites char loc -- )
 185     GL_MODELVIEW [
 186         0 0 glTranslated
 187         char-sprite dlist>> glCallList
 188     ] do-matrix ;
 189
 190 : char-widths ( open-font string -- widths )
 191     [ char-width ] with { } map-as ;
 192
 193 : scan-sums ( seq -- seq' )
 194     0 [ + ] accumulate nip ;
 195
 196 :: (draw-string) ( open-font sprites string loc -- )
 197     GL_TEXTURE_2D [
 198         loc [
 199             string open-font string char-widths scan-sums [
 200                 [ open-font sprites ] 2dip draw-char
 201             ] 2each
 202         ] with-translation
 203     ] do-enabled ;
 204
 205 : font-sprites ( font world -- open-font sprites )
 206     fonts>> [ open-font H{ } clone 2array ] cache first2 ;
 207
 208 M: freetype-renderer draw-string ( font string loc -- )
 209     >r >r world get font-sprites r> r> (draw-string) ;
 210
 211 : run-char-widths ( open-font string -- widths )
 212     char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
 213
 214 M: freetype-renderer x>offset ( x open-font string -- n )
 215     [ run-char-widths [ <= ] with find drop ] keep swap
 216     [ ] [ length ] ?if ;
 217
 218 T{ freetype-renderer } font-renderer set-global