path: root/chickadee/graphics/mesh.scm

;;; Chickadee Game Toolkit
;;; Copyright © 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 mesh rendering and generation.
;;
;;; Code:

(define-module (chickadee graphics mesh)
  #:use-module (chickadee math)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math vector)
  #:use-module (chickadee graphics blend)
  #:use-module (chickadee graphics buffer)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics depth)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics multisample)
  #:use-module (chickadee graphics light)
  #:use-module (chickadee graphics polygon)
  #:use-module (chickadee graphics shader)
  #:use-module (chickadee graphics skybox)
  #:use-module (chickadee graphics stencil)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee utils)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:export (make-material
            material?
            material-name
            material-shader
            material-blend-mode
            material-polygon-mode
            material-cull-face-mode
            material-depth-test
            material-stencil-test
            material-multisample?
            material-texture-0
            material-texture-1
            material-texture-2
            material-texture-3
            material-texture-4
            material-properties

            make-primitive
            primitive?
            primitive-name
            primitive-vertex-array
            primitive-material

            make-mesh
            mesh?
            mesh-name
            mesh-primitives
            draw-mesh

            make-plane
            make-tesselated-plane
            make-cube
            make-sphere))


;;;
;;; Materials
;;;

(define-record-type <material>
  (%make-material name shader blend-mode polygon-mode cull-face-mode
                  depth-test stencil-test multisample?
                  texture-0 texture-1 texture-2 texture-3 texture-4
                  properties)
  material?
  (name material-name)
  (shader material-shader)
  (blend-mode material-blend-mode)
  (polygon-mode material-polygon-mode)
  (cull-face-mode material-cull-face-mode)
  (depth-test material-depth-test)
  (stencil-test material-stencil-test)
  (multisample? material-multisample?)
  (texture-0 material-texture-0)
  (texture-1 material-texture-1)
  (texture-2 material-texture-2)
  (texture-3 material-texture-3)
  (texture-4 material-texture-4)
  (properties material-properties))

(define* (make-material #:key
                        (name "anonymous")
                        (shader null-shader)
                        (blend-mode blend:replace)
                        (polygon-mode fill-polygon-mode)
                        (cull-face-mode back-cull-face-mode)
                        (depth-test basic-depth-test)
                        (stencil-test default-stencil-test)
                        multisample?
                        (texture-0 null-texture)
                        (texture-1 null-texture)
                        (texture-2 null-texture)
                        (texture-3 null-texture)
                        (texture-4 null-texture)
                        properties)
  (%make-material name shader blend-mode polygon-mode cull-face-mode
                  depth-test stencil-test multisample? texture-0
                  texture-1 texture-2 texture-3 texture-4 properties))

(define %camera-position (vec3 0.0 0.0 0.0))

