math: matrix: Add matrix4-2d-transform! procedure.
[chickadee.git] / chickadee / render / font.scm
CommitLineData
233d13ca
DT
1;;; Chickadee Game Toolkit
2;;; Copyright © 2017 David Thompson <davet@gnu.org>
3;;;
4;;; Chickadee is free software: you can redistribute it and/or modify
5;;; it under the terms of the GNU General Public License as published
6;;; by the Free Software Foundation, either version 3 of the License,
7;;; or (at your option) any later version.
8;;;
9;;; Chickadee is distributed in the hope that it will be useful, but
10;;; WITHOUT ANY WARRANTY; without even the implied warranty of
11;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12;;; General Public License for more details.
13;;;
14;;; You should have received a copy of the GNU General Public License
15;;; along with this program. If not, see
16;;; <http://www.gnu.org/licenses/>.
17
18;;; Commentary:
19;;
20;; Bitmap font rendering.
21;;
22;;; Code:
23
24(define-module (chickadee render font)
25 #:use-module (ice-9 format)
a4670ba8
DT
26 #:use-module (ice-9 match)
27 #:use-module (srfi srfi-1)
233d13ca
DT
28 #:use-module (srfi srfi-9)
29 #:use-module (srfi srfi-9 gnu)
30 #:use-module (srfi srfi-11)
31 #:use-module (sxml xpath)
32 #:use-module (sxml simple)
33 #:use-module (chickadee math matrix)
34 #:use-module (chickadee math rect)
35 #:use-module (chickadee math vector)
36 #:use-module (chickadee render)
37 #:use-module (chickadee render shader)
38 #:use-module (chickadee render sprite)
39 #:use-module (chickadee render texture)
40 #:export (load-font
b61558f5 41 load-tile-font
233d13ca
DT
42 font?
43 font-face
44 font-line-height
45 font-bold?
46 font-italic?
47 draw-text))
48
49(define-record-type <font-char>
45c5d680 50 (make-font-char id texture-region offset dimensions advance)
233d13ca
DT
51 font-char?
52 (id font-char-id)
45c5d680 53 (texture-region font-char-texture-region)
233d13ca
DT
54 (offset font-char-offset)
55 (dimensions font-char-dimensions)
56 (advance font-char-advance))
57
58(define-record-type <font>
59 (make-font face bold? italic? line-height chars kerning)
60 font?
61 (face font-face)
62 (bold? font-bold?)
63 (italic? font-italic?)
64 (line-height font-line-height)
65 (chars font-chars)
66 (kerning font-kerning))
67
68(define (display-font font port)
69 (format port "#<font face: ~a line-height: ~d bold?: ~a italic?: ~a>"
70 (font-face font)
71 (font-line-height font)
72 (font-bold? font)
73 (font-italic? font)))
74
75(set-record-type-printer! <font> display-font)
76
b61558f5
DT
77(define* (load-tile-font file tile-width tile-height characters #:key
78 (face "untitled") (margin 0) (spacing 0))
79 "Load the font named FACE from FILE, a bitmap image containing the
80characters in the string CHARACTERS that are TILE-WIDTH by TILE-HEIGHT
81pixels in size. The characters in the image *must* appear in the
82order that they are specified in the character set or text will not
83render properly. Optionally, each tile may have SPACING pixels of
84horizontal and vertical space between surrounding tiles and the entire
85image may have MARGIN pixels of empty space around its border."
86 (let* ((atlas (split-texture (load-image file) tile-width tile-height
87 #:margin margin
88 #:spacing spacing))
89 (chars
90 (let ((table (make-hash-table)))
91 (string-for-each-index
92 (lambda (i)
93 (hash-set! table (string-ref characters i)
94 (make-font-char (string-ref characters i)
95 (texture-atlas-ref atlas i)
96 (vec2 0.0 0.0)
97 (vec2 tile-width tile-height)
98 (vec2 tile-width 0.0))))
99 characters)
100 table))
101 ;; These fonts are by definition monospace fonts, so no
102 ;; kerning.
103 (kernings (make-hash-table)))
104 (make-font face #f #f tile-height chars kernings)))
105
233d13ca 106(define (load-font file)
a4670ba8
DT
107 "Load the AngelCode formatted bitmap font within FILE. The file
108extension must be either .xml or .fnt."
109 (cond
110 ((string-suffix? ".xml" file)
111 (parse-bmfont-sxml file (call-with-input-file file xml->sxml)))
112 ((string-suffix? ".fnt" file)
113 (parse-bmfont-sxml file (parse-fnt file)))
114 (else
115 (error "unknown bmfont file type: " file))))
116
117(define (parse-fnt file)
118 (define (newline? char)
119 (eqv? char #\newline))
120 (define (whitespace? char)
121 (and (not (newline? char))
122 (char-set-contains? char-set:whitespace char)))
123 (define (letter? char)
124 (char-set-contains? char-set:letter char))
125 (define (consume-whitespace port)
126 (match (peek-char port)
127 ((? eof-object?) *unspecified*)
128 ((? whitespace?)
129 (read-char port)
130 (consume-whitespace port))
131 (_ *unspecified*)))
132 (define (read-tag port)
133 (list->symbol
134 (let loop ()
135 (match (peek-char port)
136 ((? letter? char)
137 (read-char port)
138 (cons char (loop)))
139 ((? whitespace? char)
140 '())))))
141 (define (read-key port)
142 (list->symbol
143 (let loop ()
144 (match (read-char port)
145 (#\= '())
146 ((? letter? char)
147 (cons char (loop)))))))
148 (define (read-quoted-string port)
149 (match (read-char port)
150 (#\" #t))
151 (list->string
152 (let loop ()
153 (match (read-char port)
154 (#\"
155 (if (or (whitespace? (peek-char port))
156 (newline? (peek-char port)))
157 '()
158 (cons #\" (loop))))
159 (char (cons char (loop)))))))
160 (define (read-unquoted-string port)
161 (list->string
162 (let loop ()
163 (match (peek-char port)
164 ((or (? whitespace?)
165 (? newline?))
166 '())
167 (char
168 (read-char port)
169 (cons char (loop)))))))
170 (define (read-value port)
171 (match (peek-char port)
172 (#\"
173 (read-quoted-string port))
174 (_ (read-unquoted-string port))))
175 (define (read-key/value-pair port)
176 (list (read-key port) (read-value port)))
177 (define (read-key/value-pairs port)
178 (cons '@
179 (let loop ()
180 (consume-whitespace port)
181 (match (peek-char port)
182 ((? newline?)
183 (read-char port)
184 '())
185 ((? letter?)
186 (cons (read-key/value-pair port)
187 (loop)))))))
188 (define (read-line port)
189 (list (read-tag port) (read-key/value-pairs port)))
190 `(*TOP*
191 (font
192 ,@(call-with-input-file file
193 (lambda (port)
194 (let loop ((pages '()))
195 (match (peek-char port)
196 ((? eof-object?)
197 `((pages (@ (count ,(number->string (length pages))))
198 ,@pages)))
199 ((? newline?)
200 (read-char port)
201 (loop pages))
202 ((? letter?)
203 (match (read-line port)
204 ((tag ('@ ('count count)))
205 (cons (cons* tag
206 `(@ (count ,count))
207 (list-tabulate (string->number count)
208 (lambda (i)
209 (read-line port))))
210 (loop pages)))
211 ((and ('page . _) page)
212 (loop (cons page pages)))
213 (exp (cons exp (loop pages))))))))))))
214
215(define (parse-bmfont-sxml file tree)
233d13ca
DT
216 (define directory (dirname file))
217 (define* (attr tree name #:optional (parse identity))
218 (let ((result ((sxpath `(@ ,name *text*)) tree)))
219 (if (null? result)
220 #f
221 (parse (car result)))))
222 (define (parse-pages nodes)
223 (let ((table (make-hash-table)))
224 (for-each (lambda (node)
225 (let* ((id (attr node 'id string->number))
226 (file (attr node 'file))
227 (texture (load-image
228 (string-append directory "/" file))))
229 (hash-set! table id texture)))
230 nodes)
231 table))
232 (define (string->character s)
233 (integer->char (string->number s)))
234 (define (parse-chars nodes pages image-width image-height line-height)
235 (define (x->s x)
236 (exact->inexact (/ x image-width)))
237 (define (y->t y)
238 (exact->inexact (/ y image-height)))
239 (let ((table (make-hash-table)))
240 (for-each (lambda (node)
241 (let* ((id (attr node 'id string->character))
242 (width (attr node 'width string->number))
243 (height (attr node 'height string->number))
244 (x (attr node 'x string->number))
245 ;; Invert the y axis. Our origin is the
246 ;; bottom-left corner, not top-left.
247 (y (- image-height height
248 (attr node 'y string->number)))
249 (x-offset (attr node 'xoffset string->number))
250 (y-offset (- line-height height
251 (attr node 'yoffset string->number)))
252 (x-advance (attr node 'xadvance string->number))
253 (page (or (attr node 'page string->number) 0))
45c5d680
DT
254 (region (make-texture-region (hash-ref pages page)
255 x y width height))
233d13ca 256 (char (make-font-char id
233d13ca
DT
257 region
258 (vec2 x-offset y-offset)
259 (vec2 width height)
260 (vec2 x-advance 0.0))))
261 (hash-set! table id char)))
262 nodes)
263 table))
264 (define (parse-kernings nodes)
265 (let ((table (make-hash-table)))
266 (for-each (lambda (node)
267 (let* ((first (attr node 'first string->character))
268 (second (attr node 'second string->character))
269 (x-offset (attr node 'amount string->number))
270 (inner-table (hash-ref table first)))
271 (if inner-table
272 (hash-set! inner-table second (vec2 x-offset 0.0))
273 (let ((inner-table (make-hash-table)))
274 (hash-set! inner-table second (vec2 x-offset 0.0))
275 (hash-set! table first inner-table)))))
276 nodes)
277 table))
a4670ba8 278 (let* ((info ((sxpath '(font info)) tree))
233d13ca
DT
279 (common ((sxpath '(font common)) tree))
280 (face (attr info 'face))
281 (bold? (attr info 'bold (const #t)))
282 (italic? (attr info 'italic (const #t)))
283 (line-height (attr common 'lineHeight string->number))
284 (image-width (attr common 'scaleW string->number))
285 (image-height (attr common 'scaleH string->number))
286 (pages (parse-pages ((sxpath '(font pages page)) tree)))
287 (chars (parse-chars ((sxpath '(font chars char)) tree)
288 pages
289 image-width
290 image-height
291 line-height))
292 (kernings (parse-kernings ((sxpath '(font kernings kerning)) tree))))
293 (make-font face bold? italic? line-height chars kernings)))
294
295(define (font-ref font char)
296 (hashv-ref (font-chars font) char))
297
cf1b09a1
DT
298(define %default-offset (vec2 0.0 0.0))
299
233d13ca 300(define draw-text
45c5d680
DT
301 (let ((cursor (vec2 0.0 0.0))
302 (char-pos (vec2 0.0 0.0)))
cf1b09a1
DT
303 (lambda* (font text position #:key
304 (rotation 0)
305 (scale 1.0)
306 matrix
307 (offset %default-offset)
308 (blend-mode 'alpha))
233d13ca
DT
309 "Draw the string TEXT with the first character starting at
310POSITION using FONT."
311 ;; TODO: Respect kerning.
312 (define (render-char c)
313 (let* ((char (font-ref font c))
314 (dimensions (font-char-dimensions char))
315 (offset (font-char-offset char)))
45c5d680
DT
316 (set-vec2-x! char-pos (+ (vec2-x cursor) (vec2-x offset)))
317 (set-vec2-y! char-pos (+ (vec2-y cursor) (vec2-y offset)))
318 (draw-sprite (font-char-texture-region char)
319 char-pos
cf1b09a1 320 #:offset offset
233d13ca
DT
321 #:scale scale
322 #:rotation rotation
cf1b09a1 323 #:matrix matrix
233d13ca
DT
324 #:blend-mode blend-mode)
325 ;; Move forward to where the next character needs to be drawn.
45c5d680
DT
326 (set-vec2-x! cursor
327 (+ (vec2-x cursor)
233d13ca
DT
328 (vec2-x
329 (font-char-advance char))))))
45c5d680 330 (vec2-copy! position cursor) ; initialize position
233d13ca
DT
331 (with-batched-sprites
332 (string-for-each render-char text)))))