graphics: font: Add compositor and page layers to rendering pipeline.

These new abstractions will allow for caching rendered text and
rendering more complicated text with multiple fonts, font sizes, and
colors.

Leaving them undocumented for now so I can test the API more and make
tweaks before really committing to anything.

1 files changed, 309 insertions, 123 deletions

diff --git a/chickadee/graphics/font.scm b/chickadee/graphics/font.scm
index c818ff8..4e21ba0 100644
--- a/chickadee/graphics/font.scm
+++ b/chickadee/graphics/font.scm
@@ -1,5 +1,5 @@
 ;;; Chickadee Game Toolkit
-;;; Copyright © 2017, 2020, 2021 David Thompson <davet@gnu.org>
+;;; Copyright © 2017, 2020, 2021, 2022 David Thompson <davet@gnu.org>
 ;;;
 ;;; Chickadee is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published
@@ -33,7 +33,9 @@
   #:use-module (sxml xpath)
   #:use-module (sxml simple)
   #:use-module (chickadee config)
+  #:use-module (chickadee data array-list)
   #:use-module (chickadee freetype)
+  #:use-module (chickadee math)
   #:use-module (chickadee math matrix)
   #:use-module (chickadee math rect)
   #:use-module (chickadee math vector)
@@ -52,26 +54,52 @@
             font-face
             font-ascent
             font-descent
+            font-glyph
+            font-glyph*
             font-line-height
             font-line-width
             font-bold?
             font-italic?
             default-font
+
+            glyph?
+            glyph-id
+            glyph-texture-region
+            glyph-offset
+            glyph-dimensions
+            glyph-advance
+
+            make-compositor
+            compositor?
+            compositor-cursor
+            compositor-reset!
+            typeset-lrtb
+
+            make-page
+            page?
+            page-bounding-box
+            page-reset!
+            page-write!
+            draw-page
             draw-text*
             draw-text))
 