(define (material-apply material vertex-array model-matrix view-matrix
                        camera-position skybox light-vector)
  (with-graphics-state ((g:blend-mode (material-blend-mode material))
                        (g:cull-face-mode (material-cull-face-mode material))
                        (g:depth-test (material-depth-test material))
                        (g:multisample? (material-multisample? material))
                        (g:polygon-mode (material-polygon-mode material))
                        (g:stencil-test (material-stencil-test material))
                        (g:texture-0 (skybox-cube-map skybox))
                        (g:texture-1 (material-texture-0 material))
                        (g:texture-2 (material-texture-1 material))
                        (g:texture-3 (material-texture-2 material))
                        (g:texture-4 (material-texture-3 material))
                        (g:texture-5 (material-texture-4 material)))
    (shader-apply (material-shader material) vertex-array
                  #:model model-matrix
                  #:view view-matrix
                  #:projection (current-projection)
                  #:camera-position camera-position
                  #:lights light-vector
                  #:material (material-properties material))))


;;;
;;; Primitives
;;;

;; A primitive represents a single draw call: Some material applied to
;; some vertex data.
(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 primitive model-matrix view-matrix camera-position
                        skybox light-vector)
  (material-apply (primitive-material primitive)
                  (primitive-vertex-array primitive)
                  model-matrix
                  view-matrix
                  camera-position
                  skybox
                  light-vector))


;;;
;;; Meshes
;;;

;; A mesh is just a glorified list of primitives.
(define-record-type <mesh>
  (%make-mesh name primitives light-vector)
  mesh?
  (name mesh-name)
  (primitives mesh-primitives)
  (light-vector mesh-light-vector))

(define (make-mesh name primitives)
  (%make-mesh name primitives (make-vector %max-lights %disabled-light)))

(define %identity-matrix (make-identity-matrix4))
(define %origin (vec3 0.0 0.0 0.0))

(define* (draw-mesh mesh #:key (model-matrix %identity-matrix)
                    (view-matrix %identity-matrix)
                    (camera-position %origin)
                    (skybox (default-skybox))
                    (lights '()))
  ;; Populate light vector to pass on to shader.
  (let ((light-vector (mesh-light-vector mesh)))
    (let loop ((i 0)
               (lights lights))
      (when (< i %max-lights)
        (match lights
          (()
           (vector-set! light-vector i %disabled-light)
           (loop (+ i 1) '()))
          ((light . rest)
           (vector-set! light-vector i light)
           (loop (+ i 1) rest)))))
    (for-each (lambda (primitive)
                (draw-primitive primitive model-matrix view-matrix camera-position
                                skybox light-vector))
              (mesh-primitives mesh))))


;;;
;;; Programattically generated meshes
;;;

(define-record-type <vertex>
  (vertex position uv normal)
  vertex?
  (position vertex-position)
  (uv vertex-uv)
  (normal vertex-normal))

(define (build-mesh name vertices material)
  (let* ((index (make-hash-table))
         ;; Build index and count unique verts.
         (count
          (fold (lambda (vertex count)
                  (if (hashq-ref index vertex)
                      count
                      (begin
                        (hashq-set! index vertex count)
                        (+ count 1))))
                0
                vertices))
         ;; 8 floats per vertex.
         (stride (* 8 4))
         (verts (make-bytevector (* count stride)))
         (indices (make-u32vector (length vertices))))
    ;; Pack verts.
    (hash-for-each (lambda (vertex i)
                     (let ((p (vertex-position vertex))
                           (uv (vertex-uv vertex))
                           (n (vertex-normal vertex))
                           (offset (* i stride)))
                       (bytevector-ieee-single-native-set! verts offset
                                                           (vec3-x p))
                       (bytevector-ieee-single-native-set! verts (+ offset 4)
                                                           (vec3-y p))
                       (bytevector-ieee-single-native-set! verts (+ offset 8)
                                                           (vec3-z p))
                       (bytevector-ieee-single-native-set! verts (+ offset 12)
                                                           (vec2-x uv))
                       (bytevector-ieee-single-native-set! verts (+ offset 16)
                                                           (vec2-y uv))
                       (bytevector-ieee-single-native-set! verts (+ offset 20)
                                                           (vec3-x n))
                       (bytevector-ieee-single-native-set! verts (+ offset 24)
                                                           (vec3-y n))
                       (bytevector-ieee-single-native-set! verts (+ offset 28)
                                                           (vec3-z n))))
                   index)
    ;; Pack indices.
    (let loop ((i 0)
               (vertices vertices))
      (match vertices
        (() #t)
        ((vertex . rest)
         (u32vector-set! indices i (hashq-ref index vertex))
         (loop (+ i 1) rest))))
    (let* ((vertex-buffer (make-buffer verts #:stride stride))
           (index-buffer (make-buffer indices #:target 'index))
           (positions (make-vertex-attribute #:buffer vertex-buffer
                                             #:type 'vec3
                                             #:component-type 'float))
           (uvs (make-vertex-attribute #:buffer vertex-buffer
                                       #:offset 12
                                       #:type 'vec2
                                       #:component-type 'float))
           (normals (make-vertex-attribute #:buffer vertex-buffer
                                           #:offset 20
                                           #:type 'vec3
                                           #:component-type 'float))
           (vertex-array
            (make-vertex-array #:indices
                               (make-vertex-attribute #:buffer index-buffer
                                                      #:type 'scalar
                                                      #:component-type 'unsigned-int)
                               #:attributes `((0 . ,positions)
                                              (1 . ,uvs)
                                              (2 . ,normals)))))
      (make-mesh name (list (make-primitive name vertex-array material))))))

(define (make-plane length width material)
  (let* ((hl (/ length 2.0))
         (hw (/ width 2.0))
         (bottom-left (vertex (vec3 (- hw) 0.0 (- hl))
                              (vec2 0.0 0.0)
                              (vec3 0.0 1.0 0.0)))
         (bottom-right (vertex (vec3 hw 0.0 (- hl))
                               (vec2 1.0 0.0)
                               (vec3 0.0 1.0 0.0)))
         (top-right (vertex (vec3 hw 0.0 hl)
                            (vec2 1.0 1.0)
                            (vec3 0.0 1.0 0.0)))
         (top-left (vertex (vec3 (- hw) 0.0 hl)
                           (vec2 0.0 1.0)
                           (vec3 0.0 1.0 0.0))))
    (build-mesh "plane"
                (list bottom-left
                      top-left
                      top-right
                      bottom-left
                      top-right
                      bottom-right)
                material)))

(define (make-tesselated-plane length width resolution material)
  (let ((hl (/ length 2.0))
        (hw (/ width 2.0))
        (stepl (/ length resolution))
        (stepw (/ width resolution))
        (uvstep (/ 1.0 resolution))
        (cache (make-vector (* resolution resolution) #f)))
    (define (get-vertex x z)
      (or (vector-ref cache (+ (* resolution z) x))
          (let ((v (vertex (vec3 (- (* x stepw) hw) 0.0 (- (* z stepl) hl))
                           (vec2 (* x uvstep) (* z uvstep))
                           (vec3 0.0 1.0 0.0))))
            (vector-set! cache (+ (* resolution z) x) v)
            v)))
    (build-mesh "tesselated plane"
                (let loop ((x 0)
                           (z 0))
                  (cond
                   ((= z (- resolution 1))
                    '())
                   ((= x (- resolution 1))
                    (loop 0 (+ z 1)))
                   (else
                    (cons* (get-vertex x z)
                           (get-vertex x (+ z 1))
                           (get-vertex (+ x 1) (+ z 1))
                           (get-vertex x z)
                           (get-vertex (+ x 1) (+ z 1))
                           (get-vertex (+ x 1) z)
                           (loop (+ x 1) z)))))
                material)))

(define (make-cube size material)
  (let* ((hs (/ size 2.0))
         (bottom0 (vertex (vec3 (- hs) (- hs) (- hs))
                          (vec2 0.0 0.0)
                          (vec3 0.0 -1.0 0.0)))
         (bottom1 (vertex (vec3 hs (- hs) (- hs))
                          (vec2 1.0 0.0)
                          (vec3 0.0 -1.0 0.0)))
         (bottom2 (vertex (vec3 hs (- hs) hs)
                          (vec2 1.0 1.0)
                          (vec3 0.0 -1.0 0.0)))
         (bottom3 (vertex (vec3 (- hs) (- hs) hs)
                          (vec2 0.0 1.0)
                          (vec3 0.0 -1.0 0.0)))
         (top0 (vertex (vec3 (- hs) hs (- hs))
                       (vec2 0.0 0.0)
                       (vec3 0.0 1.0 0.0)))
         (top1 (vertex (vec3 hs hs (- hs))
                       (vec2 1.0 0.0)
                       (vec3 0.0 1.0 0.0)))
         (top2 (vertex (vec3 hs hs hs)
                       (vec2 1.0 1.0)
                       (vec3 0.0 1.0 0.0)))
         (top3 (vertex (vec3 (- hs) hs hs)
                       (vec2 0.0 1.0)
                       (vec3 0.0 1.0 0.0)))
         (left0 (vertex (vec3 (- hs) (- hs) (- hs))
                        (vec2 0.0 0.0)
                        (vec3 -1.0 0.0 0.0)))
         (left1 (vertex (vec3 (- hs) hs (- hs))
                        (vec2 1.0 0.0)
                        (vec3 -1.0 0.0 0.0)))
         (left2 (vertex (vec3 (- hs) hs hs)
                        (vec2 1.0 1.0)
                        (vec3 -1.0 0.0 0.0)))
         (left3 (vertex (vec3 (- hs) (- hs) hs)
                        (vec2 0.0 1.0)
                        (vec3 -1.0 0.0 0.0)))
         (right0 (vertex (vec3 hs (- hs) (- hs))
                         (vec2 0.0 0.0)
                         (vec3 1.0 0.0 0.0)))
         (right1 (vertex (vec3 hs hs (- hs))
                         (vec2 1.0 0.0)
                         (vec3 1.0 0.0 0.0)))
         (right2 (vertex (vec3 hs hs hs)
                         (vec2 1.0 1.0)
                         (vec3 1.0 0.0 0.0)))
         (right3 (vertex (vec3 hs (- hs) hs)
                         (vec2 0.0 1.0)
                         (vec3 1.0 0.0 0.0)))
         (front0 (vertex (vec3 (- hs) (- hs) hs)
                         (vec2 0.0 0.0)
                         (vec3 0.0 0.0 1.0)))
         (front1 (vertex (vec3 hs (- hs) hs)
                         (vec2 1.0 0.0)
                         (vec3 0.0 0.0 1.0)))
         (front2 (vertex (vec3 hs hs hs)
                         (vec2 1.0 1.0)
                         (vec3 0.0 0.0 1.0)))
         (front3 (vertex (vec3 (- hs) hs hs)
                         (vec2 0.0 1.0)
                         (vec3 0.0 0.0 1.0)))
         (back0 (vertex (vec3 (- hs) (- hs) (- hs))
                        (vec2 0.0 0.0)
                        (vec3 0.0 0.0 -1.0)))
         (back1 (vertex (vec3 hs (- hs) (- hs))
                        (vec2 1.0 0.0)
                        (vec3 0.0 0.0 -1.0)))
         (back2 (vertex (vec3 hs hs (- hs))
                        (vec2 1.0 1.0)
                        (vec3 0.0 0.0 -1.0)))
         (back3 (vertex (vec3 (- hs) hs (- hs))
                        (vec2 0.0 1.0)
                        (vec3 0.0 0.0 -1.0))))
    (build-mesh "cube"
                (list bottom0 bottom3 bottom2 bottom0 bottom2 bottom1
                      top0 top3 top2 top0 top2 top1
                      left0 left3 left2 left0 left2 left1
                      right0 right3 right2 right0 right2 right1
                      front0 front3 front2 front0 front2 front1
                      back0 back3 back2 back0 back2 back1)
                material)))

(define* (make-sphere radius material #:key (quality 2))
  (define phi 1.618033988749895) ; the golden ratio
  ;; Compute the vector halfway between A and B.
  (define (halfway a b)
    (vec3+ a (vec3* (vec3- b a) 0.5)))
  ;; "Normalization" in this context refers to transforming each
  ;; vertex such that it is a constant distance (as determined by the
  ;; radius argument) away from the origin.
  ;;
  ;; The result is memoized so that vertex data is shared as much as
  ;; possible in the final mesh.  For example, a sphere of quality 3
  ;; requires 3840 vertices, but only 642 of them are unique.
  ;; Memoization reduces the mesh vertex buffer size by ~82%.
  (define normalize
    (memoize
     (lambda (p)
       (let ((n (vec3-normalize p)))
         (vertex (vec3* n radius)
                 (vec2 (+ (/ (atan (vec3-x n) (vec3-z n)) tau) 0.5)
                       (+ (/ (asin (vec3-y n)) pi) 0.5))
                 n)))))
  ;; When mapping UV's to the sphere's vertices, there is some
  ;; distortion that occurs at the 6 triangles that form a pole. The
  ;; polar vertex has a U coordinate of 0.5, but the U coordinates of
  ;; the other vertices that form the triangles are the percentage of
  ;; how far they have traversed a unit circle.  Something like this:
  ;;
  ;;     0.588   0.412
  ;;        *-----*
  ;;       / \ C / \
  ;;      / D \ / B \
  ;; 0.75 *----*-0.5-* 0.25
  ;;      \ E / \ A /
  ;;       \ / F \ /
  ;;        *-----*
  ;;      0.911    0.089
  ;;
  ;; There are 2 problems:
  ;;
  ;; 1) With the exception of triangle C, 0.5 is not the halfway point
  ;; between the other 2 U values, which results in a very obvious
  ;; visual artifact where the texture looks very compressed in the
  ;; triangle.
  ;;
  ;; 2) Triangle F, in addition to suffering from issue 1, also has
  ;; the issue that it spans the seam where there's a hard jump from
  ;; U=1 to U=0, causing another compressed visual artifact.
  ;;
  ;; The solution is to duplicate the polar vertex for all triangles
  ;; and supply unique UV coordinates for each one such that the U
  ;; value lies halfway between the other 2 U values.  Additionally,
  ;; triangle F needs the vertex with the lowest U value (0.089 in the
  ;; example) adjusted to extend past 1 (1.089 would be the fixed
  ;; value in the example.)
  ;;
  ;; This UV map adjustment is not without it's own issues, but the
  ;; result looks far more acceptable.
  (define (find-minu v)
    (let ((u (vec2-x (vertex-uv v))))
      ;; We don't want the center point to ever be considered the min.
      (if (= u 0.5) 1.0 u)))
  (define (find-maxu v)
    (let ((u (vec2-x (vertex-uv v))))
      ;; We don't want the center point to ever be considered the max.
      (if (= u 0.5) 0.0 u)))
  (define (fix-pole a b c)
    (let* ((minu (min (find-minu a) (find-minu b) (find-minu c)))
           (maxu (max (find-maxu a) (find-maxu b) (find-maxu c)))
           (seam? (and (< minu 0.25) (> maxu 0.75))))
      (define (fix v)
        (let ((uv (vertex-uv v)))
          (cond
           ((and seam? (= (vec2-x uv) 0.5))
            (vertex (vertex-position v)
                    (vec2 (+ maxu minu)
                          (vec2-y uv))
                    (vertex-normal v)))
           ((= (vec2-x uv) 0.5)
            (vertex (vertex-position v)
                    (vec2 (+ minu (/ (- maxu minu) 2.0)) (vec2-y uv))
                    (vertex-normal v)))
           ((and seam? (= minu (vec2-x uv)))
            (vertex (vertex-position v)
                    (vec2 (+ maxu (* minu 2.0)) (vec2-y uv))
                    (vertex-normal v)))
           (else v))))
      (list (fix a) (fix b) (fix c))))
  ;; Triangles at the poles have a vertex with a V value of either 0
  ;; or 1.
  (define (on-pole? a b c)
    (let ((av (vec2-y (vertex-uv a)))
          (bv (vec2-y (vertex-uv b)))
          (cv (vec2-y (vertex-uv c))))
      (or (= av 0.0) (= av 1.0) (= bv 0.0) (= bv 1.0) (= cv 0.0) (= cv 1.0))))
  ;; When mapping UVs to the sphere's vertices, there's a smooth
  ;; wrapping of U values from 0 to 1 around the sphere, but when it
  ;; reaches the beginning again there is a hard jump from 1 back to
  ;; 0.  This creates a glaringly obvious, distorted seam when a
  ;; texture is applied.  To fix it, we must identify triangles that
  ;; are in the back hemisphere (-Z values) with at least one vertex
  ;; whose U coordinate is 1.  These are the faces that span the seam.
  ;; The UVs of each vertex are then adjusted as necessary to reduce
  ;; the range of U values to the desired amount.
  (define (on-seam? a b c)
    (and (or (negative? (vec3-z (vertex-position a)))
             (negative? (vec3-z (vertex-position b)))
             (negative? (vec3-z (vertex-position c))))
         (or (= (vec2-x (vertex-uv a)) 1.0)
             (= (vec2-x (vertex-uv b)) 1.0)
             (= (vec2-x (vertex-uv c)) 1.0))))
  (define fix-seam-maybe
    (memoize
     (lambda (v)
       (let* ((uv (vertex-uv v))
              (du (- 1.0 (vec2-x uv))))
         (if (< du 0.5)
             (vertex (vertex-position v)
                     (vec2 (- du) (vec2-y uv))
                     (vertex-normal v))
             v)))))
  (define (fix-uvs a b c)
    (cond
     ((on-seam? a b c)
      (list (fix-seam-maybe a)
            (fix-seam-maybe b)
            (fix-seam-maybe c)))
     ((on-pole? a b c)
      (fix-pole a b c))
     (else
      (list a b c))))
  ;; Recursively subdivide a triangle into 4 sub-triangles n times.
  (define (subdivide tri n)
    (match tri
      ((a b c)
       (if (= n 0)
           (fix-uvs (normalize a) (normalize b) (normalize c))
           ;; Subdivide one triangle into 4, like so:
           ;;
           ;;         B
           ;;         *
           ;;        / \
           ;;       /   \
           ;;    E *_____* F
           ;;     / \   / \
           ;;    /   \ /   \
           ;;   *_____*_____*
           ;;  A      G      C
           (let ((e (halfway a b))
                 (f (halfway b c))
                 (g (halfway c a)))
             (append (subdivide (list a g e) (- n 1))
                     (subdivide (list e f b) (- n 1))
                     (subdivide (list g c f) (- n 1))
                     (subdivide (list e g f) (- n 1))))))))
  ;; Icosahedrons (picture a 20-sided die) have 12 vertices.  The
  ;; position of these vertices can be defined using 3 mutually
  ;; centered, mutually orthogonal golden rectangles.  See
  ;; https://math.wikia.org/wiki/Icosahedron#Cartesian_coordinates for
  ;; a visualization of this.
  ;;
  ;; Rectangle on the YZ plane
  (let ((yz0 (vec3 0.0 -1.0 (- phi)))
        (yz1 (vec3 0.0 1.0 (- phi)))
        (yz2 (vec3 0.0 1.0 phi))
        (yz3 (vec3 0.0 -1.0 phi))
        ;; Rectangle on the XY plane
        (xy0 (vec3 -1.0 (- phi) 0.0))
        (xy1 (vec3 1.0 (- phi) 0.0))
        (xy2 (vec3 1.0 phi 0.0))
        (xy3 (vec3 -1.0 phi 0.0))
        ;; Rectangle on the XZ plane
        (xz0 (vec3 (- phi) 0.0 -1.0))
        (xz1 (vec3 phi 0.0 -1.0))
        (xz2 (vec3 phi 0.0 1.0))
        (xz3 (vec3 (- phi) 0.0 1.0)))
    (build-mesh "sphere"
                (append-map (lambda (tri)
                              (subdivide tri quality))
                            ;; 20 triangles form the base icosahedron,
                            ;; which will be subdivided to form a
                            ;; higher resolution mesh that closely
                            ;; approximates a sphere.
                            (list (list xy3 xy2 yz1)
                                  (list yz2 xy3 xy2)
                                  (list yz2 xy3 xz3)
                                  (list xy3 xz3 xz0)
                                  (list xz0 xy3 yz1) ; 5
                                  (list xy2 yz1 xz1)
                                  (list yz0 yz1 xz1)
                                  (list yz0 yz1 xz0)
                                  (list yz0 xz0 xy0)
                                  (list xy0 xz0 xz3) ; 10
                                  (list xz3 xy0 yz3)
                                  (list yz3 yz2 xz3)
                                  (list yz3 yz2 xz2)
                                  (list yz2 xz2 xy2)
                                  (list xz2 xz1 xy2) ; 15
                                  (list xz2 xz1 xy1)
                                  (list xz1 xy1 yz0)
                                  (list xy0 xy1 yz0)
                                  (list xy0 xy1 yz3)
                                  (list xy1 yz3 xz2)))
                material)))