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