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