path: root/chickadee/render/model.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2019 David Thompson <davet@gnu.org>
;;;
;;; Chickadee is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; Chickadee is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; 3D Model loading and rendering.
;;
;;; Code:

(define-module (chickadee render model)
  #:use-module (chickadee array-list)
  #:use-module (chickadee json)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math vector)
  #:use-module (chickadee render)
  #:use-module (chickadee render buffer)
  #:use-module (chickadee render color)
  #:use-module (chickadee render pbr)
  #:use-module (chickadee render phong)
  #:use-module (chickadee render shader)
  #:use-module (chickadee render texture)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-9)
  #:use-module ((srfi srfi-43) #:select (vector-every))
  #:export (model?
            draw-model
            load-obj
            load-gltf))


;;;
;;; Rendering State
;;;

(define-record-type <render-state>
  (%make-render-state shader renderer world-matrix view-matrix)
  render-state?
  (shader render-state-shader)
  (renderer render-state-renderer)
  (world-matrix render-state-world-matrix)
  (view-matrix render-state-view-matrix))

(define* (make-render-state #:key shader renderer)
  (%make-render-state shader renderer
                      (make-identity-matrix4)
                      (make-identity-matrix4)))

(define (render-state-reset! state)
  (matrix4-identity! (render-state-world-matrix state))
  (matrix4-identity! (render-state-view-matrix state)))

(define (render-state-world-matrix-mult! state matrix)
  (let ((world (render-state-world-matrix state)))
    (matrix4-mult! world world matrix)))

(define (render-state-view-matrix-mult! state matrix)
  (let ((view (render-state-view-matrix state)))
    (matrix4-mult! view view matrix)))


;;;
;;; Primitives
;;;

;; A piece of a mesh.  Represents a single draw call.
(define-record-type <primitive>
  (make-primitive name vertex-array material)
  primitive?
  (name primitive-name)
  (vertex-array primitive-vertex-array)
  (material primitive-material))

(define (draw-primitive/phong primitive state)
  (gpu-apply/phong (render-state-shader state)
                   (primitive-vertex-array primitive)
                   (primitive-material primitive)
                   (render-state-world-matrix state)
                   (render-state-view-matrix state)))

(define (draw-primitive/pbr primitive state)
  (gpu-apply/pbr (render-state-shader state)
                 (primitive-vertex-array primitive)
                 (primitive-material primitive)
                 (render-state-world-matrix state)
                 (render-state-view-matrix state)))


;;;
;;; Meshes
;;;

;; A complete 3D model composed of many primitives.
(define-record-type <mesh>
  (make-mesh name primitives)
  mesh?
  (name mesh-name)
  (primitives mesh-primitives))

(define (draw-mesh mesh state)
  (let ((render (render-state-renderer state)))
    (for-each (lambda (primitive) (render primitive state))
              (mesh-primitives mesh))))


;;;
;;; Scene Node
;;;

;; A tree of meshes with their own transformation matrices.
(define-record-type <scene-node>
  (%make-scene-node name mesh matrix children)
  node?
  (name scene-node-name)
  (mesh scene-node-mesh)
  (matrix scene-node-matrix)
  (children scene-node-children))

(define* (make-scene-node #:key
                          (name "anonymous")
                          mesh
                          (matrix (make-identity-matrix4))
                          (children '()))
  (%make-scene-node name mesh matrix children))

(define (draw-scene-node node state)
  ;; TODO: Apply push/pop model matrix stuff.
  (for-each (lambda (child)
              (draw-scene-node child state))
            (scene-node-children node))
  (let ((mesh (scene-node-mesh node)))
    (when mesh
      (draw-mesh mesh state))))


;;;
;;; Model
;;;

;; A collection of scenes and the associated information about *how*
;; to actually render the darn thing.
(define-record-type <model>
  (%make-model name scenes default-scene render-state)
  model?
  (name model-name)
  (scenes model-scenes)
  (default-scene model-default-scene)
  (render-state model-render-state))

(define* (make-model #:key name scenes (default-scene (car scenes)) render-state)
  (%make-model name scenes default-scene render-state))

(define (draw-model model model-matrix view-matrix)
  ;; TODO: Support drawing non-default scenes.
  (let ((state (model-render-state model)))
    (render-state-reset! state)
    (render-state-view-matrix-mult! state view-matrix)
    (render-state-world-matrix-mult! state model-matrix)
    (draw-scene-node (model-default-scene model) state)))


;;;
;;; OBJ Format
;;;

(define (load-obj file-name)
  (define (scope-file other-file)
    (string-append (dirname file-name) "/" other-file))
  (call-with-input-file file-name
    (lambda (port)
      (let ((vertices (make-array-list))
            (texcoords (make-array-list))
            (normals (make-array-list))
            (faces (make-array-list))
            (face-map (make-hash-table))
            (face-indices-map (make-hash-table))
            (material-map (make-hash-table)))
        (define (load-mtl mtl-file-name)
          (call-with-input-file mtl-file-name
            (lambda (port)
              (let loop ((name #f)
                         (ambient #f)
                         (diffuse #f)
                         (specular #f)
                         (shininess #f))
                (define (maybe-add-material)
                  (when name
                    (hash-set! material-map
                               name
                               (make-phong-material
                                #:name name
                                #:ambient ambient
                                #:diffuse diffuse
                                #:specular specular
                                #:shininess shininess))))
                (match (read-line port)
                  ((? eof-object?)
                   (maybe-add-material))
                  (line
                   (match (delete "" (string-split line char-set:whitespace))
                     ((or () ("#" . _)) ; ignore comments and blank lines
                      (loop name ambient diffuse specular shininess))
                     (("Ka" r g b)
                      (let ((new-ambient (vec3 (string->number r)
                                               (string->number g)
                                               (string->number b))))
                        (loop name new-ambient diffuse specular shininess)))
                     (("Kd" r g b)
                      (let ((new-diffuse (vec3 (string->number r)
                                               (string->number g)
                                               (string->number b))))
                        (loop name ambient new-diffuse specular shininess)))
                     (("Ks" r g b)
                      (let ((new-specular (vec3 (string->number r)
                                                (string->number g)
                                                (string->number b))))
                        (loop name ambient diffuse new-specular shininess)))
                     (("Ns" n)
                      (let ((new-exp (* (string->number n) 1.0))) ; force it to be a float
                        (loop name ambient diffuse specular new-exp)))
                     (("newmtl" new-name)
                      ;; Begin new material
                      (maybe-add-material)
                      (loop new-name
                            (vec3 0.0 0.0 0.0)
                            (vec3 0.0 0.0 0.0)
                            (vec3 0.0 0.0 0.0)
                            1.0))
                     (data
                      (format (current-error-port)
                              "warning: ~a:~d: unsupported MTL data: ~s~%"
                              mtl-file-name
                              (port-line port)
                              data)
                      (loop name ambient diffuse specular shininess)))))))))
        (define (parse-error message args)
          (apply error (format #f "OBJ parser error @ ~a:~d: ~a"
                         file-name
                         (port-line port)
                         message)
                 args))
        (define (parse-vertex args)
          (array-list-push! vertices
                            (match args
                              ((x y z)
                               (vec3 (string->number x)
                                     (string->number y)
                                     (string->number z)))
                              ;; TODO: handle w properly
                              ((x y z w)
                               (vec3 (string->number x)
                                     (string->number y)
                                     (string->number z)))
                              (_
                               (parse-error "wrong number of vertex arguments" args)))))
        (define (parse-texcoord args)
          ;; TODO: Handle w properly.
          (array-list-push! texcoords
                            (match args
                              ((u)
                               (vec2 (string->number u) 0.0))
                              ((u v)
                               (vec2 (string->number u) (string->number v)))
                              ((u v w)
                               (vec2 (string->number u)
                                     (string->number v)))
                              (_
                               (parse-error "wrong number of texcoord arguments" args)))))
        (define (parse-normal args)
          (array-list-push! normals
                            (match args
                              ((i j k)
                               (vec3 (string->number i)
                                     (string->number j)
                                     (string->number k)))
                              (_
                               (parse-error "wrong number of normal arguments" args)))))
        (define (parse-face-index arg)
          (- (string->number arg) 1))
        (define (parse-face-element arg)
          (match (string-split arg #\/)
            ((v)
             (list (parse-face-index v) #f #f))
            ((v t)
             (list (parse-face-index v)
                   (parse-face-index t)
                   #f))
            ((v "" n)
             (list (parse-face-index v)
                   #f
                   (parse-face-index n)))
            ((v t n)
             (list (parse-face-index v)
                   (parse-face-index t)
                   (parse-face-index n)))
            (_
             (parse-error "invalid face syntax" (list arg)))))
        (define (indices-for-material material)
          (or (hash-ref face-indices-map material)
              (let ((new-indices (make-array-list)))
                (hash-set! face-indices-map material new-indices)
                new-indices)))
        (define (parse-face args material)
          (match args
            ((and (_ _ _ . _) args)
             (for-each (lambda (e)
                         ;; Faces may very well be redundant, so we
                         ;; deduplicate in order to make the VBOs we
                         ;; build later as small as possible.
                         (let ((cached-index (hash-ref face-map e))
                               (face-indices (indices-for-material material)))
                           (if cached-index
                               (array-list-push! face-indices cached-index)
                               (let ((i (array-list-size faces)))
                                 (array-list-push! faces (parse-face-element e))
                                 (array-list-push! face-indices i)
                                 (hash-set! face-map e i)))))
                       args))
            (_
             (parse-error "wrong number of face arguments" args))))
        ;; Register default material
        (hash-set! material-map "default" default-phong-material)
        ;; Parse file.
        (let loop ((material "default"))
          (match (read-line port)
            ((? eof-object?)
             #f)
            (line
             (match (delete "" (string-split line char-set:whitespace))
               ((or () ("#" . _)) ; ignore comments and blank lines
                (loop material))
               (("f" . args)
                (parse-face args material)
                (loop material))
               (("g" . _) ; ignore
                (loop material))
               (("mtllib" mtl-file-name)
                (load-mtl (scope-file mtl-file-name))
                (loop material))
               (("s" . _) ; ignore
                (loop material))
               (("usemtl" new-material)
                (loop new-material))
               (("v" . args)
                (parse-vertex args)
                (loop material))
               (("vn" . args)
                (parse-normal args)
                (loop material))
               (("vt" . args)
                (parse-texcoord args)
                (loop material))
               (data
                (format (current-error-port)
                        "warning: ~a:~d: unsupported OBJ data: ~s~%"
                        file-name
                        (port-line port)
                        data)
                (loop material))))))
        ;; Build a vertex array for all the faces of a single
        ;; material.
        ;;
        ;; XXX: We assume there is normal and texture data.  Models
        ;; that don't have one or both will still use up as much
        ;; memory as if they did.  Maybe that's just fine?  Dunno.
        (define (make-primitive-for-material material)
          (let* ((face-indices (indices-for-material material))
                 (vertex-count (array-list-size faces))
                 (index-count (array-list-size face-indices))
                 (stride 8)
                 (mesh-data (make-f32vector (* vertex-count stride)))
                 (mesh-indices (make-u32vector index-count))
                 (null-texcoord (vec2 0.0 0.0))
                 (null-normal (vec3 0.0 0.0 0.0)))
            ;; The mesh vertex data is packed like so:
            ;;   - 3 floats for vertex
            ;;   - 2 floats for texture coordinate
            ;;   - 3 floats for normal
            ;;   - repeat for each face
            (let loop ((i 0))
              (when (< i vertex-count)
                (let ((offset (* i stride)))
                  (match (array-list-ref faces i)
                    ((vert-index tex-index norm-index)
                     ;; Vertex
                     (let ((v (array-list-ref vertices vert-index)))
                       (f32vector-set! mesh-data offset (vec3-x v))
                       (f32vector-set! mesh-data (+ offset 1) (vec3-y v))
                       (f32vector-set! mesh-data (+ offset 2) (vec3-z v)))
                     ;; Texture coordinate
                     (let ((t (if tex-index
                                  (array-list-ref texcoords tex-index)
                                  null-texcoord)))
                       (f32vector-set! mesh-data (+ offset 3) (vec2-x t))
                       (f32vector-set! mesh-data (+ offset 4) (vec2-y t)))
                     ;; Normal
                     (let ((n (if norm-index
                                  (array-list-ref normals norm-index)
                                  null-normal)))
                       (f32vector-set! mesh-data (+ offset 5) (vec3-x n))
                       (f32vector-set! mesh-data (+ offset 6) (vec3-y n))
                       (f32vector-set! mesh-data (+ offset 7) (vec3-z n))))))
                (loop (+ i 1))))
            ;; Pack indices.
            (let loop ((i 0))
              (when (< i index-count)
                (u32vector-set! mesh-indices i (array-list-ref face-indices i))
                (loop (+ i 1))))
            ;; Construct vertex array.
            ;; TODO: Add names to buffers and views.
            (let* ((index-buffer (make-buffer mesh-indices #:target 'index))
                   (index-view (make-buffer-view #:type 'scalar
                                                 #:component-type 'unsigned-int
                                                 #:buffer index-buffer))
                   (data-buffer (make-buffer mesh-data #:stride (* stride 4)))
                   (vertex-view (make-buffer-view #:type 'vec3
                                                  #:component-type 'float
                                                  #:buffer data-buffer))
                   (texcoord-view (make-buffer-view #:type 'vec2
                                                    #:component-type 'float
                                                    #:buffer data-buffer
                                                    #:offset 12))
                   (normal-view (make-buffer-view #:type 'vec3
                                                  #:component-type 'float
                                                  #:buffer data-buffer
                                                  #:offset 20)))
              (make-primitive material
                              (make-vertex-array
                               #:indices index-view
                               #:attributes `((0 . ,vertex-view)
                                              (1 . ,texcoord-view)
                                              (2 . ,normal-view)))
                              (or (hash-ref material-map material)
                                  (hash-ref material-map "default"))))))
        ;; Construct a mesh by composing primitives.  One primitive
        ;; per material.
        (let* ((model-name (basename file-name))
               (mesh (make-mesh model-name
                                (hash-fold (lambda (material indices memo)
                                             ;; It's possible that a material has
                                             ;; no data associated with it, so we
                                             ;; drop those.
                                             (if (array-list-empty? indices)
                                                 memo
                                                 (cons (make-primitive-for-material material)
                                                       memo)))
                                           '()
                                           face-indices-map)))
               (scene (make-scene-node #:name model-name
                                       #:mesh mesh)))
          (make-model #:name model-name
                      #:scenes (list scene)
                      #:render-state
                      (make-render-state #:shader (load-phong-shader)
                                         #:renderer draw-primitive/phong)))))))


;;;
;;; glTF 2.0
;;;

(define (load-gltf file-name)
  (define (object-ref obj key)
    (let ((value (assoc-ref obj key)))
      (unless (pair? value)
        (error "expected object for key" key value))
      value))
  (define (object-ref/optional obj key)
    (let ((value (assoc-ref obj key)))
      (unless (or (not value) (pair? value))
        (error "expected object for optional key" key value))
      value))
  (define (array-ref obj key)
    (let ((value (assoc-ref obj key)))
      (unless (vector? value)
        (error "expected array for key" key value))
      value))
  (define (array-ref/optional obj key)
    (let ((value (assoc-ref obj key)))
      (unless (or (not value) (vector? value))
        (error "expected array for optional key" key value))
      value))
  (define (string-ref obj key)
    (let ((value (assoc-ref obj key)))
      (unless (string? value)
        (error "expected string for key" key value))
      value))
  (define (string-ref/optional obj key)
    (let ((value (assoc-ref obj key)))
      (unless (or (not value) (string? value))
        (error "expected string for optional key" key value))
      value))
  (define (number-ref obj key)
    (let ((value (assoc-ref obj key)))
      (unless (number? value)
        (error "expected number for key" key value))
      value))
  (define (number-ref/optional obj key)
    (let ((value (assoc-ref obj key)))
      (unless (or (not value) (number? value))
        (error "expected number for key" key value))
      value))
  (define (boolean-ref/optional obj key)
    (let ((value (assoc-ref obj key)))
      (unless (boolean? value)
        (error "expected boolean for key" key value))
      value))
  (define (number-array-ref/optional obj key)
    (let ((value (assoc-ref obj key)))
      (unless (or (not value)
                  (and (vector? value) (vector-every number? value)))
        (error "expected numeric array for key" key value))
      value))
  (define (matrix-ref/optional obj key)
    (let ((value (assoc-ref obj key)))
      (cond
       ((not value) #f)
       ((and (vector? value)
             (= (vector-length value) 16)
             (vector-every number? value))
        ;; glTF matrices are in column-major order.
        (make-matrix4 (vector-ref value 0)
                      (vector-ref value 4)
                      (vector-ref value 8)
                      (vector-ref value 12)
                      (vector-ref value 1)
                      (vector-ref value 5)
                      (vector-ref value 9)
                      (vector-ref value 13)
                      (vector-ref value 2)
                      (vector-ref value 6)
                      (vector-ref value 10)
                      (vector-ref value 14)
                      (vector-ref value 3)
                      (vector-ref value 7)
                      (vector-ref value 11)
                      (vector-ref value 15)))
       (else
        (error "expected 4x4 matrix for key" key value)))))
  (define (assert-color v)
    (if (and (= (vector-length v) 4)
             (vector-every (lambda (x) (and (>= x 0.0) (<= x 1.0))) v))
        (make-color (vector-ref v 0)
                    (vector-ref v 1)
                    (vector-ref v 2)
                    (vector-ref v 3))
        (error "not a color vector" v)))
  (define scope-file
    (let ((gltf-root (dirname
                      (if (absolute-file-name? file-name)
                          file-name
                          (string-append (getcwd) "/" file-name)))))
      (lambda (other-file)
        (if (absolute-file-name? other-file)
            other-file
            (string-append gltf-root "/" other-file)))))
  (define (parse-buffer obj)
    ;; TODO: support base64 encoded buffer data as uri
    ;; TODO: support glb-stored buffers:
    ;;   https://github.com/KhronosGroup/glTF/blob/master/specification/2.0/README.md#glb-stored-buffer
    (let* ((uri (string-ref/optional obj "uri"))
           (length (number-ref obj "byteLength"))
           (name (or (string-ref/optional obj "name") "anonymous"))
           (extensions (object-ref/optional obj "extensions"))
           (extras (assoc-ref obj "extras"))
           (data (if uri
                     (call-with-input-file (scope-file uri)
                       (lambda (port)
                         (get-bytevector-n port length)))
                     (make-bytevector length))))
      data))
  (define (parse-buffer-view obj buffers)
    (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)))
          (extensions (object-ref/optional obj "extensions"))
          (extras (assoc-ref obj "extras")))
      (make-buffer data
                   #:name name
                   #:offset offset
                   #:length length
                   #:stride stride
                   #:target target)))
  (define (parse-accessor obj buffer-views)
    (define (type-length type)
      (match type
        ('scalar 1)
        ('vec2 2)
        ('vec3 3)
        ('vec4 4)
        ('mat2 4)
        ('mat3 9)
        ('mat4 16)))
    (let ((name (or (string-ref/optional obj "name") "anonymous"))
          (view (match (number-ref/optional obj "bufferView")
                  (#f #f)
                  (n (vector-ref buffer-views n))))
          (offset (or (number-ref/optional obj "byteOffset") 0))
          (component-type (match (number-ref obj "componentType")
                            (5120 'byte)
                            (5121 'unsigned-byte)
                            (5122 'short)
                            (5123 'unsigned-short)
                            (5125 'unsigned-int)
                            (5126 'float)))
          (normalized? (boolean-ref/optional obj "normalized"))
          (length (number-ref obj "count"))
          (type (match (string-ref obj "type")
                  ("SCALAR" 'scalar)
                  ("VEC2" 'vec2)
                  ("VEC3" 'vec3)
                  ("VEC4" 'vec4)
                  ("MAT2" 'mat2)
                  ("MAT3" 'mat3)
                  ("MAT4" 'mat4)))
          (max (number-array-ref/optional obj "max"))
          (min (number-array-ref/optional obj "min"))
          (sparse (object-ref/optional obj "sparse"))
          (extensions (object-ref/optional obj "extensions"))
          (extras (assoc-ref obj "extras")))
      (unless (>= length 1)
        (error "count must be greater than 0" length))
      (when (and (vector? max)
                 (not (= (vector-length max) (type-length type))))
        (error "not enough elements for max" max type))
      (when (and (vector? min)
                 (not (= (vector-length min) (type-length type))))
        (error "not enough elements for min" min type))
      (make-buffer-view #:name name
                        #:buffer view
                        #:offset offset
                        #:component-type component-type
                        #:normalized? normalized?
                        #:length length
                        #:type type
                        #:max max
                        #:min min
                        #:sparse sparse)))
  (define (texture-filter n)
    (match n
      (9728 'nearest)
      ((or #f 9729) 'linear)
      ;; TODO: Support mip-mapping
      ;; (9984 'nearest-mipmap-nearest)
      ;; (9985 'linear-mipmap-nearest)
      ;; (9986 'nearest-mipmap-linear)
      ;; (9987 'linear-mipmap-linear)
      (_ 'linear)))
  (define (texture-wrap n)
    (match n
      (10496 'clamp)
      ((or #f 10497) 'repeat)
      (33069 'clamp-to-border)
      (33071 'clamp-to-edge)))
  (define (parse-texture obj images samplers)
    (let ((image (vector-ref images (number-ref obj "source")))
          (sampler
           (vector-ref samplers (or (number-ref/optional obj "sampler") 0))))
      (load-image (scope-file (string-ref image "uri"))
                  #:min-filter (texture-filter
                                (number-ref/optional sampler "minFilter"))
                  #:mag-filter (texture-filter
                                (number-ref/optional sampler "magFilter"))
                  #:wrap-s (texture-wrap (number-ref/optional sampler "wrapS"))
                  #:wrap-t (texture-wrap (number-ref/optional sampler "wrapT")))))
  (define (parse-material obj textures)
    (let* ((name (or (string-ref/optional obj "name") "anonymous"))
           (pbrmr (or (object-ref/optional obj "pbrMetallicRoughness") '()))
           (base-color-factor
            (let ((v (or (number-array-ref/optional pbrmr "baseColorFactor")
                         #(1.0 1.0 1.0 1.0))))
              (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
           (base-color-texture
            (match (object-ref/optional pbrmr "baseColorTexture")
              (#f null-texture)
              (obj
               (vector-ref textures (number-ref obj "index")))))
           (metallic-factor
            (or (number-ref/optional pbrmr "metallicFactor")
                1.0))
           (roughness-factor
            (or (number-ref/optional pbrmr "roughnessFactor")
                1.0))
           (metallic-roughness-texture
            (match (object-ref/optional pbrmr "metallicRoughnessTexture")
              (#f null-texture)
              (obj
               (vector-ref textures (number-ref obj "index")))))
           (normal-factor
            (let ((v (or (array-ref/optional obj "normalFactor")
                         #(1.0 1.0 1.0))))
              (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
           (normal-texture
            (match (object-ref/optional obj "normalTexture")
              (#f null-texture)
              (obj (vector-ref textures (number-ref obj "index")))))
           (occlusion-factor
            (let ((v (or (array-ref/optional obj "occlusionFactor")
                         #(1.0 1.0 1.0))))
              (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
           (occlusion-texture
            (match (object-ref/optional obj "occlusionTexture")
              (#f null-texture)
              (obj (vector-ref textures (number-ref obj "index")))))
           (emissive-factor
            (let ((v (or (array-ref/optional obj "emissiveFactor")
                         #(1.0 1.0 1.0))))
              (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))))
           (emissive-texture
            (match (object-ref/optional obj "emissiveTexture")
              (#f null-texture)
              (obj (vector-ref textures (number-ref obj "index")))))
           (alpha-mode (match (or (string-ref/optional obj "alphaMode")
                                  "BLEND")
                         ("OPAQUE" 'opaque)
                         ("MASK" 'mask)
                         ("BLEND" 'blend)))
           (alpha-cutoff (or (number-ref/optional obj "alphaCutoff") 0.5))
           (double-sided? (boolean-ref/optional obj "doubleSided"))
           (extensions (object-ref/optional obj "extensions"))
           (extras (assoc-ref obj "extras")))
      (make-pbr-material #:name name
                         #:base-color-factor base-color-factor
                         #:base-color-texture base-color-texture
                         #:metallic-factor metallic-factor
                         #:roughness-factor roughness-factor
                         #:metallic-roughness-texture metallic-roughness-texture
                         #:normal-factor normal-factor
                         #:normal-texture normal-texture
                         #:occlusion-factor occlusion-factor
                         #:occlusion-texture occlusion-texture
                         #:emissive-factor emissive-factor
                         #:emissive-texture emissive-texture
                         #:alpha-mode alpha-mode
                         #:alpha-cutoff alpha-cutoff
                         #:double-sided? double-sided?)))
  (define (attribute-name->index name)
    (let ((shader (load-pbr-shader)))
      (match name
        ("POSITION"
         (attribute-location
          (hash-ref (shader-attributes shader) "position")))
        ("NORMAL" 1)
        ("TANGENT" 2)
        ("TEXCOORD_0"
         (attribute-location
          (hash-ref (shader-attributes shader) "texcoord0")))
        ("TEXCOORD_1" 4)
        ("COLOR_0" 5)
        ("JOINTS_0" 6)
        ("WEIGHTS_0" 7))))
  (define (parse-primitive obj materials accessors)
    (let ((attributes (map (match-lambda
                             ((name . n)
                              (cons (attribute-name->index name)
                                    (vector-ref accessors n))))
                           (object-ref obj "attributes")))
          (indices (match (number-ref/optional obj "indices")
                     (#f #f)
                     (n (vector-ref accessors n))))
          ;; TODO: Set a default material when none is given.
          (material (match (number-ref/optional obj "material")
                      (#f #f)
                      (n (vector-ref materials n))))
          (mode (match (or (number-ref/optional obj "mode") 4)
                  (0 'points)
                  (1 'lines)
                  (2 'line-loop)
                  (3 'line-strip)
                  (4 'triangles)
                  (5 'triangle-strip)
                  (6 'triangle-fan)))
          ;; TODO: Support morph targets.
          (targets #f))
      (make-primitive "primitive"
                      (make-vertex-array #:indices indices
                                         #:attributes attributes
                                         #:mode mode)
                      material)))
  (define (parse-mesh obj materials accessors)
    (let ((name (or (string-ref/optional obj "name") "anonymous"))
          (primitives
           (map (lambda (obj)
                  (parse-primitive obj materials accessors))
                (vector->list (array-ref obj "primitives"))))
          (weights (number-array-ref/optional obj "weights")))
      ;; TODO: Support weights.
      (make-mesh name primitives)))
  (define (parse-node obj parse-child meshes)
    ;; TODO: Parse all fields of nodes.
    (let ((name (or (string-ref/optional obj "name") "anonymous"))
          ;; TODO: Parse camera.
          (camera #f)
          ;; TODO: Parse skin.
          (skin #f)
          (matrix (or (matrix-ref/optional obj "matrix")
                      (make-identity-matrix4)))
          (mesh (match (number-ref/optional obj "mesh")
                  (#f #f)
                  (n (vector-ref meshes n))))
          ;; TODO: Parse rotation, scale, translation
          (rotation #f)
          (scale #f)
          (translation #f)
          ;; TODO: Parse weights.
          (weights #f)
          (children (map parse-child
                         (vector->list
                          (or (array-ref/optional obj "children")
                              #())))))
      (make-scene-node #:name name
                       #:children children
                       #:matrix matrix
                       #:mesh mesh)))
  (define (parse-nodes array meshes)
    (define nodes (make-vector (vector-length array) #f))
    (define (parse-node* i)
      (let ((node (vector-ref nodes i)))
        (or node
            (let ((node (parse-node (vector-ref array i)
                                    parse-node*
                                    meshes)))
              (vector-set! nodes i node)
              node))))
    (let loop ((i 0))
      (when (< i (vector-length array))
        (parse-node* i)
        (loop (+ i 1))))
    nodes)
  (define (parse-scene obj nodes)
    (let ((name (or (string-ref/optional obj "name") "anonymous"))
          (children
           (map (lambda (i) (vector-ref nodes i))
                (vector->list
                 (or (number-array-ref/optional obj "nodes")
                     #())))))
      (make-scene-node #:name name #:children children)))
  (define (vector-map proc v)
    (let ((new-v (make-vector (vector-length v))))
      (let loop ((i 0))
        (when (< i (vector-length v))
          (vector-set! new-v i (proc (vector-ref v i)))
          (loop (+ i 1))))
      new-v))
  (call-with-input-file file-name
    (lambda (port)
      (let* ((tree (read-json port))
             (asset (object-ref tree "asset"))
             (version (string-ref asset "version"))
             (copyright (string-ref/optional asset "copyright"))
             (generator (string-ref/optional asset "generator"))
             (minimum-version (string-ref/optional asset "minVersion"))
             (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
                                  (or (assoc-ref tree "buffers") #())))
             (buffer-views (vector-map (lambda (obj)
                                         (parse-buffer-view obj buffers))
                                       (or (assoc-ref tree "bufferViews") #())))
             (accessors (vector-map (lambda (obj)
                                      (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)
                                     (parse-texture obj images samplers))
                                   (or (assoc-ref tree "textures") #())))
             (materials (vector-map (lambda (obj)
                                      (parse-material obj textures))
                                    (or (assoc-ref tree "materials") #())))
             (meshes (vector-map (lambda (obj)
                                   (parse-mesh obj materials accessors))
                                 (or (assoc-ref tree "meshes") #())))
             (nodes (parse-nodes (or (assoc-ref tree "nodes") #()) meshes))
             (scenes (map (lambda (obj)
                            (parse-scene obj nodes))
                          (vector->list
                           (or (assoc-ref tree "scenes") #()))))
             (default-scene (list-ref scenes
                                      (or (number-ref/optional tree "scene")
                                          0))))
        (unless (string=? version "2.0")
          (error "unsupported glTF version" version))
        (make-model #:name (basename file-name)
                    #:scenes (list default-scene)
                    #:render-state
                    (make-render-state #:shader (load-pbr-shader)
                                       #:renderer draw-primitive/pbr))))))