render: model: Invert texture V coords when parsing OBJ files.
[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 ;; OBJ texture coordinates use the
381 ;; top-left of the image as the origin,
382 ;; but OpenGL uses the bottom-left, so
383 ;; all V values must be inverted.
384 (vec2 (string->number u)
385 (- 1.0 (string->number v))))
386 ((u v w)
387 (vec2 (string->number u)
388 (- 1.0 (string->number v))))
389 (_
390 (parse-error "wrong number of texcoord arguments" args)))))
391 (define (parse-normal args)
392 (array-list-push! normals
393 (match args
394 ((i j k)
395 (vec3 (string->number i)
396 (string->number j)
397 (string->number k)))
398 (_
399 (parse-error "wrong number of normal arguments" args)))))
400 (define (parse-face-index arg)
401 (- (string->number arg) 1))
402 (define (parse-face-element arg)
403 (match (string-split arg #\/)
404 ((v)
405 (list (parse-face-index v) #f #f))
406 ((v t)
407 (list (parse-face-index v)
408 (parse-face-index t)
409 #f))
410 ((v "" n)
411 (list (parse-face-index v)
412 #f
413 (parse-face-index n)))
414 ((v t n)
415 (list (parse-face-index v)
416 (parse-face-index t)
417 (parse-face-index n)))
418 (_
419 (parse-error "invalid face syntax" (list arg)))))
420 (define (indices-for-material material)
421 (or (hash-ref face-indices-map material)
422 (let ((new-indices (make-array-list)))
423 (hash-set! face-indices-map material new-indices)
424 new-indices)))
425 (define (deduplicate-face-element e)
426 ;; Faces are often redundant, so we deduplicate in order to
427 ;; make the VBOs we build later as small as possible.
428 (or (hash-ref face-map e)
429 (let ((i (array-list-size faces)))
430 (array-list-push! faces (parse-face-element e))
431 (hash-set! face-map e i)
432 i)))
433 (define (push-face material e)
434 (array-list-push! (indices-for-material material)
435 (deduplicate-face-element e)))
436 (define (parse-face args material)
437 (match args
438 ;; A single triangle. Ah, life is so simple...
439 ((a b c)
440 (push-face material a)
441 (push-face material b)
442 (push-face material c))
443 ;; A quadrilateral. Needs to be split into 2 triangles.
444 ;;
445 ;; d-------c
446 ;; | /|
447 ;; | / |
448 ;; | / |
449 ;; |/ |
450 ;; a-------b
451 ((a b c d)
452 ;; triangle 1: a b c
453 (push-face material a)
454 (push-face material b)
455 (push-face material c)
456 ;; triangle 2: a c d
457 (push-face material a)
458 (push-face material c)
459 (push-face material d))
460 ;; 3 or more triangles. Interpret as a strip of triangles
461 ;; moving from right to left (because counter-clockwise
462 ;; winding) like this:
463 ;;
464 ;; h-------f-------d-------c
465 ;; | /| /| /|
466 ;; | / | / | / |
467 ;; | / | / | / |
468 ;; |/ |/ |/ |
469 ;; g-------e-------a-------b
470 ;;
471 ;; ... and so on for however many face elements there are.
472 ;; Every other triangle is flipped over, hence the 'flip?'
473 ;; flag in the loop below.
474 ((a b . rest)
475 (let loop ((a a)
476 (b b)
477 (args rest)
478 (flip? #f))
479 (match args
480 (() #t)
481 ((c . rest)
482 (push-face material a)
483 (push-face material b)
484 (push-face material c)
485 (if flip?
486 (loop c a rest #f)
487 (loop a c rest #t))))))
488 (_
489 (parse-error "invalid face" args))))
490 ;; Register default material
491 (hash-set! material-map "default" default-phong-material)
492 ;; Parse file.
493 (let loop ((material "default"))
494 (match (read-line port)
495 ((? eof-object?)
496 #f)
497 (line
498 (match (delete "" (string-split line char-set:whitespace))
499 ((or () ("#" . _)) ; ignore comments and blank lines
500 (loop material))
501 (("f" . args)
502 (parse-face args material)
503 (loop material))
504 (("g" . _) ; ignore group name for now
505 (loop material))
506 (("mtllib" mtl-file-name)
507 (load-mtl (scope-file mtl-file-name))
508 (loop material))
509 (("o" . _) ;ignore object name for now
510 (loop material))
511 (("s" . _) ; ignore smoothing group for now
512 (loop material))
513 (("usemtl" new-material)
514 (loop new-material))
515 (("v" . args)
516 (parse-vertex args)
517 (loop material))
518 (("vn" . args)
519 (parse-normal args)
520 (loop material))
521 (("vt" . args)
522 (parse-texcoord args)
523 (loop material))
524 (data
525 (format (current-error-port)
526 "warning: ~a:~d: unsupported OBJ data: ~s~%"
527 file-name
528 (port-line port)
529 data)
530 (loop material))))))
531 ;; Build a vertex array for all the faces of a single
532 ;; material.
533 ;;
534 ;; XXX: We assume there is normal and texture data. Models
535 ;; that don't have one or both will still use up as much
536 ;; memory as if they did. Maybe that's just fine? Dunno.
537 (define (make-primitive-for-material material)
538 (let* ((face-indices (indices-for-material material))
539 (vertex-count (array-list-size faces))
540 (index-count (array-list-size face-indices))
541 (stride 8)
542 (mesh-data (make-f32vector (* vertex-count stride)))
543 (mesh-indices (make-u32vector index-count))
544 (null-texcoord (vec2 0.0 0.0))
545 (null-normal (vec3 0.0 0.0 0.0)))
546 ;; The mesh vertex data is packed like so:
547 ;; - 3 floats for vertex
548 ;; - 2 floats for texture coordinate
549 ;; - 3 floats for normal
550 ;; - repeat for each face
551 (let loop ((i 0))
552 (when (< i vertex-count)
553 (let ((offset (* i stride)))
554 (match (array-list-ref faces i)
555 ((vert-index tex-index norm-index)
556 ;; Vertex
557 (let ((v (array-list-ref vertices vert-index)))
558 (f32vector-set! mesh-data offset (vec3-x v))
559 (f32vector-set! mesh-data (+ offset 1) (vec3-y v))
560 (f32vector-set! mesh-data (+ offset 2) (vec3-z v)))
561 ;; Texture coordinate
562 (let ((t (if tex-index
563 (array-list-ref texcoords tex-index)
564 null-texcoord)))
565 (f32vector-set! mesh-data (+ offset 3) (vec2-x t))
566 (f32vector-set! mesh-data (+ offset 4) (vec2-y t)))
567 ;; Normal
568 (let ((n (if norm-index
569 (array-list-ref normals norm-index)
570 null-normal)))
571 (f32vector-set! mesh-data (+ offset 5) (vec3-x n))
572 (f32vector-set! mesh-data (+ offset 6) (vec3-y n))
573 (f32vector-set! mesh-data (+ offset 7) (vec3-z n))))))
574 (loop (+ i 1))))
575 ;; Pack indices.
576 (let loop ((i 0))
577 (when (< i index-count)
578 (u32vector-set! mesh-indices i (array-list-ref face-indices i))
579 (loop (+ i 1))))
580 ;; Construct vertex array.
581 ;; TODO: Add names to buffers and views.
582 (let* ((index-buffer (make-buffer mesh-indices #:target 'index))
583 (index-view (make-buffer-view #:type 'scalar
584 #:component-type 'unsigned-int
585 #:buffer index-buffer))
586 (data-buffer (make-buffer mesh-data #:stride (* stride 4)))
587 (vertex-view (make-buffer-view #:type 'vec3
588 #:component-type 'float
589 #:buffer data-buffer))
590 (texcoord-view (make-buffer-view #:type 'vec2
591 #:component-type 'float
592 #:buffer data-buffer
593 #:offset 12))
594 (normal-view (make-buffer-view #:type 'vec3
595 #:component-type 'float
596 #:buffer data-buffer
597 #:offset 20)))
598 (make-primitive material
599 (make-vertex-array
600 #:indices index-view
601 #:attributes `((0 . ,vertex-view)
602 (1 . ,texcoord-view)
603 (2 . ,normal-view)))
604 (or (hash-ref material-map material)
605 (hash-ref material-map "default"))))))
606 ;; Construct a mesh by composing primitives. One primitive
607 ;; per material.
608 (let* ((model-name (basename file-name))
609 (mesh (make-mesh model-name
610 (hash-fold (lambda (material indices memo)
611 ;; It's possible that a material has
612 ;; no data associated with it, so we
613 ;; drop those.
614 (if (array-list-empty? indices)
615 memo
616 (cons (make-primitive-for-material material)
617 memo)))
618 '()
619 face-indices-map)))
620 (scene (make-scene-node #:name model-name
621 #:mesh mesh)))
622 (make-model #:name model-name
623 #:scenes (list scene)
624 #:render-state
625 (make-render-state #:shader (load-phong-shader)
626 #:renderer draw-primitive/phong)))))))
627
628 \f
629 ;;;
630 ;;; glTF 2.0
631 ;;;
632
633 (define (load-gltf file-name)
634 (define (object-ref obj key)
635 (let ((value (assoc-ref obj key)))
636 (unless (pair? value)
637 (error "expected object for key" key value))
638 value))
639 (define (object-ref/optional obj key)
640 (let ((value (assoc-ref obj key)))
641 (unless (or (not value) (pair? value))
642 (error "expected object for optional key" key value))
643 value))
644 (define (array-ref obj key)
645 (let ((value (assoc-ref obj key)))
646 (unless (vector? value)
647 (error "expected array for key" key value))
648 value))
649 (define (array-ref/optional obj key)
650 (let ((value (assoc-ref obj key)))
651 (unless (or (not value) (vector? value))
652 (error "expected array for optional key" key value))
653 value))
654 (define (string-ref obj key)
655 (let ((value (assoc-ref obj key)))
656 (unless (string? value)
657 (error "expected string for key" key value))
658 value))
659 (define (string-ref/optional obj key)
660 (let ((value (assoc-ref obj key)))
661 (unless (or (not value) (string? value))
662 (error "expected string for optional key" key value))
663 value))
664 (define (number-ref obj key)
665 (let ((value (assoc-ref obj key)))
666 (unless (number? value)
667 (error "expected number for key" key value))
668 value))
669 (define (number-ref/optional obj key)
670 (let ((value (assoc-ref obj key)))
671 (unless (or (not value) (number? value))
672 (error "expected number for key" key value))
673 value))
674 (define (boolean-ref/optional obj key)
675 (let ((value (assoc-ref obj key)))
676 (unless (boolean? value)
677 (error "expected boolean for key" key value))
678 value))
679 (define (number-array-ref/optional obj key)
680 (let ((value (assoc-ref obj key)))
681 (unless (or (not value)
682 (and (vector? value) (vector-every number? value)))
683 (error "expected numeric array for key" key value))
684 value))
685 (define (matrix-ref/optional obj key)
686 (let ((value (assoc-ref obj key)))
687 (cond
688 ((not value) #f)
689 ((and (vector? value)
690 (= (vector-length value) 16)
691 (vector-every number? value))
692 ;; glTF matrices are in column-major order.
693 (make-matrix4 (vector-ref value 0)
694 (vector-ref value 4)
695 (vector-ref value 8)
696 (vector-ref value 12)
697 (vector-ref value 1)
698 (vector-ref value 5)
699 (vector-ref value 9)
700 (vector-ref value 13)
701 (vector-ref value 2)
702 (vector-ref value 6)
703 (vector-ref value 10)
704 (vector-ref value 14)
705 (vector-ref value 3)
706 (vector-ref value 7)
707 (vector-ref value 11)
708 (vector-ref value 15)))
709 (else
710 (error "expected 4x4 matrix for key" key value)))))
711 (define (assert-color v)
712 (if (and (= (vector-length v) 4)
713 (vector-every (lambda (x) (and (>= x 0.0) (<= x 1.0))) v))
714 (make-color (vector-ref v 0)
715 (vector-ref v 1)
716 (vector-ref v 2)
717 (vector-ref v 3))
718 (error "not a color vector" v)))
719 (define scope-file
720 (let ((gltf-root (dirname
721 (if (absolute-file-name? file-name)
722 file-name
723 (string-append (getcwd) "/" file-name)))))
724 (lambda (other-file)
725 (if (absolute-file-name? other-file)
726 other-file
727 (string-append gltf-root "/" other-file)))))
728 (define (parse-buffer obj)
729 ;; TODO: support base64 encoded buffer data as uri
730 ;; TODO: support glb-stored buffers:
731 ;; https://github.com/KhronosGroup/glTF/blob/master/specification/2.0/README.md#glb-stored-buffer
732 (let* ((uri (string-ref/optional obj "uri"))
733 (length (number-ref obj "byteLength"))
734 (name (or (string-ref/optional obj "name") "anonymous"))
735 (extensions (object-ref/optional obj "extensions"))
736 (extras (assoc-ref obj "extras"))
737 (data (if uri
738 (call-with-input-file (scope-file uri)
739 (lambda (port)
740 (get-bytevector-n port length)))
741 (make-bytevector length))))
742 data))
743 (define (parse-buffer-view obj buffers)
744 (let ((name (string-ref/optional obj "name"))
745 (data (vector-ref buffers (number-ref obj "buffer")))
746 (offset (or (number-ref/optional obj "byteOffset") 0))
747 (length (number-ref obj "byteLength"))
748 (stride (number-ref/optional obj "byteStride"))
749 (target (match (or (number-ref/optional obj "target") 34962)
750 (34962 'vertex)
751 (34963 'index)))
752 (extensions (object-ref/optional obj "extensions"))
753 (extras (assoc-ref obj "extras")))
754 (make-buffer data
755 #:name name
756 #:offset offset
757 #:length length
758 #:stride stride
759 #:target target)))
760 (define (parse-accessor obj buffer-views)
761 (define (type-length type)
762 (match type
763 ('scalar 1)
764 ('vec2 2)
765 ('vec3 3)
766 ('vec4 4)
767 ('mat2 4)
768 ('mat3 9)
769 ('mat4 16)))
770 (let ((name (or (string-ref/optional obj "name") "anonymous"))
771 (view (match (number-ref/optional obj "bufferView")
772 (#f #f)
773 (n (vector-ref buffer-views n))))
774 (offset (or (number-ref/optional obj "byteOffset") 0))
775 (component-type (match (number-ref obj "componentType")
776 (5120 'byte)
777 (5121 'unsigned-byte)
778 (5122 'short)
779 (5123 'unsigned-short)
780 (5125 'unsigned-int)
781 (5126 'float)))
782 (normalized? (boolean-ref/optional obj "normalized"))
783 (length (number-ref obj "count"))
784 (type (match (string-ref obj "type")
785 ("SCALAR" 'scalar)
786 ("VEC2" 'vec2)
787 ("VEC3" 'vec3)
788 ("VEC4" 'vec4)
789 ("MAT2" 'mat2)
790 ("MAT3" 'mat3)
791 ("MAT4" 'mat4)))
792 (max (number-array-ref/optional obj "max"))
793 (min (number-array-ref/optional obj "min"))
794 (sparse (object-ref/optional obj "sparse"))
795 (extensions (object-ref/optional obj "extensions"))
796 (extras (assoc-ref obj "extras")))
797 (unless (>= length 1)
798 (error "count must be greater than 0" length))
799 (when (and (vector? max)
800 (not (= (vector-length max) (type-length type))))
801 (error "not enough elements for max" max type))
802 (when (and (vector? min)
803 (not (= (vector-length min) (type-length type))))
804 (error "not enough elements for min" min type))
805 (make-buffer-view #:name name
806 #:buffer view
807 #:offset offset
808 #:component-type component-type
809 #:normalized? normalized?
810 #:length length
811 #:type type
812 #:max max
813 #:min min
814 #:sparse sparse)))
815 (define (texture-filter n)
816 (match n
817 (9728 'nearest)
818 ((or #f 9729) 'linear)
819 ;; TODO: Support mip-mapping
820 ;; (9984 'nearest-mipmap-nearest)
821 ;; (9985 'linear-mipmap-nearest)
822 ;; (9986 'nearest-mipmap-linear)
823 ;; (9987 'linear-mipmap-linear)
824 (_ 'linear)))
825 (define (texture-wrap n)
826 (match n
827 (10496 'clamp)
828 ((or #f 10497) 'repeat)
829 (33069 'clamp-to-border)
830 (33071 'clamp-to-edge)))
831 (define (parse-texture obj images samplers)
832 (let ((image (vector-ref images (number-ref obj "source")))
833 (sampler
834 (vector-ref samplers (or (number-ref/optional obj "sampler") 0))))
835 (load-image (scope-file (string-ref image "uri"))
836 #:min-filter (texture-filter
837 (number-ref/optional sampler "minFilter"))
838 #:mag-filter (texture-filter
839 (number-ref/optional sampler "magFilter"))
840 #:wrap-s (texture-wrap (number-ref/optional sampler "wrapS"))
841 #:wrap-t (texture-wrap (number-ref/optional sampler "wrapT")))))
842 (define (parse-material obj textures)
843 (let* ((name (or (string-ref/optional obj "name") "anonymous"))
844 (pbrmr (or (object-ref/optional obj "pbrMetallicRoughness") '()))
845 (base-color-factor
846 (let ((v (or (number-array-ref/optional pbrmr "baseColorFactor")
847 #(1.0 1.0 1.0 1.0))))
848 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
849 (base-color-texture
850 (match (object-ref/optional pbrmr "baseColorTexture")
851 (#f null-texture)
852 (obj
853 (vector-ref textures (number-ref obj "index")))))
854 (metallic-factor
855 (or (number-ref/optional pbrmr "metallicFactor")
856 1.0))
857 (roughness-factor
858 (or (number-ref/optional pbrmr "roughnessFactor")
859 1.0))
860 (metallic-roughness-texture
861 (match (object-ref/optional pbrmr "metallicRoughnessTexture")
862 (#f null-texture)
863 (obj
864 (vector-ref textures (number-ref obj "index")))))
865 (normal-factor
866 (let ((v (or (array-ref/optional obj "normalFactor")
867 #(1.0 1.0 1.0))))
868 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
869 (normal-texture
870 (match (object-ref/optional obj "normalTexture")
871 (#f null-texture)
872 (obj (vector-ref textures (number-ref obj "index")))))
873 (occlusion-factor
874 (let ((v (or (array-ref/optional obj "occlusionFactor")
875 #(1.0 1.0 1.0))))
876 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
877 (occlusion-texture
878 (match (object-ref/optional obj "occlusionTexture")
879 (#f null-texture)
880 (obj (vector-ref textures (number-ref obj "index")))))
881 (emissive-factor
882 (let ((v (or (array-ref/optional obj "emissiveFactor")
883 #(1.0 1.0 1.0))))
884 (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
885 (emissive-texture
886 (match (object-ref/optional obj "emissiveTexture")
887 (#f null-texture)
888 (obj (vector-ref textures (number-ref obj "index")))))
889 (alpha-mode (match (or (string-ref/optional obj "alphaMode")
890 "BLEND")
891 ("OPAQUE" 'opaque)
892 ("MASK" 'mask)
893 ("BLEND" 'blend)))
894 (alpha-cutoff (or (number-ref/optional obj "alphaCutoff") 0.5))
895 (double-sided? (boolean-ref/optional obj "doubleSided"))
896 (extensions (object-ref/optional obj "extensions"))
897 (extras (assoc-ref obj "extras")))
898 (make-pbr-material #:name name
899 #:base-color-factor base-color-factor
900 #:base-color-texture base-color-texture
901 #:metallic-factor metallic-factor
902 #:roughness-factor roughness-factor
903 #:metallic-roughness-texture metallic-roughness-texture
904 #:normal-factor normal-factor
905 #:normal-texture normal-texture
906 #:occlusion-factor occlusion-factor
907 #:occlusion-texture occlusion-texture
908 #:emissive-factor emissive-factor
909 #:emissive-texture emissive-texture
910 #:alpha-mode alpha-mode
911 #:alpha-cutoff alpha-cutoff
912 #:double-sided? double-sided?)))
913 (define (attribute-name->index name)
914 (let ((shader (load-pbr-shader)))
915 (match name
916 ("POSITION"
917 (attribute-location
918 (hash-ref (shader-attributes shader) "position")))
919 ("NORMAL" 1)
920 ("TANGENT" 2)
921 ("TEXCOORD_0"
922 (attribute-location
923 (hash-ref (shader-attributes shader) "texcoord0")))
924 ("TEXCOORD_1" 4)
925 ("COLOR_0" 5)
926 ("JOINTS_0" 6)
927 ("WEIGHTS_0" 7))))
928 (define (parse-primitive obj materials accessors)
929 (let ((attributes (map (match-lambda
930 ((name . n)
931 (cons (attribute-name->index name)
932 (vector-ref accessors n))))
933 (object-ref obj "attributes")))
934 (indices (match (number-ref/optional obj "indices")
935 (#f #f)
936 (n (vector-ref accessors n))))
937 ;; TODO: Set a default material when none is given.
938 (material (match (number-ref/optional obj "material")
939 (#f #f)
940 (n (vector-ref materials n))))
941 (mode (match (or (number-ref/optional obj "mode") 4)
942 (0 'points)
943 (1 'lines)
944 (2 'line-loop)
945 (3 'line-strip)
946 (4 'triangles)
947 (5 'triangle-strip)
948 (6 'triangle-fan)))
949 ;; TODO: Support morph targets.
950 (targets #f))
951 (make-primitive "primitive"
952 (make-vertex-array #:indices indices
953 #:attributes attributes
954 #:mode mode)
955 material)))
956 (define (parse-mesh obj materials accessors)
957 (let ((name (or (string-ref/optional obj "name") "anonymous"))
958 (primitives
959 (map (lambda (obj)
960 (parse-primitive obj materials accessors))
961 (vector->list (array-ref obj "primitives"))))
962 (weights (number-array-ref/optional obj "weights")))
963 ;; TODO: Support weights.
964 (make-mesh name primitives)))
965 (define (parse-node obj parse-child meshes)
966 ;; TODO: Parse all fields of nodes.
967 (let ((name (or (string-ref/optional obj "name") "anonymous"))
968 ;; TODO: Parse camera.
969 (camera #f)
970 ;; TODO: Parse skin.
971 (skin #f)
972 (matrix (or (matrix-ref/optional obj "matrix")
973 (make-identity-matrix4)))
974 (mesh (match (number-ref/optional obj "mesh")
975 (#f #f)
976 (n (vector-ref meshes n))))
977 ;; TODO: Parse rotation, scale, translation
978 (rotation #f)
979 (scale #f)
980 (translation #f)
981 ;; TODO: Parse weights.
982 (weights #f)
983 (children (map parse-child
984 (vector->list
985 (or (array-ref/optional obj "children")
986 #())))))
987 (make-scene-node #:name name
988 #:children children
989 #:matrix matrix
990 #:mesh mesh)))
991 (define (parse-nodes array meshes)
992 (define nodes (make-vector (vector-length array) #f))
993 (define (parse-node* i)
994 (let ((node (vector-ref nodes i)))
995 (or node
996 (let ((node (parse-node (vector-ref array i)
997 parse-node*
998 meshes)))
999 (vector-set! nodes i node)
1000 node))))
1001 (let loop ((i 0))
1002 (when (< i (vector-length array))
1003 (parse-node* i)
1004 (loop (+ i 1))))
1005 nodes)
1006 (define (parse-scene obj nodes)
1007 (let ((name (or (string-ref/optional obj "name") "anonymous"))
1008 (children
1009 (map (lambda (i) (vector-ref nodes i))
1010 (vector->list
1011 (or (number-array-ref/optional obj "nodes")
1012 #())))))
1013 (make-scene-node #:name name #:children children)))
1014 (define (vector-map proc v)
1015 (let ((new-v (make-vector (vector-length v))))
1016 (let loop ((i 0))
1017 (when (< i (vector-length v))
1018 (vector-set! new-v i (proc (vector-ref v i)))
1019 (loop (+ i 1))))
1020 new-v))
1021 (call-with-input-file file-name
1022 (lambda (port)
1023 (let* ((tree (read-json port))
1024 (asset (object-ref tree "asset"))
1025 (version (string-ref asset "version"))
1026 (copyright (string-ref/optional asset "copyright"))
1027 (generator (string-ref/optional asset "generator"))
1028 (minimum-version (string-ref/optional asset "minVersion"))
1029 (extensions (object-ref/optional asset "extensions"))
1030 ;; TODO: Figure out how to parse extras in a user-defined way
1031 (extras (assoc-ref asset "extras"))
1032 (buffers (vector-map parse-buffer
1033 (or (assoc-ref tree "buffers") #())))
1034 (buffer-views (vector-map (lambda (obj)
1035 (parse-buffer-view obj buffers))
1036 (or (assoc-ref tree "bufferViews") #())))
1037 (accessors (vector-map (lambda (obj)
1038 (parse-accessor obj buffer-views))
1039 (or (assoc-ref tree "accessors") #())))
1040 (images (or (assoc-ref tree "images") #()))
1041 (samplers (or (assoc-ref tree "samplers") #(())))
1042 (textures (vector-map (lambda (obj)
1043 (parse-texture obj images samplers))
1044 (or (assoc-ref tree "textures") #())))
1045 (materials (vector-map (lambda (obj)
1046 (parse-material obj textures))
1047 (or (assoc-ref tree "materials") #())))
1048 (meshes (vector-map (lambda (obj)
1049 (parse-mesh obj materials accessors))
1050 (or (assoc-ref tree "meshes") #())))
1051 (nodes (parse-nodes (or (assoc-ref tree "nodes") #()) meshes))
1052 (scenes (map (lambda (obj)
1053 (parse-scene obj nodes))
1054 (vector->list
1055 (or (assoc-ref tree "scenes") #()))))
1056 (default-scene (list-ref scenes
1057 (or (number-ref/optional tree "scene")
1058 0))))
1059 (unless (string=? version "2.0")
1060 (error "unsupported glTF version" version))
1061 (make-model #:name (basename file-name)
1062 #:scenes (list default-scene)
1063 #:render-state
1064 (make-render-state #:shader (load-pbr-shader)
1065 #:renderer draw-primitive/pbr))))))