summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/math/vector.scm320
-rw-r--r--chickadee/render/shader.scm50
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!)))