Add code for creating and rendering font atlases

This code was ported from https://macoy.me/code/macoy/presentation .

ReadMe.org

@@ -107,7 +107,7 @@ Here are the known compatibility results, where blank means untested/unknown:
 | DynamicArray.cake           | Yes          | Yes          | Yes         | Yes   |
 | FileDialog.cake             | Yes          | Yes          | Yes         |       |
 | FileSystem.cake             | Yes          | Yes          | Yes         |       |
-| FreeType.cake               | Yes          |              |             |       |
+| FreeType.cake               | Yes          |              | Yes         |       |
 | Hash.cake                   | Yes          | Yes          | Yes         | Yes   |
 | Image.cake                  | Yes          | Yes          | Yes         |       |
 | ImGui.cake                  | Yes          | No[1]        | Yes         |       |

src/FreeType.cake

@@ -1,3 +1,4 @@
+;; FreeType.cake: Use FreeType to create font atlases
 (export-and-evaluate
  (c-import
   ;; Included only for FT_BEGIN_HEADER etc.
@@ -6,6 +7,9 @@
   "freetype/config/ftheader.h"
   "freetype/freetype.h"))
 
+;; Needed for font atlas lookup tables
+(import "Dictionary.cake")
+
 (defmacro freetype-check-result-or-return (result symbol while-doing string)
     (tokenize-push output
       (unless (= (token-splice result) FT_Err_Ok)
@@ -14,6 +18,215 @@
         (return 1)))
     (return true))
 
