diff options
| -rw-r--r-- | chickadee/graphics/font.scm | 432 |
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 |