9a1421a7905ee626ff564e3698b3f6d96b35a0fd
[chickadee.git] / chickadee / render / texture.scm
1 ;;; Chickadee Game Toolkit
2 ;;; Copyright © 2016 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 (define-module (chickadee render texture)
19 #:use-module (ice-9 format)
20 #:use-module (ice-9 match)
21 #:use-module (rnrs bytevectors)
22 #:use-module (srfi srfi-9)
23 #:use-module (srfi srfi-9 gnu)
24 #:use-module (system foreign)
25 #:use-module (gl)
26 #:use-module ((gl enums)
27 #:select (texture-min-filter texture-mag-filter)
28 #:prefix gl:)
29 #:use-module ((sdl2 image) #:prefix sdl-image:)
30 #:use-module (sdl2 surface)
31 #:use-module (oop goops)
32 #:use-module (chickadee math rect)
33 #:use-module (chickadee render gl)
34 #:use-module (chickadee render gpu)
35 #:export (make-texture
36 load-image
37 texture?
38 texture-null?
39 texture-id
40 texture-parent
41 texture-width
42 texture-height
43 texture-min-filter
44 texture-mag-filter
45 texture-wrap-s
46 texture-wrap-t
47 null-texture
48 texture-set!
49 texture-ref
50
51 make-texture-region
52 texture-region?
53 texture-region-texture
54 texture-region-x
55 texture-region-y
56 texture-region-width
57 texture-region-height
58
59 texture-atlas
60 list->texture-atlas
61 split-texture
62 texture-atlas?
63 texture-atlas-texture
64 texture-atlas-ref))
65
66 \f
67 ;;;
68 ;;; Textures
69 ;;;
70
71 ;; The <texture> object is a simple wrapper around an OpenGL texture
72 ;; id.
73 (define-record-type <texture>
74 (%make-texture id width height min-filter mag-filter wrap-s wrap-t gl-size)
75 texture?
76 (id texture-id)
77 (width texture-width)
78 (height texture-height)
79 (min-filter texture-min-filter)
80 (mag-filter texture-mag-filter)
81 (wrap-s texture-wrap-s)
82 (wrap-t texture-wrap-t)
83 (gl-size texture-gl-size))
84
85 (set-record-type-printer! <texture>
86 (lambda (texture port)
87 (format port
88 "#<texture width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>"
89 (texture-width texture)
90 (texture-height texture)
91 (texture-min-filter texture)
92 (texture-mag-filter texture)
93 (texture-wrap-s texture)
94 (texture-wrap-t texture))))
95
96 (define null-texture
97 (%make-texture 0 0 0 'linear 'linear 'repeat 'repeat (f32vector 0.0 0.0)))
98
99 (define <<texture>> (class-of null-texture))
100
101 (define (texture-null? texture)
102 "Return #t if TEXTURE is the null texture."
103 (eq? texture null-texture))
104
105 (define (free-texture texture)
106 (gl-delete-texture (texture-id texture)))
107
108 (define-method (gpu-finalize (texture <<texture>>))
109 (free-texture texture))
110
111 (define (make-apply-texture n)
112 (let ((texture-unit (+ (version-1-3 texture0) n)))
113 (lambda (texture)
114 (set-gl-active-texture texture-unit)
115 (gl-bind-texture (texture-target texture-2d)
116 (texture-id texture)))))
117
118 (define *texture-states*
119 (let ((states (make-vector 32)))
120 (let loop ((i 0))
121 (if (< i 32)
122 (begin
123 (vector-set! states i (make-gpu-state (make-apply-texture i)
124 null-texture))
125 (loop (1+ i)))
126 states))))
127
128 (define (texture-ref! n)
129 (gpu-state-ref (vector-ref *texture-states* n)))
130
131 (define (texture-set! n texture)
132 (gpu-state-set! (vector-ref *texture-states* n) texture))
133
134 (define* (make-texture pixels width height #:key
135 (min-filter 'linear)
136 (mag-filter 'linear)
137 (wrap-s 'repeat)
138 (wrap-t 'repeat)
139 (format 'rgba))
140 "Translate the bytevector PIXELS into an OpenGL texture with
141 dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format.
142 The generated texture uses MIN-FILTER for downscaling and MAG-FILTER
143 for upscaling. WRAP-S and WRAP-T are symbols that control how texture
144 access is handled for texture coordinates outside the [0, 1] range.
145 Allowed symbols are: repeat (the default), clamp, clamp-to-border,
146 clamp-to-edge. FORMAT specifies the pixel format. Currently only
147 32-bit RGBA format is supported."
148 (define (gl-wrap mode)
149 (match mode
150 ('repeat (texture-wrap-mode repeat))
151 ('clamp (texture-wrap-mode clamp))
152 ('clamp-to-border (texture-wrap-mode clamp-to-border-sgis))
153 ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis))))
154
155 (let ((texture (gpu-guard
156 (%make-texture (gl-generate-texture) width height
157 min-filter mag-filter wrap-s wrap-t
158 (f32vector width height)))))
159 (texture-set! 0 texture)
160 (gl-texture-parameter (texture-target texture-2d)
161 (texture-parameter-name texture-min-filter)
162 (match min-filter
163 ('nearest (gl:texture-min-filter nearest))
164 ('linear (gl:texture-min-filter linear))))
165 (gl-texture-parameter (texture-target texture-2d)
166 (texture-parameter-name texture-mag-filter)
167 (match mag-filter
168 ('nearest (gl:texture-mag-filter nearest))
169 ('linear (gl:texture-mag-filter linear))))
170 (gl-texture-parameter (texture-target texture-2d)
171 (texture-parameter-name texture-wrap-s)
172 (gl-wrap wrap-s))
173 (gl-texture-parameter (texture-target texture-2d)
174 (texture-parameter-name texture-wrap-t)
175 (gl-wrap wrap-t))
176 (gl-texture-image-2d (texture-target texture-2d)
177 0 (pixel-format rgba) width height 0
178 (match format
179 ('rgba (pixel-format rgba)))
180 (color-pointer-type unsigned-byte)
181 (or pixels %null-pointer))
182 texture))
183
184 (define (flip-pixels-vertically pixels width height)
185 "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
186 HEIGHT, 32 bit color bytevector."
187 (let ((buffer (make-u8vector (bytevector-length pixels)))
188 (row-width (* width 4))) ; assuming 32 bit color
189 (let loop ((y 0))
190 (when (< y height)
191 (let* ((y* (- height y 1))
192 (source-start (* y row-width))
193 (target-start (* y* row-width)))
194 (bytevector-copy! pixels source-start buffer target-start row-width)
195 (loop (1+ y)))))
196 buffer))
197
198 (define (surface->texture surface min-filter mag-filter wrap-s wrap-t)
199 "Convert SURFACE, an SDL2 surface object, into a texture that uses
200 the given MIN-FILTER and MAG-FILTER."
201 ;; Convert to 32 bit RGBA color.
202 (call-with-surface (convert-surface-format surface 'abgr8888)
203 (lambda (surface)
204 (let* ((width (surface-width surface))
205 (height (surface-height surface))
206 ;; OpenGL textures use the bottom-left corner as the
207 ;; origin, whereas SDL uses the top-left, so the rows
208 ;; of pixels must be reversed before creating a
209 ;; texture from them.
210 (pixels (flip-pixels-vertically (surface-pixels surface)
211 width height)))
212 (make-texture pixels width height
213 #:min-filter min-filter
214 #:mag-filter mag-filter
215 #:wrap-s wrap-s
216 #:wrap-t wrap-t)))))
217
218 (define* (load-image file #:key
219 (min-filter 'nearest)
220 (mag-filter 'nearest)
221 (wrap-s 'repeat)
222 (wrap-t 'repeat))
223 "Load a texture from an image in FILE. MIN-FILTER and MAG-FILTER
224 describe the method that should be used for minification and
225 magnification. Valid values are 'nearest and 'linear. By default,
226 'nearest is used."
227 (call-with-surface (sdl-image:load-image file)
228 (lambda (surface)
229 (surface->texture surface min-filter mag-filter wrap-s wrap-t))))
230
231 \f
232 ;;;
233 ;;; Texture Regions
234 ;;;
235
236 (define-record-type <texture-region>
237 (%make-texture-region texture x y width height gl-rect gl-size)
238 texture-region?
239 (texture texture-region-texture)
240 (x texture-region-x)
241 (y texture-region-y)
242 (width texture-region-width)
243 (height texture-region-height)
244 (gl-rect texture-region-gl-rect)
245 (gl-size texture-region-gl-size))
246
247 (define (make-texture-region texture x y width height)
248 "Create a new texture region covering a section of TEXTURE defined
249 by the bounding box X, Y, WIDTH, and HEIGHT. All coordinates are
250 measured in pixels and must be integers."
251 (let* ((tw (texture-width texture))
252 (th (texture-height texture))
253 (gl-rect (make-rect (/ x tw) (/ y th)
254 (/ (+ x width) tw) (/ (+ y height) th))))
255 (%make-texture-region texture x y width height gl-rect
256 (f32vector width height))))
257
258 \f
259 ;;;
260 ;;; Texture Atlas
261 ;;;
262
263 (define-record-type <texture-atlas>
264 (%make-texture-atlas texture vector)
265 texture-atlas?
266 (texture texture-atlas-texture)
267 (vector texture-atlas-vector))
268
269 (define (list->texture-atlas texture rects)
270 "Return a new atlas for TEXTURE containing RECTS, a list of texture
271 coordinate rects denoting the various tiles within."
272 (let ((v (make-vector (length rects))))
273 (let loop ((i 0)
274 (rects rects))
275 (match rects
276 (() (%make-texture-atlas texture v))
277 (((x y width height) . rest)
278 (vector-set! v i (make-texture-region texture x y width height))
279 (loop (1+ i) rest))))))
280
281 (define (texture-atlas texture . rects)
282 "Return a new atlas for TEXTURE containing RECTS, a series of
283 4-tuples in the form (x y width height) describing the various tiles
284 within."
285 (list->texture-atlas texture rects))
286
287 (define (texture-atlas-ref atlas index)
288 "Return the texture region associated with INDEX in
289 ATLAS."
290 (vector-ref (texture-atlas-vector atlas) index))
291
292 (define* (split-texture texture tile-width tile-height #:key
293 (margin 0) (spacing 0))
294 "Return a new texture atlas that splits TEXTURE into a grid of
295 TILE-WIDTH by TILE-HEIGHT rectangles. Optionally, each tile may have
296 SPACING pixels of horizontal and vertical space between surrounding
297 tiles and the entire image may have MARGIN pixels of empty space
298 around its border.
299
300 This type of texture atlas layout is very common for tile map
301 terrain."
302 (let* ((w (texture-width texture))
303 (h (texture-height texture))
304 (sw (/ tile-width w))
305 (th (/ tile-height h))
306 (rows (/ (- h margin) (+ tile-height spacing)))
307 (columns (/ (- w margin) (+ tile-width spacing)))
308 (v (make-vector (* rows columns))))
309 (define (make-tile tx ty)
310 (let* ((x (+ (* tx (+ tile-width spacing)) margin))
311 (y (+ (* ty (+ tile-height spacing)) margin)))
312 (make-texture-region texture x y tile-width tile-height)))
313 (let y-loop ((y 0))
314 (when (< y rows)
315 (let x-loop ((x 0))
316 (when (< x columns)
317 (vector-set! v (+ x (* y columns)) (make-tile x y))
318 (x-loop (1+ x))))
319 (y-loop (1+ y))))
320 (%make-texture-atlas texture v)))