diff options
| -rw-r--r-- | chickadee/render/font.scm | 115 |
1 files 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))) |