path: root/chickadee/graphics/model.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2019, 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

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

(define-module (chickadee graphics model)
  #:use-module (chickadee base64)
  #:use-module (chickadee data array-list)
  #:use-module (chickadee json)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math quaternion)
  #:use-module (chickadee math vector)
  #:use-module (chickadee graphics buffer)
  #:use-module (chickadee graphics blend)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics depth)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics light)
  #:use-module (chickadee graphics mesh)
  #:use-module (chickadee graphics multisample)
  #:use-module (chickadee graphics pbr)
  #:use-module (chickadee graphics phong)
  #:use-module (chickadee graphics polygon)
  #:use-module (chickadee graphics shader)
  #:use-module (chickadee graphics skybox)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee utils)
  #: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-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module ((srfi srfi-43) #:select (vector-every))
  #:use-module (web uri)
  #:export (scene-node?
            scene-node-name
            scene-node-mesh
            scene-node-matrix
            scene-node-children
            model?
            model-scenes
            model-default-scene
            draw-model
            load-obj
            load-gltf))


;;;
;;; Rendering State
;;;

(define-record-type <render-state>
  (%make-render-state model-matrix world-model-matrix)
  render-state?
  (model-matrix render-state-model-matrix)
  (world-model-matrix render-state-world-model-matrix))

(define (make-render-state)
  (%make-render-state (make-identity-matrix4)
                      (make-identity-matrix4)))

(define (render-state-reset! state)
  (matrix4-identity! (render-state-model-matrix state)))

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

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


;;;
;;; Model Node
;;;

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

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

