graphics: mesh: Add make-sphere procedure.

1 files changed, 205 insertions, 0 deletions

diff --git a/chickadee/graphics/mesh.scm b/chickadee/graphics/mesh.scm
index 44c670e..b0db1b4 100644
--- a/chickadee/graphics/mesh.scm
+++ b/chickadee/graphics/mesh.scm
@@ -22,6 +22,7 @@
 ;;; 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)
@@ -432,3 +433,207 @@
                       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)))