1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
;;; guile-sdl2 --- FFI bindings for SDL2
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; This file is part of guile-sdl2.
;;;
;;; Guile-sdl2 is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Guile-sdl2 is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with guile-sdl2. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Font rendering.
;;
;;; Code:
(define-module (sdl2 ttf)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (system foreign)
#:use-module (sdl2)
#:use-module ((sdl2 bindings ttf) #:prefix ffi:)
#:export (ttf-init
ttf-quit
font?
load-font
delete-font!
font-height
font-ascent
font-descent
font-line-skip
font-size
font-glyph-index
font-glyph-metrics
font-style
set-font-style!
render-font-solid
render-font-blended))
(define (ttf-init)
"Initialize the TTF system."
(unless (zero? (ffi:ttf-init))
(sdl-error "ttf-init" "failed to initialize TTF library")))
(define (ttf-quit)
"Shut down and clean up the TTF system."
(ffi:ttf-quit))
(define-wrapped-pointer-type <font>
font?
wrap-font unwrap-font
(lambda (font port)
(format port "#<font ~x>"
(pointer-address (unwrap-font font)))))
(define (load-font file point-size)
"Load TTF font from FILE and return a new font object whose glyph
size is POINT-SIZE."
(let ((ptr (ffi:ttf-open-font (string->pointer file) point-size)))
(if (null-pointer? ptr)
(sdl-error "load-font" "failed to load font" file)
(wrap-font ptr))))
(define (delete-font! font)
"Delete the memory allocated for FONT."
(ffi:ttf-close-font (unwrap-font font)))
(define (font-height font)
"Return the maximum height of FONT."
(ffi:ttf-font-height (unwrap-font font)))
(define (font-ascent font)
"Return the maximum pixel ascent of all glyphs in FONT."
(ffi:ttf-font-ascent (unwrap-font font)))
(define (font-descent font)
"Return the maximum pixel descent of all glyphs in FONT."
(ffi:ttf-font-descent (unwrap-font font)))
(define (font-line-skip font)
"Return the recommended pixel height of a line in FONT."
(ffi:ttf-font-line-skip (unwrap-font font)))
(define (font-size font text)
"Return a 2-element list containing the resulting surface size of
the string TEXT using FONT in the following format: (width height)."
(let ((bv (make-s32vector 2)))
(if (zero? (ffi:ttf-size-utf8 (unwrap-font font)
(string->pointer text)
(bytevector->pointer bv)
(bytevector->pointer bv 4)))
(s32vector->list bv)
(sdl-error "size-utf8" "failed to get size utf8"))))
(define (font-glyph-index font char)
"Return the index of the glyph for CHAR in FONT, or #f if CHAR is
not present."
(let ((result (ffi:ttf-glyph-is-provided (unwrap-font font) (char->integer char))))
(if (eq? result 0) #f result)))
(define (font-glyph-metrics font char)
"Return a 5-element list containing the metrics of CHAR in FONT in
the following format: (minx maxx miny maxy advance)"
(let ((bv (make-s32vector 5)))
(if (zero? (ffi:ttf-glyph-metrics (unwrap-font font)
(char->integer char)
(bytevector->pointer bv)
(bytevector->pointer bv 4)
(bytevector->pointer bv 8)
(bytevector->pointer bv 12)
(bytevector->pointer bv 16)))
(s32vector->list bv)
(sdl-error "font-glyph-metrics" "failed to get glyph metrics"))))
(define (font-style font)
"Return the rendering style of FONT. Return a list that may contain
any of the following symbols:
- bold
- italic
- underline
- strikethrough
The empty list returned if no there is no style applied."
(let ((bitmask (ffi:ttf-get-font-style (unwrap-font font))))
(filter-map (match-lambda
((sym . bit)
(and (not (zero? (logand bitmask bit))) sym)))
`((bold . ,ffi:SDL_TTF_STYLE_BOLD)
(italic . ,ffi:SDL_TTF_STYLE_ITALIC)
(underline . ,ffi:SDL_TTF_STYLE_UNDERLINE)
(strikethrough . ,ffi:SDL_TTF_STYLE_STRIKETHROUGH)))))
(define (set-font-style! font style)
"Set the rendering style of FONT to STYLE, a list that may contain
any of the following symbols:
- bold
- italic
- underline
- strikethrough
Use an empty list to set the normal style."
(let ((bitmask
(fold (lambda (flag prev)
(logior prev
(match flag
('bold ffi:SDL_TTF_STYLE_BOLD)
('italic ffi:SDL_TTF_STYLE_ITALIC)
('underline ffi:SDL_TTF_STYLE_UNDERLINE)
('strikethrough ffi:SDL_TTF_STYLE_STRIKETHROUGH))))
0
style)))
(ffi:ttf-set-font-style (unwrap-font font) bitmask)))
(define (render-font-solid font text color)
"Render TEXT, a UTF-8 encoded string, using FONT and COLOR, the
foreground color, and return a surface containing the results."
(let ((ptr (ffi:ttf-render-utf8-solid (unwrap-font font)
(string->pointer text)
((@@ (sdl2) color->struct) color))))
(if (null-pointer? ptr)
(sdl-error "render-font-solid" "failed to render text")
((@@ (sdl2 surface) wrap-surface) ptr))))
(define (render-font-blended font text color)
"Render TEXT, a UTF-8 encoded string, using FONT and COLOR, the
foreground color, and return a high-quality alpha-blended surface
containing the results."
(let ((ptr (ffi:ttf-render-utf8-blended (unwrap-font font)
(string->pointer text)
((@@ (sdl2) color->struct) color))))
(if (null-pointer? ptr)
(sdl-error "render-font-blended" "failed to render text")
((@@ (sdl2 surface) wrap-surface) ptr))))
|