(define (draw-model-node node state view-matrix camera-position skybox lights)
  (match node
    (($ <model-node> name mesh matrix world-matrix children)
     (for-each (lambda (child)
                 (draw-model-node child state view-matrix camera-position
                                  skybox lights))
               children)
     (when mesh
       (render-state-world-model-matrix-mult! state world-matrix)
       (draw-mesh mesh
                  #:model-matrix (render-state-world-model-matrix state)
                  #:view-matrix view-matrix
                  #:camera-position camera-position
                  #:skybox skybox
                  #:lights lights)))))


;;;
;;; 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 %depth-test (make-depth-test))
(define %identity-matrix (make-identity-matrix4))
(define %origin (vec3 0.0 0.0 0.0))

(define* (draw-model model #:key
                     (model-matrix %identity-matrix)
                     (view-matrix %identity-matrix)
                     (camera-position %origin)
                     (skybox (default-skybox))
                     (lights '()))
  (with-graphics-state ((g:depth-test %depth-test)
                        (g:multisample? #t))
    (let ((state (model-render-state model)))
      (render-state-reset! state)
      (render-state-model-matrix-mult! state model-matrix)
      ;; TODO: Support drawing non-default scenes.
      (draw-model-node (model-default-scene model) state view-matrix
                       camera-position skybox lights))))


;;;
;;; OBJ Format
;;;

;; Reference documentation:
;;   * http://paulbourke.net/dataformats/obj
;;   * http://paulbourke.net/dataformats/mtl
(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 (parse-map-args args)
          (define (map-option? str)
            (string-prefix? "-" str))
          (let loop ((args args)
                     (opts '()))
            (match args
              (() opts)
              (((? map-option? opt) arg . rest)
               (loop rest
                     (cons (cons (string->symbol
                                  (substring opt 1))
                                 arg)
                           opts)))
              ((file-name . rest)
               (loop rest (cons (cons 'file-name file-name) opts))))))
        (define (load-mtl mtl-file-name)
          (define (scope-file other-file)
            (string-append (dirname mtl-file-name) "/" other-file))
          (call-with-input-file mtl-file-name
            (lambda (port)
              (let loop ((opts '()))
                (define (maybe-add-material)
                  (let ((name (assq-ref opts 'name)))
                    (when name
                      (let* ((ambient-texture (or (assq-ref opts 'ambient-map)
                                                  (white-texture)))
                             (diffuse-texture (or (assq-ref opts 'diffuse-map)
                                                  (white-texture)))
                             (specular-texture (or (assq-ref opts 'specular-map)
                                                   (white-texture)))
                             (normal-texture (or (assq-ref opts 'normal-map)
                                                 (flat-texture)))
                             (material
                              (make-phong-material #:name name
                                                   #:ambient-texture ambient-texture
                                                   #:diffuse-texture diffuse-texture
                                                   #:specular-texture specular-texture
                                                   #:normal-texture normal-texture
                                                   #:ambient-factor (assq-ref opts 'ambient)
                                                   #:diffuse-factor (assq-ref opts 'diffuse)
                                                   #:specular-factor (assq-ref opts 'specular)
                                                   #:shininess (assq-ref opts 'shininess))))
                        (hash-set! material-map name material)))))
                (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 opts))
                     (("d" d) ; ignore dissolve for now
                      (loop opts))
                     (("illum" n) ; ignore illumation model for now
                      (loop opts))
                     (("Ka" r g b) ; ambient factor
                      (let ((new-ambient (vec3 (string->number r)
                                               (string->number g)
                                               (string->number b))))
                        (loop (cons (cons 'ambient new-ambient) opts))))
                     (("Ka" r) ; ambient factor
                      (let ((new-ambient (vec3 (string->number r)
                                               (string->number r)
                                               (string->number r))))
                        (loop (cons (cons 'ambient new-ambient) opts))))
                     (("Kd" r g b) ; diffuse factor
                      (let ((new-diffuse (vec3 (string->number r)
                                               (string->number g)
                                               (string->number b))))
                        (loop (cons (cons 'diffuse new-diffuse) opts))))
                     (("Kd" r) ; diffuse factor
                      (let ((new-diffuse (vec3 (string->number r)
                                               (string->number r)
                                               (string->number r))))
                        (loop (cons (cons 'diffuse new-diffuse) opts))))
                     (("Ks" r g b) ; specular factor
                      (let ((new-specular (vec3 (string->number r)
                                                (string->number g)
                                                (string->number b))))
                        (loop (cons (cons 'specular new-specular) opts))))
                     (("Ks" r) ; specular factor
                      (let ((new-specular (vec3 (string->number r)
                                                (string->number r)
                                                (string->number r))))
                        (loop (cons (cons 'specular new-specular) opts))))
                     (("Ni" i) ; ignore optical density for now
                      (loop opts))
                     (("Ns" s) ; specular exponent (shininess)
                      ;; Force specular exponent to be a float.
                      (let ((new-shininess (* (string->number s) 1.0)))
                        (loop (cons (cons 'shininess new-shininess) opts))))
                     (("map_Ka" . args) ; ambient map
                      (let* ((ambient-opts (parse-map-args args))
                             (file (scope-file (assq-ref ambient-opts
                                                         'file-name)))
                             (texture (load-image file
                                                  #:min-filter 'linear
                                                  #:mag-filter 'linear
                                                  #:flip? #f)))
                        (loop (cons (cons 'ambient-map texture)
                                    opts))))
                     (("map_Kd" . args) ; diffuse map
                      (let* ((diffuse-opts (parse-map-args args))
                             (file (scope-file (assq-ref diffuse-opts
                                                         'file-name)))
                             (texture (load-image file
                                                  #:min-filter 'linear
                                                  #:mag-filter 'linear
                                                  #:flip? #f)))
                        (loop (cons (cons 'diffuse-map texture)
                                    opts))))
                     (("map_Ks" . args) ; specular map
                      (let* ((specular-opts (parse-map-args args))
                             (file (scope-file (assq-ref specular-opts
                                                         'file-name)))
                             (texture (load-image file
                                                  #:min-filter 'linear
                                                  #:mag-filter 'linear
                                                  #:flip? #f)))
                        (loop (cons (cons 'specular-map texture)
                                    opts))))
                     (((or "map_Bump" "map_bump" "bump") . args) ; normal map
                      (let* ((normal-opts (parse-map-args args))
                             (file (scope-file (assq-ref normal-opts
                                                         'file-name)))
                             (texture (load-image file
                                                  #:min-filter 'linear
                                                  #:mag-filter 'linear
                                                  #:flip? #f)))
                        (loop (cons (cons 'normal-map texture)
                                    opts))))
                     (("newmtl" new-name)
                      ;; Begin new material
                      (maybe-add-material)
                      (loop `((name . ,new-name)
                              (ambient . ,(vec3 1.0 1.0 1.0))
                              (ambient-map . ,null-texture)
                              (diffuse . ,(vec3 1.0 1.0 1.0))
                              (diffuse-map . ,null-texture)
                              (specular . ,(vec3 1.0 1.0 1.0))
                              (specular-map . ,null-texture)
                              (shininess . 1.0)
                              (normal-map . ,null-texture))))
                     (data
                      (format (current-error-port)
                              "warning: ~a:~d: unsupported MTL data: ~s~%"
                              mtl-file-name
                              (port-line port)
                              data)
                      (loop opts)))))))))
        (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)
                               ;; OBJ texture coordinates use the
                               ;; top-left of the image as the origin,
                               ;; but OpenGL uses the bottom-left, so
                               ;; all V values must be inverted.
                               (vec2 (string->number u)
                                     (- 1.0 (string->number v))))
                              ((u v w)
                               (vec2 (string->number u)
                                     (- 1.0 (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 (deduplicate-face-element e)
          ;; Faces are often redundant, so we deduplicate in order to
          ;; make the VBOs we build later as small as possible.
          (or (hash-ref face-map e)
              (let ((i (array-list-size faces)))
                (array-list-push! faces (parse-face-element e))
                (hash-set! face-map e i)
                i)))
        (define (push-face material e)
          (array-list-push! (indices-for-material material)
                            (deduplicate-face-element e)))
        (define (parse-face args material)
          (match args
            ;; A single triangle.  Ah, life is so simple...
            ((a b c)
             (push-face material a)
             (push-face material b)
             (push-face material c))
            ;; A quadrilateral.  Needs to be split into 2 triangles.
            ;;
            ;; d-------c
            ;; |      /|
            ;; |    /  |
            ;; |  /    |
            ;; |/      |
            ;; a-------b
            ((a b c d)
             ;; triangle 1: a b c
             (push-face material a)
             (push-face material b)
             (push-face material c)
             ;; triangle 2: a c d
             (push-face material a)
             (push-face material c)
             (push-face material d))
            ;; 3 or more triangles.  Interpret as a strip of triangles
            ;; moving from right to left (because counter-clockwise
            ;; winding) like this:
            ;;
            ;; h-------f-------d-------c
            ;; |      /|      /|      /|
            ;; |    /  |    /  |    /  |
            ;; |  /    |  /    |  /    |
            ;; |/      |/      |/      |
            ;; g-------e-------a-------b
            ;;
            ;; ... and so on for however many face elements there are.
            ;; Every other triangle is flipped over, hence the 'flip?'
            ;; flag in the loop below.
            ((a b . rest)
             (let loop ((a a)
                        (b b)
                        (args rest)
                        (flip? #f))
               (match args
                 (() #t)
                 ((c . rest)
                  (push-face material a)
                  (push-face material b)
                  (push-face material c)
                  (if flip?
                      (loop c a rest #f)
                      (loop a c rest #t))))))
            (_
             (parse-error "invalid face" args))))
        ;; 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
            (for-range ((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)))))))
            ;; Pack indices.
            (for-range ((i index-count))
              (u32vector-set! mesh-indices i (array-list-ref face-indices i)))
            ;; Construct vertex array.
            ;; TODO: Add names to buffers and views.
            (let* ((index-buffer (make-buffer mesh-indices #:target 'index))
                   (index-view (make-vertex-attribute #:type 'scalar
                                                      #:component-type 'unsigned-int
                                                      #:buffer index-buffer))
                   (data-buffer (make-buffer mesh-data #:stride (* stride 4)))
                   (vertex-view (make-vertex-attribute #:type 'vec3
                                                       #:component-type 'float
                                                       #:buffer data-buffer))
                   (texcoord-view (make-vertex-attribute #:type 'vec2
                                                         #:component-type 'float
                                                         #:buffer data-buffer
                                                         #:offset 12))
                   (normal-view (make-vertex-attribute #: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"))))))
        ;; Register default material
        (hash-set! material-map "default"
                   (make-phong-material #:name "default"))
        ;; 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 group name for now
                (loop material))
               (("mtllib" mtl-file-name)
                (load-mtl (scope-file mtl-file-name))
                (loop material))
               (("o" . _) ;ignore object name for now
                (loop material))
               (("s" . _) ; ignore smoothing group for now
                (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))))))
        ;; 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-model-node #:name model-name
                                       #:mesh mesh)))
          (make-model #:name model-name
                      #:scenes (list scene)
                      #:render-state (make-render-state)))))))


;;;
;;; 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) (null? 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 base64-prefix "data:application/octet-stream;base64,")
  (define (parse-buffer obj)
    ;; 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 (cond
                  ((string-prefix? base64-prefix uri)
                   (base64-decode (substring uri (string-length base64-prefix))))
                  (uri
                   (call-with-input-file (scope-file (uri-decode uri))
                     (lambda (port)
                       (get-bytevector-n port length))))
                  (else
                   (make-bytevector length)))))
      data))
  (define (parse-vertex-attribute 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"))
          ;; 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
                   #:name name
                   #:offset offset
                   #:length length
                   #:stride stride
                   #:target target)))
  (define (parse-accessor obj vertex-attributes)
    (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 vertex-attributes 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))
      (when sparse
        (display "glTF: sparse accessors currently unsupported"
                 (current-error-port))
        (newline (current-error-port)))
      (make-vertex-attribute #:name name
                             #:buffer view
                             #:offset offset
                             #:component-type component-type
                             #:normalized? normalized?
                             #:length length
                             #:type type)))
  (define (texture-filter n)
    (match n
      (9728 'nearest)
      ((or #f 9729) 'linear)
      (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)
      (10497 'repeat)
      (33069 'clamp-to-border)
      (33071 'clamp-to-edge)
      (33648 'mirrored-repeat)
      (_ 'repeat)))
  (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 (uri-decode (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"))
                  #:flip? #f)))
  (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))))
           (metallic-factor
            (or (number-ref/optional pbrmr "metallicFactor")
                1.0))
           (roughness-factor
            (or (number-ref/optional pbrmr "roughnessFactor")
                1.0))
           (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))))
           ;; TODO: Sort primitives such that all OPAQUE and MASK
           ;; objects are drawn first, then draw primitives with
           ;; BLEND.
           (alpha-mode (match (or (string-ref/optional obj "alphaMode")
                                  "OPAQUE")
                         ("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")))
      (define (parse-texture obj key default)
        (match (object-ref/optional obj key)
          (#f (values (default) 0))
          (texture
           (values (vector-ref textures (number-ref texture "index"))
                   (or (number-ref/optional texture "texCoord") 0)))))
      (let-values (((base-color-texture base-color-texcoord)
                    (parse-texture pbrmr "baseColorTexture" white-texture))
                   ((metal-rough-texture metal-rough-texcoord)
                    (parse-texture pbrmr "metallicRoughnessTexture" white-texture))
                   ((normal-texture normal-texcoord)
                    (parse-texture obj "normalTexture" flat-texture))
                   ((occlusion-texture occlusion-texcoord)
                    (parse-texture obj "occlusionTexture" white-texture))
                   ((emissive-texture emissive-texcoord)
                    (parse-texture obj "emissiveTexture" black-texture)))
        (make-pbr-material
         #:name name
         #:blend-mode (if (eq? alpha-mode 'opaque) blend:alpha blend:replace)
         #:cull-face-mode (if double-sided?
                              no-cull-face-mode
                              back-cull-face-mode)
         #:base-color-texture base-color-texture
         #:metallic-roughness-texture metal-rough-texture
         #:normal-texture normal-texture
         #:occlusion-texture occlusion-texture
         #:emissive-texture emissive-texture
         #:base-color-factor base-color-factor
         #:base-color-texcoord base-color-texcoord
         #:metallic-factor metallic-factor
         #:roughness-factor roughness-factor
         #:metallic-roughness-texcoord metal-rough-texcoord
         #:normal-texcoord normal-texcoord
         #:occlusion-texcoord occlusion-texcoord
         #:emissive-factor emissive-factor
         #:emissive-texcoord emissive-texcoord
         #:alpha-mode alpha-mode
         #:alpha-cutoff alpha-cutoff))))
  (define (attribute-name->index name)
    (let ((shader (pbr-shader)))
      (match name
        ("POSITION"
         (attribute-location
          (hash-ref (shader-attributes shader) "position")))
        ("NORMAL"
         (attribute-location
          (hash-ref (shader-attributes shader) "normal")))
        ("TEXCOORD_0"
         (attribute-location
          (hash-ref (shader-attributes shader) "texcoord0")))
        ("TEXCOORD_1"
         (attribute-location
          (hash-ref (shader-attributes shader) "texcoord1")))
        ("COLOR_0"
         (attribute-location
          (hash-ref (shader-attributes shader) "color0")))
        ;; TODO
        ("TANGENT" #f)
        ("JOINTS_0" #f)
        ("WEIGHTS_0" #f)
        (_ #f))))
  ;; TODO: When normals are not specified, generate flat normals.
  ;;
  ;; TODO: When positions are not specified, skip the entire
  ;; primitive.
  (define (parse-primitive obj materials accessors)
    (let ((attributes (filter-map (match-lambda
                                    ((name . n)
                                     (let ((attr (attribute-name->index name)))
                                       (and attr
                                            (cons attr
                                                  (vector-ref accessors n))))))
                                  (object-ref obj "attributes")))
          (indices (match (number-ref/optional obj "indices")
                     (#f #f)
                     (n (vector-ref accessors n))))
          (material (match (number-ref/optional obj "material")
                      (#f (make-pbr-material))
                      (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 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")
                       (let ((rotation (or (array-ref/optional obj "rotation")
                                           #(0.0 0.0 0.0 1.0)))
                             (scale (or (array-ref/optional obj "scale")
                                        #(1.0 1.0 1.0)))
                             (translation (or (array-ref/optional obj "translation")
                                              #(0.0 0.0 0.0))))
                         (matrix4* (match scale
                                     (#(x y z)
                                      (matrix4-scale (vec3 x y z))))
                                   (match rotation
                                     (#(x y z w)
                                      ;; Rotation needs to be negated
                                      ;; for some reason.
                                      (matrix4-rotate
                                       (quaternion (- x) (- y) (- z) w))))
                                   (match translation
                                     (#(x y z)
                                      (matrix4-translate (vec3 x y z))))))))
           (mesh (match (number-ref/optional obj "mesh")
                   (#f #f)
                   (n (vector-ref meshes n))))
           ;; TODO: Parse weights.
           (weights #f))
      (make-model-node #:name name
                       #:matrix matrix
                       #:mesh mesh)))
  (define (parse-nodes array meshes)
    (let* ((k (vector-length array))
           (nodes (make-vector k)))
      ;; Creating the node tree is a multi-phase process.  First, we
      ;; parse all of the nodes in order, ignoring children since the
      ;; array is not guaranteed to be topologically sorted and the
      ;; child nodes may not exist yet.  Then, we take another pass to
      ;; initialize children now that all nodes can be referenced.
      ;; Next, we topologically sort the nodes and initialize world
      ;; matrices.  The topological sort ensures that we initialize the
      ;; matrices of parents before their children.
      (for-range ((i k))
        (vector-set! nodes i (parse-node (vector-ref array i) meshes)))
      (for-range ((i k))
        (let ((node (vector-ref nodes i))
              (children (or (array-ref/optional (vector-ref array i) "children")
                            #())))
          (set-model-node-children! node (map (lambda (j)
                                                (vector-ref nodes j))
                                              (vector->list children)))))
      (let ((visited (make-hash-table))
            (top-nodes '()))
        (define (visit node)
          (match (hashq-ref visited node)
            (#f
             (hashq-set! visited node 'temp)
             (for-each visit (model-node-children node))
             (hashq-set! visited node 'perm)
             (set! top-nodes (cons node top-nodes)))
            ('temp (error "cycle in glTF node tree"))
            ('perm #t)))
        (for-range ((i k))
          (visit (vector-ref nodes i)))
        ;; Reuse the visited table for world matrix initialization.
        (hash-clear! visited)
        (define (init-world-matrix node parent-matrix)
          (match node
            (($ <model-node> name mesh matrix world-matrix children)
             (matrix4-mult! world-matrix parent-matrix matrix)
             (hashq-set! visited node #t)
             (for-each (lambda (child)
                         (init-world-matrix child world-matrix))
                       children))))
        (for-each (lambda (node)
                    (unless (hashq-ref visited node)
                      (init-world-matrix node (make-identity-matrix4))))
                  top-nodes))
      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-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) i)))
      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 (lambda (obj i)
                                    (parse-buffer obj))
                                  (or (assoc-ref tree "buffers") #())))
             (indices (index-ids tree))
             (vertex-attributes (vector-map (lambda (obj i)
                                              (parse-vertex-attribute obj i buffers indices))
                                            (or (assoc-ref tree "bufferViews") #())))
             (accessors (vector-map (lambda (obj i)
                                      (parse-accessor obj vertex-attributes))
                                    (or (assoc-ref tree "accessors") #())))
             (images (or (assoc-ref tree "images") #()))
             (samplers (or (assoc-ref tree "samplers") #(())))
             (textures (vector-map (lambda (obj i)
                                     (parse-texture obj images samplers))
                                   (or (assoc-ref tree "textures") #())))
             (materials (vector-map (lambda (obj i)
                                      (parse-material obj textures))
                                    (or (assoc-ref tree "materials") #())))
             (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))
             (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))))))