texture: tileset: Fix rows/columns calculation.
[chickadee.git] / chickadee / render / texture.scm
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)
24 #:use-module (system foreign)
25 #:use-module (gl)
26 #:use-module (gl enums)
27 #:use-module (sdl2 surface)
28 #:use-module (oop goops)
29 #:use-module (chickadee math rect)
30 #:use-module (chickadee render gl)
31 #:use-module (chickadee render gpu)
32 #:export (make-texture
33 make-texture-region
34 load-image
35 texture?
36 texture-region?
37 texture-null?
38 texture-id
39 texture-parent
40 texture-min-filter
41 texture-mag-filter
42 texture-wrap-s
43 texture-wrap-t
44 texture-x
45 texture-y
46 texture-width
47 texture-height
48 texture-gl-rect
49 texture-gl-tex-rect
50 null-texture
51 texture-set!
52 texture-ref
53
54 texture-atlas
55 list->texture-atlas
56 split-texture
57 texture-atlas?
58 texture-atlas-texture
59 texture-atlas-ref))
60
61 \f
62 ;;;
63 ;;; Textures
64 ;;;
65
66 ;; The <texture> object is a simple wrapper around an OpenGL texture
67 ;; id.
68 (define-record-type <texture>
69 (%make-texture id parent min-filter mag-filter wrap-s wrap-t
70 x y width height gl-rect gl-tex-rect)
71 texture?
72 (id texture-id)
73 (parent texture-parent)
74 (min-filter texture-min-filter)
75 (mag-filter texture-mag-filter)
76 (wrap-s texture-wrap-s)
77 (wrap-t texture-wrap-t)
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))
84
85 (set-record-type-printer! <texture>
86 (lambda (texture port)
87 (format port
88 "#<texture region?: ~a x: ~d y: ~d width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>"
89 (texture-region? texture)
90 (texture-x texture)
91 (texture-y texture)
92 (texture-width texture)
93 (texture-height texture)
94 (texture-min-filter texture)
95 (texture-mag-filter texture)
96 (texture-wrap-s texture)
97 (texture-wrap-t texture))))
98
99 (define null-texture
100 (%make-texture 0 #f 'linear 'linear 'repeat 'repeat 0 0 0 0
101 (make-rect 0.0 0.0 0.0 0.0) (make-rect 0.0 0.0 0.0 0.0)))
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
109 (define (texture-region? texture)
110 (texture? (texture-parent texture)))
111
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
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)))))
124
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))
140
141 (define* (make-texture pixels width height #:key
142 flip?
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
149 dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format.
150 The first pixe lin PIXELS corresponds to the upper-left corner of the
151 image. If this is not the case and the first pixel corresponds to the
152 lower-left corner of the image, set FLIP? to #t. The generated
153 texture uses MIN-FILTER for downscaling and MAG-FILTER for upscaling.
154 WRAP-S and WRAP-T are symbols that control how texture access is
155 handled for texture coordinates outside the [0, 1] range. Allowed
156 symbols are: repeat (the default), clamp, clamp-to-border,
157 clamp-to-edge. FORMAT specifies the pixel format. Currently only
158 32-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
167 (%make-texture (gl-generate-texture) #f
168 min-filter mag-filter wrap-s wrap-t
169 0 0 width height
170 (make-rect 0.0 0.0 width height)
171 (if flip?
172 (make-rect 0.0 1.0 1.0 -1.0)
173 (make-rect 0.0 0.0 1.0 1.0))))))
174 (texture-set! 0 texture)
175 (gl-texture-parameter (texture-target texture-2d)
176 (texture-parameter-name texture-min-filter)
177 (match min-filter
178 ('nearest 9728)
179 ('linear 9729)))
180 (gl-texture-parameter (texture-target texture-2d)
181 (texture-parameter-name texture-mag-filter)
182 (match mag-filter
183 ('nearest 9728)
184 ('linear 9729)))
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)
196 (or pixels %null-pointer))
197 texture))
198
199 (define (make-texture-region texture rect)
200 "Create a new texture region covering a section of TEXTURE defined
201 by the bounding box RECT."
202 (let* ((pw (texture-width texture))
203 (ph (texture-height texture))
204 (x (rect-x rect))
205 (y (rect-y rect))
206 (w (rect-width rect))
207 (h (rect-height rect))
208 (vert-rect (make-rect 0.0 0.0 w h))
209 (tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph))))
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)
216 x y w h
217 vert-rect
218 tex-rect)))
219
220 (define (flip-pixels-vertically pixels width height)
221 "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
222 HEIGHT, 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
236 the 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))
242 (pixels (surface-pixels surface)))
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
249 (define* (load-image file #:key
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
255 describe the method that should be used for minification and
256 magnification. Valid values are 'nearest and 'linear. By default,
257 'nearest is used."
258 (call-with-surface ((@ (sdl2 image) load-image) file)
259 (lambda (surface)
260 (surface->texture surface min-filter mag-filter wrap-s wrap-t))))
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
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
281 (define (list->texture-atlas texture rects)
282 "Return a new atlas for TEXTURE containing RECTS, a list of texture
283 coordinate 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))
289 (((x y width height) . rest)
290 (vector-set! v i (make-texture-region texture (make-rect x y width height)))
291 (loop (1+ i) rest))))))
292
293 (define (texture-atlas texture . rects)
294 "Return a new atlas for TEXTURE containing RECTS, a series of
295 4-tuples in the form (x y width height) describing the various tiles
296 within."
297 (list->texture-atlas texture rects))
298
299 (define (texture-atlas-ref atlas index)
300 "Return the texture region associated with INDEX in
301 ATLAS."
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
307 TILE-WIDTH by TILE-HEIGHT rectangles. Optionally, each tile may have
308 SPACING pixels of horizontal and vertical space between surrounding
309 tiles and the entire image may have MARGIN pixels of empty space
310 around its border.
311
312 This type of texture atlas layout is very common for tile map
313 terrain."
314 (let* ((w (texture-width texture))
315 (h (texture-height texture))
316 (rows (inexact->exact (ceiling (/ (- h margin) (+ tile-height spacing)))))
317 (columns (inexact->exact (ceiling (/ (- w margin) (+ tile-width spacing)))))
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)))
322 (make-texture-region texture (make-rect x y tile-width tile-height))))
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)))