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