-(define-record-type <font-char>
-  (make-font-char id texture-region offset dimensions advance)
-  font-char?
-  (id font-char-id)
-  (texture-region font-char-texture-region)
-  (offset font-char-offset)
-  (dimensions font-char-dimensions)
-  (advance font-char-advance))
+
+;;;
+;;; Fonts
+;;;
+
+(define-record-type <glyph>
+  (make-glyph id texture-region offset dimensions advance)
+  glyph?
+  (id glyph-id)
+  (texture-region glyph-texture-region)
+  (offset glyph-offset)
+  (dimensions glyph-dimensions)
+  (advance glyph-advance))
 
 (define-record-type <font>
-  (make-font face bold? italic? ascent descent line-height chars kernings
-             sprite-batches)
+  (make-font face bold? italic? ascent descent line-height glyphs kernings)
   font?
   (face font-face)
   (bold? font-bold?)
@@ -79,9 +107,8 @@
   (ascent font-ascent)
   (descent font-descent)
   (line-height font-line-height)
-  (chars font-chars)
-  (kernings font-kernings)
-  (sprite-batches font-sprite-batches))
+  (glyphs font-glyphs)
+  (kernings font-kernings))
 
 (define (display-font font port)
   (format port "#<font face: ~a line-height: ~d bold?: ~a italic?: ~a>"
@@ -97,12 +124,15 @@
   (let loop ((width 0.0)
              (i 0))
     (if (< i (string-length text))
-        (let ((char (or (font-ref font (string-ref text i))
-                        (font-ref font #\?))))
-          (loop (+ width (vec2-x (font-char-advance char)))
+        (let ((char (font-glyph* font (string-ref text i))))
+          (loop (+ width (vec2-x (glyph-advance char)))
                 (+ i 1)))
         width)))
 
+(define (font-kerning font a b)
+  (let ((t (hashv-ref (font-kernings font) b)))
+    (and t (hashv-ref t a))))
+
 (define freetype-handle
   (delay (init-freetype)))
 
@@ -114,7 +144,6 @@ display it at POINT-SIZE.  By default, the ASCII character is used."
   (let ((face (load-face (force freetype-handle) file-name))
         (chars (make-hash-table))
         (kernings (make-hash-table))
-        (batches (make-hash-table))
         (texture-size (min (graphics-engine-max-texture-size) 2048)))
     ;; TODO: Use actual screen DPI.
     (set-char-size! face (* point-size 64) 0 96 96)
@@ -177,29 +206,28 @@ display it at POINT-SIZE.  By default, the ASCII character is used."
                                        (get-char-index face right)))
                        (kx (s64vector-ref k 0))
                        (ky (s64vector-ref k 1))
-                       (t (hash-ref kernings left)))
+                       (t (hashv-ref kernings left)))
                   (unless (and (zero? kx) (zero? ky))
                     (let ((kv (vec2 (/ kx 64.0) (/ ky 64.0))))
                       (if t
-                          (hash-set! t right kv)
+                          (hashv-set! t right kv)
                           (let ((t (make-hash-table)))
-                            (hash-set! t right kv)
-                            (hash-set! kernings left t)))))))
+                            (hashv-set! t right kv)
+                            (hashv-set! kernings left t)))))))
               char-set)))
          char-set)
         ;; Build chars.
         (for-each (match-lambda
                     ((char x y width height left top advance)
-                     (hash-set! chars char
-                                (make-font-char char
-                                                (and x y
-                                                     (make-texture-region texture
-                                                                          (make-rect x y width height)))
-                                                (vec2 left (- top height))
-                                                (vec2 width height)
-                                                (vec2 advance 0.0)))))
-                  specs)
-        (hashq-set! batches texture (make-sprite-batch texture))))
+                     (hashv-set! chars char
+                                 (make-glyph char
+                                             (and x y
+                                                  (make-texture-region texture
+                                                                       (make-rect x y width height)))
+                                             (vec2 left (- top height))
+                                             (vec2 width height)
+                                             (vec2 advance 0.0)))))
+                  specs)))
     (let ((style (face-style-name face)))
       (match (size-metrics (face-size face))
         ((_ _ _ _ ascent descent height _)
@@ -210,8 +238,7 @@ display it at POINT-SIZE.  By default, the ASCII character is used."
                     (/ descent 64.0)
                     (/ height 64.0)
                     chars
-                    kernings
-                    batches))))))
+                    kernings))))))
 
 (define* (load-tile-font file tile-width tile-height characters #:key
                          (face "untitled") (margin 0) (spacing 0))
@@ -230,21 +257,19 @@ image may have MARGIN pixels of empty space around its border."
           (let ((table (make-hash-table)))
             (string-for-each-index
              (lambda (i)
-               (hash-set! table (string-ref characters i)
-                          (make-font-char (string-ref characters i)
-                                          (texture-atlas-ref atlas i)
-                                          (vec2 0.0 0.0)
-                                          (vec2 tile-width tile-height)
-                                          (vec2 tile-width 0.0))))
+               (hashv-set! table (string-ref characters i)
+                           (make-glyph (string-ref characters i)
+                                       (texture-atlas-ref atlas i)
+                                       (vec2 0.0 0.0)
+                                       (vec2 tile-width tile-height)
+                                       (vec2 tile-width 0.0))))
              characters)
             table))
          ;; These fonts are by definition monospace fonts, so no
          ;; kerning.
