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