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