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