core/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 SYMBOL: freetype
   9 SYMBOL: open-fonts
  10
  11 : freetype-error ( n -- )
  12     zero? [ "FreeType error" throw ] unless ;
  13
  14 : init-freetype ( -- )
  15     global [
  16         f <void*> dup FT_Init_FreeType freetype-error
  17         *void* freetype set
  18         H{ } clone open-fonts set
  19     ] bind ;
  20
  21 TUPLE: font ascent descent height handle widths ;
  22
  23 M: font equal? eq? ;
  24
  25 : close-font ( font -- ) font-handle FT_Done_Face ;
  26
  27 : close-freetype ( -- )
  28     global [
  29         open-fonts [ hash-values [ close-font ] each f ] change
  30         freetype [ FT_Done_FreeType f ] change
  31     ] bind ;
  32
  33 : with-freetype ( quot -- )
  34     freetype get expired? [
  35         init-freetype [ close-freetype ] cleanup
  36     ] [
  37         call
  38     ] if ; inline
  39
  40 : ttf-name ( font style -- name )
  41     2array H{
  42         { { "monospace" plain        } "VeraMono" }
  43         { { "monospace" bold         } "VeraMoBd" }
  44         { { "monospace" bold-italic  } "VeraMoBI" }
  45         { { "monospace" italic       } "VeraMoIt" }
  46         { { "sans-serif" plain       } "Vera"     }
  47         { { "sans-serif" bold        } "VeraBd"   }
  48         { { "sans-serif" bold-italic } "VeraBI"   }
  49         { { "sans-serif" italic      } "VeraIt"   }
  50         { { "serif" plain            } "VeraSe"   }
  51         { { "serif" bold             } "VeraSeBd" }
  52         { { "serif" bold-italic      } "VeraBI"   }
  53         { { "serif" italic           } "VeraIt"   }
  54     } hash ;
  55
  56 : ttf-path ( name -- string )
  57     "/fonts/" swap ".ttf" 3append resource-path ;
  58
  59 : open-face ( font style -- face )
  60     ttf-name ttf-path >r freetype get r>
  61     0 f <void*> [ FT_New_Face freetype-error ] keep *void* ;
  62
  63 : dpi 72 ; inline
  64
  65 : ft-floor -6 shift ; inline
  66
  67 : ft-ceil 63 + -64 bitand -6 shift ; inline
  68
  69 : font-units>pixels ( n font -- n )
  70     face-size face-size-y-scale FT_MulFix ;
  71
  72 : init-ascent ( font face -- )
  73     dup face-y-max swap font-units>pixels swap set-font-ascent ;
  74
  75 : init-descent ( font face -- )
  76     dup face-y-min swap font-units>pixels swap set-font-descent ;
  77
  78 : init-font ( font -- )
  79     dup font-handle 2dup init-ascent dupd init-descent
  80     dup font-ascent over font-descent - ft-ceil
  81     swap set-font-height ;
  82
  83 C: font ( handle -- font )
  84     [ set-font-handle ] keep dup init-font
  85     V{ } clone over set-font-widths ;
  86
  87 : (open-font) ( font -- open-font )
  88     first3 >r open-face dup 0 r> 6 shift
  89     dpi dpi FT_Set_Char_Size freetype-error <font> ;
  90
  91 : open-font ( font -- open-font )
  92     open-fonts get [ (open-font) ] cache ;
  93
  94 : load-glyph ( font char -- glyph )
  95     >r font-handle dup r> 0 FT_Load_Char
  96     freetype-error face-glyph ;
  97
  98 : char-width ( open-font char -- w )
  99     over font-widths [
 100         dupd load-glyph glyph-hori-advance ft-ceil
 101     ] cache-nth nip ;
 102
 103 : glyph-size ( glyph -- dim )
 104     dup glyph-hori-advance ft-ceil
 105     swap glyph-height ft-ceil 2array ;
 106
 107 : render-glyph ( font char -- bitmap )
 108     load-glyph dup
 109     FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
 110
 111 : copy-pixel ( bit tex -- bit tex )
 112     255 f pick set-alien-unsigned-1 1+
 113     f pick alien-unsigned-1
 114     f pick set-alien-unsigned-1 >r 1+ r> 1+ ;
 115
 116 : (copy-row) ( bit tex bitend texend -- bitend texend )
 117     >r pick over >= [
 118         r> 2swap 2drop
 119     ] [
 120         >r copy-pixel r> r> (copy-row)
 121     ] if ;
 122
 123 : copy-row ( bit tex width width2 -- bitend texend width width2 )
 124     [ pick + >r pick + r> (copy-row) ] 2keep ;
 125
 126 : copy-bitmap ( glyph texture -- )
 127     over glyph-bitmap-rows >r
 128     over glyph-bitmap-width dup next-power-of-2 2 *
 129     >r >r >r glyph-bitmap-buffer alien-address r> r> r> r>
 130     [ copy-row ] times 2drop 2drop ;
 131
 132 : bitmap>texture ( glyph sprite -- id )
 133     tuck sprite-size2 * 2 * [
 134         alien-address [ copy-bitmap ] keep <alien> gray-texture
 135     ] with-malloc ;
 136
 137 : glyph-texture-loc ( glyph font -- loc )
 138     over glyph-hori-bearing-x ft-floor -rot
 139     font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
 140
 141 : glyph-texture-size ( glyph -- dim )
 142     dup glyph-bitmap-width next-power-of-2
 143     swap glyph-bitmap-rows next-power-of-2 2array ;
 144
 145 : <char-sprite> ( font char -- sprite )
 146     over >r render-glyph dup r> glyph-texture-loc
 147     over glyph-size pick glyph-texture-size <sprite>
 148     [ bitmap>texture ] keep [ init-sprite ] keep ;
 149
 150 : draw-char ( open-font char sprites -- )
 151     [ dupd <char-sprite> ] cache-nth nip
 152     sprite-dlist glCallList ;
 153
 154 : (draw-string) ( open-font sprites string loc -- )
 155     GL_TEXTURE_2D [
 156         [
 157             [ >r 2dup r> swap draw-char ] each 2drop
 158         ] with-translation
 159     ] do-enabled ;