blob: 4e9d4013084baf177d521b21904aa54a416b3ddb (
plain)
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
|
;;; guile-2d
;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program 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 General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Font rendering.
;;
;;; Code:
(define-module (2d font)
#:use-module (srfi srfi-9)
#:use-module (system foreign)
#:use-module ((sdl sdl) #:prefix SDL:)
#:use-module ((sdl ttf) #:prefix SDL:)
#:use-module (gl)
#:use-module (gl contrib packed-struct)
#:use-module (2d color)
#:use-module (2d config)
#:use-module (2d shader)
#:use-module (2d signal)
#:use-module (2d texture)
#:use-module (2d vector2)
#:use-module (2d window)
#:use-module (2d wrappers gl)
#:export (load-font
load-default-font
font?
font-point-size
make-label
label?
label-font
label-text
label-position
label-color
draw-label))
(SDL:ttf-init)
;;;
;;; Font
;;;
(define-record-type <font>
(make-font ttf point-size)
font?
(ttf font-ttf)
(point-size font-point-size))
(define (load-font filename point-size)
"Load the TTF font in FILENAME with the given POINT-SIZE."
(if (file-exists? filename)
(make-font (SDL:load-font filename point-size) point-size)
(error "File not found!" filename)))
(define* (load-default-font #:optional (point-size 12))
"Load the guile-2d default TTF font. POINT-SIZE is an optional
argument with a default value of 12."
(load-font (string-append %pkgdatadir "/fonts/DejaVuSans.ttf") point-size))
(define (render-text font text)
"Return a new texture with TEXT rendered using FONT."
(let* ((surface (SDL:render-utf8 (font-ttf font) text
(SDL:make-color 255 255 255) #t))
(pixels (SDL:surface-pixels surface))
(texture-id (gl-generate-texture)))
(with-gl-bind-texture (texture-target texture-2d) texture-id
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-min-filter)
(texture-min-filter nearest))
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-mag-filter)
(texture-mag-filter nearest))
(gl-texture-image-2d (texture-target texture-2d)
0
(pixel-format rgba)
(SDL:surface:w surface)
(SDL:surface:h surface)
0
(version-1-2 bgra)
(color-pointer-type unsigned-byte)
pixels))
(make-texture texture-id #f
(SDL:surface:w surface)
(SDL:surface:h surface)
0 0 1 1)))
(define-record-type <label>
(%make-label font text position anchor color texture vertices)
label?
(font label-font)
(text label-text)
(position label-position)
(anchor label-anchor)
(color label-color)
(texture label-texture)
(vertices label-vertices))
(define (make-label-vertices texture)
"Return a packed array of vertices for TEXTURE."
(let ((vertices (make-packed-array texture-vertex 4)))
(pack-texture-vertices vertices 0
(texture-width texture)
(texture-height texture)
(texture-s1 texture)
(texture-t1 texture)
(texture-s2 texture)
(texture-t2 texture))
vertices))
(define* (make-label font text position #:optional #:key
(color white) (anchor 'top-left))
"Return a new label containing the string TEXT rendered with FONT at
the given position. Optional arguments are COLOR with a default of
white and ANCHOR with a default of 'top-left."
(let* ((texture (render-text font text))
(vertices (make-label-vertices texture))
(anchor (anchor-texture texture anchor)))
(%make-label font text position anchor color texture vertices)))
(define font-shader
(make-shader-program
(load-vertex-shader (string-append %pkgdatadir
"/shaders/font-vertex.glsl"))
(load-fragment-shader (string-append %pkgdatadir
"/shaders/font-fragment.glsl"))))
(define (draw-label label)
"Draw LABEL on the screen."
(with-shader-program font-shader
(uniforms ((projection (signal-ref window-projection))
(position (label-position label))
(anchor (label-anchor label))
(color (label-color label)))
(draw-texture-vertices (label-texture label) (label-vertices label) 1)))
*unspecified*)
|
