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