render: texture: Add support for transparent color keys.
[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)
2dae3022 27 #:use-module ((sdl2 surface) #:prefix sdl2:)
98dc87a0 28 #:use-module (oop goops)
2f4eab3c 29 #:use-module (chickadee math rect)
2dae3022 30 #:use-module (chickadee render color)
98dc87a0
DT
31 #:use-module (chickadee render gl)
32 #:use-module (chickadee render gpu)
33 #:export (make-texture
fedd9bca 34 make-texture-region
98dc87a0
DT
35 load-image
36 texture?
fedd9bca 37 texture-region?
98dc87a0 38 texture-null?
98dc87a0 39 texture-parent
98dc87a0
DT
40 texture-min-filter
41 texture-mag-filter
42 texture-wrap-s
43 texture-wrap-t
5896bde4
DT
44 texture-x
45 texture-y
46 texture-width
47 texture-height
fedd9bca 48 texture-gl-rect
5896bde4 49 texture-gl-tex-rect
98dc87a0 50 null-texture
98dc87a0 51
2f4eab3c
DT
52 texture-atlas
53 list->texture-atlas
54 split-texture
55 texture-atlas?
69d61338 56 texture-atlas-texture
2f4eab3c
DT
57 texture-atlas-ref))
58
59\f
98dc87a0
DT
60;;;
61;;; Textures
62;;;
63
64;; The <texture> object is a simple wrapper around an OpenGL texture
65;; id.
66(define-record-type <texture>
5896bde4
DT
67 (%make-texture id parent min-filter mag-filter wrap-s wrap-t
68 x y width height gl-rect gl-tex-rect)
98dc87a0
DT
69 texture?
70 (id texture-id)
fedd9bca 71 (parent texture-parent)
98dc87a0
DT
72 (min-filter texture-min-filter)
73 (mag-filter texture-mag-filter)
74 (wrap-s texture-wrap-s)
c7d382fd 75 (wrap-t texture-wrap-t)
5896bde4
DT
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))
98dc87a0
DT
82
83(set-record-type-printer! <texture>
84 (lambda (texture port)
85 (format port
9b1c41dc
DT
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)
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
74961fae 117(define (apply-texture n texture)
8152ddc9 118 (let ((texture-unit (+ (version-1-3 texture0) n)))
74961fae
DT
119 (set-gl-active-texture texture-unit)
120 (gl-bind-texture (texture-target texture-2d)
121 (texture-id texture))))
98dc87a0
DT
122
123(define* (make-texture pixels width height #:key
372abd79 124 flip?
98dc87a0
DT
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
131dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format.
372abd79
DT
132The first pixe lin PIXELS corresponds to the upper-left corner of the
133image. If this is not the case and the first pixel corresponds to the
134lower-left corner of the image, set FLIP? to #t. The generated
135texture uses MIN-FILTER for downscaling and MAG-FILTER for upscaling.
136WRAP-S and WRAP-T are symbols that control how texture access is
137handled for texture coordinates outside the [0, 1] range. Allowed
138symbols are: repeat (the default), clamp, clamp-to-border,
98dc87a0
DT
139clamp-to-edge. FORMAT specifies the pixel format. Currently only
14032-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
fedd9bca 149 (%make-texture (gl-generate-texture) #f
c7d382fd 150 min-filter mag-filter wrap-s wrap-t
5896bde4 151 0 0 width height
fedd9bca 152 (make-rect 0.0 0.0 width height)
372abd79 153 (if flip?
b69cdffb 154 (make-rect 0.0 1.0 1.0 -1.0)
372abd79 155 (make-rect 0.0 0.0 1.0 1.0))))))
74961fae 156 (set-gpu-texture! (current-gpu) 0 texture)
98dc87a0
DT
157 (gl-texture-parameter (texture-target texture-2d)
158 (texture-parameter-name texture-min-filter)
159 (match min-filter
3879c714
DT
160 ('nearest 9728)
161 ('linear 9729)))
98dc87a0
DT
162 (gl-texture-parameter (texture-target texture-2d)
163 (texture-parameter-name texture-mag-filter)
164 (match mag-filter
3879c714
DT
165 ('nearest 9728)
166 ('linear 9729)))
98dc87a0
DT
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)
51d3c475 178 (or pixels %null-pointer))
98dc87a0
DT
179 texture))
180
fedd9bca
DT
181(define (make-texture-region texture rect)
182 "Create a new texture region covering a section of TEXTURE defined
183by the bounding box RECT."
5896bde4
DT
184 (let* ((pw (texture-width texture))
185 (ph (texture-height texture))
fedd9bca
DT
186 (x (rect-x rect))
187 (y (rect-y rect))
188 (w (rect-width rect))
189 (h (rect-height rect))
5896bde4
DT
190 (vert-rect (make-rect 0.0 0.0 w h))
191 (tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph))))
fedd9bca
DT
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)
5896bde4
DT
198 x y w h
199 vert-rect
200 tex-rect)))
fedd9bca 201
98dc87a0
DT
202(define (flip-pixels-vertically pixels width height)
203 "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
204HEIGHT, 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
2dae3022 216(define (surface->texture surface min-filter mag-filter wrap-s wrap-t transparent-color)
98dc87a0
DT
217 "Convert SURFACE, an SDL2 surface object, into a texture that uses
218the given MIN-FILTER and MAG-FILTER."
219 ;; Convert to 32 bit RGBA color.
2dae3022 220 (sdl2:call-with-surface (sdl2:convert-surface-format surface 'abgr8888)
98dc87a0 221 (lambda (surface)
2dae3022
DT
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))))))
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)
2dae3022
DT
252 (wrap-t 'repeat)
253 transparent-color)
98dc87a0
DT
254 "Load a texture from an image in FILE. MIN-FILTER and MAG-FILTER
255describe the method that should be used for minification and
256magnification. Valid values are 'nearest and 'linear. By default,
257'nearest is used."
2dae3022 258 (sdl2:call-with-surface ((@ (sdl2 image) load-image) file)
98dc87a0 259 (lambda (surface)
2dae3022
DT
260 (surface->texture surface min-filter mag-filter wrap-s wrap-t
261 transparent-color))))
2f4eab3c
DT
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
4649420f
DT
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
2f4eab3c
DT
282(define (list->texture-atlas texture rects)
283 "Return a new atlas for TEXTURE containing RECTS, a list of texture
6a236d69 284coordinate rects denoting the various regions within."
2f4eab3c
DT
285 (let ((v (make-vector (length rects))))
286 (let loop ((i 0)
287 (rects rects))
288 (match rects
289 (() (%make-texture-atlas texture v))
31b6f11b 290 (((x y width height) . rest)
fedd9bca 291 (vector-set! v i (make-texture-region texture (make-rect x y width height)))
2f4eab3c
DT
292 (loop (1+ i) rest))))))
293
294(define (texture-atlas texture . rects)
295 "Return a new atlas for TEXTURE containing RECTS, a series of
31b6f11b
DT
2964-tuples in the form (x y width height) describing the various tiles
297within."
2f4eab3c
DT
298 (list->texture-atlas texture rects))
299
300(define (texture-atlas-ref atlas index)
31b6f11b 301 "Return the texture region associated with INDEX in
2f4eab3c
DT
302ATLAS."
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
308TILE-WIDTH by TILE-HEIGHT rectangles. Optionally, each tile may have
309SPACING pixels of horizontal and vertical space between surrounding
310tiles and the entire image may have MARGIN pixels of empty space
311around its border.
312
313This type of texture atlas layout is very common for tile map
314terrain."
5896bde4
DT
315 (let* ((w (texture-width texture))
316 (h (texture-height texture))
0ac43945
DT
317 (rows (inexact->exact (ceiling (/ (- h margin) (+ tile-height spacing)))))
318 (columns (inexact->exact (ceiling (/ (- w margin) (+ tile-width spacing)))))
2f4eab3c
DT
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)))
fedd9bca 323 (make-texture-region texture (make-rect x y tile-width tile-height))))
2f4eab3c
DT
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)))