library/ui/freetype/freetype-gl.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays errors hashtables io kernel
   4 libc math namespaces opengl prettyprint
   5 sequences styles ;
   6 IN: freetype
   7
   8 ! Memory management: freetype is allocated and freed by
   9 ! with-freetype.
  10 SYMBOL: freetype
  11 SYMBOL: open-fonts
  12
  13 : freetype-error ( n -- )
  14     zero? [ "FreeType error" throw ] unless ;
  15
  16 : init-freetype ( -- )
  17     global [
  18         f <void*> dup FT_Init_FreeType freetype-error
  19         *void* freetype set
  20         H{ } clone open-fonts set
  21     ] bind ;
  22
  23 ! A font object from FreeType.
  24 ! the handle is an FT_Face.
  25 ! sprites is a vector.
  26 TUPLE: font ascent descent height handle widths ;
  27
  28 M: font equal? eq? ;
  29
  30 : close-font ( font -- ) font-handle FT_Done_Face ;
  31
  32 : close-freetype ( -- )
  33     global [
  34         open-fonts [ hash-values [ close-font ] each f ] change
  35         freetype [ FT_Done_FreeType f ] change
  36     ] bind ;
  37
  38 : with-freetype ( quot -- )
  39     init-freetype [ close-freetype ] cleanup ; inline
  40
  41 : ttf-name ( font style -- name )
  42     2array H{
  43         { { "monospace" plain        } "VeraMono" }
  44         { { "monospace" bold         } "VeraMoBd" }
  45         { { "monospace" bold-italic  } "VeraMoBI" }
  46         { { "monospace" italic       } "VeraMoIt" }
  47         { { "sans-serif" plain       } "Vera"     }
  48         { { "sans-serif" bold        } "VeraBd"   }
  49         { { "sans-serif" bold-italic } "VeraBI"   }
  50         { { "sans-serif" italic      } "VeraIt"   }
  51         { { "serif" plain            } "VeraSe"   }
  52         { { "serif" bold             } "VeraSeBd" }
  53         { { "serif" bold-italic      } "VeraBI"   }
  54         { { "serif" italic           } "VeraIt"   }
  55     } hash ;
  56
  57 : ttf-path ( name -- string )
  58     "/fonts/" swap ".ttf" append3 resource-path ;
  59
  60 : open-face ( font style -- face )
  61     #! Open a TrueType font with the given logical name and
  62     #! style.
  63     ttf-name ttf-path >r freetype get r>
  64     0 f <void*> [ FT_New_Face freetype-error ] keep *void* ;
  65
  66 : dpi 72 ; inline
  67
  68 : ft-floor -6 shift ; inline
  69
  70 : ft-ceil 63 + -64 bitand -6 shift ; inline
  71
  72 : font-units>pixels ( n font -- n )
  73     face-size face-size-y-scale FT_MulFix ;
  74
  75 : init-ascent ( font face -- )
  76     dup face-y-max swap font-units>pixels swap set-font-ascent ;
  77
  78 : init-descent ( font face -- )
  79     dup face-y-min swap font-units>pixels swap set-font-descent ;
  80
  81 : init-font ( font -- )
  82     dup font-handle 2dup init-ascent dupd init-descent
  83     dup font-ascent over font-descent - ft-ceil
  84     swap set-font-height ;
  85
  86 C: font ( handle -- font )
  87     [ set-font-handle ] keep dup init-font
  88     V{ } clone over set-font-widths ;
  89
  90 : open-font ( fontspec -- font )
  91     #! Open a font and set the point size of the font.
  92     first3 >r open-face dup 0 r> 6 shift
  93     dpi dpi FT_Set_Char_Size freetype-error <font> ;
  94
  95 : lookup-font ( fontspec -- font )
  96     #! Cache open fonts.
  97     open-fonts get [ open-font ] cache ;
  98
  99 : load-glyph ( font char -- glyph )
 100     >r font-handle dup r> 0 FT_Load_Char
 101     freetype-error face-glyph ;
 102
 103 : char-width ( open-font char -- w )
 104     over font-widths [
 105         dupd load-glyph glyph-hori-advance ft-ceil
 106     ] cache-nth nip ;
 107
 108 : string-width ( open-font string -- w )
 109     0 -rot [ char-width + ] each-with ;
 110
 111 : glyph-size ( glyph -- dim )
 112     dup glyph-hori-advance ft-ceil
 113     swap glyph-height ft-ceil 2array ;
 114
 115 : render-glyph ( font char -- bitmap )
 116     #! Render a character and return a pointer to the bitmap.
 117     load-glyph dup
 118     FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
 119
 120 : copy-pixel ( bit tex -- bit tex )
 121     255 f pick set-alien-unsigned-1 1+
 122     f pick alien-unsigned-1
 123     f pick set-alien-unsigned-1 >r 1+ r> 1+ ;
 124
 125 : (copy-row) ( bit tex bitend texend -- bitend texend )
 126     >r pick over >= [
 127         r> 2swap 2drop
 128     ] [
 129         >r copy-pixel r> r> (copy-row)
 130     ] if ;
 131
 132 : copy-row ( bit tex width width2 -- bitend texend width width2 )
 133     [ pick + >r pick + r> (copy-row) ] 2keep ;
 134
 135 : copy-bitmap ( glyph texture -- )
 136     over glyph-bitmap-rows >r
 137     over glyph-bitmap-width dup next-power-of-2 2 *
 138     >r >r >r glyph-bitmap-buffer alien-address r> r> r> r>
 139     [ copy-row ] times 2drop 2drop ;
 140
 141 : bitmap>texture ( glyph sprite -- id )
 142     #! Given a glyph bitmap, copy it to a texture with the given
 143     #! width/height (which must be powers of two).
 144     tuck sprite-size2 * 2 * [
 145         alien-address [ copy-bitmap ] keep <alien> gray-texture
 146     ] with-malloc ;
 147
 148 : glyph-texture-loc ( glyph font -- loc )
 149     over glyph-hori-bearing-x ft-floor -rot
 150     font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
 151
 152 : glyph-texture-size ( glyph -- dim )
 153     dup glyph-bitmap-width next-power-of-2
 154     swap glyph-bitmap-rows next-power-of-2 2array ;
 155
 156 : <char-sprite> ( font char -- sprite )
 157     #! Create a new display list of a rendered glyph. This
 158     #! allocates external resources. See free-sprites.
 159     over >r render-glyph dup r> glyph-texture-loc
 160     over glyph-size pick glyph-texture-size <sprite>
 161     [ bitmap>texture ] keep [ init-sprite ] keep ;
 162
 163 : draw-char ( open-font char sprites -- )
 164     [ dupd <char-sprite> ] cache-nth nip
 165     sprite-dlist glCallList ;
 166
 167 : (draw-string) ( open-font sprites string loc -- )
 168     GL_TEXTURE_2D [
 169         [
 170             [ >r 2dup r> swap draw-char ] each 2drop
 171         ] with-translation
 172     ] do-enabled ;