cb4426f1e0ff0390d1c2d0891f35214ae5cc9db3
[chickadee.git] / chickadee / render / shader.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 shader)
19 #:use-module (ice-9 rdelim)
20 #:use-module (ice-9 match)
21 #:use-module (oop goops)
22 #:use-module (system foreign)
23 #:use-module (rnrs bytevectors)
24 #:use-module (rnrs io ports)
25 #:use-module (srfi srfi-1)
26 #:use-module (srfi srfi-4)
27 #:use-module (srfi srfi-9)
28 #:use-module (srfi srfi-9 gnu)
29 #:use-module (gl)
30 #:use-module (chickadee math matrix)
31 #:use-module (chickadee math vector)
32 #:use-module (chickadee render color)
33 #:use-module (chickadee render gl)
34 #:use-module (chickadee render gpu)
35 #:use-module (chickadee render texture)
36 #:export (make-shader
37 shader?
38 null-shader
39 load-shader
40 strings->shader
41 shader-uniform
42 shader-uniforms
43 shader-attributes
44 uniform?
45 uniform-name
46 uniform-type
47 uniform-value
48 uniform-default-value
49 set-uniform-value!
50 attribute?
51 attribute-name
52 attribute-location
53 attribute-type
54 *shader-state*))
55
56 (define-record-type <shader>
57 (%make-shader id attributes uniforms)
58 shader?
59 (id shader-id)
60 (attributes shader-attributes)
61 (uniforms shader-uniforms))
62
63 (define-record-type <uniform>
64 (make-uniform name location type value setter)
65 uniform?
66 (name uniform-name)
67 (location uniform-location)
68 (type uniform-type)
69 (value uniform-value %set-uniform-value!)
70 (setter uniform-setter))
71
72 (define-record-type <attribute>
73 (make-attribute name location type)
74 attribute?
75 (name attribute-name)
76 (location attribute-location)
77 (type attribute-type))
78
79 (define null-shader (%make-shader 0 (make-hash-table) (make-hash-table)))
80
81 (define <<shader>> (class-of null-shader))
82
83 (define-method (gpu-finalize (shader <<shader>>))
84 (gl-delete-program (shader-id shader)))
85
86 (define (apply-shader shader)
87 (gl-use-program (shader-id shader)))
88
89 (define *shader-state* (make-gpu-state apply-shader null-shader))
90
91 (define (shader-compiled? id)
92 (let ((status (make-u32vector 1)))
93 (gl-get-shaderiv id (version-2-0 compile-status)
94 (bytevector->pointer status))
95 (= (u32vector-ref status 0) 1)))
96
97 (define (shader-linked? id)
98 (let ((status (make-u32vector 1)))
99 (gl-get-programiv id (version-2-0 link-status)
100 (bytevector->pointer status))
101 (= (u32vector-ref status 0) 1)))
102
103 (define (info-log length-proc log-proc id)
104 (let ((log-length-bv (make-u32vector 1)))
105 (length-proc id (version-2-0 info-log-length)
106 (bytevector->pointer log-length-bv))
107 (u32vector-ref log-length-bv 0)
108 ;; Add one byte to account for the null string terminator.
109 (let* ((log-length (u32vector-ref log-length-bv 0))
110 (log (make-u8vector (1+ log-length))))
111 (log-proc id log-length %null-pointer (bytevector->pointer log))
112 (utf8->string log))))
113
114 (define (compilation-error id)
115 (info-log gl-get-shaderiv gl-get-shader-info-log id))
116
117 (define (linking-error id)
118 (info-log gl-get-programiv gl-get-program-info-log id))
119
120 (define (uniform-count id)
121 (let ((bv (make-u32vector 1)))
122 (gl-get-programiv id
123 (arb-shader-objects active-uniforms)
124 (bytevector->pointer bv))
125 (u32vector-ref bv 0)))
126
127 (define (utf8->string* bv length)
128 (let ((bv* (make-bytevector length)))
129 (bytevector-copy! bv 0 bv* 0 length)
130 (utf8->string bv*)))
131
132 (define (set-boolean-uniform! location bool)
133 (gl-uniform1i location (if bool 1 0)))
134
135 (define (set-integer-uniform! location n)
136 (gl-uniform1i location n))
137
138 (define (set-unsigned-integer-uniform! location n)
139 (gl-uniform1ui location n))
140
141 (define (set-float-uniform! location n)
142 (gl-uniform1f location n))
143
144 (define (set-float-vector2-uniform! location v)
145 (gl-uniform2fv location 1 (vec2->pointer v)))
146
147 ;; (define (set-float-vector3-uniform! location v)
148 ;; (gl-uniform3f location (vx v) (vy v) (vz v)))
149
150 (define (set-float-vector4-uniform! location v)
151 (if (color? v)
152 (gl-uniform4f location
153 (color-r v)
154 (color-g v)
155 (color-b v)
156 (color-a v))
157 #f
158 ;; (gl-uniform4f location (vx v) (vy v) (vz v) (vw v))
159 ))
160
161 ;; (define (set-integer-vector2-uniform! location v)
162 ;; (gl-uniform2i location (vx v) (vy v)))
163
164 ;; (define (set-integer-vector3-uniform! location v)
165 ;; (gl-uniform3i location (vx v) (vy v) (vz v)))
166
167 ;; (define (set-integer-vector4-uniform! location v)
168 ;; (gl-uniform4i location (vx v) (vy v) (vz v) (vw v)))
169
170 (define (set-float-matrix4-uniform! location m)
171 (gl-uniform-matrix4fv location 1 #f
172 ((@@ (chickadee math matrix) matrix4-ptr) m)))
173
174 (define (set-sampler-2d-uniform! location texture-unit)
175 (gl-uniform1i location texture-unit))
176
177 (define (gl-type->symbol type)
178 (cond
179 ((= type (version-2-0 bool)) 'bool)
180 ((= type (data-type int)) 'int)
181 ((= type (data-type unsigned-int)) 'unsigned-int)
182 ((= type (data-type float)) 'float)
183 ((= type (version-2-0 float-vec2)) 'float-vec2)
184 ((= type (version-2-0 float-vec3)) 'float-vec3)
185 ((= type (version-2-0 float-vec4)) 'float-vec4)
186 ;; ((= type (version-2-0 int-vec2)) 'int-vec2)
187 ;; ((= type (version-2-0 int-vec3)) 'int-vec3)
188 ;; ((= type (version-2-0 int-vec4)) 'int-vec4)
189 ((= type (version-2-0 float-mat4)) 'mat4)
190 ((= type (version-2-0 sampler-2d)) 'sampler-2d)
191 (else
192 (error "unsupported OpenGL type" type))))
193
194 (define %default-mat4 (make-identity-matrix4))
195
196 (define (default-uniform-value type)
197 (match type
198 ('bool #f)
199 ('int 0)
200 ('unsigned-int 0)
201 ('float 0.0)
202 ('float-vec2 (vec2 0.0 0.0))
203 ;; ('float-vec3 (vector3 0.0 0.0 0.0))
204 ('float-vec4 (make-color 0.0 0.0 0.0 0.0))
205 ;; ('int-vec2 (vector2 0 0))
206 ;; ('int-vec3 (vector3 0 0 0))
207 ;; ('int-vec4 (vector4 0 0 0 0))
208 ('mat4 %default-mat4)))
209
210 (define (uniform-setter-for-type type)
211 ;; TODO: Handle more data types, notably matrices.
212 (match type
213 ('bool set-boolean-uniform!)
214 ('int set-integer-uniform!)
215 ('unsigned-int set-unsigned-integer-uniform!)
216 ('float set-float-uniform!)
217 ('float-vec2 set-float-vector2-uniform!)
218 ;; ('float-vec3 set-float-vector3-uniform!)
219 ('float-vec4 set-float-vector4-uniform!)
220 ;; ('int-vec2 set-integer-vector2-uniform!)
221 ;; ('int-vec3 set-integer-vector3-uniform!)
222 ;; ('int-vec4 set-integer-vector4-uniform!)
223 ('mat4 set-float-matrix4-uniform!)
224 ('sampler-2d set-sampler-2d-uniform!)))
225
226 (define (extract-uniforms id)
227 (let ((total (uniform-count id))
228 (table (make-hash-table)))
229 (let loop ((i 0)
230 (texture-unit 0))
231 (unless (= i total)
232 (let ((length-bv (make-u32vector 1))
233 (size-bv (make-u32vector 1))
234 (type-bv (make-u32vector 1))
235 (name-bv (make-bytevector 255)))
236 (gl-get-active-uniform id i
237 (bytevector-length name-bv)
238 (bytevector->pointer length-bv)
239 (bytevector->pointer size-bv)
240 (bytevector->pointer type-bv)
241 (bytevector->pointer name-bv))
242 (let* ((length (u32vector-ref length-bv 0))
243 (name (utf8->string* name-bv length))
244 (location (gl-get-uniform-location id name))
245 (size (u32vector-ref size-bv 0))
246 (type (gl-type->symbol (u32vector-ref type-bv 0)))
247 (sampler? (eq? type 'sampler-2d))
248 (default (if sampler?
249 texture-unit
250 (default-uniform-value type)))
251 (setter (uniform-setter-for-type type)))
252 ;; TODO: Handle uniform arrays.
253 (unless (= size 1)
254 (error "unsupported uniform size" name size))
255
256 (hash-set! table
257 name
258 (make-uniform name location type default setter))
259 (loop (1+ i)
260 (if sampler?
261 (1+ texture-unit)
262 texture-unit))))))
263 table))
264
265 (define (attribute-count id)
266 (let ((bv (make-u32vector 1)))
267 (gl-get-programiv id
268 (arb-shader-objects active-attributes)
269 (bytevector->pointer bv))
270 (u32vector-ref bv 0)))
271
272 (define (extract-attributes id)
273 (let ((total (attribute-count id))
274 (table (make-hash-table)))
275 (let loop ((i 0))
276 (unless (= i total)
277 (let ((length-bv (make-u32vector 1))
278 (size-bv (make-u32vector 1))
279 (type-bv (make-u32vector 1))
280 (name-bv (make-bytevector 255)))
281 (gl-get-active-attrib id i
282 (bytevector-length name-bv)
283 (bytevector->pointer length-bv)
284 (bytevector->pointer size-bv)
285 (bytevector->pointer type-bv)
286 (bytevector->pointer name-bv))
287 (let* ((length (u32vector-ref length-bv 0))
288 (name (utf8->string* name-bv length))
289 (size (u32vector-ref size-bv 0))
290 (type (gl-type->symbol (u32vector-ref type-bv 0)))
291 (location (gl-get-attrib-location id name)))
292 (unless (= size 1)
293 (error "unsupported attribute size" name size))
294
295 (hash-set! table name (make-attribute name location type))))
296 (loop (1+ i))))
297 table))
298
299 (define (make-shader vertex-port fragment-port)
300 (define (make-shader-stage type port)
301 (let ((id (gl-create-shader type))
302 (source (get-bytevector-all port)))
303 (gl-shader-source id 1
304 (bytevector->pointer
305 (u64vector
306 (pointer-address (bytevector->pointer source))))
307 (bytevector->pointer
308 (u32vector (bytevector-length source))))
309 (gl-compile-shader id)
310 (unless (shader-compiled? id)
311 (let ((error-log (compilation-error id)))
312 (gl-delete-shader id) ; clean up GPU resource.
313 (error "failed to compile shader" error-log)))
314 id))
315
316 (let ((vertex-id (make-shader-stage (version-2-0 vertex-shader)
317 vertex-port))
318 (fragment-id (make-shader-stage (version-2-0 fragment-shader)
319 fragment-port))
320 (id (gl-create-program)))
321 (gl-attach-shader id vertex-id)
322 (gl-attach-shader id fragment-id)
323 (gl-link-program id)
324 (unless (shader-linked? id)
325 (let ((error-log (linking-error id)))
326 (gl-delete-program id)
327 (error "failed to link shader" error-log)))
328 (gl-delete-shader vertex-id)
329 (gl-delete-shader fragment-id)
330 (gpu-guard (%make-shader id (extract-attributes id) (extract-uniforms id)))))
331
332 (define (load-shader vertex-source-file fragment-source-file)
333 (call-with-input-file vertex-source-file
334 (lambda (vertex-port)
335 (call-with-input-file fragment-source-file
336 (lambda (fragment-port)
337 (make-shader vertex-port fragment-port))))))
338
339 (define (strings->shader vertex-source fragment-source)
340 (call-with-input-string vertex-source
341 (lambda (vertex-port)
342 (call-with-input-string fragment-source
343 (lambda (fragment-port)
344 (make-shader vertex-port fragment-port))))))
345
346 (define (shader-uniform shader name)
347 (let ((uniform (hash-ref (shader-uniforms shader) name)))
348 (or uniform (error "no such uniform" name))))
349
350 (define (set-uniform-value! uniform x)
351 "Change the value of UNIFORM to X. This procedure assumes that the
352 shader where UNIFORM is defined is currently bound in the OpenGL
353 context. The behavior of this procedure under any other circumstance
354 is undefined."
355 ((uniform-setter uniform) (uniform-location uniform) x)
356 (%set-uniform-value! uniform x))
357
358 (define (uniform-default-value uniform)
359 (default-uniform-value (uniform-type uniform)))