-         (kernings (make-hash-table))
-         (batches (make-hash-table)))
-    (hashq-set! batches texture (make-sprite-batch texture))
+         (kernings (make-hash-table)))
     (make-font face #f #f (exact->inexact tile-height) 0.0
-               (exact->inexact tile-height) chars kernings batches)))
+               (exact->inexact tile-height) chars kernings)))
 
 (define (load-bitmap-font file)
   "Load the AngelCode formatted bitmap font within FILE.  The file
@@ -319,15 +344,15 @@ extension must be either .xml or .fnt."
     (list (read-key port) (read-value port)))
   (define (read-key/value-pairs port)
     (cons '@
-          (let loop ()
-            (consume-whitespace port)
-            (match (peek-char port)
-              ((? newline?)
-               (read-char port)
-               '())
-              ((? letter?)
-               (cons (read-key/value-pair port)
-                     (loop)))))))
+     (let loop ()
+       (consume-whitespace port)
+       (match (peek-char port)
+         ((? newline?)
+          (read-char port)
+          '())
+         ((? letter?)
+          (cons (read-key/value-pair port)
+                (loop)))))))
   (define (read-line port)
     (list (read-tag port) (read-key/value-pairs port)))
   `(*TOP*
@@ -369,7 +394,7 @@ extension must be either .xml or .fnt."
                          (file (attr node 'file))
                          (texture (load-image
                                    (string-append directory "/" file))))
-                    (hash-set! table id texture)))
+                    (hashv-set! table id texture)))
                 nodes)
       table))
   (define (string->character s)
@@ -394,14 +419,14 @@ extension must be either .xml or .fnt."
                                       (attr node 'yoffset string->number)))
                          (x-advance (attr node 'xadvance string->number))
                          (page (or (attr node 'page string->number) 0))
-                         (region (make-texture-region (hash-ref pages page)
+                         (region (make-texture-region (hashv-ref pages page)
                                                       (make-rect x y width height)))
-                         (char (make-font-char id
-                                               region
-                                               (vec2 x-offset y-offset)
-                                               (vec2 width height)
-                                               (vec2 x-advance 0.0))))
-                    (hash-set! table id char)))
+                         (char (make-glyph id
+                                           region
+                                           (vec2 x-offset y-offset)
+                                           (vec2 width height)
+                                           (vec2 x-advance 0.0))))
+                    (hashv-set! table id char)))
                 nodes)
       table))
   (define (parse-kernings nodes)
@@ -410,12 +435,12 @@ extension must be either .xml or .fnt."
                   (let* ((first (attr node 'first string->character))
                          (second (attr node 'second string->character))
                          (x-offset (attr node 'amount string->number))
-                         (inner-table (hash-ref table first)))
+                         (inner-table (hashv-ref table first)))
                     (if inner-table
-                        (hash-set! inner-table second (vec2 x-offset 0.0))
+                        (hashv-set! inner-table second (vec2 x-offset 0.0))
                         (let ((inner-table (make-hash-table)))
-                          (hash-set! inner-table second (vec2 x-offset 0.0))
-                          (hash-set! table first inner-table)))))
+                          (hashv-set! inner-table second (vec2 x-offset 0.0))
+                          (hashv-set! table first inner-table)))))
                 nodes)
       table))
   (let* ((info ((sxpath '(font info)) tree))
@@ -432,67 +457,227 @@ extension must be either .xml or .fnt."
                              image-width
                              image-height
                              line-height))
-         (kernings (parse-kernings ((sxpath '(font kernings kerning)) tree)))
-         (batches (make-hash-table)))
-    (hash-for-each (lambda (id texture)
-                     (hashq-set! batches texture (make-sprite-batch texture)))
-                   pages)
-    (make-font face bold? italic? line-height 0.0 line-height chars kernings batches)))
+         (kernings (parse-kernings ((sxpath '(font kernings kerning)) tree))))
+    (make-font face bold? italic? line-height 0.0 line-height chars kernings)))
+
+(define (font-glyph font char)
+  "Return the glyph for CHAR in FONT, or #f if the char is not
+represented in FONT."
+  (hashv-ref (font-glyphs font) char))
+
+(define (font-glyph* font char)
+  "Return the glyph for CHAR in FONT, or a placeholder glyph if the char
+is not represented in FONT."
+  (or (font-glyph font char) (font-glyph font #\?)))
+
+
+;;;
+;;; Typesetting
+;;;
+
+;; Using an old printing press metaphor here.  The compositor was the
+;; person who arranged the individual characters for printing.  A
+;; composited glyph is a glyph that has been placed in a particular
+;; location, assigned a color, and, optionally, given an arbitrary
+;; transformation matrix.
+(define-record-type <composited-glyph>
+  (%make-composited-glyph position)
+  composited-glyph?
+  (glyph composited-glyph-glyph set-composited-glyph-glyph!)
+  (position composited-glyph-position)
+  (color composited-glyph-color set-composited-glyph-color!)
+  (matrix composited-glyph-matrix set-composited-glyph-matrix!))
+
+;; A compositor manages the state of the typesetting process.  It does
+;; not know anything about typesetting techniques, as even something
+;; as fundamental as which way the text is read varies greatly.
+;; English reads left to right.  Arabic reads right to left.  Japanese
+;; can read left to right or top to bottom.  Since layout decisions
+;; are so context sensitive, we leave glyph placement up to a user
+;; provided compositing procedure.
+;;
+;; The coordinate space of the compositor is *different* than the
+;; coordinate space of OpenGL in that the positive Y axis points
+;; *down*, not up.  This just makes more sense for text since we read
+;; from the top of a page.  The Y coordinates will be inverted later
+;; when assembling the vertex data.
+(define-record-type <compositor>
+  (%make-compositor cursor free-cglyphs cglyphs size)
+  compositor?
+  ;; The position where glyphs will be placed.
+  (cursor compositor-cursor)
+  (free-cglyphs compositor-free-cglyphs)
+  (cglyphs compositor-cglyphs)
+  ;; Tracking the extremes of the cursor position.  Currently only the
+  ;; Y value is tracked, for the purposes of inverting coordinates
+  ;; later.
+  (size compositor-size))
+
+(define (make-compositor)
+  (%make-compositor (vec2 0.0 0.0)
+                    (make-array-list)
+                    (make-array-list)
+                    (vec2 0.0 0.0)))
+
+(define (compositor-free-composited-glyph compositor)
+  (let ((free-cglyphs (compositor-free-cglyphs compositor)))
+    (if (array-list-empty? free-cglyphs)
+        (%make-composited-glyph (vec2 0.0 0.0))
+        (array-list-pop! free-cglyphs))))
+
+(define (make-composited-glyph compositor glyph color matrix)
+  (let ((cglyph (compositor-free-composited-glyph compositor)))
+    (vec2-copy! (compositor-cursor compositor)
+                (composited-glyph-position cglyph))
+    (set-composited-glyph-glyph! cglyph glyph)
+    (set-composited-glyph-color! cglyph color)
+    (set-composited-glyph-matrix! cglyph matrix)
+    cglyph))
+
+(define* (compositor-put-glyph! compositor glyph color #:optional (matrix #f))
+  (let ((size (compositor-size compositor)))
+    (array-list-push! (compositor-cglyphs compositor)
+                      (make-composited-glyph compositor glyph color matrix))
+    (set-vec2-y! size
+                 (max (vec2-y size)
+                      (vec2-y (compositor-cursor compositor))))))
+
+(define (compositor-reset! compositor)
+  (let ((cglyphs (compositor-cglyphs compositor))
+        (free-cglyphs (compositor-free-cglyphs compositor)))
+    (set-vec2! (compositor-cursor compositor) 0.0 0.0)
+    (set-vec2! (compositor-size compositor) 0.0 0.0)
+    (while (not (array-list-empty? cglyphs))
+      (array-list-push! free-cglyphs (array-list-pop! cglyphs)))))
+
+;; Simple left to right, top to bottom typesetting for a single font
+;; and color.
+(define* (typeset-lrtb compositor font text color #:key
+                       (start 0) (end (string-length text)))
+  (let ((cursor (compositor-cursor compositor)))
+    (let loop ((i start)
+               (prev #f))
+      (when (< i end)
+        (let ((c (string-ref text i)))
+          (case c
+            ((#\newline)
+             (set-vec2-x! cursor 0.0)
+             (set-vec2-y! cursor (+ (vec2-y cursor)
+                                    (font-line-height font))))
+            (else
+             (let* ((glyph (font-glyph* font c))
+                    (k (font-kerning font c prev)))
+               ;; Adjust cursor with kerning, if present.
+               (when k
+                 (set-vec2-x! cursor (+ (vec2-x cursor) (vec2-x k))))
+               ;; Add glyph.
+               (compositor-put-glyph! compositor glyph color)
+               ;; Move forward to where the next character needs to be drawn.
+               (set-vec2-x! cursor
+                            (+ (vec2-x cursor)
+                               (vec2-x
+                                (glyph-advance glyph)))))))
+          (loop (+ i 1) c))))))
+
+
+;;;
+;;; Rendering
+;;;
+
+;; A page is the "printed" form of a collection of composited glyphs.
+;; It is a collection of sprite batches that are ready to be rendered.
+;; By compiling text strings to pages, large amounts of static text
+;; containing multiple colors, fonts, and transformations can be
+;; cached and rendered cheaply.
+(define-record-type <page>
+  (%make-page free-batches batches scratch-rect bounding-box)
+  page?
+  (free-batches page-free-batches)
+  (batches page-batches)
+  (scratch-rect page-scratch-rect)
+  (bounding-box page-bounding-box))
+
+(define (make-page)
+  (%make-page (make-array-list)
+              (make-hash-table)
+              (make-null-rect)
+              (make-null-rect)))
+
+(define (page-reset! page)
+  (let ((free-batches (page-free-batches page))
+        (bb (page-bounding-box page)))
+    (hash-for-each (lambda (texture batch)
+                     (array-list-push! free-batches batch))
+                   (page-batches page))
+    (hash-clear! (page-batches page))
+    (set-rect-x! bb 0.0)
+    (set-rect-y! bb 0.0)
+    (set-rect-width! bb 0.0)
+    (set-rect-height! bb 0.0)))
+
+(define (page-free-batch page)
+  (let ((free-batches (page-free-batches page)))
+    (if (array-list-empty? free-batches)
+        (make-sprite-batch null-texture)
+        (array-list-pop! free-batches))))
+
+(define (make-page-batch page texture)
+  (let ((batch (page-free-batch page)))
+    (set-sprite-batch-texture! batch texture)
+    batch))
+
+(define (page-batch page texture)
+  (let ((batches (page-batches page)))
+    (or (hashq-ref batches texture)
+        (let ((batch (make-page-batch page texture)))
+          (hashq-set! batches texture batch)
+          (sprite-batch-clear! batch)
+          batch))))
+
+(define %identity-matrix (make-identity-matrix4))
+(define (page-write! page compositor)
+  (let ((rect (page-scratch-rect page))
+        (bb (page-bounding-box page))
+        (size (compositor-size compositor)))
+    (define (write-glyph i cglyph)
+      (let* ((glyph (composited-glyph-glyph cglyph))
+             (position (composited-glyph-position cglyph))
+             (offset (glyph-offset glyph))
+             (dimensions (glyph-dimensions glyph))
+             (texture (glyph-texture-region glyph))
+             ;; Not all glyphs have a visual representation, such as
+             ;; the space character.
+             (batch (and texture
+                         (page-batch page (texture-parent texture)))))
+        (set-rect-x! rect (+ (vec2-x position) (vec2-x offset)))
+        (set-rect-y! rect (+ (- (vec2-y size) (vec2-y position)) (vec2-y offset)))
+        (set-rect-width! rect (vec2-x dimensions))
+        (set-rect-height! rect (vec2-y dimensions))
+        (rect-union! bb rect) ; expand bounding box to include this char
+        (when batch
+          (sprite-batch-add* batch rect
+                             (or (composited-glyph-matrix cglyph)
+                                 %identity-matrix)
+                             #:texture-region texture
+                             #:tint (composited-glyph-color cglyph)))))
+    (array-list-for-each write-glyph (compositor-cglyphs compositor))))
 
-(define (font-ref font char)
-  (hashv-ref (font-chars font) char))
+(define* (draw-page page matrix #:key (blend-mode blend:alpha))
+  (hash-for-each (lambda (texture batch)
+                   (draw-sprite-batch* batch matrix #:blend-mode blend-mode))
+                 (page-batches page)))
 
 (define draw-text*
-  (let ((cursor (vec2 0.0 0.0))
-        (rect (make-rect 0.0 0.0 0.0 0.0)))
+  (let ((compositor (make-compositor))
+        (page (make-page)))
     (lambda* (font text matrix #:key (blend-mode blend:alpha)
-                   (color white) (start 0) (end (string-length text)))
-      (let ((batches (font-sprite-batches font))
-            (kernings (font-kernings font)))
-        (define (kerning char prev)
-          (let ((t (hash-ref kernings prev)))
-            (and t (hash-ref t char))))
-        (define (render-char c prev)
-          (if (eqv? c #\newline)
-              (begin
-                (set-vec2-x! cursor 0.0)
-                (set-vec2-y! cursor (- (vec2-y cursor) (font-line-height font))))
-              ;; TODO: What if "?" isn't in the font?
-              (let* ((char (or (font-ref font c) (font-ref font #\?)))
-                     (k (kerning c prev))
-                     (texture (font-char-texture-region char))
-                     (batch (and texture (hashq-ref batches (texture-parent texture))))
-                     (dimensions (font-char-dimensions char))
-                     (offset (font-char-offset char)))
-                ;; Apply kerning, if present.
-                (when k
-                  (set-vec2-x! cursor (+ (vec2-x cursor) (vec2-x k))))
-                (when texture
-                  (set-rect-x! rect (+ (vec2-x cursor) (vec2-x offset)))
-                  (set-rect-y! rect (+ (vec2-y cursor) (vec2-y offset)))
-                  (set-rect-width! rect (vec2-x dimensions))
-                  (set-rect-height! rect (vec2-y dimensions))
-                  (sprite-batch-add* batch rect matrix
-                                     #:texture-region texture
-                                     #:tint color))
-                ;; Move forward to where the next character needs to be drawn.
-                (set-vec2-x! cursor
-                             (+ (vec2-x cursor)
-                                (vec2-x
-                                 (font-char-advance char)))))))
-        (set-vec2! cursor 0.0 0.0)
-        (hash-for-each (lambda (texture batch)
-                         (sprite-batch-clear! batch))
-                       batches)
-        (let loop ((i start)
-                   (prev #f))
-          (when (< i end)
-            (let ((char (string-ref text i)))
-              (render-char char prev)
-              (loop (+ i 1) char))))
-        (hash-for-each (lambda (texture batch)
-                         (draw-sprite-batch batch #:blend-mode blend-mode))
-                       batches)))))
+                   (color white) (start 0) (end (string-length text))
+                   (typeset typeset-lrtb))
+      (compositor-reset! compositor)
+      (page-reset! page)
+      (typeset compositor font text color #:start start #:end end)
+      (page-write! page compositor)
+      (draw-page page matrix #:blend-mode blend-mode))))
 
 (define %default-scale (vec2 1.0 1.0))
 (define %null-vec2 (vec2 0.0 0.0))
@@ -514,7 +699,8 @@ extension must be either .xml or .fnt."
               (scale %default-scale)
               (blend-mode blend:alpha)
               (start 0)
-              (end (string-length text)))
+              (end (string-length text))
+              (typeset typeset-lrtb))
       "Draw the string TEXT with the first character starting at
 POSITION using FONT."
       (matrix4-2d-transform! matrix