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