graphics: model: Fix buffer view index/vertex logic.

This is the gnarliest part of the glTF spec I've run into yet.

1 files changed, 26 insertions, 12 deletions

diff --git a/chickadee/graphics/model.scm b/chickadee/graphics/model.scm
index 152cee9..cae9752 100644
--- a/chickadee/graphics/model.scm
+++ b/chickadee/graphics/model.scm
@@ -42,6 +42,7 @@
   #:use-module (ice-9 rdelim)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module ((srfi srfi-43) #:select (vector-every))
@@ -761,15 +762,18 @@
                   (else
                    (make-bytevector length)))))
       data))
-  (define (parse-buffer-view obj buffers)
+  (define (parse-buffer-view obj i buffers index-ids)
     (let ((name (string-ref/optional obj "name"))
           (data (vector-ref buffers (number-ref obj "buffer")))
           (offset (or (number-ref/optional obj "byteOffset") 0))
           (length (number-ref obj "byteLength"))
           (stride (number-ref/optional obj "byteStride"))
-          (target (match (or (number-ref/optional obj "target") 34962)
-                    (34962 'vertex)
-                    (34963 'index)))
+          ;; XXX: The "target" key is useless.  It may be present, it
+          ;; may not be.  The only way to know for sure if we are
+          ;; dealing with vertex or index data is to scan all mesh
+          ;; primitives and see which buffer views are used for
+          ;; indices.
+          (target (if (memv i index-ids) 'index 'vertex))
           (extensions (object-ref/optional obj "extensions"))
           (extras (assoc-ref obj "extras")))
       (make-buffer data
@@ -1057,10 +1061,18 @@
                  (or (number-array-ref/optional obj "nodes")
                      #())))))
       (make-model-node #:name name #:children children)))
+  (define (index-ids tree)
+    (append-map (lambda (mesh)
+                  (filter-map (lambda (primitive)
+                                (assoc-ref primitive "indices"))
+                              (vector->list
+                               (or (assoc-ref mesh "primitives") #()))))
+                (vector->list
+                 (or (assoc-ref tree "meshes") #()))))
   (define (vector-map proc v)
     (let ((new-v (make-vector (vector-length v))))
       (for-range ((i (vector-length v)))
-        (vector-set! new-v i (proc (vector-ref v i))))
+        (vector-set! new-v i (proc (vector-ref v i) i)))
       new-v))
   (call-with-input-file file-name
     (lambda (port)
@@ -1073,23 +1085,25 @@
              (extensions (object-ref/optional asset "extensions"))
              ;; TODO: Figure out how to parse extras in a user-defined way
              (extras (assoc-ref asset "extras"))
-             (buffers (vector-map parse-buffer
+             (buffers (vector-map (lambda (obj i)
+                                    (parse-buffer obj))
                                   (or (assoc-ref tree "buffers") #())))
-             (buffer-views (vector-map (lambda (obj)
-                                         (parse-buffer-view obj buffers))
+             (indices (index-ids tree))
+             (buffer-views (vector-map (lambda (obj i)
+                                         (parse-buffer-view obj i buffers indices))
                                        (or (assoc-ref tree "bufferViews") #())))
-             (accessors (vector-map (lambda (obj)
+             (accessors (vector-map (lambda (obj i)
                                       (parse-accessor obj buffer-views))
                                     (or (assoc-ref tree "accessors") #())))
              (images (or (assoc-ref tree "images") #()))
              (samplers (or (assoc-ref tree "samplers") #(())))
-             (textures (vector-map (lambda (obj)
+             (textures (vector-map (lambda (obj i)
                                      (parse-texture obj images samplers))
                                    (or (assoc-ref tree "textures") #())))
-             (materials (vector-map (lambda (obj)
+             (materials (vector-map (lambda (obj i)
                                       (parse-material obj textures))
                                     (or (assoc-ref tree "materials") #())))
-             (meshes (vector-map (lambda (obj)
+             (meshes (vector-map (lambda (obj i)
                                    (parse-mesh obj materials accessors))
                                  (or (assoc-ref tree "meshes") #())))
              (nodes (parse-nodes (or (assoc-ref tree "nodes") #()) meshes))