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