+(c-import "<stdio.h>"
+          &with-decls "<stdint.h>")
+
+;; TODO: Support UTF-8 by using non char-sized keys
+(defstruct glyph-entry
+  key char
+  x uint16_t
+  y uint16_t
+  width uint16_t
+  height uint16_t
+  to-origin-left int16_t
+  to-origin-top int16_t
+  advance-x int16_t)
+
+(defstruct kerning-entry
+  key uint16_t ;; first character << 8, second character
+  x int16_t
+  ;; Unused
+  y int16_t)
+
+(defstruct font-atlas
+  glyph-lookup-table (addr glyph-entry) ;; dictionary
+  kerning-lookup-table (addr kerning-entry) ;; dictionary
+  pixel-buffer (addr (unsigned char)) ;; malloc'd
+  width uint16_t
+  height uint16_t
+
+  ;; Default line spacing (baseline-to-baseline
+  font-height uint16_t)
+
+(defun free-font-atlas (font-atlas-to-free (addr font-atlas))
+  (dict-free (path font-atlas-to-free > glyph-lookup-table))
+  (dict-free (path font-atlas-to-free > kerning-lookup-table))
+  (free (path font-atlas-to-free > pixel-buffer)))
+
+(defun font-atlas-make-character-pair (character-a char
+                                       character-b char
+                                       &return uint16_t)
+  (return (bit-or (bit-shift-<< character-a 8) character-b)))
+
+;; Returns 0 for success or anything else for failure
+(defun build-font-atlas (font-face (addr (const (unsigned char)))
+                         font-face-size (unsigned int)
+                         device-dpi (unsigned int)
+                         character-height-points (unsigned char)
+                         enable-subpixel-antialiasing bool
+                         font-atlas-out (addr font-atlas) &return int)
+  (var freetype-library FT_Library)
+  (var result int
+    (FT_Init_FreeType (addr freetype-library)))
+  (freetype-check-result-or-return result "initializing FreeType")
+  (defer (FT_Done_FreeType freetype-library))
+
+  (var typeface FT_Face)
+  (var face-index int 0)
+  (set result (FT_New_Memory_Face freetype-library font-face font-face-size
+                                  face-index (addr typeface)))
+  (unless (= result FT_Err_Ok)
+    (fprintf stderr "error: encountered error %d while loading font\n" result)
+    (return 1))
+  (defer (FT_Done_Face typeface))
+
+  (set result (FT_Set_Char_Size
+               typeface    ;; handle to face object
+               0       ;; char_width in 1/64th of points
+               (* character-height-points 64) ;; char_height in 1/64th of points
+               device-dpi     ;; horizontal device resolution
+               device-dpi))   ;; vertical device resolution
+
+  (freetype-check-result-or-return result "setting character size")
+
+  (defstruct ascii-glyph-range
+    start-character char
+    end-character-inclusive char)
+  ;; This is a bit silly
+  (var ranges-to-render (array ascii-glyph-range)
+    (array (array 'a' 'z') (array 'A' 'Z') (array '0' '9') (array ' ' '/') (array ':' '@')
+           (array '[' '`') (array '{' '~')))
+
+  (var atlas-width uint16_t 1024)
+  (var atlas-height uint16_t 1024)
+  (var num-components-per-pixel char 4)
+  (var pixel-buffer-size (unsigned int) (* atlas-width atlas-height num-components-per-pixel))
+  (set (path font-atlas-out > pixel-buffer)
+       (type-cast (malloc pixel-buffer-size)
+                  (addr (unsigned char))))
+  (memset (path font-atlas-out > pixel-buffer) 0 pixel-buffer-size)
+  (set (path font-atlas-out > width) atlas-width)
+  (set (path font-atlas-out > height) atlas-height)
+  (set (path font-atlas-out > font-height) (bit-shift->> (path typeface > size > metrics . height) 6))
+  (var atlas-write-x uint16_t 0)
+  (var atlas-write-y uint16_t 0)
+  (var atlas-tallest-character-this-row uint16_t 0)
+
+  (each-in-array ranges-to-render range-index
+    (var range (addr ascii-glyph-range) (addr (at range-index ranges-to-render)))
+    (each-in-range (- (+ 1 (path range > end-character-inclusive)) (path range > start-character))
+        character-offset-from-start
+      (var character char (+ character-offset-from-start (path range > start-character)))
+      (var glyph-index int (FT_Get_Char_Index typeface character))
+      (unless glyph-index
+        (fprintf stderr "error: could not find glyph '%c' in font\n" character)
+        (return 1))
+
+      (set result (FT_Load_Glyph typeface glyph-index FT_LOAD_DEFAULT))
+      (freetype-check-result-or-return result "loading glyph")
+
+      ;; One slot for the whole face
+      (set result (FT_Render_Glyph (path typeface > glyph)
+                                   (? enable-subpixel-antialiasing
+                                      FT_RENDER_MODE_LCD
+                                      FT_RENDER_MODE_NORMAL)))
+      (freetype-check-result-or-return result "rendering glyph")
+
+      (var num-components-per-freetype-pixel (unsigned char) (? enable-subpixel-antialiasing 3 1))
+
+      (var num-rows int (path typeface > glyph > bitmap . rows))
+      (var num-columns int (/ (path typeface > glyph > bitmap . width)
+                              num-components-per-freetype-pixel))
+
+      (when (> num-rows atlas-tallest-character-this-row)
+        (set atlas-tallest-character-this-row num-rows))
+
+      (when (> (+ num-columns atlas-write-x) atlas-width)
+        (set atlas-write-x 0)
+        (set atlas-write-y (+ atlas-write-y atlas-tallest-character-this-row))
+        (set atlas-tallest-character-this-row num-rows)
+        (when (> (+ atlas-write-y atlas-tallest-character-this-row) atlas-height)
+          (fprintf stderr "error: ran out of space in atlas size %dx%d\n" atlas-width atlas-height)
+          (return 1)))
+
+      (var new-glyph-entry glyph-entry (array 0))
+      (set (field new-glyph-entry key) character)
+      (set (field new-glyph-entry x) atlas-write-x)
+      (set (field new-glyph-entry y) atlas-write-y)
+      (set (field new-glyph-entry width) num-columns)
+      (set (field new-glyph-entry height) num-rows)
+      (set (field new-glyph-entry to-origin-left) (path typeface > glyph > bitmap_left))
+      (set (field new-glyph-entry to-origin-top) (path typeface > glyph > bitmap_top))
+      (set (field new-glyph-entry advance-x) (bit-shift->> (path typeface > glyph > advance . x) 6))
+      (dict-set-struct (path font-atlas-out > glyph-lookup-table) new-glyph-entry)
+
+      ;; TODO: This can become a memcpy if we can get FreeType to render to our same format
+      (each-in-range num-rows row
+        (each-in-range num-columns column
+          (var current-pixel (addr (unsigned char))
+            (addr
+             (at (+ (* num-components-per-freetype-pixel column)
+                    (* row (path typeface > glyph > bitmap . pitch)))
+                 (path typeface > glyph > bitmap . buffer))))
+          (var current-pixel-out (addr (unsigned char))
+            (addr
+             (at (* num-components-per-pixel
+                    (+ (+ column atlas-write-x) (* (+ atlas-write-y row) atlas-width)))
+                 (path font-atlas-out > pixel-buffer))))
+          (var pixel-set bool false)
+          (each-in-range num-components-per-freetype-pixel i
+            (when (> (at i current-pixel) 0)
+              (set pixel-set true)
+              (break)))
+          (when pixel-set
+            (if (> num-components-per-freetype-pixel 1)
+                (scope
+                 (each-in-range 3 component
+                   (set (at component current-pixel-out) (at component current-pixel))))
+                (scope
+                 (each-in-range 3 component
+                   (set (at component current-pixel-out) (deref current-pixel)))))
+            (set (at 3 current-pixel-out) 255))))
+
+      ;; Wrapping happens after we know what the next glyph's dimensions are
+      (set atlas-write-x (+ atlas-write-x num-columns))))
+
+  ;; Build kerning lookup table
+  (each-in-array ranges-to-render range-index-a
+    (var range-a (addr ascii-glyph-range) (addr (at range-index-a ranges-to-render)))
+    (each-in-range (- (+ 1 (path range-a > end-character-inclusive)) (path range-a > start-character))
+        character-offset-from-start
+      (var character-a char (+ character-offset-from-start (path range-a > start-character)))
+      (var glyph-index-a int (FT_Get_Char_Index typeface character-a))
+      (unless glyph-index-a
+        (continue))
+
+      (each-in-array ranges-to-render range-index-b
+        (var range-b (addr ascii-glyph-range) (addr (at range-index-b ranges-to-render)))
+        (each-in-range (- (+ 1 (path range-b > end-character-inclusive)) (path range-b > start-character))
+            character-offset-from-start
+          (var character-b char (+ character-offset-from-start (path range-b > start-character)))
+          ;; If this is slow, it might make sense to cache it in the outer loop
+          (var glyph-index-b int (FT_Get_Char_Index typeface character-b))
+          (unless glyph-index-b
+            (continue))
+
+          (var kerning FT_Vector)
+          (set result (FT_Get_Kerning typeface glyph-index-a glyph-index-b
+                                      FT_KERNING_DEFAULT (addr kerning)))
+          (freetype-check-result-or-return result "Getting kerning value")
+          (when (or (field kerning x) (field kerning y))
+            (var new-kerning-entry kerning-entry (array 0))
+            (var character-pair uint16_t (font-atlas-make-character-pair
+                                          character-a character-b))
+            (set (field new-kerning-entry key) character-pair)
+            (set (field new-kerning-entry x) (bit-shift->> (field kerning x) 6))
+            (set (field new-kerning-entry y) (bit-shift->> (field kerning y) 6))
+            (dict-set-struct (path font-atlas-out > kerning-lookup-table)
+                             new-kerning-entry))))))
+
+  (return 0))
+
 (comptime-cond
  ('auto-test
   (c-import "<stdio.h>")

src/SDL.cake

@@ -17,6 +17,8 @@
 ;;
 
 (forward-declare (struct SDL_Window)
+                 (struct SDL_Renderer)
+                 (struct SDL_Texture)
                  (struct SDL_AudioSpec))
 
 (defun sdl-print-error ()
@@ -322,6 +324,28 @@
             in-directory)
   (SDL_OpenURL url-current-directory))
 
+;;
+;; Rendering
+;;
+
+(defun sdl-texture-from-bmp-data (renderer (addr SDL_Renderer)
+                                  data-start (addr (unsigned char))
+                                  data-end (addr (unsigned char))
+                                  &return (addr SDL_Texture))
+   (var surface (addr SDL_Surface)
+     (SDL_LoadBMP_RW (SDL_RWFromMem data-start (- data-end data-start))
+                     ;; freesrc (free the RWOps)
+                     1))
+   (unless surface
+     (sdl-print-error)
+     (return null))
+   (defer (SDL_FreeSurface surface))
+   (var texture (addr SDL_Texture) (SDL_CreateTextureFromSurface renderer surface))
+   (unless texture
+     (sdl-print-error)
+     (return null))
+   (return texture))
+
 ;;
 ;; Test
 ;;

src/SDLFontAtlas.cake

@@ -0,0 +1,101 @@
+(set-cakelisp-option cakelisp-src-dir "Dependencies/cakelisp/src")
+(add-cakelisp-search-directory "Dependencies/cakelisp/runtime")
+
+;; SDLFontAtlas.cake: Render font atlases generated by FreeType.cake. This is kept separate from
+;; both libraries in order to not force a dependency on either.
+(import "SDL.cake" "FreeType.cake" "Dictionary.cake"
+        "CHelpers.cake")
+
+(forward-declare (struct SDL_Renderer)
+                 (struct SDL_Texture)
+                 (struct font-atlas))
+
+(var s-enable-kerning bool true)
+
+;; TODO: Support UTF-8
+(defun render-string (renderer (addr SDL_Renderer) font (addr font-atlas) font-texture (addr SDL_Texture)
+                      x int y int str (addr (const char)))
+  (var write-x int x)
+  (var write-y int y)
+  (var tab-width int 100)
+  (scope ;; Get tab width based on space advance
+   (var space-key char ' ')
+   (var glyph (addr glyph-entry) (dict-ptr-at (path font > glyph-lookup-table) space-key))
+   (when glyph
+     (set tab-width (* 4 (path glyph > advance-x)))))
+
+  (var line-height int (path font > font-height))
+
+  (each-char-in-string-const str current-char
+    (cond
+      ((= (deref current-char) '\r')
+       (continue))
+      ((= (deref current-char) '\n')
+       (set write-y (+ line-height write-y))
+       (set write-x x)
+       (continue))
+      ((= (deref current-char) '\t')
+       (set write-x (+ write-x tab-width))
+       (continue)))
+
+    (var search-key char (deref current-char))
+    (var glyph (addr glyph-entry) (dict-ptr-at (path font > glyph-lookup-table) search-key))
+    (unless glyph ;; fallback
+      (set search-key '?')
+      (set glyph (dict-ptr-at (path font > glyph-lookup-table) search-key)))
+    (unless glyph ;; even the fallback is missing!
+      (continue))
+    (var source-rectangle SDL_Rect
+      (array (path glyph > x)
+             (path glyph > y)
+             (path glyph > width)
+             (path glyph > height)))
+    (var destination-rectangle SDL_Rect
+      (array
+       (+ write-x (path glyph > to-origin-left))
+       (- write-y (path glyph > to-origin-top))
+       (path glyph > width)
+       (path glyph > height)))
+    (SDL_RenderCopy renderer font-texture
+                    (addr source-rectangle) (addr destination-rectangle))
+    (set write-x (+ write-x (path glyph > advance-x)))
+
+    (when (and s-enable-kerning (+ 1 current-char))
+      (var character-pair uint16_t (font-atlas-make-character-pair
+                                    (deref current-char) (at 1 current-char)))
+      (var kerning (addr kerning-entry)
+        (dict-ptr-at (path font > kerning-lookup-table) character-pair))
+      (when kerning
+        (set write-x (+ write-x (path kerning > x)))))))
+
+(defun make-font-atlas-and-texture (renderer (addr SDL_Renderer)
+                                    font-atlas-out (addr font-atlas) font-texture-out (addr (addr SDL_Texture))
+                                    font-data (addr (const (unsigned char))) font-data-size (unsigned int)
+                                    device-dpi (unsigned int)
+                                    font-size-points (unsigned char)
+                                    &return bool)
+  (var enable-subpixel-antialiasing bool true)
+  (unless (= 0 (build-font-atlas font-data font-data-size
+                                 font-size-points
+                                 device-dpi
+                                 enable-subpixel-antialiasing
+                                 font-atlas-out))
+    (return false))
+
+  (scope
+   (var font-surface (addr SDL_Surface)
+     (SDL_CreateRGBSurfaceWithFormatFrom
+      (path font-atlas-out > pixel-buffer)
+      (path font-atlas-out > width)
+      (path font-atlas-out > height)
+      32 ;; bit depth of each pixel (RGBA)
+      (* (path font-atlas-out > width) 4) ;; pitch (width of a row in bytes)
+      ;; Because of how SDL reads pixels in, this does seem to be endian-dependent
+      ;; I don't fully understand why
+      SDL_PIXELFORMAT_RGBA32))
+   (defer (SDL_FreeSurface font-surface)) ;; We don't need this after making the texture
+   (set (deref font-texture-out) (SDL_CreateTextureFromSurface renderer font-surface))
+   (unless (deref font-texture-out)
+     (sdl-print-error)
+     (return false)))
+  (return true))