Fix build bug for real this time.
[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)
98dc87a0
DT
27 #:use-module ((sdl2 image) #:prefix sdl-image:)
28 #:use-module (sdl2 surface)
29 #:use-module (oop goops)
2f4eab3c 30 #:use-module (chickadee math rect)
98dc87a0
DT
31 #:use-module (chickadee render gl)
32 #:use-module (chickadee render gpu)
33 #:export (make-texture
34 load-image
35 texture?
36 texture-null?
37 texture-id
38 texture-parent
39 texture-width
40 texture-height
41 texture-min-filter
42 texture-mag-filter
43 texture-wrap-s
44 texture-wrap-t
45 null-texture
8152ddc9
DT
46 texture-set!
47 texture-ref
98dc87a0 48
c8457c8c
DT
49 make-texture-region
50 texture-region?
51 texture-region-texture
52 texture-region-x
53 texture-region-y
54 texture-region-width
55 texture-region-height
56
2f4eab3c
DT
57 texture-atlas
58 list->texture-atlas
59 split-texture
60 texture-atlas?
69d61338 61 texture-atlas-texture
2f4eab3c
DT
62 texture-atlas-ref))
63
64\f
98dc87a0
DT
65;;;
66;;; Textures
67;;;
68
69;; The <texture> object is a simple wrapper around an OpenGL texture
70;; id.
71(define-record-type <texture>
c7d382fd 72 (%make-texture id width height min-filter mag-filter wrap-s wrap-t gl-size)
98dc87a0
DT
73 texture?
74 (id texture-id)
75 (width texture-width)
76 (height texture-height)
77 (min-filter texture-min-filter)
78 (mag-filter texture-mag-filter)
79 (wrap-s texture-wrap-s)
c7d382fd
DT
80 (wrap-t texture-wrap-t)
81 (gl-size texture-gl-size))
98dc87a0
DT
82
83(set-record-type-printer! <texture>
84 (lambda (texture port)
85 (format port
86 "#<texture width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>"
87 (texture-width texture)
88 (texture-height texture)
89 (texture-min-filter texture)
90 (texture-mag-filter texture)
91 (texture-wrap-s texture)
92 (texture-wrap-t texture))))
93
c7d382fd
DT
94(define null-texture
95 (%make-texture 0 0 0 'linear 'linear 'repeat 'repeat (f32vector 0.0 0.0)))
98dc87a0
DT
96
97(define <<texture>> (class-of null-texture))
98
99(define (texture-null? texture)
100 "Return #t if TEXTURE is the null texture."
101 (eq? texture null-texture))
102
103(define (free-texture texture)
104 (gl-delete-texture (texture-id texture)))
105
106(define-method (gpu-finalize (texture <<texture>>))
107 (free-texture texture))
108
8152ddc9
DT
109(define (make-apply-texture n)
110 (let ((texture-unit (+ (version-1-3 texture0) n)))
111 (lambda (texture)
112 (set-gl-active-texture texture-unit)
113 (gl-bind-texture (texture-target texture-2d)
114 (texture-id texture)))))
98dc87a0 115
8152ddc9
DT
116(define *texture-states*
117 (let ((states (make-vector 32)))
118 (let loop ((i 0))
119 (if (< i 32)
120 (begin
121 (vector-set! states i (make-gpu-state (make-apply-texture i)
122 null-texture))
123 (loop (1+ i)))
124 states))))
125
126(define (texture-ref! n)
127 (gpu-state-ref (vector-ref *texture-states* n)))
128
129(define (texture-set! n texture)
130 (gpu-state-set! (vector-ref *texture-states* n) texture))
98dc87a0
DT
131
132(define* (make-texture pixels width height #:key
133 (min-filter 'linear)
134 (mag-filter 'linear)
135 (wrap-s 'repeat)
136 (wrap-t 'repeat)
137 (format 'rgba))
138 "Translate the bytevector PIXELS into an OpenGL texture with
139dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format.
140The generated texture uses MIN-FILTER for downscaling and MAG-FILTER
141for upscaling. WRAP-S and WRAP-T are symbols that control how texture
142access is handled for texture coordinates outside the [0, 1] range.
143Allowed symbols are: repeat (the default), clamp, clamp-to-border,
144clamp-to-edge. FORMAT specifies the pixel format. Currently only
14532-bit RGBA format is supported."
146 (define (gl-wrap mode)
147 (match mode
148 ('repeat (texture-wrap-mode repeat))
149 ('clamp (texture-wrap-mode clamp))
150 ('clamp-to-border (texture-wrap-mode clamp-to-border-sgis))
151 ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis))))
152
153 (let ((texture (gpu-guard
154 (%make-texture (gl-generate-texture) width height
c7d382fd
DT
155 min-filter mag-filter wrap-s wrap-t
156 (f32vector width height)))))
8152ddc9 157 (texture-set! 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
182(define (flip-pixels-vertically pixels width height)
183 "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
184HEIGHT, 32 bit color bytevector."
185 (let ((buffer (make-u8vector (bytevector-length pixels)))
186 (row-width (* width 4))) ; assuming 32 bit color
187 (let loop ((y 0))
188 (when (< y height)
189 (let* ((y* (- height y 1))
190 (source-start (* y row-width))
191 (target-start (* y* row-width)))
192 (bytevector-copy! pixels source-start buffer target-start row-width)
193 (loop (1+ y)))))
194 buffer))
195
196(define (surface->texture surface min-filter mag-filter wrap-s wrap-t)
197 "Convert SURFACE, an SDL2 surface object, into a texture that uses
198the given MIN-FILTER and MAG-FILTER."
199 ;; Convert to 32 bit RGBA color.
200 (call-with-surface (convert-surface-format surface 'abgr8888)
201 (lambda (surface)
202 (let* ((width (surface-width surface))
203 (height (surface-height surface))
204 ;; OpenGL textures use the bottom-left corner as the
205 ;; origin, whereas SDL uses the top-left, so the rows
206 ;; of pixels must be reversed before creating a
207 ;; texture from them.
208 (pixels (flip-pixels-vertically (surface-pixels surface)
209 width height)))
210 (make-texture pixels width height
211 #:min-filter min-filter
212 #:mag-filter mag-filter
213 #:wrap-s wrap-s
214 #:wrap-t wrap-t)))))
215
7015cd49 216(define* (load-image file #:key
98dc87a0
DT
217 (min-filter 'nearest)
218 (mag-filter 'nearest)
219 (wrap-s 'repeat)
220 (wrap-t 'repeat))
221 "Load a texture from an image in FILE. MIN-FILTER and MAG-FILTER
222describe the method that should be used for minification and
223magnification. Valid values are 'nearest and 'linear. By default,
224'nearest is used."
225 (call-with-surface (sdl-image:load-image file)
226 (lambda (surface)
227 (surface->texture surface min-filter mag-filter wrap-s wrap-t))))
2f4eab3c
DT
228
229\f
230;;;
c8457c8c
DT
231;;; Texture Regions
232;;;
233
234(define-record-type <texture-region>
235 (%make-texture-region texture x y width height gl-rect gl-size)
236 texture-region?
237 (texture texture-region-texture)
238 (x texture-region-x)
239 (y texture-region-y)
240 (width texture-region-width)
241 (height texture-region-height)
242 (gl-rect texture-region-gl-rect)
243 (gl-size texture-region-gl-size))
244
245(define (make-texture-region texture x y width height)
246 "Create a new texture region covering a section of TEXTURE defined
247by the bounding box X, Y, WIDTH, and HEIGHT. All coordinates are
248measured in pixels and must be integers."
249 (let* ((tw (texture-width texture))
250 (th (texture-height texture))
251 (gl-rect (make-rect (/ x tw) (/ y th)
252 (/ (+ x width) tw) (/ (+ y height) th))))
253 (%make-texture-region texture x y width height gl-rect
254 (f32vector width height))))
255
256\f
257;;;
2f4eab3c
DT
258;;; Texture Atlas
259;;;
260
261(define-record-type <texture-atlas>
262 (%make-texture-atlas texture vector)
263 texture-atlas?
264 (texture texture-atlas-texture)
265 (vector texture-atlas-vector))
266
267(define (list->texture-atlas texture rects)
268 "Return a new atlas for TEXTURE containing RECTS, a list of texture
269coordinate rects denoting the various tiles within."
270 (let ((v (make-vector (length rects))))
271 (let loop ((i 0)
272 (rects rects))
273 (match rects
274 (() (%make-texture-atlas texture v))
31b6f11b
DT
275 (((x y width height) . rest)
276 (vector-set! v i (make-texture-region texture x y width height))
2f4eab3c
DT
277 (loop (1+ i) rest))))))
278
279(define (texture-atlas texture . rects)
280 "Return a new atlas for TEXTURE containing RECTS, a series of
31b6f11b
DT
2814-tuples in the form (x y width height) describing the various tiles
282within."
2f4eab3c
DT
283 (list->texture-atlas texture rects))
284
285(define (texture-atlas-ref atlas index)
31b6f11b 286 "Return the texture region associated with INDEX in
2f4eab3c
DT
287ATLAS."
288 (vector-ref (texture-atlas-vector atlas) index))
289
290(define* (split-texture texture tile-width tile-height #:key
291 (margin 0) (spacing 0))
292 "Return a new texture atlas that splits TEXTURE into a grid of
293TILE-WIDTH by TILE-HEIGHT rectangles. Optionally, each tile may have
294SPACING pixels of horizontal and vertical space between surrounding
295tiles and the entire image may have MARGIN pixels of empty space
296around its border.
297
298This type of texture atlas layout is very common for tile map
299terrain."
300 (let* ((w (texture-width texture))
301 (h (texture-height texture))
302 (sw (/ tile-width w))
303 (th (/ tile-height h))
304 (rows (/ (- h margin) (+ tile-height spacing)))
305 (columns (/ (- w margin) (+ tile-width spacing)))
306 (v (make-vector (* rows columns))))
307 (define (make-tile tx ty)
308 (let* ((x (+ (* tx (+ tile-width spacing)) margin))
309 (y (+ (* ty (+ tile-height spacing)) margin)))
31b6f11b 310 (make-texture-region texture x y tile-width tile-height)))
2f4eab3c
DT
311 (let y-loop ((y 0))
312 (when (< y rows)
313 (let x-loop ((x 0))
314 (when (< x columns)
315 (vector-set! v (+ x (* y columns)) (make-tile x y))
316 (x-loop (1+ x))))
317 (y-loop (1+ y))))
318 (%make-texture-atlas texture v)))