6136849e387ffda6a14be4da9f8b818da4658d1a
[chickadee.git] / chickadee / render / font.scm
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)
26 #:use-module (ice-9 match)
27 #:use-module (srfi srfi-1)
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 config)
34 #:use-module (chickadee math matrix)
35 #:use-module (chickadee math rect)
36 #:use-module (chickadee math vector)
37 #:use-module (chickadee render)
38 #:use-module (chickadee render shader)
39 #:use-module (chickadee render sprite)
40 #:use-module (chickadee render texture)
41 #:export (load-font
42 load-tile-font
43 font?
44 font-face
45 font-line-height
46 font-line-width
47 font-bold?
48 font-italic?
49 draw-text*
50 draw-text))
51
52 (define-record-type <font-char>
53 (make-font-char id texture-region offset dimensions advance)
54 font-char?
55 (id font-char-id)
56 (texture-region font-char-texture-region)
57 (offset font-char-offset)
58 (dimensions font-char-dimensions)
59 (advance font-char-advance))
60
61 (define-record-type <font>
62 (make-font face bold? italic? line-height chars kerning)
63 font?
64 (face font-face)
65 (bold? font-bold?)
66 (italic? font-italic?)
67 (line-height font-line-height)
68 (chars font-chars)
69 (kerning font-kerning))
70
71 (define (display-font font port)
72 (format port "#<font face: ~a line-height: ~d bold?: ~a italic?: ~a>"
73 (font-face font)
74 (font-line-height font)
75 (font-bold? font)
76 (font-italic? font)))
77
78 (set-record-type-printer! <font> display-font)
79
80 (define (font-line-width font text)
81 "Return the width of TEXT when rendered with FONT."
82 (let loop ((width 0.0)
83 (i 0))
84 (if (< i (string-length text))
85 (let ((char (or (font-ref font (string-ref text i))
86 (font-ref font #\?))))
87 (loop (+ width (vec2-x (font-char-advance char)))
88 (+ i 1)))
89 width)))
90
91 (define* (load-tile-font file tile-width tile-height characters #:key
92 (face "untitled") (margin 0) (spacing 0))
93 "Load the font named FACE from FILE, a bitmap image containing the
94 characters in the string CHARACTERS that are TILE-WIDTH by TILE-HEIGHT
95 pixels in size. The characters in the image *must* appear in the
96 order that they are specified in the character set or text will not
97 render properly. Optionally, each tile may have SPACING pixels of
98 horizontal and vertical space between surrounding tiles and the entire
99 image may have MARGIN pixels of empty space around its border."
100 (let* ((atlas (split-texture (load-image file) tile-width tile-height
101 #:margin margin
102 #:spacing spacing))
103 (chars
104 (let ((table (make-hash-table)))
105 (string-for-each-index
106 (lambda (i)
107 (hash-set! table (string-ref characters i)
108 (make-font-char (string-ref characters i)
109 (texture-atlas-ref atlas i)
110 (vec2 0.0 0.0)
111 (vec2 tile-width tile-height)
112 (vec2 tile-width 0.0))))
113 characters)
114 table))
115 ;; These fonts are by definition monospace fonts, so no
116 ;; kerning.
117 (kernings (make-hash-table)))
118 (make-font face #f #f tile-height chars kernings)))
119
120 (define (load-font file)
121 "Load the AngelCode formatted bitmap font within FILE. The file
122 extension must be either .xml or .fnt."
123 (cond
124 ((string-suffix? ".xml" file)
125 (parse-bmfont-sxml file (call-with-input-file file xml->sxml)))
126 ((string-suffix? ".fnt" file)
127 (parse-bmfont-sxml file (parse-fnt file)))
128 (else
129 (error "unknown bmfont file type: " file))))
130
131 (define (parse-fnt file)
132 (define (newline? char)
133 (eqv? char #\newline))
134 (define (whitespace? char)
135 (and (not (newline? char))
136 (char-set-contains? char-set:whitespace char)))
137 (define (letter? char)
138 (char-set-contains? char-set:letter char))
139 (define (consume-whitespace port)
140 (match (peek-char port)
141 ((? eof-object?) *unspecified*)
142 ((? whitespace?)
143 (read-char port)
144 (consume-whitespace port))
145 (_ *unspecified*)))
146 (define (read-tag port)
147 (list->symbol
148 (let loop ()
149 (match (peek-char port)
150 ((? letter? char)
151 (read-char port)
152 (cons char (loop)))
153 ((? whitespace? char)
154 '())))))
155 (define (read-key port)
156 (list->symbol
157 (let loop ()
158 (match (read-char port)
159 (#\= '())
160 ((? letter? char)
161 (cons char (loop)))))))
162 (define (read-quoted-string port)
163 (match (read-char port)
164 (#\" #t))
165 (list->string
166 (let loop ()
167 (match (read-char port)
168 (#\"
169 (if (or (whitespace? (peek-char port))
170 (newline? (peek-char port)))
171 '()
172 (cons #\" (loop))))
173 (char (cons char (loop)))))))
174 (define (read-unquoted-string port)
175 (list->string
176 (let loop ()
177 (match (peek-char port)
178 ((or (? whitespace?)
179 (? newline?))
180 '())
181 (char
182 (read-char port)
183 (cons char (loop)))))))
184 (define (read-value port)
185 (match (peek-char port)
186 (#\"
187 (read-quoted-string port))
188 (_ (read-unquoted-string port))))
189 (define (read-key/value-pair port)
190 (list (read-key port) (read-value port)))
191 (define (read-key/value-pairs port)
192 (cons '@
193 (let loop ()
194 (consume-whitespace port)
195 (match (peek-char port)
196 ((? newline?)
197 (read-char port)
198 '())
199 ((? letter?)
200 (cons (read-key/value-pair port)
201 (loop)))))))
202 (define (read-line port)
203 (list (read-tag port) (read-key/value-pairs port)))
204 `(*TOP*
205 (font
206 ,@(call-with-input-file file
207 (lambda (port)
208 (let loop ((pages '()))
209 (match (peek-char port)
210 ((? eof-object?)
211 `((pages (@ (count ,(number->string (length pages))))
212 ,@pages)))
213 ((? newline?)
214 (read-char port)
215 (loop pages))
216 ((? letter?)
217 (match (read-line port)
218 ((tag ('@ ('count count)))
219 (cons (cons* tag
220 `(@ (count ,count))
221 (list-tabulate (string->number count)
222 (lambda (i)
223 (read-line port))))
224 (loop pages)))
225 ((and ('page . _) page)
226 (loop (cons page pages)))
227 (exp (cons exp (loop pages))))))))))))
228
229 (define (parse-bmfont-sxml file tree)
230 (define directory (dirname file))
231 (define* (attr tree name #:optional (parse identity))
232 (let ((result ((sxpath `(@ ,name *text*)) tree)))
233 (if (null? result)
234 #f
235 (parse (car result)))))
236 (define (parse-pages nodes)
237 (let ((table (make-hash-table)))
238 (for-each (lambda (node)
239 (let* ((id (attr node 'id string->number))
240 (file (attr node 'file))
241 (texture (load-image
242 (string-append directory "/" file))))
243 (hash-set! table id texture)))
244 nodes)
245 table))
246 (define (string->character s)
247 (integer->char (string->number s)))
248 (define (parse-chars nodes pages image-width image-height line-height)
249 (define (x->s x)
250 (exact->inexact (/ x image-width)))
251 (define (y->t y)
252 (exact->inexact (/ y image-height)))
253 (let ((table (make-hash-table)))
254 (for-each (lambda (node)
255 (let* ((id (attr node 'id string->character))
256 (width (attr node 'width string->number))
257 (height (attr node 'height string->number))
258 (x (attr node 'x string->number))
259 (y (attr node 'y string->number))
260 (x-offset (attr node 'xoffset string->number))
261 (y-offset (- line-height height
262 (attr node 'yoffset string->number)))
263 (x-advance (attr node 'xadvance string->number))
264 (page (or (attr node 'page string->number) 0))
265 (region (make-texture-region (hash-ref pages page)
266 (make-rect x y width height)))
267 (char (make-font-char id
268 region
269 (vec2 x-offset y-offset)
270 (vec2 width height)
271 (vec2 x-advance 0.0))))
272 (hash-set! table id char)))
273 nodes)
274 table))
275 (define (parse-kernings nodes)
276 (let ((table (make-hash-table)))
277 (for-each (lambda (node)
278 (let* ((first (attr node 'first string->character))
279 (second (attr node 'second string->character))
280 (x-offset (attr node 'amount string->number))
281 (inner-table (hash-ref table first)))
282 (if inner-table
283 (hash-set! inner-table second (vec2 x-offset 0.0))
284 (let ((inner-table (make-hash-table)))
285 (hash-set! inner-table second (vec2 x-offset 0.0))
286 (hash-set! table first inner-table)))))
287 nodes)
288 table))
289 (let* ((info ((sxpath '(font info)) tree))
290 (common ((sxpath '(font common)) tree))
291 (face (attr info 'face))
292 (bold? (attr info 'bold (const #t)))
293 (italic? (attr info 'italic (const #t)))
294 (line-height (attr common 'lineHeight string->number))
295 (image-width (attr common 'scaleW string->number))
296 (image-height (attr common 'scaleH string->number))
297 (pages (parse-pages ((sxpath '(font pages page)) tree)))
298 (chars (parse-chars ((sxpath '(font chars char)) tree)
299 pages
300 image-width
301 image-height
302 line-height))
303 (kernings (parse-kernings ((sxpath '(font kernings kerning)) tree))))
304 (make-font face bold? italic? line-height chars kernings)))
305
306 (define (font-ref font char)
307 (hashv-ref (font-chars font) char))
308
309 (define draw-text*
310 (let ((cursor (vec2 0.0 0.0))
311 (rect (make-rect 0.0 0.0 0.0 0.0)))
312 (lambda* (font text matrix #:key (blend-mode 'alpha)
313 (start 0) (end (string-length text)))
314 ;; TODO: Respect kerning.
315 (define (render-char c)
316 ;; TODO: What if "?" isn't in the font?
317 (let* ((char (or (font-ref font c) (font-ref font #\?)))
318 (texture (font-char-texture-region char))
319 (dimensions (font-char-dimensions char))
320 (offset (font-char-offset char)))
321 (set-rect-x! rect (+ (vec2-x cursor) (vec2-x offset)))
322 (set-rect-y! rect (+ (vec2-y cursor) (vec2-y offset)))
323 (set-rect-width! rect (vec2-x dimensions))
324 (set-rect-height! rect (vec2-y dimensions))
325 (draw-sprite* texture rect matrix #:blend-mode blend-mode)
326 ;; Move forward to where the next character needs to be drawn.
327 (set-vec2-x! cursor
328 (+ (vec2-x cursor)
329 (vec2-x
330 (font-char-advance char))))))
331 (set-vec2! cursor 0.0 0.0)
332 (string-for-each render-char text start end))))
333
334 (define %default-scale (vec2 1.0 1.0))
335 (define %null-vec2 (vec2 0.0 0.0))
336
337 (define default-font
338 (delay
339 (load-font (scope-datadir "fonts/good-neighbors.fnt"))))
340
341 (define draw-text
342 (let ((matrix (make-null-matrix4)))
343 (lambda* (text
344 position
345 #:key
346 (font (force default-font))
347 (origin %null-vec2)
348 (rotation 0)
349 (scale %default-scale)
350 (blend-mode 'alpha)
351 (start 0)
352 (end (string-length text)))
353 "Draw the string TEXT with the first character starting at
354 POSITION using FONT."
355 (matrix4-2d-transform! matrix
356 #:origin origin
357 #:position position
358 #:rotation rotation
359 #:scale scale)
360 (draw-text* font text matrix #:blend-mode blend-mode
361 #:start start #:end end))))