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