heap: Fix heap-remove!
[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
ecc4cc24 51 apply-texture
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
9b1c41dc
DT
87 "#<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>"
88 (texture-id texture)
fedd9bca 89 (texture-region? texture)
5896bde4
DT
90 (texture-x texture)
91 (texture-y texture)
92 (texture-width texture)
93 (texture-height texture)
98dc87a0
DT
94 (texture-min-filter texture)
95 (texture-mag-filter texture)
96 (texture-wrap-s texture)
97 (texture-wrap-t texture))))
98
c7d382fd 99(define null-texture
5896bde4 100 (%make-texture 0 #f 'linear 'linear 'repeat 'repeat 0 0 0 0
fedd9bca 101 (make-rect 0.0 0.0 0.0 0.0) (make-rect 0.0 0.0 0.0 0.0)))
98dc87a0
DT
102
103(define <<texture>> (class-of null-texture))
104
105(define (texture-null? texture)
106 "Return #t if TEXTURE is the null texture."
107 (eq? texture null-texture))
108
fedd9bca
DT
109(define (texture-region? texture)
110 (texture? (texture-parent texture)))
111
98dc87a0
DT
112(define (free-texture texture)
113 (gl-delete-texture (texture-id texture)))
114
115(define-method (gpu-finalize (texture <<texture>>))
116 (free-texture texture))
117
74961fae 118(define (apply-texture n texture)
8152ddc9 119 (let ((texture-unit (+ (version-1-3 texture0) n)))
74961fae
DT
120 (set-gl-active-texture texture-unit)
121 (gl-bind-texture (texture-target texture-2d)
122 (texture-id texture))))
98dc87a0
DT
123
124(define* (make-texture pixels width height #:key
372abd79 125 flip?
98dc87a0
DT
126 (min-filter 'linear)
127 (mag-filter 'linear)
128 (wrap-s 'repeat)
129 (wrap-t 'repeat)
130 (format 'rgba))
131 "Translate the bytevector PIXELS into an OpenGL texture with
132dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format.
372abd79
DT
133The first pixe lin PIXELS corresponds to the upper-left corner of the
134image. If this is not the case and the first pixel corresponds to the
135lower-left corner of the image, set FLIP? to #t. The generated
136texture uses MIN-FILTER for downscaling and MAG-FILTER for upscaling.
137WRAP-S and WRAP-T are symbols that control how texture access is
138handled for texture coordinates outside the [0, 1] range. Allowed
139symbols are: repeat (the default), clamp, clamp-to-border,
98dc87a0
DT
140clamp-to-edge. FORMAT specifies the pixel format. Currently only
14132-bit RGBA format is supported."
142 (define (gl-wrap mode)
143 (match mode
144 ('repeat (texture-wrap-mode repeat))
145 ('clamp (texture-wrap-mode clamp))
146 ('clamp-to-border (texture-wrap-mode clamp-to-border-sgis))
147 ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis))))
148
149 (let ((texture (gpu-guard
fedd9bca 150 (%make-texture (gl-generate-texture) #f
c7d382fd 151 min-filter mag-filter wrap-s wrap-t
5896bde4 152 0 0 width height
fedd9bca 153 (make-rect 0.0 0.0 width height)
372abd79 154 (if flip?
b69cdffb 155 (make-rect 0.0 1.0 1.0 -1.0)
372abd79 156 (make-rect 0.0 0.0 1.0 1.0))))))
74961fae 157 (set-gpu-texture! (current-gpu) 0 texture)
98dc87a0
DT
158 (gl-texture-parameter (texture-target texture-2d)
159 (texture-parameter-name texture-min-filter)
160 (match min-filter
3879c714
DT
161 ('nearest 9728)
162 ('linear 9729)))
98dc87a0
DT
163 (gl-texture-parameter (texture-target texture-2d)
164 (texture-parameter-name texture-mag-filter)
165 (match mag-filter
3879c714
DT
166 ('nearest 9728)
167 ('linear 9729)))
98dc87a0
DT
168 (gl-texture-parameter (texture-target texture-2d)
169 (texture-parameter-name texture-wrap-s)
170 (gl-wrap wrap-s))
171 (gl-texture-parameter (texture-target texture-2d)
172 (texture-parameter-name texture-wrap-t)
173 (gl-wrap wrap-t))
174 (gl-texture-image-2d (texture-target texture-2d)
175 0 (pixel-format rgba) width height 0
176 (match format
177 ('rgba (pixel-format rgba)))
178 (color-pointer-type unsigned-byte)
51d3c475 179 (or pixels %null-pointer))
98dc87a0
DT
180 texture))
181
fedd9bca
DT
182(define (make-texture-region texture rect)
183 "Create a new texture region covering a section of TEXTURE defined
184by the bounding box RECT."
5896bde4
DT
185 (let* ((pw (texture-width texture))
186 (ph (texture-height texture))
fedd9bca
DT
187 (x (rect-x rect))
188 (y (rect-y rect))
189 (w (rect-width rect))
190 (h (rect-height rect))
5896bde4
DT
191 (vert-rect (make-rect 0.0 0.0 w h))
192 (tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph))))
fedd9bca
DT
193 (%make-texture (texture-id texture)
194 texture
195 (texture-min-filter texture)
196 (texture-mag-filter texture)
197 (texture-wrap-s texture)
198 (texture-wrap-t texture)
5896bde4
DT
199 x y w h
200 vert-rect
201 tex-rect)))
fedd9bca 202
98dc87a0
DT
203(define (flip-pixels-vertically pixels width height)
204 "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
205HEIGHT, 32 bit color bytevector."
206 (let ((buffer (make-u8vector (bytevector-length pixels)))
207 (row-width (* width 4))) ; assuming 32 bit color
208 (let loop ((y 0))
209 (when (< y height)
210 (let* ((y* (- height y 1))
211 (source-start (* y row-width))
212 (target-start (* y* row-width)))
213 (bytevector-copy! pixels source-start buffer target-start row-width)
214 (loop (1+ y)))))
215 buffer))
216
2dae3022 217(define (surface->texture surface min-filter mag-filter wrap-s wrap-t transparent-color)
98dc87a0
DT
218 "Convert SURFACE, an SDL2 surface object, into a texture that uses
219the given MIN-FILTER and MAG-FILTER."
220 ;; Convert to 32 bit RGBA color.
2dae3022 221 (sdl2:call-with-surface (sdl2:convert-surface-format surface 'abgr8888)
98dc87a0 222 (lambda (surface)
2dae3022
DT
223 (let* ((width (sdl2:surface-width surface))
224 (height (sdl2:surface-height surface))
225 (pixels (sdl2:surface-pixels surface)))
226 ;; Zero the alpha channel of pixels that match the transparent
227 ;; color key.
228 (when transparent-color
229 (let ((r (inexact->exact (* (color-r transparent-color) 255)))
230 (g (inexact->exact (* (color-g transparent-color) 255)))
231 (b (inexact->exact (* (color-b transparent-color) 255)))
232 (pixel-count (* width height 4)))
233 (let loop ((i 0))
234 (when (< i pixel-count)
235 (when (and (= r (bytevector-u8-ref pixels i))
236 (= g (bytevector-u8-ref pixels (+ i 1)))
237 (= b (bytevector-u8-ref pixels (+ i 2))))
2dae3022
DT
238 (bytevector-u8-set! pixels (+ i 3) 0))
239 (loop (+ i 4))))))
98dc87a0
DT
240 (make-texture pixels width height
241 #:min-filter min-filter
242 #:mag-filter mag-filter
243 #:wrap-s wrap-s
244 #:wrap-t wrap-t)))))
245
7015cd49 246(define* (load-image file #:key
98dc87a0
DT
247 (min-filter 'nearest)
248 (mag-filter 'nearest)
249 (wrap-s 'repeat)
2dae3022
DT
250 (wrap-t 'repeat)
251 transparent-color)
98dc87a0
DT
252 "Load a texture from an image in FILE. MIN-FILTER and MAG-FILTER
253describe the method that should be used for minification and
254magnification. Valid values are 'nearest and 'linear. By default,
255'nearest is used."
2dae3022 256 (sdl2:call-with-surface ((@ (sdl2 image) load-image) file)
98dc87a0 257 (lambda (surface)
2dae3022
DT
258 (surface->texture surface min-filter mag-filter wrap-s wrap-t
259 transparent-color))))
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)))