20034ddf6ecf44cfbea71b9980c1dedbf4f26af7
[chickadee.git] / chickadee / render / asset.scm
1 ;;; Chickadee Game Toolkit
2 ;;; Copyright © 2017 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 ;;; Commentary:
19 ;;
20 ;; Implementation of the glTF 2.0 specification
21 ;;
22 ;;; Code:
23
24 (define-module (chickadee render asset)
25 #:use-module (chickadee json)
26 #:use-module (chickadee math matrix)
27 #:use-module (chickadee math vector)
28 #:use-module (chickadee render buffer)
29 #:use-module (chickadee render color)
30 #:use-module (chickadee render scene)
31 #:use-module (chickadee render shader)
32 #:use-module (chickadee render texture)
33 #:use-module (ice-9 format)
34 #:use-module (ice-9 match)
35 #:use-module (rnrs base)
36 #:use-module (rnrs bytevectors)
37 #:use-module (rnrs io ports)
38 #:use-module (srfi srfi-9)
39 #:use-module (srfi srfi-9 gnu)
40 #:use-module ((srfi srfi-43) #:select (vector-every))
41 #:export (load-asset
42 asset?
43 asset-copyright
44 asset-generator
45 asset-scenes
46 asset-default-scene
47 draw-asset))
48
49 (define-record-type <asset>
50 (make-asset copyright generator scenes default-scene)
51 asset?
52 (copyright asset-copyright)
53 (generator asset-generator)
54 (scenes asset-scenes)
55 (default-scene asset-default-scene))
56
57 (define (display-asset asset port)
58 (format port "#<asset generator: ~s scene: ~s>"
59 (asset-generator asset)
60 (scene-name (asset-default-scene asset))))
61
62 (set-record-type-printer! <asset> display-asset)
63
64 (define (read-gltf port file)
65 (define (object-ref obj key)
66 (let ((value (assoc-ref obj key)))
67 (unless (pair? value)
68 (error "expected object for key" key value))
69 value))
70 (define (object-ref/optional obj key)
71 (let ((value (assoc-ref obj key)))
72 (unless (or (not value) (pair? value))
73 (error "expected object for optional key" key value))
74 value))
75 (define (array-ref obj key)
76 (let ((value (assoc-ref obj key)))
77 (unless (vector? value)
78 (error "expected array for key" key value))
79 value))
80 (define (array-ref/optional obj key)
81 (let ((value (assoc-ref obj key)))
82 (unless (or (not value) (vector? value))
83 (error "expected array for optional key" key value))
84 value))
85 (define (string-ref obj key)
86 (let ((value (assoc-ref obj key)))
87 (unless (string? value)
88 (error "expected string for key" key value))
89 value))
90 (define (string-ref/optional obj key)
91 (let ((value (assoc-ref obj key)))
92 (unless (or (not value) (string? value))
93 (error "expected string for optional key" key value))
94 value))
95 (define (number-ref obj key)
96 (let ((value (assoc-ref obj key)))
97 (unless (number? value)
98 (error "expected number for key" key value))
99 value))
100 (define (number-ref/optional obj key)
101 (let ((value (assoc-ref obj key)))
102 (unless (or (not value) (number? value))
103 (error "expected number for key" key value))
104 value))
105 (define (boolean-ref/optional obj key)
106 (let ((value (assoc-ref obj key)))
107 (unless (boolean? value)
108 (error "expected boolean for key" key value))
109 value))
110 (define (number-array-ref/optional obj key)
111 (let ((value (assoc-ref obj key)))
112 (unless (or (not value)
113 (and (vector? value) (vector-every number? value)))
114 (error "expected numeric array for key" key value))
115 value))
116 (define (matrix-ref/optional obj key)
117 (let ((value (assoc-ref obj key)))
118 (cond
119 ((not value) #f)
120 ((and (vector? value)
121 (= (vector-length value) 16)
122 (vector-every number? value))
123 ;; glTF matrices are in column-major order.
124 (make-matrix4 (vector-ref value 0)
125 (vector-ref value 4)
126 (vector-ref value 8)
127 (vector-ref value 12)
128 (vector-ref value 1)
129 (vector-ref value 5)
130 (vector-ref value 9)
131 (vector-ref value 13)
132 (vector-ref value 2)
133 (vector-ref value 6)
134 (vector-ref value 10)
135 (vector-ref value 14)
136 (vector-ref value 3)
137 (vector-ref value 7)
138 (vector-ref value 11)
139 (vector-ref value 15)))
140 (else
141 (error "expected 4x4 matrix for key" key value)))))
142 (define (assert-color v)
143 (if (and (= (vector-length v) 4)
144 (vector-every (lambda (x) (and (>= x 0.0) (<= x 1.0))) v))
145 (make-color (vector-ref v 0)
146 (vector-ref v 1)
147 (vector-ref v 2)
148 (vector-ref v 3))
149 (error "not a color vector" v)))
150 (define scope-file
151 (let ((gltf-root (dirname
152 (if (absolute-file-name? file)
153 file
154 (string-append (getcwd) "/" file)))))
155 (lambda (file)
156 (if (absolute-file-name? file)
157 file
158 (string-append gltf-root "/" file)))))
159 (define (parse-buffer obj)
160 ;; TODO: support base64 encoded buffer data as uri
161 ;; TODO: support glb-stored buffers:
162 ;; https://github.com/KhronosGroup/glTF/blob/master/specification/2.0/README.md#glb-stored-buffer
163 (let* ((uri (string-ref/optional obj "uri"))
164 (length (number-ref obj "byteLength"))
165 (name (or (string-ref/optional obj "name") "anonymous"))
166 (extensions (object-ref/optional obj "extensions"))
167 (extras (assoc-ref obj "extras"))
168 (data (if uri
169 (call-with-input-file (scope-file uri)
170 (lambda (port)
171 (get-bytevector-n port length)))
172 (make-bytevector length))))
173 data))
174 (define (parse-buffer-view obj buffers)
175 (let ((name (string-ref/optional obj "name"))
176 (data (vector-ref buffers (number-ref obj "buffer")))
177 (offset (or (number-ref/optional obj "byteOffset") 0))
178 (length (number-ref obj "byteLength"))
179 (stride (number-ref/optional obj "byteStride"))
180 (target (match (or (number-ref/optional obj "target") 34962)
181 (34962 'vertex)
182 (34963 'index)))
183 (extensions (object-ref/optional obj "extensions"))
184 (extras (assoc-ref obj "extras")))
185 (make-buffer data
186 #:name name
187 #:offset offset
188 #:length length
189 #:stride stride
190 #:target target)))
191 (define (parse-accessor obj buffer-views)
192 (define (type-length type)
193 (match type
194 ('scalar 1)
195 ('vec2 2)
196 ('vec3 3)
197 ('vec4 4)
198 ('mat2 4)
199 ('mat3 9)
200 ('mat4 16)))
201 (let ((name (or (string-ref/optional obj "name") "anonymous"))
202 (view (match (number-ref/optional obj "bufferView")
203 (#f #f)
204 (n (vector-ref buffer-views n))))
205 (offset (or (number-ref/optional obj "byteOffset") 0))
206 (component-type (match (number-ref obj "componentType")
207 (5120 'byte)
208 (5121 'unsigned-byte)
209 (5122 'short)
210 (5123 'unsigned-short)
211 (5125 'unsigned-int)
212 (5126 'float)))
213 (normalized? (boolean-ref/optional obj "normalized"))
214 (length (number-ref obj "count"))
215 (type (match (string-ref obj "type")
216 ("SCALAR" 'scalar)
217 ("VEC2" 'vec2)
218 ("VEC3" 'vec3)
219 ("VEC4" 'vec4)
220 ("MAT2" 'mat2)
221 ("MAT3" 'mat3)
222 ("MAT4" 'mat4)))
223 (max (number-array-ref/optional obj "max"))
224 (min (number-array-ref/optional obj "min"))
225 (sparse (object-ref/optional obj "sparse"))
226 (extensions (object-ref/optional obj "extensions"))
227 (extras (assoc-ref obj "extras")))
228 (unless (>= length 1)
229 (error "count must be greater than 0" length))
230 (when (and (vector? max)
231 (not (= (vector-length max) (type-length type))))
232 (error "not enough elements for max" max type))
233 (when (and (vector? min)
234 (not (= (vector-length min) (type-length type))))
235 (error "not enough elements for min" min type))
236 (make-typed-buffer #:name name
237 #:buffer view
238 #:offset offset
239 #:component-type component-type
240 #:normalized? normalized?
241 #:length length
242 #:type type
243 #:max max
244 #:min min
245 #:sparse sparse)))
246 (define (texture-filter n)
247 (match n
248 (9728 'nearest)
249 ((or #f 9729) 'linear)
250 (9984 'nearest-mipmap-nearest)
251 (9985 'linear-mipmap-nearest)
252 (9986 'nearest-mipmap-linear)
253 (9987 'linear-mipmap-linear)))
254 (define (texture-wrap n)
255 (match n
256 (10496 'clamp)
257 ((or #f 10497) 'repeat)
258 (33069 'clamp-to-border)
259 (33071 'clamp-to-edge)))
260 (define (parse-texture obj images samplers)
261 (let ((image (vector-ref images (number-ref obj "source")))
262 (sampler (vector-ref samplers (number-ref obj "sampler"))))
263 (load-image (scope-file (string-ref image "uri"))
264 #:min-filter (texture-filter
265 (number-ref/optional sampler "minFilter"))
266 #:mag-filter (texture-filter
267 (number-ref/optional sampler "magFilter"))
268 #:wrap-s (texture-wrap (number-ref/optional sampler "wrapS"))
269 #:wrap-t (texture-wrap (number-ref/optional sampler "wrapT")))))
270 (define (parse-material obj textures)
271 (let* ((name (or (string-ref/optional obj "name") "anonymous"))
272 (pbrmr (or (object-ref/optional obj "pbrMetallicRoughness") '()))
273 (base-color-factor
274 (let ((v (or (number-array-ref/optional pbrmr "baseColorFactor")
275 #(1.0 1.0 1.0 1.0))))
276 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
277 (base-color-texture
278 (match (object-ref/optional pbrmr "baseColorTexture")
279 (#f null-texture)
280 (obj
281 (vector-ref textures (number-ref obj "index")))))
282 (metallic-factor
283 (or (number-ref/optional pbrmr "metallicFactor")
284 1.0))
285 (roughness-factor
286 (or (number-ref/optional pbrmr "roughnessFactor")
287 1.0))
288 (metallic-roughness-texture
289 (match (object-ref/optional pbrmr "metallicRoughnessTexture")
290 (#f null-texture)
291 (obj
292 (vector-ref textures (number-ref obj "index")))))
293 (normal-factor
294 (let ((v (or (array-ref/optional obj "normalFactor")
295 #(0.0 0.0 0.0))))
296 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
297 (normal-texture
298 (match (object-ref/optional obj "normalTexture")
299 (#f null-texture)
300 (obj (vector-ref textures (number-ref obj "index")))))
301 (occlusion-factor
302 (let ((v (or (array-ref/optional obj "occlusionFactor")
303 #(0.0 0.0 0.0))))
304 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
305 (occlusion-texture
306 (match (object-ref/optional obj "occlusionTexture")
307 (#f null-texture)
308 (obj (vector-ref textures (number-ref obj "index")))))
309 (emissive-factor
310 (let ((v (or (array-ref/optional obj "emissiveFactor")
311 #(0.0 0.0 0.0))))
312 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
313 (emissive-texture
314 (match (object-ref/optional obj "emissiveTexture")
315 (#f null-texture)
316 (obj (vector-ref textures (number-ref obj "index")))))
317 (alpha-mode (match (or (string-ref/optional obj "alphaMode")
318 "BLEND")
319 ("OPAQUE" 'opaque)
320 ("MASK" 'mask)
321 ("BLEND" 'blend)))
322 (alpha-cutoff (or (number-ref/optional obj "alphaCutoff") 0.5))
323 (double-sided? (boolean-ref/optional obj "doubleSided"))
324 (extensions (object-ref/optional obj "extensions"))
325 (extras (assoc-ref obj "extras")))
326 (make-material #:name name
327 #:base-color-factor base-color-factor
328 #:base-color-texture base-color-texture
329 #:metallic-factor metallic-factor
330 #:roughness-factor roughness-factor
331 #:metallic-roughness-texture metallic-roughness-texture
332 #:normal-factor normal-factor
333 #:normal-texture normal-texture
334 #:occlusion-factor occlusion-factor
335 #:occlusion-texture occlusion-texture
336 #:emissive-factor emissive-factor
337 #:emissive-texture emissive-texture
338 #:alpha-mode alpha-mode
339 #:alpha-cutoff alpha-cutoff
340 #:double-sided? double-sided?)))
341 (define (attribute-name->index name)
342 (match name
343 ("POSITION"
344 (attribute-location
345 (hash-ref (shader-attributes (pbr-shader)) "position")))
346 ("NORMAL" 1)
347 ("TANGENT" 2)
348 ("TEXCOORD_0"
349 (attribute-location
350 (hash-ref (shader-attributes (pbr-shader)) "texcoord_0")))
351 ("TEXCOORD_1" 4)
352 ("COLOR_0" 5)
353 ("JOINTS_0" 6)
354 ("WEIGHTS_0" 7)))
355 (define (parse-primitive obj materials accessors)
356 (let ((attributes (map (match-lambda
357 ((name . n)
358 (cons (attribute-name->index name)
359 (vector-ref accessors n))))
360 (object-ref obj "attributes")))
361 (indices (match (number-ref/optional obj "indices")
362 (#f #f)
363 (n (vector-ref accessors n))))
364 ;; TODO: Set a default material when none is given.
365 (material (match (number-ref/optional obj "material")
366 (#f #f)
367 (n (vector-ref materials n))))
368 (mode (match (or (number-ref/optional obj "mode") 4)
369 (0 'points)
370 (1 'lines)
371 (2 'line-loop)
372 (3 'line-strip)
373 (4 'triangles)
374 (5 'triangle-strip)
375 (6 'triangle-fan)))
376 ;; TODO: Support morph targets.
377 (targets #f))
378 (make-primitive #:vertex-array
379 (make-vertex-array #:indices indices
380 #:attributes attributes
381 #:mode mode)
382 #:material material
383 #:targets targets)))
384 (define (parse-mesh obj materials accessors)
385 (let ((name (or (string-ref/optional obj "name") "anonymous"))
386 (primitives
387 (map (lambda (obj)
388 (parse-primitive obj materials accessors))
389 (vector->list (array-ref obj "primitives"))))
390 (weights (number-array-ref/optional obj "weights")))
391 (make-mesh #:name name
392 #:primitives primitives
393 #:weights weights)))
394 (define (parse-node obj parse-child meshes)
395 ;; TODO: Parse all fields of nodes.
396 (let ((name (or (string-ref/optional obj "name") "anonymous"))
397 ;; TODO: Parse camera.
398 (camera #f)
399 ;; TODO: Parse skin.
400 (skin #f)
401 (matrix (or (matrix-ref/optional obj "matrix")
402 (make-identity-matrix4)))
403 (mesh (match (number-ref/optional obj "mesh")
404 (#f #f)
405 (n (vector-ref meshes n))))
406 ;; TODO: Parse rotation, scale, translation
407 (rotation #f)
408 (scale #f)
409 (translation #f)
410 ;; TODO: Parse weights.
411 (weights #f)
412 (children (map parse-child
413 (vector->list
414 (or (array-ref/optional obj "children")
415 #())))))
416 (make-scene-node #:name name
417 #:children children
418 #:camera camera
419 #:skin skin
420 #:matrix matrix
421 #:mesh mesh
422 #:rotation rotation
423 #:scale scale
424 #:translation translation
425 #:weights weights)))
426 (define (parse-nodes array meshes)
427 (define nodes (make-vector (vector-length array) #f))
428 (define (parse-node* i)
429 (let ((node (vector-ref nodes i)))
430 (or node
431 (let ((node (parse-node (vector-ref array i)
432 parse-node*
433 meshes)))
434 (vector-set! nodes i node)
435 node))))
436 (let loop ((i 0))
437 (when (< i (vector-length array))
438 (parse-node* i)
439 (loop (+ i 1))))
440 nodes)
441 (define (parse-scene obj nodes)
442 (let ((name (or (string-ref/optional obj "name") "anonymous"))
443 (children
444 (map (lambda (i) (vector-ref nodes i))
445 (vector->list
446 (or (number-array-ref/optional obj "nodes")
447 #())))))
448 (make-scene #:name name #:nodes children)))
449 (let* ((tree (read-json port))
450 (asset (object-ref tree "asset"))
451 (version (string-ref asset "version"))
452 (copyright (string-ref/optional asset "copyright"))
453 (generator (string-ref/optional asset "generator"))
454 (minimum-version (string-ref/optional asset "minVersion"))
455 (extensions (object-ref/optional asset "extensions"))
456 ;; TODO: Figure out how to parse extras in a user-defined way
457 (extras (assoc-ref asset "extras"))
458 (buffers (vector-map parse-buffer
459 (or (assoc-ref tree "buffers") #())))
460 (buffer-views (vector-map (lambda (obj)
461 (parse-buffer-view obj buffers))
462 (or (assoc-ref tree "bufferViews") #())))
463 (accessors (vector-map (lambda (obj)
464 (parse-accessor obj buffer-views))
465 (or (assoc-ref tree "accessors") #())))
466 (images (pk 'sources (or (assoc-ref tree "images") #())))
467 (samplers (pk 'samplers (or (assoc-ref tree "samplers") #())))
468 (textures (vector-map (lambda (obj)
469 (parse-texture obj images samplers))
470 (or (assoc-ref tree "textures") #())))
471 (materials (vector-map (lambda (obj)
472 (parse-material obj textures))
473 (or (assoc-ref tree "materials") #())))
474 (meshes (vector-map (lambda (obj)
475 (parse-mesh obj materials accessors))
476 (or (assoc-ref tree "meshes") #())))
477 (nodes (parse-nodes (or (assoc-ref tree "nodes") #()) meshes))
478 (scenes (map (lambda (obj)
479 (parse-scene obj nodes))
480 (vector->list
481 (or (assoc-ref tree "scenes") #()))))
482 (default-scene (list-ref scenes
483 (or (number-ref/optional tree "scene")
484 0))))
485 (unless (string=? version "2.0")
486 (error "unsupported glTF version" version))
487 (make-asset copyright generator scenes default-scene)))
488
489 (define (load-asset file)
490 (call-with-input-file file (lambda (port) (read-gltf port file))))