math: Begin rewrite of vector math module.

2 files changed, 164 insertions, 206 deletions

diff --git a/chickadee/math/vector.scm b/chickadee/math/vector.scm
index 66a21fd..b34d5a2 100644
--- a/chickadee/math/vector.scm
+++ b/chickadee/math/vector.scm
@@ -16,186 +16,142 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (chickadee math vector)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
+  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-9)
-  #:export (<vector2>
-            <vector3>
-            <vector4>
-            vector2 vector3 vector4
-            vector2? vector3? vector4?
-            polar2
-            vx vy vz vw
-
-            vadd! vmul!
-            vx-in-range? vy-in-range?
-
-            vmap v+ v- v* vdot vcross
-            magnitude normalize
-            anchor-vector)
-  #:replace (magnitude))
-
-(define-inlinable (square x)
-  (* x x))
-
-(define-record-type <vector2>
-  (vector2 x y)
-  vector2?
-  (x vector2-x)
-  (y vector2-y))
-
-(define-record-type <vector3>
-  (vector3 x y z)
-  vector3?
-  (x vector3-x)
-  (y vector3-y)
-  (z vector3-z))
-
-(define-record-type <vector4>
-  (vector4 x y z w)
-  vector4?
-  (x vector4-x)
-  (y vector4-y)
-  (z vector4-z)
-  (w vector4-w))
-
-(define vx
-  (match-lambda
-   ((or ($ <vector2> x _)
-        ($ <vector3> x _ _)
-        ($ <vector4> x _ _ _))
-    x)))
-
-(define vy
-  (match-lambda
-   ((or ($ <vector2> _ y)
-        ($ <vector3> _ y _)
-        ($ <vector4> _ y _ _))
-    y)))
-
-(define vz
-  (match-lambda
-   ((or ($ <vector3> _ _ z)
-        ($ <vector4> _ _ z _))
-    z)))
-
-(define vw vector4-w)
-
-(define (polar2 r theta)
-  "Create a new 2D vector from the polar coordinate (R, THETA) where R
-is the radius and THETA is the angle."
-  (vector2 (* r (cos theta))
-           (* r (sin theta))))
-
-(define (vmap proc v)
-  "Return a new vector that is the result of applying PROC to each
-element of the 2D/3D/4D vector V."
-  (match v
-    (($ <vector2> x y)
-     (vector2 (proc x) (proc y)))
-    (($ <vector3> x y z)
-     (vector3 (proc x) (proc y) (proc z)))
-    (($ <vector4> x y z w)
-     (vector4 (proc x) (proc y) (proc z) (proc w)))))
-
-(define-syntax-rule (vector-lambda proc)
-  (match-lambda*
-   ((($ <vector2> x1 y1) ($ <vector2> x2 y2))
-    (vector2 (proc x1 x2) (proc y1 y2)))
-   ((($ <vector2> x y) (? number? k))
-    (vector2 (proc x k) (proc y k)))
-   (((? number? k) ($ <vector2> x y))
-    (vector2 (proc k x) (proc k y)))
-   ((($ <vector3> x1 y1 z1) ($ <vector3> x2 y2 z2))
-    (vector3 (proc x1 x2) (proc y1 y2) (proc z1 z2)))
-   ((($ <vector3> x y z) (? number? k))
-    (vector3 (proc x k) (proc y k) (proc z k)))
-   (((? number? k) ($ <vector3> x y z))
-    (vector3 (proc k x) (proc k y) (proc k z)))
-   ((($ <vector4> x1 y1 z1 w1) ($ <vector4> x2 y2 z2 w2))
-    (vector4 (proc x1 x2) (proc y1 y2) (proc z1 z2) (proc w1 w2)))
-   ((($ <vector4> x y z w) (? number? k))
-    (vector4 (proc x k) (proc y k) (proc z k) (proc w k)))
-   (((? number? k) ($ <vector4> x y z w))
-    (vector4 (proc k x) (proc k y) (proc k z) (proc k w)))))
-
-(define (v+ . vectors)
-  (reduce (vector-lambda +) 0 vectors))
-
-(define v-
-  (match-lambda*
-   ((v) (v- 0 v))
-   ((v v* ...)
-    (fold-right (let ((- (vector-lambda -)))
-                  (lambda (prev v)
-                    (- v prev)))
-                v v*))))
-
-(define (v* . vectors)
-  (reduce (vector-lambda *) 1 vectors))
-
-(define vdot
-  (match-lambda*
-   ((($ <vector2> x1 y1) ($ <vector2> x2 y2))
-    (+ (* x1 x2) (* y1 y2)))
-   ((($ <vector3> x1 y1 z1) ($ <vector3> x2 y2 z2))
-    (+ (* x1 x2) (* y1 y2) (* z1 z2)))
-   ((($ <vector4> x1 y1 z1 w1) ($ <vector4> x2 y2 z2 w2))
-    (+ (* x1 x2) (* y1 y2) (* z1 z2) (* w1 w2)))))
-
-(define vcross
-  (match-lambda*
-   ((($ <vector3> x1 y1 z1) ($ <vector3> x2 y2 z2))
-    (vector3 (- (* y1 z2) (* z1 y2))
-             (- (* z1 x2) (* x1 z2))
-             (- (* x1 y2) (* y1 x2))))))
-
-(define (magnitude v)
-  "Return the magnitude of the vector V."
-  (sqrt
-   (match v
-     (($ <vector2> x y)
-      (+ (square x) (square y)))
-     (($ <vector3> x y z)
-      (+ (square x) (square y) (square z)))
-     (($ <vector4> x y z w)
-      (+ (square x) (square y) (square z) (square w))))))
-
-(define (normalize v)
-  "Return the normalized form of the vector V."
-  (let ((m (magnitude v)))
-    (if (zero? m)
-        v
-        (match v
-          (($ <vector2> x y)
-           (vector2 (/ x m) (/ y m)))
-          (($ <vector3> x y z)
-           (vector3 (/ x m) (/ y m) (/ z m)))
-          (($ <vector4> x y z w)
-           (vector4 (/ x m) (/ y m) (/ z m) (/ w m)))))))
-
-(define (anchor-vector width height anchor)
-  "Create an anchor point vector from the description ANCHOR within
-the rectangular defined by WIDTH and HEIGHT.  Valid values for ANCHOR
-are: 'center', 'top-left', 'top-right', 'bottom-left', 'bottom-right',
-'top-center', 'bottom-center', or any 2D vector.  When ANCHOR is a 2D
-vector, the return value is simply the same vector."
-  (match anchor
-    ((? vector2? anchor)
-     anchor)
-    ('center
-     (vector2 (/ width 2)
-              (/ height 2)))
-    ('top-left
-     (vector2 0 height))
-    ('top-right
-     (vector2 width height))
-    ('bottom-left
-     (vector2 0 0))
-    ('bottom-right
-     (vector2 width 0))
-    ('top-center
-     (vector2 (/ width 2) height))
-    ('bottom-center
-     (vector2 (/ width 2) 0))
-    (_ (error "Invalid anchor type: " anchor))))
+  #:use-module (system foreign)
+  #:use-module (chickadee math)
+  #:export (vec2
+            vec2/polar
+            vec2?
+            vec2->pointer
+            copy-vec2
+            copy-vec2!
+            vec2-x
+            vec2-y
+            vec2-magnitude
+            vec2-dot-product
+            vec2-normalize
+            set-vec2-x!
+            set-vec2-y!
+            vec2-normalize!
+            vec2-mult!
+            vec2-add!
+            vec2-sub!))
+
+(define-record-type <vec2>
+  (wrap-vec2 bv pointer)
+  vec2?
+  (bv unwrap-vec2)
+  (pointer vec2-pointer set-vec2-pointer!))
+
+(define (vec2->pointer v)
+  "Return a foreign pointer to V."
+  ;; Create foreign pointer lazily.
+  (or (vec2-pointer v)
+      (let ((pointer (bytevector->pointer (unwrap-vec2 v))))
+        (set-vec2-pointer! v pointer)
+        pointer)))
+
+(define (make-null-vec2)
+  (wrap-vec2 (make-f32vector 2) #f))
+
+(define-syntax-rule (with-new-vec2 name body ...)
+  (let ((name (make-null-vec2))) body ... name))
+
+(define-inlinable (vec2-ref v i)
+  (f32vector-ref (unwrap-vec2 v) i))
+
+(define-inlinable (vec2-set! v i x)
+  (f32vector-set! (unwrap-vec2 v) i x))
+
+(define-inlinable (vec2 x y)
+  "Return a new vec2 with coordinates (X, Y)."
+  (with-new-vec2 v
+    (vec2-set! v 0 x)
+    (vec2-set! v 1 y)))
+
+(define-inlinable (vec2/polar r theta)
+  "Return a new vec2 containing the Cartesian representation of the
+polar coordinate (R, THETA)."
+  (vec2 (* r (cos theta)) (* r (sin theta))))
+
+(define (vec2-copy! source-vec2 target-vec2)
+  "Copy TARGET-VEC2 to SOURCE-VEC2."
+  (bytevector-copy! (unwrap-vec2 source-vec2)
+                    0
+                    (unwrap-vec2 target-vec2)
+                    0
+                    16))
+
+(define (vec2-copy vec2)
+  "Return a new vec2 that is a copy of VEC2."
+  (with-new-vec2 new
+    (vec2-copy! vec2 new)))
+
+(define-inlinable (vec2-x v)
+  "Return the x coordinate of the vec2 V."
+  (vec2-ref v 0))
+
+(define-inlinable (vec2-y v)
+  "Return the y coordinate of the vec2 V."
+  (vec2-ref v 1))
+
+(define-inlinable (vec2-magnitude v)
+  "Return the magnitude of the vec2 V."
+  (sqrt (+ (square (vec2-x v)) (square (vec2-y v)))))
+
+(define-inlinable (vec2-dot-product v1 v2)
+  "Return the dot product of the vec2s V1 and V2."
+  (+ (* (vec2-x v1) (vec2-x v2))
+     (* (vec2-y v1) (vec2-y v2))))
+
+(define (vec2-normalize v)
+  "Return the normalized form of the vec2 V."
+  (with-new-vec2 new
+    (vec2-copy! v new)
+    (vec2-normalize! new)))
+
+(define-inlinable (set-vec2-x! v x)
+  "Set the x coordinate of the vec2 V to X."
+  (vec2-set! v 0 x))
+
+(define-inlinable (set-vec2-y! v y)
+  "Set the y coordinate of the vec2 V to Y."
+  (vec2-set! v 1 y))
+
+(define-inlinable (vec2-normalize! v)
+  "Normalize the vec2 V in-place."
+  (unless (and (zero? (vec2-x v)) (zero? (vec2-y v)))
+    (let ((m (vec2-magnitude v)))
+      (set-vec2-x! v (/ (vec2-x v) m))
+      (set-vec2-y! v (/ (vec2-y v) m)))))
+
+(define-inlinable (vec2-mult! v x)
+  "Multiply the vec2 V by X, a real number or vec2."
+  (if (real? x)
+      (begin
+        (set-vec2-x! v (* (vec2-x v) x))
+        (set-vec2-y! v (* (vec2-y v) x)))
+      (begin
+        (set-vec2-x! v (* (vec2-x v) (vec2-x x)))
+        (set-vec2-y! v (* (vec2-y v) (vec2-y x))))))
+
+(define-inlinable (vec2-add! v x)
+  "Add X, a real number or vec2, to the vec2 V."
+  (if (real? x)
+      (begin
+        (set-vec2-x! v (+ (vec2-x v) x))
+        (set-vec2-y! v (+ (vec2-y v) x)))
+      (begin
+        (set-vec2-x! v (+ (vec2-x v) (vec2-x x)))
+        (set-vec2-y! v (+ (vec2-y v) (vec2-y x))))))
+
+(define-inlinable (vec2-sub! v x)
+  "Subtract X, a real number or vec2, from the vec2 V."
+  (if (real? x)
+      (begin
+        (set-vec2-x! v (- (vec2-x v) x))
+        (set-vec2-y! v (- (vec2-y v) x)))
+      (begin
+        (set-vec2-x! v (- (vec2-x v) (vec2-x x)))
+        (set-vec2-y! v (- (vec2-y v) (vec2-y x))))))
diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm
index 5e8afc9..0b882d6 100644
--- a/chickadee/render/shader.scm
+++ b/chickadee/render/shader.scm
@@ -136,10 +136,10 @@
   (gl-uniform1f location n))
 
 (define (set-float-vector2-uniform! location v)
-  (gl-uniform2f location (vx v) (vy v)))
+  (gl-uniform2fv location 1 (vec2->pointer v)))
 
