First commit!
[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)
31 #:use-module (chickadee render gl)
32 #:use-module (chickadee render gpu)
33 #:export (make-texture
34 load-image
35 texture?
36 texture-null?
37 texture-id
38 texture-parent
39 texture-width
40 texture-height
41 texture-min-filter
42 texture-mag-filter
43 texture-wrap-s
44 texture-wrap-t
45 null-texture
46 *texture-state*))
47
48;;;
49;;; Textures
50;;;
51
52;; The <texture> object is a simple wrapper around an OpenGL texture
53;; id.
54(define-record-type <texture>
55 (%make-texture id width height min-filter mag-filter wrap-s wrap-t)
56 texture?
57 (id texture-id)
58 (width texture-width)
59 (height texture-height)
60 (min-filter texture-min-filter)
61 (mag-filter texture-mag-filter)
62 (wrap-s texture-wrap-s)
63 (wrap-t texture-wrap-t))
64
65(set-record-type-printer! <texture>
66 (lambda (texture port)
67 (format port
68 "#<texture width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>"
69 (texture-width texture)
70 (texture-height texture)
71 (texture-min-filter texture)
72 (texture-mag-filter texture)
73 (texture-wrap-s texture)
74 (texture-wrap-t texture))))
75
76(define null-texture (%make-texture 0 0 0 'linear 'linear 'repeat 'repeat))
77
78(define <<texture>> (class-of null-texture))
79
80(define (texture-null? texture)
81 "Return #t if TEXTURE is the null texture."
82 (eq? texture null-texture))
83
84(define (free-texture texture)
85 (gl-delete-texture (texture-id texture)))
86
87(define-method (gpu-finalize (texture <<texture>>))
88 (free-texture texture))
89
90(define (apply-texture texture)
91 (gl-enable (enable-cap texture-2d))
92 (gl-bind-texture (texture-target texture-2d)
93 (texture-id texture)))
94
95(define *texture-state* (make-gpu-state apply-texture null-texture))
96
97(define* (make-texture pixels width height #:key
98 (min-filter 'linear)
99 (mag-filter 'linear)
100 (wrap-s 'repeat)
101 (wrap-t 'repeat)
102 (format 'rgba))
103 "Translate the bytevector PIXELS into an OpenGL texture with
104dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format.
105The generated texture uses MIN-FILTER for downscaling and MAG-FILTER
106for upscaling. WRAP-S and WRAP-T are symbols that control how texture
107access is handled for texture coordinates outside the [0, 1] range.
108Allowed symbols are: repeat (the default), clamp, clamp-to-border,
109clamp-to-edge. FORMAT specifies the pixel format. Currently only
11032-bit RGBA format is supported."
111 (define (gl-wrap mode)
112 (match mode
113 ('repeat (texture-wrap-mode repeat))
114 ('clamp (texture-wrap-mode clamp))
115 ('clamp-to-border (texture-wrap-mode clamp-to-border-sgis))
116 ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis))))
117
118 (let ((texture (gpu-guard
119 (%make-texture (gl-generate-texture) width height
120 min-filter mag-filter wrap-s wrap-t))))
121 (gpu-state-set! *texture-state* texture)
122 (gl-texture-parameter (texture-target texture-2d)
123 (texture-parameter-name texture-min-filter)
124 (match min-filter
125 ('nearest (gl:texture-min-filter nearest))
126 ('linear (gl:texture-min-filter linear))))
127 (gl-texture-parameter (texture-target texture-2d)
128 (texture-parameter-name texture-mag-filter)
129 (match mag-filter
130 ('nearest (gl:texture-mag-filter nearest))
131 ('linear (gl:texture-mag-filter linear))))
132 (gl-texture-parameter (texture-target texture-2d)
133 (texture-parameter-name texture-wrap-s)
134 (gl-wrap wrap-s))
135 (gl-texture-parameter (texture-target texture-2d)
136 (texture-parameter-name texture-wrap-t)
137 (gl-wrap wrap-t))
138 (gl-texture-image-2d (texture-target texture-2d)
139 0 (pixel-format rgba) width height 0
140 (match format
141 ('rgba (pixel-format rgba)))
142 (color-pointer-type unsigned-byte)
143 pixels)
144 texture))
145
146(define (flip-pixels-vertically pixels width height)
147 "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
148HEIGHT, 32 bit color bytevector."
149 (let ((buffer (make-u8vector (bytevector-length pixels)))
150 (row-width (* width 4))) ; assuming 32 bit color
151 (let loop ((y 0))
152 (when (< y height)
153 (let* ((y* (- height y 1))
154 (source-start (* y row-width))
155 (target-start (* y* row-width)))
156 (bytevector-copy! pixels source-start buffer target-start row-width)
157 (loop (1+ y)))))
158 buffer))
159
160(define (surface->texture surface min-filter mag-filter wrap-s wrap-t)
161 "Convert SURFACE, an SDL2 surface object, into a texture that uses
162the given MIN-FILTER and MAG-FILTER."
163 ;; Convert to 32 bit RGBA color.
164 (call-with-surface (convert-surface-format surface 'abgr8888)
165 (lambda (surface)
166 (let* ((width (surface-width surface))
167 (height (surface-height surface))
168 ;; OpenGL textures use the bottom-left corner as the
169 ;; origin, whereas SDL uses the top-left, so the rows
170 ;; of pixels must be reversed before creating a
171 ;; texture from them.
172 (pixels (flip-pixels-vertically (surface-pixels surface)
173 width height)))
174 (make-texture pixels width height
175 #:min-filter min-filter
176 #:mag-filter mag-filter
177 #:wrap-s wrap-s
178 #:wrap-t wrap-t)))))
179
180(define* (load-image file #:optional #:key
181 (min-filter 'nearest)
182 (mag-filter 'nearest)
183 (wrap-s 'repeat)
184 (wrap-t 'repeat))
185 "Load a texture from an image in FILE. MIN-FILTER and MAG-FILTER
186describe the method that should be used for minification and
187magnification. Valid values are 'nearest and 'linear. By default,
188'nearest is used."
189 (call-with-surface (sdl-image:load-image file)
190 (lambda (surface)
191 (surface->texture surface min-filter mag-filter wrap-s wrap-t))))