From a4670ba826fd6643922072e188ca77f1039769a3 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 11 Nov 2017 16:02:37 -0500
Subject: render: font: Add support for .fnt formatted fonts.

* chickadee/render/font.scm (load-font): Check for .xml and .fnt file
extensions and DTRT.
(parse-fnt, parse-bmfont-sxml): New procedure.
---
 chickadee/render/font.scm | 115 ++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 112 insertions(+), 3 deletions(-)

diff --git a/chickadee/render/font.scm b/chickadee/render/font.scm
index 97a680b..31670ad 100644
--- a/chickadee/render/font.scm
+++ b/chickadee/render/font.scm
@@ -23,6 +23,8 @@
 
 (define-module (chickadee render font)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
@@ -102,7 +104,115 @@ image may have MARGIN pixels of empty space around its border."
     (make-font face #f #f tile-height chars kernings)))
 
 (define (load-font file)
-  "Load the Angel Code XML formatted font within 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)))
@@ -165,8 +275,7 @@ image may have MARGIN pixels of empty space around its border."
                           (hash-set! table first inner-table)))))
                 nodes)
       table))
-  (let* ((tree (call-with-input-file file xml->sxml))
-         (info ((sxpath '(font info)) tree))
+  (let* ((info ((sxpath '(font info)) tree))
          (common ((sxpath '(font common)) tree))
          (face (attr info 'face))
          (bold? (attr info 'bold (const #t)))
-- 
cgit v1.2.3