diff options
| -rw-r--r-- | chickadee/math/vector.scm | 320 | ||||
| -rw-r--r-- | chickadee/render/shader.scm | 50 |
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!))) |