diff options
Diffstat (limited to 'chickadee/graphics/text.scm')
| -rw-r--r-- | chickadee/graphics/text.scm | 715 |
1 files changed, 715 insertions, 0 deletions
diff --git a/chickadee/graphics/text.scm b/chickadee/graphics/text.scm new file mode 100644 index 0000000..42c6fa5 --- /dev/null +++ b/chickadee/graphics/text.scm @@ -0,0 +1,715 @@ +;;; Chickadee Game Toolkit +;;; 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 +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Bitmap font rendering. +;; +;;; Code: + +(define-module (chickadee graphics text) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-4) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #: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) + #:use-module (chickadee graphics blend) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics engine) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics sprite) + #:use-module (chickadee graphics texture) + #:use-module (chickadee utils) + #:use-module (rnrs bytevectors) + #:export (load-tile-font + load-bitmap-font + load-font + font? + 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)) + + +;;; +;;; 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 glyphs kernings) + font? + (face font-face) + (bold? font-bold?) + (italic? font-italic?) + (ascent font-ascent) + (descent font-descent) + (line-height font-line-height) + (glyphs font-glyphs) + (kernings font-kernings)) + +(define (display-font font port) + (format port "#<font face: ~a line-height: ~d bold?: ~a italic?: ~a>" + (font-face font) + (font-line-height font) + (font-bold? font) + (font-italic? font))) + +(set-record-type-printer! <font> display-font) + +(define (font-line-width font text) + "Return the width of TEXT when rendered with FONT." + (let loop ((width 0.0) + (i 0)) + (if (< i (string-length text)) + (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))) + +(define* (load-font file-name point-size #:key (char-set char-set:ascii)) + "Load all the glyphs in CHAR-SET from the font in FILE-NAME and +display it at POINT-SIZE. By default, the ASCII character is used." + (unless (file-exists? file-name) + (error "no such file" file-name)) + (let ((face (load-face (force freetype-handle) file-name)) + (chars (make-hash-table)) + (kernings (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) + (let ((glyph (face-glyph-slot face)) + (pixels (make-bytevector (* texture-size texture-size 4))) + (x 0) + (y 0) + (next-y 0)) + (define (add-pixels char width height pitch left top advance glyph-pixels) + (when (> (+ x width) texture-size) + (set! y next-y) + (set! x 0)) + (for-range ((column width) + (row height)) + (let ((gray (u8vector-ref glyph-pixels + (+ (* row pitch) column))) + (offset (+ (* (- height (+ y row) 1) texture-size 4) + (* (+ x column) 4)))) + (u8vector-set! pixels offset 255) + (u8vector-set! pixels (+ offset 1) 255) + (u8vector-set! pixels (+ offset 2) 255) + (u8vector-set! pixels (+ offset 3) gray))) + (let ((spec (list char x y width height left top advance))) + ;; 1 pixel of padding to avoid artifacts when texture is + ;; scaled up. + (set! x (+ x width 1)) + (set! next-y (max next-y (+ y height 1))) + spec)) + ;; Render individual glyph bitmaps and compose them into larger + ;; images to be used as textures. + (let* ((specs + (char-set-fold + (lambda (char prev) + (load-char face char '(render)) + (let ((left (glyph-bitmap-left glyph)) + (top (glyph-bitmap-top glyph))) + (match (glyph-metrics glyph) + ((bearing-x bearing-y advance) + (match (glyph-bitmap glyph) + ((width height pitch glyph-pixels) + (cons (if glyph-pixels + (add-pixels char width height + pitch left top + advance + glyph-pixels) + (list char #f #f width height left top advance)) + prev))))))) + '() + char-set)) + ;; TODO: Use multiple textures if needed. + (texture (make-texture pixels texture-size texture-size))) + ;; Process kernings. + (char-set-for-each + (lambda (left) + (let ((left-index (get-char-index face left))) + (char-set-for-each + (lambda (right) + (let* ((k (get-kerning face + left-index + (get-char-index face right))) + (kx (s64vector-ref k 0)) + (ky (s64vector-ref k 1)) + (t (hashv-ref kernings left))) + (unless (and (zero? kx) (zero? ky)) + (let ((kv (vec2 (/ kx 64.0) (/ ky 64.0)))) + (if t + (hashv-set! t right kv) + (let ((t (make-hash-table))) + (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) + (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 _) + (make-font (face-family-name face) + (and (string-match ".*[B,b]old.*" style) #t) + (and (string-match ".*[I,i]talic.*" style) #t) + (/ ascent 64.0) + (/ descent 64.0) + (/ height 64.0) + chars + kernings)))))) + +(define* (load-tile-font file tile-width tile-height characters #:key + (face "untitled") (margin 0) (spacing 0)) + "Load the font named FACE from FILE, a bitmap image containing the +characters in the string CHARACTERS that are TILE-WIDTH by TILE-HEIGHT +pixels in size. The characters in the image *must* appear in the +order that they are specified in the character set or text will not +render properly. Optionally, each tile may have SPACING pixels of +horizontal and vertical space between surrounding tiles and the entire +image may have MARGIN pixels of empty space around its border." + (let* ((texture (load-image file)) + (atlas (split-texture texture tile-width tile-height + #:margin margin + #:spacing spacing)) + (chars + (let ((table (make-hash-table))) + (string-for-each-index + (lambda (i) + (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))) + (make-font face #f #f (exact->inexact tile-height) 0.0 + (exact->inexact tile-height) chars kernings))) + +(define (load-bitmap-font file) + "Load the AngelCode formatted bitmap font within FILE. The file +extension must be either .xml or .fnt." + (cond + ((string-suffix? ".xml" file) + (parse-bmfont-sxml file (call-with-input-file file xml->sxml))) + ((string-suffix? ".fnt" file) + (parse-bmfont-sxml file (parse-fnt file))) + (else + (error "unknown bmfont file type: " file)))) + +(define (parse-fnt file) + (define (newline? char) + (eqv? char #\newline)) + (define (whitespace? char) + (and (not (newline? char)) + (char-set-contains? char-set:whitespace char))) + (define (letter? char) + (char-set-contains? char-set:letter char)) + (define (consume-whitespace port) + (match (peek-char port) + ((? eof-object?) *unspecified*) + ((? whitespace?) + (read-char port) + (consume-whitespace port)) + (_ *unspecified*))) + (define (read-tag port) + (list->symbol + (let loop () + (match (peek-char port) + ((? letter? char) + (read-char port) + (cons char (loop))) + ((? whitespace? char) + '()))))) + (define (read-key port) + (list->symbol + (let loop () + (match (read-char port) + (#\= '()) + ((? letter? char) + (cons char (loop))))))) + (define (read-quoted-string port) + (match (read-char port) + (#\" #t)) + (list->string + (let loop () + (match (read-char port) + (#\" + (if (or (whitespace? (peek-char port)) + (newline? (peek-char port))) + '() + (cons #\" (loop)))) + (char (cons char (loop))))))) + (define (read-unquoted-string port) + (list->string + (let loop () + (match (peek-char port) + ((or (? whitespace?) + (? newline?)) + '()) + (char + (read-char port) + (cons char (loop))))))) + (define (read-value port) + (match (peek-char port) + (#\" + (read-quoted-string port)) + (_ (read-unquoted-string port)))) + (define (read-key/value-pair port) + (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))))))) + (define (read-line port) + (list (read-tag port) (read-key/value-pairs port))) + `(*TOP* + (font + ,@(call-with-input-file file + (lambda (port) + (let loop ((pages '())) + (match (peek-char port) + ((? eof-object?) + `((pages (@ (count ,(number->string (length pages)))) + ,@pages))) + ((? newline?) + (read-char port) + (loop pages)) + ((? letter?) + (match (read-line port) + ((tag ('@ ('count count))) + (cons (cons* tag + `(@ (count ,count)) + (list-tabulate (string->number count) + (lambda (i) + (read-line port)))) + (loop pages))) + ((and ('page . _) page) + (loop (cons page pages))) + (exp (cons exp (loop pages)))))))))))) + +(define (parse-bmfont-sxml file tree) + (define directory (dirname file)) + (define* (attr tree name #:optional (parse identity)) + (let ((result ((sxpath `(@ ,name *text*)) tree))) + (if (null? result) + #f + (parse (car result))))) + (define (parse-pages nodes) + (let ((table (make-hash-table))) + (for-each (lambda (node) + (let* ((id (attr node 'id string->number)) + (file (attr node 'file)) + (texture (load-image + (string-append directory "/" file)))) + (hashv-set! table id texture))) + nodes) + table)) + (define (string->character s) + (integer->char (string->number s))) + (define (parse-chars nodes pages image-width image-height line-height) + (define (x->s x) + (exact->inexact (/ x image-width))) + (define (y->t y) + (exact->inexact (/ y image-height))) + (let ((table (make-hash-table))) + (for-each (lambda (node) + (let* ((id (attr node 'id string->character)) + (width (attr node 'width string->number)) + (height (attr node 'height string->number)) + (x (attr node 'x string->number)) + ;; Invert the y axis. Our origin is the + ;; bottom-left corner, not top-left. + (y (- image-height height + (attr node 'y string->number))) + (x-offset (attr node 'xoffset string->number)) + (y-offset (- line-height height + (attr node 'yoffset string->number))) + (x-advance (attr node 'xadvance string->number)) + (page (or (attr node 'page string->number) 0)) + (region (make-texture-region (hashv-ref pages page) + (make-rect x y width height))) + (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) + (let ((table (make-hash-table))) + (for-each (lambda (node) + (let* ((first (attr node 'first string->character)) + (second (attr node 'second string->character)) + (x-offset (attr node 'amount string->number)) + (inner-table (hashv-ref table first))) + (if inner-table + (hashv-set! inner-table second (vec2 x-offset 0.0)) + (let ((inner-table (make-hash-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)) + (common ((sxpath '(font common)) tree)) + (face (attr info 'face)) + (bold? (attr info 'bold (const #t))) + (italic? (attr info 'italic (const #t))) + (line-height (exact->inexact (attr common 'lineHeight string->number))) + (image-width (attr common 'scaleW string->number)) + (image-height (attr common 'scaleH string->number)) + (pages (parse-pages ((sxpath '(font pages page)) tree))) + (chars (parse-chars ((sxpath '(font chars char)) tree) + pages + image-width + image-height + line-height)) + (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* (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 ((compositor (make-compositor)) + (page (make-page))) + (lambda* (font text matrix #:key (blend-mode blend:alpha) + (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)) +(define %default-font + (delay (load-font (scope-datadir "fonts/Inconsolata-Regular.otf") 12))) + +(define (default-font) + (force %default-font)) + +(define draw-text + (let ((matrix (make-null-matrix4))) + (lambda* (text + position + #:key + (font (default-font)) + (color white) + (origin %null-vec2) + (rotation 0) + (scale %default-scale) + (blend-mode blend:alpha) + (start 0) + (end (string-length text)) + (typeset typeset-lrtb)) + "Draw the string TEXT with the first character starting at +POSITION using FONT." + (matrix4-2d-transform! matrix + #:origin origin + #:position position + #:rotation rotation + #:scale scale) + (draw-text* font text matrix + #:blend-mode blend-mode + #:color color + #:start start + #:end end)))) |