332d21181d6fbf9e181202efb24715b16091239c
[chickadee.git] / chickadee / render / model.scm
1 ;;; Chickadee Game Toolkit
2 ;;; Copyright © 2019 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 ;; 3D Model loading and rendering.
21 ;;
22 ;;; Code:
23
24 (define-module (chickadee render model)
25 #:use-module (chickadee array-list)
26 #:use-module (chickadee json)
27 #:use-module (chickadee math matrix)
28 #:use-module (chickadee math vector)
29 #:use-module (chickadee render)
30 #:use-module (chickadee render buffer)
31 #:use-module (chickadee render color)
32 #:use-module (chickadee render pbr)
33 #:use-module (chickadee render phong)
34 #:use-module (chickadee render shader)
35 #:use-module (chickadee render texture)
36 #:use-module (ice-9 format)
37 #:use-module (ice-9 match)
38 #:use-module (ice-9 rdelim)
39 #:use-module (rnrs bytevectors)
40 #:use-module (rnrs io ports)
41 #:use-module (srfi srfi-9)
42 #:use-module ((srfi srfi-43) #:select (vector-every))
43 #:export (model?
44 draw-model
45 load-obj
46 load-gltf))
47
48 \f
49 ;;;
50 ;;; Rendering State
51 ;;;
52
53 (define-record-type <render-state>
54 (%make-render-state shader renderer world-matrix view-matrix)
55 render-state?
56 (shader render-state-shader)
57 (renderer render-state-renderer)
58 (world-matrix render-state-world-matrix)
59 (view-matrix render-state-view-matrix))
60
61 (define* (make-render-state #:key shader renderer)
62 (%make-render-state shader renderer
63 (make-identity-matrix4)
64 (make-identity-matrix4)))
65
66 (define (render-state-reset! state)
67 (matrix4-identity! (render-state-world-matrix state))
68 (matrix4-identity! (render-state-view-matrix state)))
69
70 (define (render-state-world-matrix-mult! state matrix)
71 (let ((world (render-state-world-matrix state)))
72 (matrix4-mult! world world matrix)))
73
74 (define (render-state-view-matrix-mult! state matrix)
75 (let ((view (render-state-view-matrix state)))
76 (matrix4-mult! view view matrix)))
77
78 \f
79 ;;;
80 ;;; Primitives
81 ;;;
82
83 ;; A piece of a mesh. Represents a single draw call.
84 (define-record-type <primitive>
85 (make-primitive name vertex-array material)
86 primitive?
87 (name primitive-name)
88 (vertex-array primitive-vertex-array)
89 (material primitive-material))
90
91 (define (draw-primitive/phong primitive state)
92 (gpu-apply/phong (render-state-shader state)
93 (primitive-vertex-array primitive)
94 (primitive-material primitive)
95 (render-state-world-matrix state)
96 (render-state-view-matrix state)))
97
98 (define (draw-primitive/pbr primitive state)
99 (gpu-apply/pbr (render-state-shader state)
100 (primitive-vertex-array primitive)
101 (primitive-material primitive)
102 (render-state-world-matrix state)
103 (render-state-view-matrix state)))
104
105 \f
106 ;;;
107 ;;; Meshes
108 ;;;
109
110 ;; A complete 3D model composed of many primitives.
111 (define-record-type <mesh>
112 (make-mesh name primitives)
113 mesh?
114 (name mesh-name)
115 (primitives mesh-primitives))
116
117 (define (draw-mesh mesh state)
118 (let ((render (render-state-renderer state)))
119 (for-each (lambda (primitive) (render primitive state))
120 (mesh-primitives mesh))))
121
122 \f
123 ;;;
124 ;;; Scene Node
125 ;;;
126
127 ;; A tree of meshes with their own transformation matrices.
128 (define-record-type <scene-node>
129 (%make-scene-node name mesh matrix children)
130 node?
131 (name scene-node-name)
132 (mesh scene-node-mesh)
133 (matrix scene-node-matrix)
134 (children scene-node-children))
135
136 (define* (make-scene-node #:key
137 (name "anonymous")
138 mesh
139 (matrix (make-identity-matrix4))
140 (children '()))
141 (%make-scene-node name mesh matrix children))
142
143 (define (draw-scene-node node state)
144 ;; TODO: Apply push/pop model matrix stuff.
145 (for-each (lambda (child)
146 (draw-scene-node child state))
147 (scene-node-children node))
148 (let ((mesh (scene-node-mesh node)))
149 (when mesh
150 (draw-mesh mesh state))))
151
152 \f
153 ;;;
154 ;;; Model
155 ;;;
156
157 ;; A collection of scenes and the associated information about *how*
158 ;; to actually render the darn thing.
159 (define-record-type <model>
160 (%make-model name scenes default-scene render-state)
161 model?
162 (name model-name)
163 (scenes model-scenes)
164 (default-scene model-default-scene)
165 (render-state model-render-state))
166
167 (define* (make-model #:key name scenes (default-scene (car scenes)) render-state)
168 (%make-model name scenes default-scene render-state))
169
170 (define (draw-model model model-matrix view-matrix)
171 (with-depth-test #t
172 (let ((state (model-render-state model)))
173 (render-state-reset! state)
174 (render-state-view-matrix-mult! state view-matrix)
175 (render-state-world-matrix-mult! state model-matrix)
176 ;; TODO: Support drawing non-default scenes.
177 (draw-scene-node (model-default-scene model) state))))
178
179 \f
180 ;;;
181 ;;; OBJ Format
182 ;;;
183
184 ;; Reference documentation:
185 ;; * http://paulbourke.net/dataformats/obj
186 ;; * http://paulbourke.net/dataformats/mtl
187 (define (load-obj file-name)
188 (define (scope-file other-file)
189 (string-append (dirname file-name) "/" other-file))
190 (call-with-input-file file-name
191 (lambda (port)
192 (let ((vertices (make-array-list))
193 (texcoords (make-array-list))
194 (normals (make-array-list))
195 (faces (make-array-list))
196 (face-map (make-hash-table))
197 (face-indices-map (make-hash-table))
198 (material-map (make-hash-table)))
199 (define (parse-map-args args)
200 (define (map-option? str)
201 (string-prefix? "-" str))
202 (let loop ((args args)
203 (opts '()))
204 (match args
205 (() opts)
206 (((? map-option? opt) arg . rest)
207 (loop rest
208 (cons (cons (string->symbol
209 (substring opt 1))
210 arg)
211 opts)))
212 ((file-name . rest)
213 (loop rest (cons (cons 'file-name file-name) opts))))))
214 (define (load-mtl mtl-file-name)
215 (define (scope-file other-file)
216 (string-append (dirname mtl-file-name) "/" other-file))
217 (call-with-input-file mtl-file-name
218 (lambda (port)
219 (let loop ((opts '()))
220 (define (maybe-add-material)
221 (let ((name (assq-ref opts 'name)))
222 (when name
223 (hash-set! material-map
224 name
225 (make-phong-material
226 #:name name
227 #:ambient (assq-ref opts 'ambient)
228 #:ambient-map (assq-ref opts 'ambient-map)
229 #:use-ambient-map
230 (assq-ref opts 'use-ambient-map?)
231 #:diffuse (assq-ref opts 'diffuse)
232 #:diffuse-map (assq-ref opts 'diffuse-map)
233 #:use-diffuse-map
234 (assq-ref opts 'use-diffuse-map?)
235 #:specular (assq-ref opts 'specular)
236 #:specular-map (assq-ref opts 'specular-map)
237 #:use-specular-map
238 (assq-ref opts 'use-specular-map?)
239 #:shininess (assq-ref opts 'shininess)
240 #:bump-map (assq-ref opts 'bump-map)
241 #:use-bump-map
242 (assq-ref opts 'use-bump-map?))))))
243 (match (read-line port)
244 ((? eof-object?)
245 (maybe-add-material))
246 (line
247 (match (delete "" (string-split line char-set:whitespace))
248 ((or () ("#" . _)) ; ignore comments and blank lines
249 (loop opts))
250 (("d" d) ; ignore dissolve for now
251 (loop opts))
252 (("illum" n) ; ignore illumation model for now
253 (loop opts))
254 (("Ka" r g b) ; ambient factor
255 (let ((new-ambient (vec3 (string->number r)
256 (string->number g)
257 (string->number b))))
258 (loop (cons (cons 'ambient new-ambient) opts))))
259 (("Ka" r) ; ambient factor
260 (let ((new-ambient (vec3 (string->number r)
261 (string->number r)
262 (string->number r))))
263 (loop (cons (cons 'ambient new-ambient) opts))))
264 (("Kd" r g b) ; diffuse factor
265 (let ((new-diffuse (vec3 (string->number r)
266 (string->number g)
267 (string->number b))))
268 (loop (cons (cons 'diffuse new-diffuse) opts))))
269 (("Kd" r) ; diffuse factor
270 (let ((new-diffuse (vec3 (string->number r)
271 (string->number r)
272 (string->number r))))
273 (loop (cons (cons 'diffuse new-diffuse) opts))))
274 (("Ks" r g b) ; specular factor
275 (let ((new-specular (vec3 (string->number r)
276 (string->number g)
277 (string->number b))))
278 (loop (cons (cons 'specular new-specular) opts))))
279 (("Ks" r) ; specular factor
280 (let ((new-specular (vec3 (string->number r)
281 (string->number r)
282 (string->number r))))
283 (loop (cons (cons 'specular new-specular) opts))))
284 (("Ni" i) ; ignore optical density for now
285 (loop opts))
286 (("Ns" s) ; specular exponent (shininess)
287 ;; Force specular exponent to be a float.
288 (let ((new-shininess (* (string->number s) 1.0)))
289 (loop (cons (cons 'shininess new-shininess) opts))))
290 (("map_Ka" . args) ; ambient map
291 (let* ((ambient-opts (parse-map-args args))
292 (file (scope-file (assq-ref ambient-opts
293 'file-name)))
294 (texture (load-image file
295 #:min-filter 'linear
296 #:mag-filter 'linear)))
297 (loop (cons* (cons 'ambient-map texture)
298 (cons 'use-ambient-map? #t)
299 opts))))
300 (("map_Kd" . args) ; diffuse map
301 (let* ((diffuse-opts (parse-map-args args))
302 (file (scope-file (assq-ref diffuse-opts
303 'file-name)))
304 (texture (load-image file
305 #:min-filter 'linear
306 #:mag-filter 'linear)))
307 (loop (cons* (cons 'diffuse-map texture)
308 (cons 'use-diffuse-map? #t)
309 opts))))
310 (("map_Ks" . args) ; specular map
311 (let* ((specular-opts (parse-map-args args))
312 (file (scope-file (assq-ref specular-opts
313 'file-name)))
314 (texture (load-image file
315 #:min-filter 'linear
316 #:mag-filter 'linear)))
317 (loop (cons* (cons 'specular-map texture)
318 (cons 'use-specular-map? #t)
319 opts))))
320 (((or "map_Bump" "map_bump" "bump") . args) ; normal map
321 (let* ((bump-opts (parse-map-args args))
322 (file (scope-file (assq-ref bump-opts
323 'file-name)))
324 (texture (load-image file
325 #:min-filter 'linear
326 #:mag-filter 'linear)))
327 (loop (cons* (cons 'bump-map texture)
328 (cons 'use-bump-map? #t)
329 opts))))
330 (("newmtl" new-name)
331 ;; Begin new material
332 (maybe-add-material)
333 (loop `((name . ,new-name)
334 (ambient . ,(vec3 0.0 0.0 0.0))
335 (ambient-map . ,null-texture)
336 (use-ambient-map? . #f)
337 (diffuse . ,(vec3 0.0 0.0 0.0))
338 (diffuse-map . ,null-texture)
339 (use-diffuse-map? . #f)
340 (specular . ,(vec3 0.0 0.0 0.0))
341 (specular-map . ,null-texture)
342 (use-specular-map? . #f)
343 (shininess . 1.0)
344 (bump-map . ,null-texture)
345 (use-bump-map? . #f))))
346 (data
347 (format (current-error-port)
348 "warning: ~a:~d: unsupported MTL data: ~s~%"
349 mtl-file-name
350 (port-line port)
351 data)
352 (loop opts)))))))))
353 (define (parse-error message args)
354 (apply error (format #f "OBJ parser error @ ~a:~d: ~a"
355 file-name
356 (port-line port)
357 message)
358 args))
359 (define (parse-vertex args)
360 (array-list-push! vertices
361 (match args
362 ((x y z)
363 (vec3 (string->number x)
364 (string->number y)
365 (string->number z)))
366 ;; TODO: handle w properly
367 ((x y z w)
368 (vec3 (string->number x)
369 (string->number y)
370 (string->number z)))
371 (_
372 (parse-error "wrong number of vertex arguments" args)))))
373 (define (parse-texcoord args)
374 ;; TODO: Handle w properly.
375 (array-list-push! texcoords
376 (match args
377 ((u)
378 (vec2 (string->number u) 0.0))
379 ((u v)
380 (vec2 (string->number u) (string->number v)))
381 ((u v w)
382 (vec2 (string->number u)
383 (string->number v)))
384 (_
385 (parse-error "wrong number of texcoord arguments" args)))))
386 (define (parse-normal args)
387 (array-list-push! normals
388 (match args
389 ((i j k)
390 (vec3 (string->number i)
391 (string->number j)
392 (string->number k)))
393 (_
394 (parse-error "wrong number of normal arguments" args)))))
395 (define (parse-face-index arg)
396 (- (string->number arg) 1))
397 (define (parse-face-element arg)
398 (match (string-split arg #\/)
399 ((v)
400 (list (parse-face-index v) #f #f))
401 ((v t)
402 (list (parse-face-index v)
403 (parse-face-index t)
404 #f))
405 ((v "" n)
406 (list (parse-face-index v)
407 #f
408 (parse-face-index n)))
409 ((v t n)
410 (list (parse-face-index v)
411 (parse-face-index t)
412 (parse-face-index n)))
413 (_
414 (parse-error "invalid face syntax" (list arg)))))
415 (define (indices-for-material material)
416 (or (hash-ref face-indices-map material)
417 (let ((new-indices (make-array-list)))
418 (hash-set! face-indices-map material new-indices)
419 new-indices)))
420 (define (deduplicate-face-element e)
421 ;; Faces are often redundant, so we deduplicate in order to
422 ;; make the VBOs we build later as small as possible.
423 (or (hash-ref face-map e)
424 (let ((i (array-list-size faces)))
425 (array-list-push! faces (parse-face-element e))
426 (hash-set! face-map e i)
427 i)))
428 (define (push-face material e)
429 (array-list-push! (indices-for-material material)
430 (deduplicate-face-element e)))
431 (define (parse-face args material)
432 (match args
433 ;; A single triangle. Ah, life is so simple...
434 ((a b c)
435 (push-face material a)
436 (push-face material b)
437 (push-face material c))
438 ;; A quadrilateral. Needs to be split into 2 triangles.
439 ;;
440 ;; d-------c
441 ;; | /|
442 ;; | / |
443 ;; | / |
444 ;; |/ |
445 ;; a-------b
446 ((a b c d)
447 ;; triangle 1: a b c
448 (push-face material a)
449 (push-face material b)
450 (push-face material c)
451 ;; triangle 2: a c d
452 (push-face material a)
453 (push-face material c)
454 (push-face material d))
455 ;; 3 or more triangles. Interpret as a strip of triangles
456 ;; moving from right to left (because counter-clockwise
457 ;; winding) like this:
458 ;;
459 ;; h-------f-------d-------c
460 ;; | /| /| /|
461 ;; | / | / | / |
462 ;; | / | / | / |
463 ;; |/ |/ |/ |
464 ;; g-------e-------a-------b
465 ;;
466 ;; ... and so on for however many face elements there are.
467 ;; Every other triangle is flipped over, hence the 'flip?'
468 ;; flag in the loop below.
469 ((a b . rest)
470 (let loop ((a a)
471 (b b)
472 (args rest)
473 (flip? #f))
474 (match args
475 (() #t)
476 ((c . rest)
477 (push-face material a)
478 (push-face material b)
479 (push-face material c)
480 (if flip?
481 (loop c a rest #f)
482 (loop a c rest #t))))))
483 (_
484 (parse-error "invalid face" args))))
485 ;; Register default material
486 (hash-set! material-map "default" default-phong-material)
487 ;; Parse file.
488 (let loop ((material "default"))
489 (match (read-line port)
490 ((? eof-object?)
491 #f)
492 (line
493 (match (delete "" (string-split line char-set:whitespace))
494 ((or () ("#" . _)) ; ignore comments and blank lines
495 (loop material))
496 (("f" . args)
497 (parse-face args material)
498 (loop material))
499 (("g" . _) ; ignore group name for now
500 (loop material))
501 (("mtllib" mtl-file-name)
502 (load-mtl (scope-file mtl-file-name))
503 (loop material))
504 (("o" . _) ;ignore object name for now
505 (loop material))
506 (("s" . _) ; ignore smoothing group for now
507 (loop material))
508 (("usemtl" new-material)
509 (loop new-material))
510 (("v" . args)
511 (parse-vertex args)
512 (loop material))
513 (("vn" . args)
514 (parse-normal args)
515 (loop material))
516 (("vt" . args)
517 (parse-texcoord args)
518 (loop material))
519 (data
520 (format (current-error-port)
521 "warning: ~a:~d: unsupported OBJ data: ~s~%"
522 file-name
523 (port-line port)
524 data)
525 (loop material))))))
526 ;; Build a vertex array for all the faces of a single
527 ;; material.
528 ;;
529 ;; XXX: We assume there is normal and texture data. Models
530 ;; that don't have one or both will still use up as much
531 ;; memory as if they did. Maybe that's just fine? Dunno.
532 (define (make-primitive-for-material material)
533 (let* ((face-indices (indices-for-material material))
534 (vertex-count (array-list-size faces))
535 (index-count (array-list-size face-indices))
536 (stride 8)
537 (mesh-data (make-f32vector (* vertex-count stride)))
538 (mesh-indices (make-u32vector index-count))
539 (null-texcoord (vec2 0.0 0.0))
540 (null-normal (vec3 0.0 0.0 0.0)))
541 ;; The mesh vertex data is packed like so:
542 ;; - 3 floats for vertex
543 ;; - 2 floats for texture coordinate
544 ;; - 3 floats for normal
545 ;; - repeat for each face
546 (let loop ((i 0))
547 (when (< i vertex-count)
548 (let ((offset (* i stride)))
549 (match (array-list-ref faces i)
550 ((vert-index tex-index norm-index)
551 ;; Vertex
552 (let ((v (array-list-ref vertices vert-index)))
553 (f32vector-set! mesh-data offset (vec3-x v))
554 (f32vector-set! mesh-data (+ offset 1) (vec3-y v))
555 (f32vector-set! mesh-data (+ offset 2) (vec3-z v)))
556 ;; Texture coordinate
557 (let ((t (if tex-index
558 (array-list-ref texcoords tex-index)
559 null-texcoord)))
560 (f32vector-set! mesh-data (+ offset 3) (vec2-x t))
561 (f32vector-set! mesh-data (+ offset 4) (vec2-y t)))
562 ;; Normal
563 (let ((n (if norm-index
564 (array-list-ref normals norm-index)
565 null-normal)))
566 (f32vector-set! mesh-data (+ offset 5) (vec3-x n))
567 (f32vector-set! mesh-data (+ offset 6) (vec3-y n))
568 (f32vector-set! mesh-data (+ offset 7) (vec3-z n))))))
569 (loop (+ i 1))))
570 ;; Pack indices.
571 (let loop ((i 0))
572 (when (< i index-count)
573 (u32vector-set! mesh-indices i (array-list-ref face-indices i))
574 (loop (+ i 1))))
575 ;; Construct vertex array.
576 ;; TODO: Add names to buffers and views.
577 (let* ((index-buffer (make-buffer mesh-indices #:target 'index))
578 (index-view (make-buffer-view #:type 'scalar
579 #:component-type 'unsigned-int
580 #:buffer index-buffer))
581 (data-buffer (make-buffer mesh-data #:stride (* stride 4)))
582 (vertex-view (make-buffer-view #:type 'vec3
583 #:component-type 'float
584 #:buffer data-buffer))
585 (texcoord-view (make-buffer-view #:type 'vec2
586 #:component-type 'float
587 #:buffer data-buffer
588 #:offset 12))
589 (normal-view (make-buffer-view #:type 'vec3
590 #:component-type 'float
591 #:buffer data-buffer
592 #:offset 20)))
593 (make-primitive material
594 (make-vertex-array
595 #:indices index-view
596 #:attributes `((0 . ,vertex-view)
597 (1 . ,texcoord-view)
598 (2 . ,normal-view)))
599 (or (hash-ref material-map material)
600 (hash-ref material-map "default"))))))
601 ;; Construct a mesh by composing primitives. One primitive
602 ;; per material.
603 (let* ((model-name (basename file-name))
604 (mesh (make-mesh model-name
605 (hash-fold (lambda (material indices memo)
606 ;; It's possible that a material has
607 ;; no data associated with it, so we
608 ;; drop those.
609 (if (array-list-empty? indices)
610 memo
611 (cons (make-primitive-for-material material)
612 memo)))
613 '()
614 face-indices-map)))
615 (scene (make-scene-node #:name model-name
616 #:mesh mesh)))
617 (make-model #:name model-name
618 #:scenes (list scene)
619 #:render-state
620 (make-render-state #:shader (load-phong-shader)
621 #:renderer draw-primitive/phong)))))))
622
623 \f
624 ;;;
625 ;;; glTF 2.0
626 ;;;
627
628 (define (load-gltf file-name)
629 (define (object-ref obj key)
630 (let ((value (assoc-ref obj key)))
631 (unless (pair? value)
632 (error "expected object for key" key value))
633 value))
634 (define (object-ref/optional obj key)
635 (let ((value (assoc-ref obj key)))
636 (unless (or (not value) (pair? value))
637 (error "expected object for optional key" key value))
638 value))
639 (define (array-ref obj key)
640 (let ((value (assoc-ref obj key)))
641 (unless (vector? value)
642 (error "expected array for key" key value))
643 value))
644 (define (array-ref/optional obj key)
645 (let ((value (assoc-ref obj key)))
646 (unless (or (not value) (vector? value))
647 (error "expected array for optional key" key value))
648 value))
649 (define (string-ref obj key)
650 (let ((value (assoc-ref obj key)))
651 (unless (string? value)
652 (error "expected string for key" key value))
653 value))
654 (define (string-ref/optional obj key)
655 (let ((value (assoc-ref obj key)))
656 (unless (or (not value) (string? value))
657 (error "expected string for optional key" key value))
658 value))
659 (define (number-ref obj key)
660 (let ((value (assoc-ref obj key)))
661 (unless (number? value)
662 (error "expected number for key" key value))
663 value))
664 (define (number-ref/optional obj key)
665 (let ((value (assoc-ref obj key)))
666 (unless (or (not value) (number? value))
667 (error "expected number for key" key value))
668 value))
669 (define (boolean-ref/optional obj key)
670 (let ((value (assoc-ref obj key)))
671 (unless (boolean? value)
672 (error "expected boolean for key" key value))
673 value))
674 (define (number-array-ref/optional obj key)
675 (let ((value (assoc-ref obj key)))
676 (unless (or (not value)
677 (and (vector? value) (vector-every number? value)))
678 (error "expected numeric array for key" key value))
679 value))
680 (define (matrix-ref/optional obj key)
681 (let ((value (assoc-ref obj key)))
682 (cond
683 ((not value) #f)
684 ((and (vector? value)
685 (= (vector-length value) 16)
686 (vector-every number? value))
687 ;; glTF matrices are in column-major order.
688 (make-matrix4 (vector-ref value 0)
689 (vector-ref value 4)
690 (vector-ref value 8)
691 (vector-ref value 12)
692 (vector-ref value 1)
693 (vector-ref value 5)
694 (vector-ref value 9)
695 (vector-ref value 13)
696 (vector-ref value 2)
697 (vector-ref value 6)
698 (vector-ref value 10)
699 (vector-ref value 14)
700 (vector-ref value 3)
701 (vector-ref value 7)
702 (vector-ref value 11)
703 (vector-ref value 15)))
704 (else
705 (error "expected 4x4 matrix for key" key value)))))
706 (define (assert-color v)
707 (if (and (= (vector-length v) 4)
708 (vector-every (lambda (x) (and (>= x 0.0) (<= x 1.0))) v))
709 (make-color (vector-ref v 0)
710 (vector-ref v 1)
711 (vector-ref v 2)
712 (vector-ref v 3))
713 (error "not a color vector" v)))
714 (define scope-file
715 (let ((gltf-root (dirname
716 (if (absolute-file-name? file-name)
717 file-name
718 (string-append (getcwd) "/" file-name)))))
719 (lambda (other-file)
720 (if (absolute-file-name? other-file)
721 other-file
722 (string-append gltf-root "/" other-file)))))
723 (define (parse-buffer obj)
724 ;; TODO: support base64 encoded buffer data as uri
725 ;; TODO: support glb-stored buffers:
726 ;; https://github.com/KhronosGroup/glTF/blob/master/specification/2.0/README.md#glb-stored-buffer
727 (let* ((uri (string-ref/optional obj "uri"))
728 (length (number-ref obj "byteLength"))
729 (name (or (string-ref/optional obj "name") "anonymous"))
730 (extensions (object-ref/optional obj "extensions"))
731 (extras (assoc-ref obj "extras"))
732 (data (if uri
733 (call-with-input-file (scope-file uri)
734 (lambda (port)
735 (get-bytevector-n port length)))
736 (make-bytevector length))))
737 data))
738 (define (parse-buffer-view obj buffers)
739 (let ((name (string-ref/optional obj "name"))
740 (data (vector-ref buffers (number-ref obj "buffer")))
741 (offset (or (number-ref/optional obj "byteOffset") 0))
742 (length (number-ref obj "byteLength"))
743 (stride (number-ref/optional obj "byteStride"))
744 (target (match (or (number-ref/optional obj "target") 34962)
745 (34962 'vertex)
746 (34963 'index)))
747 (extensions (object-ref/optional obj "extensions"))
748 (extras (assoc-ref obj "extras")))
749 (make-buffer data
750 #:name name
751 #:offset offset
752 #:length length
753 #:stride stride
754 #:target target)))
755 (define (parse-accessor obj buffer-views)
756 (define (type-length type)
757 (match type
758 ('scalar 1)
759 ('vec2 2)
760 ('vec3 3)
761 ('vec4 4)
762 ('mat2 4)
763 ('mat3 9)
764 ('mat4 16)))
765 (let ((name (or (string-ref/optional obj "name") "anonymous"))
766 (view (match (number-ref/optional obj "bufferView")
767 (#f #f)
768 (n (vector-ref buffer-views n))))
769 (offset (or (number-ref/optional obj "byteOffset") 0))
770 (component-type (match (number-ref obj "componentType")
771 (5120 'byte)
772 (5121 'unsigned-byte)
773 (5122 'short)
774 (5123 'unsigned-short)
775 (5125 'unsigned-int)
776 (5126 'float)))
777 (normalized? (boolean-ref/optional obj "normalized"))
778 (length (number-ref obj "count"))
779 (type (match (string-ref obj "type")
780 ("SCALAR" 'scalar)
781 ("VEC2" 'vec2)
782 ("VEC3" 'vec3)
783 ("VEC4" 'vec4)
784 ("MAT2" 'mat2)
785 ("MAT3" 'mat3)
786 ("MAT4" 'mat4)))
787 (max (number-array-ref/optional obj "max"))
788 (min (number-array-ref/optional obj "min"))
789 (sparse (object-ref/optional obj "sparse"))
790 (extensions (object-ref/optional obj "extensions"))
791 (extras (assoc-ref obj "extras")))
792 (unless (>= length 1)
793 (error "count must be greater than 0" length))
794 (when (and (vector? max)
795 (not (= (vector-length max) (type-length type))))
796 (error "not enough elements for max" max type))
797 (when (and (vector? min)
798 (not (= (vector-length min) (type-length type))))
799 (error "not enough elements for min" min type))
800 (make-buffer-view #:name name
801 #:buffer view
802 #:offset offset
803 #:component-type component-type
804 #:normalized? normalized?
805 #:length length
806 #:type type
807 #:max max
808 #:min min
809 #:sparse sparse)))
810 (define (texture-filter n)
811 (match n
812 (9728 'nearest)
813 ((or #f 9729) 'linear)
814 ;; TODO: Support mip-mapping
815 ;; (9984 'nearest-mipmap-nearest)
816 ;; (9985 'linear-mipmap-nearest)
817 ;; (9986 'nearest-mipmap-linear)
818 ;; (9987 'linear-mipmap-linear)
819 (_ 'linear)))
820 (define (texture-wrap n)
821 (match n
822 (10496 'clamp)
823 ((or #f 10497) 'repeat)
824 (33069 'clamp-to-border)
825 (33071 'clamp-to-edge)))
826 (define (parse-texture obj images samplers)
827 (let ((image (vector-ref images (number-ref obj "source")))
828 (sampler
829 (vector-ref samplers (or (number-ref/optional obj "sampler") 0))))
830 (load-image (scope-file (string-ref image "uri"))
831 #:min-filter (texture-filter
832 (number-ref/optional sampler "minFilter"))
833 #:mag-filter (texture-filter
834 (number-ref/optional sampler "magFilter"))
835 #:wrap-s (texture-wrap (number-ref/optional sampler "wrapS"))
836 #:wrap-t (texture-wrap (number-ref/optional sampler "wrapT")))))
837 (define (parse-material obj textures)
838 (let* ((name (or (string-ref/optional obj "name") "anonymous"))
839 (pbrmr (or (object-ref/optional obj "pbrMetallicRoughness") '()))
840 (base-color-factor
841 (let ((v (or (number-array-ref/optional pbrmr "baseColorFactor")
842 #(1.0 1.0 1.0 1.0))))
843 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
844 (base-color-texture
845 (match (object-ref/optional pbrmr "baseColorTexture")
846 (#f null-texture)
847 (obj
848 (vector-ref textures (number-ref obj "index")))))
849 (metallic-factor
850 (or (number-ref/optional pbrmr "metallicFactor")
851 1.0))
852 (roughness-factor
853 (or (number-ref/optional pbrmr "roughnessFactor")
854 1.0))
855 (metallic-roughness-texture
856 (match (object-ref/optional pbrmr "metallicRoughnessTexture")
857 (#f null-texture)
858 (obj
859 (vector-ref textures (number-ref obj "index")))))
860 (normal-factor
861 (let ((v (or (array-ref/optional obj "normalFactor")
862 #(1.0 1.0 1.0))))
863 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
864 (normal-texture
865 (match (object-ref/optional obj "normalTexture")
866 (#f null-texture)
867 (obj (vector-ref textures (number-ref obj "index")))))
868 (occlusion-factor
869 (let ((v (or (array-ref/optional obj "occlusionFactor")
870 #(1.0 1.0 1.0))))
871 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
872 (occlusion-texture
873 (match (object-ref/optional obj "occlusionTexture")
874 (#f null-texture)
875 (obj (vector-ref textures (number-ref obj "index")))))
876 (emissive-factor
877 (let ((v (or (array-ref/optional obj "emissiveFactor")
878 #(1.0 1.0 1.0))))
879 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
880 (emissive-texture
881 (match (object-ref/optional obj "emissiveTexture")
882 (#f null-texture)
883 (obj (vector-ref textures (number-ref obj "index")))))
884 (alpha-mode (match (or (string-ref/optional obj "alphaMode")
885 "BLEND")
886 ("OPAQUE" 'opaque)
887 ("MASK" 'mask)
888 ("BLEND" 'blend)))
889 (alpha-cutoff (or (number-ref/optional obj "alphaCutoff") 0.5))
890 (double-sided? (boolean-ref/optional obj "doubleSided"))
891 (extensions (object-ref/optional obj "extensions"))
892 (extras (assoc-ref obj "extras")))
893 (make-pbr-material #:name name
894 #:base-color-factor base-color-factor
895 #:base-color-texture base-color-texture
896 #:metallic-factor metallic-factor
897 #:roughness-factor roughness-factor
898 #:metallic-roughness-texture metallic-roughness-texture
899 #:normal-factor normal-factor
900 #:normal-texture normal-texture
901 #:occlusion-factor occlusion-factor
902 #:occlusion-texture occlusion-texture
903 #:emissive-factor emissive-factor
904 #:emissive-texture emissive-texture
905 #:alpha-mode alpha-mode
906 #:alpha-cutoff alpha-cutoff
907 #:double-sided? double-sided?)))
908 (define (attribute-name->index name)
909 (let ((shader (load-pbr-shader)))
910 (match name
911 ("POSITION"
912 (attribute-location
913 (hash-ref (shader-attributes shader) "position")))
914 ("NORMAL" 1)
915 ("TANGENT" 2)
916 ("TEXCOORD_0"
917 (attribute-location
918 (hash-ref (shader-attributes shader) "texcoord0")))
919 ("TEXCOORD_1" 4)
920 ("COLOR_0" 5)
921 ("JOINTS_0" 6)
922 ("WEIGHTS_0" 7))))
923 (define (parse-primitive obj materials accessors)
924 (let ((attributes (map (match-lambda
925 ((name . n)
926 (cons (attribute-name->index name)
927 (vector-ref accessors n))))
928 (object-ref obj "attributes")))
929 (indices (match (number-ref/optional obj "indices")
930 (#f #f)
931 (n (vector-ref accessors n))))
932 ;; TODO: Set a default material when none is given.
933 (material (match (number-ref/optional obj "material")
934 (#f #f)
935 (n (vector-ref materials n))))
936 (mode (match (or (number-ref/optional obj "mode") 4)
937 (0 'points)
938 (1 'lines)
939 (2 'line-loop)
940 (3 'line-strip)
941 (4 'triangles)
942 (5 'triangle-strip)
943 (6 'triangle-fan)))
944 ;; TODO: Support morph targets.
945 (targets #f))
946 (make-primitive "primitive"
947 (make-vertex-array #:indices indices
948 #:attributes attributes
949 #:mode mode)
950 material)))
951 (define (parse-mesh obj materials accessors)
952 (let ((name (or (string-ref/optional obj "name") "anonymous"))
953 (primitives
954 (map (lambda (obj)
955 (parse-primitive obj materials accessors))
956 (vector->list (array-ref obj "primitives"))))
957 (weights (number-array-ref/optional obj "weights")))
958 ;; TODO: Support weights.
959 (make-mesh name primitives)))
960 (define (parse-node obj parse-child meshes)
961 ;; TODO: Parse all fields of nodes.
962 (let ((name (or (string-ref/optional obj "name") "anonymous"))
963 ;; TODO: Parse camera.
964 (camera #f)
965 ;; TODO: Parse skin.
966 (skin #f)
967 (matrix (or (matrix-ref/optional obj "matrix")
968 (make-identity-matrix4)))
969 (mesh (match (number-ref/optional obj "mesh")
970 (#f #f)
971 (n (vector-ref meshes n))))
972 ;; TODO: Parse rotation, scale, translation
973 (rotation #f)
974 (scale #f)
975 (translation #f)
976 ;; TODO: Parse weights.
977 (weights #f)
978 (children (map parse-child
979 (vector->list
980 (or (array-ref/optional obj "children")
981 #())))))
982 (make-scene-node #:name name
983 #:children children
984 #:matrix matrix
985 #:mesh mesh)))
986 (define (parse-nodes array meshes)
987 (define nodes (make-vector (vector-length array) #f))
988 (define (parse-node* i)
989 (let ((node (vector-ref nodes i)))
990 (or node
991 (let ((node (parse-node (vector-ref array i)
992 parse-node*
993 meshes)))
994 (vector-set! nodes i node)
995 node))))
996 (let loop ((i 0))
997 (when (< i (vector-length array))
998 (parse-node* i)
999 (loop (+ i 1))))
1000 nodes)
1001 (define (parse-scene obj nodes)
1002 (let ((name (or (string-ref/optional obj "name") "anonymous"))
1003 (children
1004 (map (lambda (i) (vector-ref nodes i))
1005 (vector->list
1006 (or (number-array-ref/optional obj "nodes")
1007 #())))))
1008 (make-scene-node #:name name #:children children)))
1009 (define (vector-map proc v)
1010 (let ((new-v (make-vector (vector-length v))))
1011 (let loop ((i 0))
1012 (when (< i (vector-length v))
1013 (vector-set! new-v i (proc (vector-ref v i)))
1014 (loop (+ i 1))))
1015 new-v))
1016 (call-with-input-file file-name
1017 (lambda (port)
1018 (let* ((tree (read-json port))
1019 (asset (object-ref tree "asset"))
1020 (version (string-ref asset "version"))
1021 (copyright (string-ref/optional asset "copyright"))
1022 (generator (string-ref/optional asset "generator"))
1023 (minimum-version (string-ref/optional asset "minVersion"))
1024 (extensions (object-ref/optional asset "extensions"))
1025 ;; TODO: Figure out how to parse extras in a user-defined way
1026 (extras (assoc-ref asset "extras"))
1027 (buffers (vector-map parse-buffer
1028 (or (assoc-ref tree "buffers") #())))
1029 (buffer-views (vector-map (lambda (obj)
1030 (parse-buffer-view obj buffers))
1031 (or (assoc-ref tree "bufferViews") #())))
1032 (accessors (vector-map (lambda (obj)
1033 (parse-accessor obj buffer-views))
1034 (or (assoc-ref tree "accessors") #())))
1035 (images (or (assoc-ref tree "images") #()))
1036 (samplers (or (assoc-ref tree "samplers") #(())))
1037 (textures (vector-map (lambda (obj)
1038 (parse-texture obj images samplers))
1039 (or (assoc-ref tree "textures") #())))
1040 (materials (vector-map (lambda (obj)
1041 (parse-material obj textures))
1042 (or (assoc-ref tree "materials") #())))
1043 (meshes (vector-map (lambda (obj)
1044 (parse-mesh obj materials accessors))
1045 (or (assoc-ref tree "meshes") #())))
1046 (nodes (parse-nodes (or (assoc-ref tree "nodes") #()) meshes))
1047 (scenes (map (lambda (obj)
1048 (parse-scene obj nodes))
1049 (vector->list
1050 (or (assoc-ref tree "scenes") #()))))
1051 (default-scene (list-ref scenes
1052 (or (number-ref/optional tree "scene")
1053 0))))
1054 (unless (string=? version "2.0")
1055 (error "unsupported glTF version" version))
1056 (make-model #:name (basename file-name)
1057 #:scenes (list default-scene)
1058 #:render-state
1059 (make-render-state #:shader (load-pbr-shader)
1060 #:renderer draw-primitive/pbr))))))