render: texture: Add support for transparent color keys.
[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) #:prefix sdl2:)
28 #:use-module (oop goops)
29 #:use-module (chickadee math rect)
30 #:use-module (chickadee render color)
31 #:use-module (chickadee render gl)
32 #:use-module (chickadee render gpu)
33 #:export (make-texture
34 make-texture-region
35 load-image
36 texture?
37 texture-region?
38 texture-null?
39 texture-parent
40 texture-min-filter
41 texture-mag-filter
42 texture-wrap-s
43 texture-wrap-t
44 texture-x
45 texture-y
46 texture-width
47 texture-height
48 texture-gl-rect
49 texture-gl-tex-rect
50 null-texture
51
52 texture-atlas
53 list->texture-atlas
54 split-texture
55 texture-atlas?
56 texture-atlas-texture
57 texture-atlas-ref))
58
59 \f
60 ;;;
61 ;;; Textures
62 ;;;
63
64 ;; The <texture> object is a simple wrapper around an OpenGL texture
65 ;; id.
66 (define-record-type <texture>
67 (%make-texture id parent min-filter mag-filter wrap-s wrap-t
68 x y width height gl-rect gl-tex-rect)
69 texture?
70 (id texture-id)
71 (parent texture-parent)
72 (min-filter texture-min-filter)
73 (mag-filter texture-mag-filter)
74 (wrap-s texture-wrap-s)
75 (wrap-t texture-wrap-t)
76 (x texture-x)
77 (y texture-y)
78 (width texture-width)
79 (height texture-height)
80 (gl-rect texture-gl-rect)
81 (gl-tex-rect texture-gl-tex-rect))
82
83 (set-record-type-printer! <texture>
84 (lambda (texture port)
85 (format port
86 "#<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>"
87 (texture-id texture)
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 (apply-texture n texture)
118 (let ((texture-unit (+ (version-1-3 texture0) n)))
119 (set-gl-active-texture texture-unit)
120 (gl-bind-texture (texture-target texture-2d)
121 (texture-id texture))))
122
123 (define* (make-texture pixels width height #:key
124 flip?
125 (min-filter 'linear)
126 (mag-filter 'linear)
127 (wrap-s 'repeat)
128 (wrap-t 'repeat)
129 (format 'rgba))
130 "Translate the bytevector PIXELS into an OpenGL texture with
131 dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format.
132 The first pixe lin PIXELS corresponds to the upper-left corner of the
133 image. If this is not the case and the first pixel corresponds to the
134 lower-left corner of the image, set FLIP? to #t. The generated
135 texture uses MIN-FILTER for downscaling and MAG-FILTER for upscaling.
136 WRAP-S and WRAP-T are symbols that control how texture access is
137 handled for texture coordinates outside the [0, 1] range. Allowed
138 symbols are: repeat (the default), clamp, clamp-to-border,
139 clamp-to-edge. FORMAT specifies the pixel format. Currently only
140 32-bit RGBA format is supported."
141 (define (gl-wrap mode)
142 (match mode
143 ('repeat (texture-wrap-mode repeat))
144 ('clamp (texture-wrap-mode clamp))
145 ('clamp-to-border (texture-wrap-mode clamp-to-border-sgis))
146 ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis))))
147
148 (let ((texture (gpu-guard
149 (%make-texture (gl-generate-texture) #f
150 min-filter mag-filter wrap-s wrap-t
151 0 0 width height
152 (make-rect 0.0 0.0 width height)
153 (if flip?
154 (make-rect 0.0 1.0 1.0 -1.0)
155 (make-rect 0.0 0.0 1.0 1.0))))))
156 (set-gpu-texture! (current-gpu) 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 (make-texture-region texture rect)
182 "Create a new texture region covering a section of TEXTURE defined
183 by the bounding box RECT."
184 (let* ((pw (texture-width texture))
185 (ph (texture-height texture))
186 (x (rect-x rect))
187 (y (rect-y rect))
188 (w (rect-width rect))
189 (h (rect-height rect))
190 (vert-rect (make-rect 0.0 0.0 w h))
191 (tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph))))
192 (%make-texture (texture-id texture)
193 texture
194 (texture-min-filter texture)
195 (texture-mag-filter texture)
196 (texture-wrap-s texture)
197 (texture-wrap-t texture)
198 x y w h
199 vert-rect
200 tex-rect)))
201
202 (define (flip-pixels-vertically pixels width height)
203 "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
204 HEIGHT, 32 bit color bytevector."
205 (let ((buffer (make-u8vector (bytevector-length pixels)))
206 (row-width (* width 4))) ; assuming 32 bit color
207 (let loop ((y 0))
208 (when (< y height)
209 (let* ((y* (- height y 1))
210 (source-start (* y row-width))
211 (target-start (* y* row-width)))
212 (bytevector-copy! pixels source-start buffer target-start row-width)
213 (loop (1+ y)))))
214 buffer))
215
216 (define (surface->texture surface min-filter mag-filter wrap-s wrap-t transparent-color)
217 "Convert SURFACE, an SDL2 surface object, into a texture that uses
218 the given MIN-FILTER and MAG-FILTER."
219 ;; Convert to 32 bit RGBA color.
220 (sdl2:call-with-surface (sdl2:convert-surface-format surface 'abgr8888)
221 (lambda (surface)
222 (let* ((width (sdl2:surface-width surface))
223 (height (sdl2:surface-height surface))
224 (pixels (sdl2:surface-pixels surface)))
225 ;; Zero the alpha channel of pixels that match the transparent
226 ;; color key.
227 (when transparent-color
228 (let ((r (inexact->exact (* (color-r transparent-color) 255)))
229 (g (inexact->exact (* (color-g transparent-color) 255)))
230 (b (inexact->exact (* (color-b transparent-color) 255)))
231 (pixel-count (* width height 4)))
232 (let loop ((i 0))
233 (when (< i pixel-count)
234 (when (and (= r (bytevector-u8-ref pixels i))
235 (= g (bytevector-u8-ref pixels (+ i 1)))
236 (= b (bytevector-u8-ref pixels (+ i 2))))
237 (bytevector-u8-set! pixels i 255)
238 (bytevector-u8-set! pixels (+ i 1) 255)
239 (bytevector-u8-set! pixels (+ i 2) 255)
240 (bytevector-u8-set! pixels (+ i 3) 0))
241 (loop (+ i 4))))))
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 transparent-color)
254 "Load a texture from an image in FILE. MIN-FILTER and MAG-FILTER
255 describe the method that should be used for minification and
256 magnification. Valid values are 'nearest and 'linear. By default,
257 'nearest is used."
258 (sdl2:call-with-surface ((@ (sdl2 image) load-image) file)
259 (lambda (surface)
260 (surface->texture surface min-filter mag-filter wrap-s wrap-t
261 transparent-color))))
262
263 \f
264 ;;;
265 ;;; Texture Atlas
266 ;;;
267
268 (define-record-type <texture-atlas>
269 (%make-texture-atlas texture vector)
270 texture-atlas?
271 (texture texture-atlas-texture)
272 (vector texture-atlas-vector))
273
274 (define (display-texture-atlas atlas port)
275 (format port
276 "#<texture-atlas texture: ~a size: ~d>"
277 (texture-atlas-texture atlas)
278 (vector-length (texture-atlas-vector atlas))))
279
280 (set-record-type-printer! <texture-atlas> display-texture-atlas)
281
282 (define (list->texture-atlas texture rects)
283 "Return a new atlas for TEXTURE containing RECTS, a list of texture
284 coordinate rects denoting the various regions within."
285 (let ((v (make-vector (length rects))))
286 (let loop ((i 0)
287 (rects rects))
288 (match rects
289 (() (%make-texture-atlas texture v))
290 (((x y width height) . rest)
291 (vector-set! v i (make-texture-region texture (make-rect x y width height)))
292 (loop (1+ i) rest))))))
293
294 (define (texture-atlas texture . rects)
295 "Return a new atlas for TEXTURE containing RECTS, a series of
296 4-tuples in the form (x y width height) describing the various tiles
297 within."
298 (list->texture-atlas texture rects))
299
300 (define (texture-atlas-ref atlas index)
301 "Return the texture region associated with INDEX in
302 ATLAS."
303 (vector-ref (texture-atlas-vector atlas) index))
304
305 (define* (split-texture texture tile-width tile-height #:key
306 (margin 0) (spacing 0))
307 "Return a new texture atlas that splits TEXTURE into a grid of
308 TILE-WIDTH by TILE-HEIGHT rectangles. Optionally, each tile may have
309 SPACING pixels of horizontal and vertical space between surrounding
310 tiles and the entire image may have MARGIN pixels of empty space
311 around its border.
312
313 This type of texture atlas layout is very common for tile map
314 terrain."
315 (let* ((w (texture-width texture))
316 (h (texture-height texture))
317 (rows (inexact->exact (ceiling (/ (- h margin) (+ tile-height spacing)))))
318 (columns (inexact->exact (ceiling (/ (- w margin) (+ tile-width spacing)))))
319 (v (make-vector (* rows columns))))
320 (define (make-tile tx ty)
321 (let* ((x (+ (* tx (+ tile-width spacing)) margin))
322 (y (+ (* ty (+ tile-height spacing)) margin)))
323 (make-texture-region texture (make-rect x y tile-width tile-height))))
324 (let y-loop ((y 0))
325 (when (< y rows)
326 (let x-loop ((x 0))
327 (when (< x columns)
328 (vector-set! v (+ x (* y columns)) (make-tile x y))
329 (x-loop (1+ x))))
330 (y-loop (1+ y))))
331 (%make-texture-atlas texture v)))