doc: Improve texture documentation.
[chickadee.git] / chickadee / render / texture.scm
... / ...
CommitLineData
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 make-texture-region
34 load-image
35 texture?
36 texture-region?
37 texture-null?
38 texture-parent
39 texture-min-filter
40 texture-mag-filter
41 texture-wrap-s
42 texture-wrap-t
43 texture-x
44 texture-y
45 texture-width
46 texture-height
47 texture-gl-rect
48 texture-gl-tex-rect
49 null-texture
50 texture-set!
51 texture-ref
52
53 texture-atlas
54 list->texture-atlas
55 split-texture
56 texture-atlas?
57 texture-atlas-texture
58 texture-atlas-ref))
59
60\f
61;;;
62;;; Textures
63;;;
64
65;; The <texture> object is a simple wrapper around an OpenGL texture
66;; id.
67(define-record-type <texture>
68 (%make-texture id parent min-filter mag-filter wrap-s wrap-t
69 x y width height gl-rect gl-tex-rect)
70 texture?
71 (id texture-id)
72 (parent texture-parent)
73 (min-filter texture-min-filter)
74 (mag-filter texture-mag-filter)
75 (wrap-s texture-wrap-s)
76 (wrap-t texture-wrap-t)
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))
83
84(set-record-type-printer! <texture>
85 (lambda (texture port)
86 (format port
87 "#<texture region?: ~a x: ~d y: ~d width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>"
88 (texture-region? texture)
89 (texture-x texture)
90 (texture-y texture)
91 (texture-width texture)
92 (texture-height texture)
93 (texture-min-filter texture)
94 (texture-mag-filter texture)
95 (texture-wrap-s texture)
96 (texture-wrap-t texture))))
97
98(define null-texture
99 (%make-texture 0 #f 'linear 'linear 'repeat 'repeat 0 0 0 0
100 (make-rect 0.0 0.0 0.0 0.0) (make-rect 0.0 0.0 0.0 0.0)))
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
108(define (texture-region? texture)
109 (texture? (texture-parent texture)))
110
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
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)))))
123
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))
139
140(define* (make-texture pixels width height #:key
141 flip?
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.
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,
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
166 (%make-texture (gl-generate-texture) #f
167 min-filter mag-filter wrap-s wrap-t
168 0 0 width height
169 (make-rect 0.0 0.0 width height)
170 (if flip?
171 (make-rect 0.0 1.0 1.0 -1.0)
172 (make-rect 0.0 0.0 1.0 1.0))))))
173 (texture-set! 0 texture)
174 (gl-texture-parameter (texture-target texture-2d)
175 (texture-parameter-name texture-min-filter)
176 (match min-filter
177 ('nearest 9728)
178 ('linear 9729)))
179 (gl-texture-parameter (texture-target texture-2d)
180 (texture-parameter-name texture-mag-filter)
181 (match mag-filter
182 ('nearest 9728)
183 ('linear 9729)))
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)
195 (or pixels %null-pointer))
196 texture))
197
198(define (make-texture-region texture rect)
199 "Create a new texture region covering a section of TEXTURE defined
200by the bounding box RECT."
201 (let* ((pw (texture-width texture))
202 (ph (texture-height texture))
203 (x (rect-x rect))
204 (y (rect-y rect))
205 (w (rect-width rect))
206 (h (rect-height rect))
207 (vert-rect (make-rect 0.0 0.0 w h))
208 (tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph))))
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)
215 x y w h
216 vert-rect
217 tex-rect)))
218
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))
241 (pixels (surface-pixels surface)))
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
248(define* (load-image file #:key
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."
257 (call-with-surface ((@ (sdl2 image) load-image) file)
258 (lambda (surface)
259 (surface->texture surface min-filter mag-filter wrap-s wrap-t))))
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
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
280(define (list->texture-atlas texture rects)
281 "Return a new atlas for TEXTURE containing RECTS, a list of texture
282coordinate rects denoting the various regions within."
283 (let ((v (make-vector (length rects))))
284 (let loop ((i 0)
285 (rects rects))
286 (match rects
287 (() (%make-texture-atlas texture v))
288 (((x y width height) . rest)
289 (vector-set! v i (make-texture-region texture (make-rect x y width height)))
290 (loop (1+ i) rest))))))
291
292(define (texture-atlas texture . rects)
293 "Return a new atlas for TEXTURE containing RECTS, a series of
2944-tuples in the form (x y width height) describing the various tiles
295within."
296 (list->texture-atlas texture rects))
297
298(define (texture-atlas-ref atlas index)
299 "Return the texture region associated with INDEX in
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."
313 (let* ((w (texture-width texture))
314 (h (texture-height texture))
315 (rows (inexact->exact (ceiling (/ (- h margin) (+ tile-height spacing)))))
316 (columns (inexact->exact (ceiling (/ (- w margin) (+ tile-width spacing)))))
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)))
321 (make-texture-region texture (make-rect x y tile-width tile-height))))
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)))