-(define (set-float-vector3-uniform! location v)
-  (gl-uniform3f location (vx v) (vy v) (vz v)))
+;; (define (set-float-vector3-uniform! location v)
+;;   (gl-uniform3f location (vx v) (vy v) (vz v)))
 
 (define (set-float-vector4-uniform! location v)
   (if (color? v)
@@ -148,16 +148,18 @@
                     (color-g v)
                     (color-b v)
                     (color-a v))
-      (gl-uniform4f location (vx v) (vy v) (vz v) (vw v))))
+      #f
+      ;; (gl-uniform4f location (vx v) (vy v) (vz v) (vw v))
+      ))
 
-(define (set-integer-vector2-uniform! location v)
-  (gl-uniform2i location (vx v) (vy v)))
+;; (define (set-integer-vector2-uniform! location v)
+;;   (gl-uniform2i location (vx v) (vy v)))
 
-(define (set-integer-vector3-uniform! location v)
-  (gl-uniform3i location (vx v) (vy v) (vz v)))
+;; (define (set-integer-vector3-uniform! location v)
+;;   (gl-uniform3i location (vx v) (vy v) (vz v)))
 
-(define (set-integer-vector4-uniform! location v)
-  (gl-uniform4i location (vx v) (vy v) (vz v) (vw v)))
+;; (define (set-integer-vector4-uniform! location v)
+;;   (gl-uniform4i location (vx v) (vy v) (vz v) (vw v)))
 
 (define (set-float-matrix4-uniform! location m)
   (gl-uniform-matrix4fv location 1 #f
@@ -175,9 +177,9 @@
    ((= type (version-2-0 float-vec2)) 'float-vec2)
    ((= type (version-2-0 float-vec3)) 'float-vec3)
    ((= type (version-2-0 float-vec4)) 'float-vec4)
-   ((= type (version-2-0 int-vec2)) 'int-vec2)
-   ((= type (version-2-0 int-vec3)) 'int-vec3)
-   ((= type (version-2-0 int-vec4)) 'int-vec4)
+   ;; ((= type (version-2-0 int-vec2)) 'int-vec2)
+   ;; ((= type (version-2-0 int-vec3)) 'int-vec3)
+   ;; ((= type (version-2-0 int-vec4)) 'int-vec4)
    ((= type (version-2-0 float-mat4)) 'mat4)
    ((= type (version-2-0 sampler-2d)) 'sampler-2d)
    (else
@@ -191,12 +193,12 @@
     ('int 0)
     ('unsigned-int 0)
     ('float 0.0)
-    ('float-vec2 (vector2 0.0 0.0))
-    ('float-vec3 (vector3 0.0 0.0 0.0))
-    ('float-vec4 (vector4 0.0 0.0 0.0 0.0))
-    ('int-vec2 (vector2 0 0))
-    ('int-vec3 (vector3 0 0 0))
-    ('int-vec4 (vector4 0 0 0 0))
+    ('float-vec2 (vec2 0.0 0.0))
+    ;; ('float-vec3 (vector3 0.0 0.0 0.0))
+    ;; ('float-vec4 (vector4 0.0 0.0 0.0 0.0))
+    ;; ('int-vec2 (vector2 0 0))
+    ;; ('int-vec3 (vector3 0 0 0))
+    ;; ('int-vec4 (vector4 0 0 0 0))
     ('sampler-2d 0)
     ('mat4 %default-mat4)))
 
@@ -208,11 +210,11 @@
     ('unsigned-int set-unsigned-integer-uniform!)
     ('float set-float-uniform!)
     ('float-vec2 set-float-vector2-uniform!)
-    ('float-vec3 set-float-vector3-uniform!)
-    ('float-vec4 set-float-vector4-uniform!)
-    ('int-vec2 set-integer-vector2-uniform!)
-    ('int-vec3 set-integer-vector3-uniform!)
-    ('int-vec4 set-integer-vector4-uniform!)
+    ;; ('float-vec3 set-float-vector3-uniform!)
+    ;; ('float-vec4 set-float-vector4-uniform!)
+    ;; ('int-vec2 set-integer-vector2-uniform!)
+    ;; ('int-vec3 set-integer-vector3-uniform!)
+    ;; ('int-vec4 set-integer-vector4-uniform!)
     ('mat4 set-float-matrix4-uniform!)
     ('sampler-2d set-sampler-2d-uniform!)))