guix: Update to latest guile-sdl2 commit.
[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)
26 #:use-module (srfi srfi-9)
27 #:use-module (srfi srfi-9 gnu)
28 #:use-module (srfi srfi-11)
29 #:use-module (sxml xpath)
30 #:use-module (sxml simple)
31 #:use-module (chickadee math matrix)
32 #:use-module (chickadee math rect)
33 #:use-module (chickadee math vector)
34 #:use-module (chickadee render)
35 #:use-module (chickadee render shader)
36 #:use-module (chickadee render sprite)
37 #:use-module (chickadee render texture)
38 #:export (load-font
b61558f5 39 load-tile-font
233d13ca
DT
40 font?
41 font-face
42 font-line-height
43 font-bold?
44 font-italic?
45 draw-text))
46
47(define-record-type <font-char>
45c5d680 48 (make-font-char id texture-region offset dimensions advance)
233d13ca
DT
49 font-char?
50 (id font-char-id)
45c5d680 51 (texture-region font-char-texture-region)
233d13ca
DT
52 (offset font-char-offset)
53 (dimensions font-char-dimensions)
54 (advance font-char-advance))
55
56(define-record-type <font>
57 (make-font face bold? italic? line-height chars kerning)
58 font?
59 (face font-face)
60 (bold? font-bold?)
61 (italic? font-italic?)
62 (line-height font-line-height)
63 (chars font-chars)
64 (kerning font-kerning))
65
66(define (display-font font port)
67 (format port "#<font face: ~a line-height: ~d bold?: ~a italic?: ~a>"
68 (font-face font)
69 (font-line-height font)
70 (font-bold? font)
71 (font-italic? font)))
72
73(set-record-type-printer! <font> display-font)
74
b61558f5
DT
75(define* (load-tile-font file tile-width tile-height characters #:key
76 (face "untitled") (margin 0) (spacing 0))
77 "Load the font named FACE from FILE, a bitmap image containing the
78characters in the string CHARACTERS that are TILE-WIDTH by TILE-HEIGHT
79pixels in size. The characters in the image *must* appear in the
80order that they are specified in the character set or text will not
81render properly. Optionally, each tile may have SPACING pixels of
82horizontal and vertical space between surrounding tiles and the entire
83image may have MARGIN pixels of empty space around its border."
84 (let* ((atlas (split-texture (load-image file) tile-width tile-height
85 #:margin margin
86 #:spacing spacing))
87 (chars
88 (let ((table (make-hash-table)))
89 (string-for-each-index
90 (lambda (i)
91 (hash-set! table (string-ref characters i)
92 (make-font-char (string-ref characters i)
93 (texture-atlas-ref atlas i)
94 (vec2 0.0 0.0)
95 (vec2 tile-width tile-height)
96 (vec2 tile-width 0.0))))
97 characters)
98 table))
99 ;; These fonts are by definition monospace fonts, so no
100 ;; kerning.
101 (kernings (make-hash-table)))
102 (make-font face #f #f tile-height chars kernings)))
103
233d13ca
DT
104(define (load-font file)
105 "Load the Angel Code XML formatted font within FILE."
106 (define directory (dirname file))
107 (define* (attr tree name #:optional (parse identity))
108 (let ((result ((sxpath `(@ ,name *text*)) tree)))
109 (if (null? result)
110 #f
111 (parse (car result)))))
112 (define (parse-pages nodes)
113 (let ((table (make-hash-table)))
114 (for-each (lambda (node)
115 (let* ((id (attr node 'id string->number))
116 (file (attr node 'file))
117 (texture (load-image
118 (string-append directory "/" file))))
119 (hash-set! table id texture)))
120 nodes)
121 table))
122 (define (string->character s)
123 (integer->char (string->number s)))
124 (define (parse-chars nodes pages image-width image-height line-height)
125 (define (x->s x)
126 (exact->inexact (/ x image-width)))
127 (define (y->t y)
128 (exact->inexact (/ y image-height)))
129 (let ((table (make-hash-table)))
130 (for-each (lambda (node)
131 (let* ((id (attr node 'id string->character))
132 (width (attr node 'width string->number))
133 (height (attr node 'height string->number))
134 (x (attr node 'x string->number))
135 ;; Invert the y axis. Our origin is the
136 ;; bottom-left corner, not top-left.
137 (y (- image-height height
138 (attr node 'y string->number)))
139 (x-offset (attr node 'xoffset string->number))
140 (y-offset (- line-height height
141 (attr node 'yoffset string->number)))
142 (x-advance (attr node 'xadvance string->number))
143 (page (or (attr node 'page string->number) 0))
45c5d680
DT
144 (region (make-texture-region (hash-ref pages page)
145 x y width height))
233d13ca 146 (char (make-font-char id
233d13ca
DT
147 region
148 (vec2 x-offset y-offset)
149 (vec2 width height)
150 (vec2 x-advance 0.0))))
151 (hash-set! table id char)))
152 nodes)
153 table))
154 (define (parse-kernings nodes)
155 (let ((table (make-hash-table)))
156 (for-each (lambda (node)
157 (let* ((first (attr node 'first string->character))
158 (second (attr node 'second string->character))
159 (x-offset (attr node 'amount string->number))
160 (inner-table (hash-ref table first)))
161 (if inner-table
162 (hash-set! inner-table second (vec2 x-offset 0.0))
163 (let ((inner-table (make-hash-table)))
164 (hash-set! inner-table second (vec2 x-offset 0.0))
165 (hash-set! table first inner-table)))))
166 nodes)
167 table))
168 (let* ((tree (call-with-input-file file xml->sxml))
169 (info ((sxpath '(font info)) tree))
170 (common ((sxpath '(font common)) tree))
171 (face (attr info 'face))
172 (bold? (attr info 'bold (const #t)))
173 (italic? (attr info 'italic (const #t)))
174 (line-height (attr common 'lineHeight string->number))
175 (image-width (attr common 'scaleW string->number))
176 (image-height (attr common 'scaleH string->number))
177 (pages (parse-pages ((sxpath '(font pages page)) tree)))
178 (chars (parse-chars ((sxpath '(font chars char)) tree)
179 pages
180 image-width
181 image-height
182 line-height))
183 (kernings (parse-kernings ((sxpath '(font kernings kerning)) tree))))
184 (make-font face bold? italic? line-height chars kernings)))
185
186(define (font-ref font char)
187 (hashv-ref (font-chars font) char))
188
189(define draw-text
45c5d680
DT
190 (let ((cursor (vec2 0.0 0.0))
191 (char-pos (vec2 0.0 0.0)))
233d13ca
DT
192 (lambda* (font text position #:key scale rotation (blend-mode 'alpha))
193 "Draw the string TEXT with the first character starting at
194POSITION using FONT."
195 ;; TODO: Respect kerning.
196 (define (render-char c)
197 (let* ((char (font-ref font c))
198 (dimensions (font-char-dimensions char))
199 (offset (font-char-offset char)))
45c5d680
DT
200 (set-vec2-x! char-pos (+ (vec2-x cursor) (vec2-x offset)))
201 (set-vec2-y! char-pos (+ (vec2-y cursor) (vec2-y offset)))
202 (draw-sprite (font-char-texture-region char)
203 char-pos
233d13ca
DT
204 #:scale scale
205 #:rotation rotation
206 #:blend-mode blend-mode)
207 ;; Move forward to where the next character needs to be drawn.
45c5d680
DT
208 (set-vec2-x! cursor
209 (+ (vec2-x cursor)
233d13ca
DT
210 (vec2-x
211 (font-char-advance char))))))
45c5d680 212 (vec2-copy! position cursor) ; initialize position
233d13ca
DT
213 (with-batched-sprites
214 (string-for-each render-char text)))))