blob: ae8026395dcb62aa090899114afd86f99c3f5b34 (
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
|
;;; Sly
;;; 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 (sly font)
#:use-module (srfi srfi-2)
#: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 (sly wrappers gl)
#:use-module (sly color)
#:use-module (sly config)
#:use-module (sly mesh)
#:use-module (sly shader)
#:use-module (sly texture)
#:use-module (sly vector)
#:export (enable-fonts
load-font
load-default-font
font?
font-point-size
make-label))
;;;
;;; Font
;;;
(define (enable-fonts)
(SDL:ttf-init))
(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 Sly 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."
;; An empty string will result in a surface value of #f, in which we
;; want to abort the texture creation process.
(and-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 linear))
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-mag-filter)
(texture-mag-filter linear))
(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* (make-label font text #:optional #:key
(anchor 'top-left) (color white)
(shader (load-default-shader)))
(let ((texture (render-text font text)))
(let ((w (texture-width texture))
(h (texture-height texture))
(s1 (texture-s1 texture))
(t1 (texture-t1 texture))
(s2 (texture-s2 texture))
(t2 (texture-t2 texture)))
(make-mesh
#:shader shader
#:texture texture
#:indices #(0 3 2 0 2 1)
#:data `(("position" ,(vector
(vector 0 0 0)
(vector w 0 0)
(vector w h 0)
(vector 0 h 0)))
("tex" ,(vector
(vector s1 t1)
(vector s2 t1)
(vector s2 t2)
(vector s1 t2))))))))
|
