Remove obsolete controller handling code.
[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 surface)
28 #:use-module (oop goops)
2f4eab3c 29 #:use-module (chickadee math rect)
98dc87a0
DT
30 #:use-module (chickadee render gl)
31 #:use-module (chickadee render gpu)
32 #:export (make-texture
fedd9bca 33 make-texture-region
98dc87a0
DT
34 load-image
35 texture?
fedd9bca 36 texture-region?
98dc87a0
DT
37 texture-null?
38 texture-id
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
8152ddc9
DT
51 texture-set!
52 texture-ref
98dc87a0 53
2f4eab3c
DT
54 texture-atlas
55 list->texture-atlas
56 split-texture
57 texture-atlas?
69d61338 58 texture-atlas-texture
2f4eab3c
DT
59 texture-atlas-ref))
60
61\f
98dc87a0
DT
62;;;
63;;; Textures
64;;;
65
66;; The <texture> object is a simple wrapper around an OpenGL texture
67;; id.
68(define-record-type <texture>
5896bde4
DT
69 (%make-texture id parent min-filter mag-filter wrap-s wrap-t
70 x y width height gl-rect gl-tex-rect)
98dc87a0
DT
71 texture?
72 (id texture-id)
fedd9bca 73 (parent texture-parent)
98dc87a0
DT
74 (min-filter texture-min-filter)
75 (mag-filter texture-mag-filter)
76 (wrap-s texture-wrap-s)
c7d382fd 77 (wrap-t texture-wrap-t)
5896bde4
DT
78 (x texture-x)
79 (y texture-y)
80 (width texture-width)
81 (height texture-height)
82 (gl-rect texture-gl-rect)
83 (gl-tex-rect texture-gl-tex-rect))
98dc87a0
DT
84
85(set-record-type-printer! <texture>
86 (lambda (texture port)
87 (format port
5896bde4 88 "#<texture region?: ~a x: ~d y: ~d width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>"
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
8152ddc9
DT
118(define (make-apply-texture n)
119 (let ((texture-unit (+ (version-1-3 texture0) n)))
120 (lambda (texture)
121 (set-gl-active-texture texture-unit)
122 (gl-bind-texture (texture-target texture-2d)
123 (texture-id texture)))))
98dc87a0 124
8152ddc9
DT
125(define *texture-states*
126 (let ((states (make-vector 32)))
127 (let loop ((i 0))
128 (if (< i 32)
129 (begin
130 (vector-set! states i (make-gpu-state (make-apply-texture i)
131 null-texture))
132 (loop (1+ i)))
133 states))))
134
135(define (texture-ref! n)
136 (gpu-state-ref (vector-ref *texture-states* n)))
137
138(define (texture-set! n texture)
139 (gpu-state-set! (vector-ref *texture-states* n) texture))
98dc87a0
DT
140
141(define* (make-texture pixels width height #:key
372abd79 142 flip?
98dc87a0
DT
143 (min-filter 'linear)
144 (mag-filter 'linear)
145 (wrap-s 'repeat)
146 (wrap-t 'repeat)
147 (format 'rgba))
148 "Translate the bytevector PIXELS into an OpenGL texture with
149dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format.
372abd79
DT
150The first pixe lin PIXELS corresponds to the upper-left corner of the
151image. If this is not the case and the first pixel corresponds to the
152lower-left corner of the image, set FLIP? to #t. The generated
153texture uses MIN-FILTER for downscaling and MAG-FILTER for upscaling.
154WRAP-S and WRAP-T are symbols that control how texture access is
155handled for texture coordinates outside the [0, 1] range. Allowed
156symbols are: repeat (the default), clamp, clamp-to-border,
98dc87a0
DT
157clamp-to-edge. FORMAT specifies the pixel format. Currently only
15832-bit RGBA format is supported."
159 (define (gl-wrap mode)
160 (match mode
161 ('repeat (texture-wrap-mode repeat))
162 ('clamp (texture-wrap-mode clamp))
163 ('clamp-to-border (texture-wrap-mode clamp-to-border-sgis))
164 ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis))))
165
166 (let ((texture (gpu-guard
fedd9bca 167 (%make-texture (gl-generate-texture) #f
c7d382fd 168 min-filter mag-filter wrap-s wrap-t
5896bde4 169 0 0 width height
fedd9bca 170 (make-rect 0.0 0.0 width height)
372abd79 171 (if flip?
b69cdffb 172 (make-rect 0.0 1.0 1.0 -1.0)
372abd79 173 (make-rect 0.0 0.0 1.0 1.0))))))
8152ddc9 174 (texture-set! 0 texture)
98dc87a0
DT
175 (gl-texture-parameter (texture-target texture-2d)
176 (texture-parameter-name texture-min-filter)
177 (match min-filter
3879c714
DT
178 ('nearest 9728)
179 ('linear 9729)))
98dc87a0
DT
180 (gl-texture-parameter (texture-target texture-2d)
181 (texture-parameter-name texture-mag-filter)
182 (match mag-filter
3879c714
DT
183 ('nearest 9728)
184 ('linear 9729)))
98dc87a0
DT
185 (gl-texture-parameter (texture-target texture-2d)
186 (texture-parameter-name texture-wrap-s)
187 (gl-wrap wrap-s))
188 (gl-texture-parameter (texture-target texture-2d)
189 (texture-parameter-name texture-wrap-t)
190 (gl-wrap wrap-t))
191 (gl-texture-image-2d (texture-target texture-2d)
192 0 (pixel-format rgba) width height 0
193 (match format
194 ('rgba (pixel-format rgba)))
195 (color-pointer-type unsigned-byte)
51d3c475 196 (or pixels %null-pointer))
98dc87a0
DT
197 texture))
198
fedd9bca
DT
199(define (make-texture-region texture rect)
200 "Create a new texture region covering a section of TEXTURE defined
201by the bounding box RECT."
5896bde4
DT
202 (let* ((pw (texture-width texture))
203 (ph (texture-height texture))
fedd9bca
DT
204 (x (rect-x rect))
205 (y (rect-y rect))
206 (w (rect-width rect))
207 (h (rect-height rect))
5896bde4
DT
208 (vert-rect (make-rect 0.0 0.0 w h))
209 (tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph))))
fedd9bca
DT
210 (%make-texture (texture-id texture)
211 texture
212 (texture-min-filter texture)
213 (texture-mag-filter texture)
214 (texture-wrap-s texture)
215 (texture-wrap-t texture)
5896bde4
DT
216 x y w h
217 vert-rect
218 tex-rect)))
fedd9bca 219
98dc87a0
DT
220(define (flip-pixels-vertically pixels width height)
221 "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
222HEIGHT, 32 bit color bytevector."
223 (let ((buffer (make-u8vector (bytevector-length pixels)))
224 (row-width (* width 4))) ; assuming 32 bit color
225 (let loop ((y 0))
226 (when (< y height)
227 (let* ((y* (- height y 1))
228 (source-start (* y row-width))
229 (target-start (* y* row-width)))
230 (bytevector-copy! pixels source-start buffer target-start row-width)
231 (loop (1+ y)))))
232 buffer))
233
234(define (surface->texture surface min-filter mag-filter wrap-s wrap-t)
235 "Convert SURFACE, an SDL2 surface object, into a texture that uses
236the given MIN-FILTER and MAG-FILTER."
237 ;; Convert to 32 bit RGBA color.
238 (call-with-surface (convert-surface-format surface 'abgr8888)
239 (lambda (surface)
240 (let* ((width (surface-width surface))
241 (height (surface-height surface))
cbf59a78 242 (pixels (surface-pixels surface)))
98dc87a0
DT
243 (make-texture pixels width height
244 #:min-filter min-filter
245 #:mag-filter mag-filter
246 #:wrap-s wrap-s
247 #:wrap-t wrap-t)))))
248
7015cd49 249(define* (load-image file #:key
98dc87a0
DT
250 (min-filter 'nearest)
251 (mag-filter 'nearest)
252 (wrap-s 'repeat)
253 (wrap-t 'repeat))
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."
5a07e08c 258 (call-with-surface ((@ (sdl2 image) load-image) file)
98dc87a0
DT
259 (lambda (surface)
260 (surface->texture surface min-filter mag-filter wrap-s wrap-t))))
2f4eab3c
DT
261
262\f
263;;;
264;;; Texture Atlas
265;;;
266
267(define-record-type <texture-atlas>
268 (%make-texture-atlas texture vector)
269 texture-atlas?
270 (texture texture-atlas-texture)
271 (vector texture-atlas-vector))
272
4649420f
DT
273(define (display-texture-atlas atlas port)
274 (format port
275 "#<texture-atlas texture: ~a size: ~d>"
276 (texture-atlas-texture atlas)
277 (vector-length (texture-atlas-vector atlas))))
278
279(set-record-type-printer! <texture-atlas> display-texture-atlas)
280
2f4eab3c
DT
281(define (list->texture-atlas texture rects)
282 "Return a new atlas for TEXTURE containing RECTS, a list of texture
283coordinate rects denoting the various tiles within."
284 (let ((v (make-vector (length rects))))
285 (let loop ((i 0)
286 (rects rects))
287 (match rects
288 (() (%make-texture-atlas texture v))
31b6f11b 289 (((x y width height) . rest)
fedd9bca 290 (vector-set! v i (make-texture-region texture (make-rect x y width height)))
2f4eab3c
DT
291 (loop (1+ i) rest))))))
292
293(define (texture-atlas texture . rects)
294 "Return a new atlas for TEXTURE containing RECTS, a series of
31b6f11b
DT
2954-tuples in the form (x y width height) describing the various tiles
296within."
2f4eab3c
DT
297 (list->texture-atlas texture rects))
298
299(define (texture-atlas-ref atlas index)
31b6f11b 300 "Return the texture region associated with INDEX in
2f4eab3c
DT
301ATLAS."
302 (vector-ref (texture-atlas-vector atlas) index))
303
304(define* (split-texture texture tile-width tile-height #:key
305 (margin 0) (spacing 0))
306 "Return a new texture atlas that splits TEXTURE into a grid of
307TILE-WIDTH by TILE-HEIGHT rectangles. Optionally, each tile may have
308SPACING pixels of horizontal and vertical space between surrounding
309tiles and the entire image may have MARGIN pixels of empty space
310around its border.
311
312This type of texture atlas layout is very common for tile map
313terrain."
5896bde4
DT
314 (let* ((w (texture-width texture))
315 (h (texture-height texture))
b7580bbf
DT
316 (rows (inexact->exact (floor (/ (- h margin) (+ tile-height spacing)))))
317 (columns (inexact->exact (floor (/ (- w margin) (+ tile-width spacing)))))
2f4eab3c
DT
318 (v (make-vector (* rows columns))))
319 (define (make-tile tx ty)
320 (let* ((x (+ (* tx (+ tile-width spacing)) margin))
321 (y (+ (* ty (+ tile-height spacing)) margin)))
fedd9bca 322 (make-texture-region texture (make-rect x y tile-width tile-height))))
2f4eab3c
DT
323 (let y-loop ((y 0))
324 (when (< y rows)
325 (let x-loop ((x 0))
326 (when (< x columns)
327 (vector-set! v (+ x (* y columns)) (make-tile x y))
328 (x-loop (1+ x))))
329 (y-loop (1+ y))))
330 (%make-texture-atlas texture v)))