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