render: Add bitmap font support.

* chickadee/render/font.scm: New file.
* Makefile.am (SOURCES): Add it.
* examples/text.scm: New file.
* examples/fonts/AUTHORS: New file.
* examples/fonts/good_neighbors_starling.png: New file.
* examples/fonts/good_neighbors_starling.xml: New file.

1 files changed, 191 insertions, 0 deletions

diff --git a/chickadee/render/font.scm b/chickadee/render/font.scm
new file mode 100644
index 0000000..8f89b95
--- /dev/null
+++ b/chickadee/render/font.scm
@@ -0,0 +1,191 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2017 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 render font)
+  #:use-module (ice-9 format)
+  #: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 math matrix)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee render)
+  #:use-module (chickadee render shader)
+  #:use-module (chickadee render sprite)
+  #:use-module (chickadee render texture)
+  #:export (load-font
+            font?
+            font-face
+            font-line-height
+            font-bold?
+            font-italic?
+            draw-text))
+
+(define-record-type <font-char>
+  (make-font-char id texture region offset dimensions advance)
+  font-char?
+  (id font-char-id)
+  (texture font-char-texture)
+  (region font-char-region)
+  (offset font-char-offset)
+  (dimensions font-char-dimensions)
+  (advance font-char-advance))
+
+(define-record-type <font>
+  (make-font face bold? italic? line-height chars kerning)
+  font?
+  (face font-face)
+  (bold? font-bold?)
+  (italic? font-italic?)
+  (line-height font-line-height)
+  (chars font-chars)
+  (kerning font-kerning))
+
+(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 (load-font file)
+  "Load the Angel Code XML formatted font within FILE."
+  (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))))
+                    (hash-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-rect (x->s x)
+                                            (y->t y)
+                                            (x->s width)
+                                            (y->t height)))
+                         (char (make-font-char id
+                                               (hash-ref pages page)
+                                               region
+                                               (vec2 x-offset y-offset)
+                                               (vec2 width height)
+                                               (vec2 x-advance 0.0))))
+                    (hash-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 (hash-ref table first)))
+                    (if inner-table
+                        (hash-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)))))
+                nodes)
+      table))
+  (let* ((tree (call-with-input-file file xml->sxml))
+         (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 (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 chars kernings)))
+
+(define (font-ref font char)
+  (hashv-ref (font-chars font) char))
+
+(define draw-text
+  (let ((p (vec2 0.0 0.0))
+        (rect (make-rect 0.0 0.0 0.0 0.0)))
+    (lambda* (font text position #:key scale rotation (blend-mode 'alpha))
+      "Draw the string TEXT with the first character starting at
+POSITION using FONT."
+      ;; TODO: Respect kerning.
+      (define (render-char c)
+        (let* ((char (font-ref font c))
+               (dimensions (font-char-dimensions char))
+               (offset (font-char-offset char)))
+          (set-rect-x! rect (+ (vec2-x p) (vec2-x offset)))
+          (set-rect-y! rect (+ (vec2-y p) (vec2-y offset)))
+          (set-rect-width! rect (vec2-x dimensions))
+          (set-rect-height! rect (vec2-y dimensions))
+          (draw-sprite (font-char-texture char)
+                       rect
+                       #:texture-region (font-char-region char)
+                       #:scale scale
+                       #:rotation rotation
+                       #:blend-mode blend-mode)
+          ;; Move forward to where the next character needs to be drawn.
+          (set-vec2-x! p
+                       (+ (vec2-x p)
+                          (vec2-x
+                           (font-char-advance char))))))
+      (vec2-copy! position p) ; initialize position
+      (with-batched-sprites
+       (string-for-each render-char text)))))