diff --git a/engine/components.scm b/engine/components.scm index bdbd8c5..d68e07a 100644 --- a/engine/components.scm +++ b/engine/components.scm @@ -3,166 +3,11 @@ (chicken base) (chicken module) (engine guards) + (engine math) (srfi 1) (srfi 4) (srfi 99)) -;; Vector exports -(export make-vector2 vector2? vector-x - set-vector-x! vector-y set-vector-y!) - -;; 2D Vector type -;; TODO: this could be done with a macro to save some definitions -(define-record-type - (int:make-vector2 x y) - vector2? - (x vector2-x int:set-vector2-x!) - (y vector2-y int:set-vector2-y!)) - -;; Type safe 2D vector constructor -(define (make-vector2 x y) - (assert (number? x)) - (assert (number? y)) - (int:make-vector2 x y)) - -;; Type safe 2D vector setter -(define (set-vector2-x! vector2 x) - (assert (vector2? vector2)) - (assert (number? x)) - (int:set-vector2-x! vector2 x)) - -;; Type safe 2D vector setter -(define (set-vector2-y! vector2 y) - (assert (vector2? vector2)) - (assert (number? y)) - (int:set-vector2-y! vector2 y)) - -;; Vector utility functions -(define (vector-x component) - (assert (record? component)) - ((rtd-accessor (record-rtd component) 'x) component)) - -(define (set-vector-x! component x) - (assert (record? component)) - (assert (number? x)) - ((rtd-mutator (record-rtd component) 'x) component x)) - -(define (vector-y component) - (assert (record? component)) - ((rtd-accessor (record-rtd component) 'y) component)) - -(define (set-vector-y! component y) - (assert (record? component)) - (assert (number? y)) - ((rtd-mutator (record-rtd component) 'y) component y)) - -;; Export vector functions -(export vector-= vector-+ vector-- vector-* vector-/ - vector-magnitude vector-normalize vector-dot - vector-angle-between) - -;; TODO: make this function accept any number of vectors -(define (vector-= vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (and (= (vector-x vec1) (vector-x vec2)) - (= (vector-y vec1) (vector-y vec2)))))) - -;; TODO: make this function accept any number of vectors -(define (vector-+ vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (make-vector2 (+ (vector-x vec1) (vector-x vec2)) - (+ (vector-y vec1) (vector-y vec2)))))) - -;; TODO: make this function accept any number of vectors -(define (vector-- vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (make-vector2 (- (vector-x vec1) (vector-x vec2)) - (- (vector-y vec1) (vector-y vec2)))))) - -;; TODO: make this function accept any number of vectors -(define (vector-* vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (make-vector2 (* (vector-x vec1) (vector-x vec2)) - (* (vector-y vec1) (vector-y vec2)))))) - -;; TODO: make this function accept any number of vectors -(define (vector-/ vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (make-vector2 (/ (vector-x vec1) (vector-x vec2)) - (/ (vector-y vec1) (vector-y vec2)))))) - -;; Magnitude -(define (vector-magnitude vec) - (assert ((disjoin vector2?) vec)) - (cond - ((vector2? vec) - (sqrt (+ (expt (vector-x vec) 2) - (expt (vector-y vec) 2)))))) - -(define (vector-dot vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (+ (* (vector-x vec1) (vector-x vec2)) - (* (vector-y vec1) (vector-y vec2)))))) - -(define (vector-angle-between vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (acos (/ (vector-dot vec1 vec2) - (* (vector-magnitude vec1) - (vector-magnitude vec2))))))) - -;; Normalization -(define (vector-normalize vec) - (assert ((disjoin vector2?) vec)) ;; TODO: This assertion should be moved out of here - (let ((magnitude (vector-magnitude vec))) - (cond - ((vector2? vec) - (make-vector2 (/ (vector-x vec) - magnitude) - (/ (vector-y vec) - magnitude)))))) - ;; Color exports (export make-color use-color color-r color-g color-b color-a set-color-r! set-color-g! set-color-b! set-color-a!) @@ -176,7 +21,7 @@ (b color-b int:set-color-b!) (a color-a int:set-color-a!)) -;; Get a raylib color vector from a color +;; Get a raylib color vec from a color (define (use-color col) (assert (color? col)) (u8vector (floor (* 255 (color-r col))) @@ -233,9 +78,9 @@ ;; Type safe constructor (define (make-screen-transform position pivot rotation scale anchor parent) - (assert (vector2? position)) + (assert (vec2? position)) (assert (real? rotation)) - (assert (vector2? scale)) + (assert (vec2? scale)) (assert (and (symbol? anchor) (member anchor '(top-left top-middle top-right center-left center center-right bottom-left bottom-middle bottom-right)))) @@ -255,7 +100,7 @@ (define (set-position! component position) (assert (record? component)) (cond - ((screen-transform? component) (assert (vector2? position)))) + ((screen-transform? component) (assert (vec2? position)))) ((rtd-mutator (record-rtd component) 'position) component position)) (define (pivot component) @@ -265,7 +110,7 @@ (define (set-pivot! component pivot) (assert (record? component)) (cond - ((screen-transform? component) (assert (vector2? pivot)))) + ((screen-transform? component) (assert (vec2? pivot)))) ((rtd-mutator (record-rtd component) 'pivot) component pivot)) (define (rotation component) @@ -285,7 +130,7 @@ (define (set-scale! component scale) (assert (record? component)) (cond - ((screen-transform? component) (assert (vector2? scale)))) + ((screen-transform? component) (assert (vec2? scale)))) ((rtd-mutator (record-rtd component) 'scale) component scale)) (define (anchor component) @@ -323,11 +168,11 @@ (position pixel-2d-position int:set-pixel-2d-position!)) (define (make-pixel-2d position) - (assert (vector2? position)) + (assert (vec2? position)) (int:make-pixel-2d position)) (define set-pixel-2d-position! - (guarded-mutator pixel-2d? 'position vector2?)) + (guarded-mutator pixel-2d? 'position vec2?)) (export line-2d? make-line-2d line-2d-start-pos set-line-2d-start-pos! line-2d-end-pos set-line-2d-end-pos! @@ -340,15 +185,15 @@ (thickness line-2d-thickness int:set-line-2d-thickness!)) (define (make-line-2d start-pos end-pos thickness) - (assert (vector2? start-pos)) - (assert (vector2? end-pos)) + (assert (vec2? start-pos)) + (assert (vec2? end-pos)) (assert ((conjoin integer? positive?) thickness)) (int:make-line-2d start-pos end-pos thickness)) (define set-line-2d-start-pos! - (guarded-mutator line-2d? 'start-pos vector2?)) + (guarded-mutator line-2d? 'start-pos vec2?)) (define set-line-2d-end-pos! - (guarded-mutator line-2d? 'end-pos vector2?)) + (guarded-mutator line-2d? 'end-pos vec2?)) (define set-line-2d-thickness! (guarded-mutator line-2d? 'start-pos (conjoin integer? positive?))) @@ -363,13 +208,13 @@ (filled circle-2d-filled? int:set-circle-2d-filled!)) (define (make-circle-2d center radius filled) - (assert (vector2? center)) + (assert (vec2? center)) (assert ((conjoin integer? positive?) radius)) (assert (boolean? filled)) (int:make-circle-2d center radius filled)) (define set-circle-2d-center! - (guarded-mutator circle-2d? 'center vector2?)) + (guarded-mutator circle-2d? 'center vec2?)) (define set-circle-2d-radius! (guarded-mutator circle-2d? 'radius (conjoin integer? positive?))) (define set-circle-2d-filled! @@ -390,7 +235,7 @@ (thickness rectangle-2d-thickness int:set-rectangle-2d-thickness)) (define (make-rectangle-2d origin width height filled thickness) - (assert (vector2? origin)) + (assert (vec2? origin)) (assert ((conjoin integer? positive?) width)) (assert ((conjoin integer? positive?) height)) (assert (boolean? filled)) @@ -398,7 +243,7 @@ (int:make-rectangle-2d origin width height filled thickness)) (define set-rectangle-2d-origin! - (guarded-mutator rectangle-2d? 'origin vector2?)) + (guarded-mutator rectangle-2d? 'origin vec2?)) (define set-rectangle-2d-width! (guarded-mutator rectangle-2d? 'width (conjoin integer? positive?))) (define set-rectangle-2d-height! @@ -420,18 +265,18 @@ (filled triangle-2d-filled? int:set-triangle-2d-filled!)) (define (make-triangle-2d vertex-1 vertex-2 vertex-3 filled) - (assert (vector2? vertex-1)) - (assert (vector2? vertex-2)) - (assert (vector2? vertex-3)) + (assert (vec2? vertex-1)) + (assert (vec2? vertex-2)) + (assert (vec2? vertex-3)) (assert (boolean? filled)) (int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled)) (define set-triangle-2d-vertex-1! - (guarded-mutator triangle-2d? 'vertex-1 vector2?)) + (guarded-mutator triangle-2d? 'vertex-1 vec2?)) (define set-triangle-2d-vertex-2! - (guarded-mutator triangle-2d? 'vertex-2 vector2?)) + (guarded-mutator triangle-2d? 'vertex-2 vec2?)) (define set-triangle-2d-vertex-3! - (guarded-mutator triangle-2d? 'vertex-3 vector2?)) + (guarded-mutator triangle-2d? 'vertex-3 vec2?)) (define set-triangle-2d-filled! (guarded-mutator triangle-2d? 'filled boolean?)) diff --git a/engine/math.scm b/engine/math.scm index e4f608d..ead9b9b 100644 --- a/engine/math.scm +++ b/engine/math.scm @@ -1,7 +1,9 @@ (module (engine math) () (import scheme (chicken base) - (chicken module)) + (chicken module) + (srfi 1) + (srfi 99)) (export PI PI/2) (define PI @@ -24,4 +26,157 @@ ;; Approximately equal - for real number comparison (define (approx-= x y) (< (abs (- x y)) (*float-precision*))) + +;; Vector exports +(export vec vec? vec2? v-x + set-v-x! v-y set-v-y!) + +;; 2D Vector type +;; TODO: this could be done with a macro to save some definitions +(define-record-type + (int:make-vector2 x y) + vec2? + (x vector2-x int:set-vector2-x!) + (y vector2-y int:set-vector2-y!)) + +;; Type safe 2D vector constructor +(define (vec . args) + (assert (every number? args)) + (apply (case (length args) + ((2) int:make-vector2)) + args)) + +(define vec? + (disjoin vec2?)) + +;; Vector utility functions +(define (v-x component) + (assert (record? component)) + ((rtd-accessor (record-rtd component) 'x) component)) + +(define (set-v-x! component x) + (assert (record? component)) + (assert (number? x)) + ((rtd-mutator (record-rtd component) 'x) component x)) + +(define (v-y component) + (assert (record? component)) + ((rtd-accessor (record-rtd component) 'y) component)) + +(define (set-v-y! component y) + (assert (record? component)) + (assert (number? y)) + ((rtd-mutator (record-rtd component) 'y) component y)) + +;; Vector operations +(export v= v+ v- v* v/) + +;; Vector equality +(define (v= . vecs) + (assert (every record? vecs)) + (assert (every vec? vecs)) + (assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs))))) + (map (compose rtd-name record-rtd) vecs))) + (and (apply = (map v-x vecs)) + (apply = (map v-y vecs)))) + +;; Vector addition +;; Note that each operand can be either a vector OR a number +;; If a number, that number is added to EVERY member of the vector +(define (v+ . operands) + (assert (every (disjoin number? (conjoin record? vec?)) operands)) + (let ((vecs (filter vec? operands))) + (assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs))))) + (map (compose rtd-name record-rtd) vecs)))) + (let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands)) + (y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands))) + (vec (apply + x-parts) + (apply + y-parts)))) + +;; Vector subtractions +;; Note that each operand can be either a vector OR a number +;; If a number, that number is subtracted from EVERY member of the vector +(define (v- . operands) + (assert (every (disjoin number? (conjoin record? vec?)) operands)) + (let ((vecs (filter vec? operands))) + (assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs))))) + (map (compose rtd-name record-rtd) vecs)))) + (let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands)) + (y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands))) + (vec (apply - x-parts) + (apply - y-parts)))) + +;; Vector multiplication +;; Note that each operand can be either a vector OR a number +;; If a number, that number is multiplied to EVERY member of the vector +(define (v* . operands) + (assert (every (disjoin number? (conjoin record? vec?)) operands)) + (let ((vecs (filter vec? operands))) + (assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs))))) + (map (compose rtd-name record-rtd) vecs)))) + (let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands)) + (y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands))) + (vec (apply * x-parts) + (apply * y-parts)))) + +;; Vector division +;; Note that each operand can be either a vector OR a number +;; If a number, EVERY member of the vector is divided by that number +(define (v/ . operands) + (assert (every (disjoin number? (conjoin record? vec?)) operands)) + (let ((vecs (filter vec? operands))) + (assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs))))) + (map (compose rtd-name record-rtd) vecs)))) + (let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands)) + (y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands))) + (vec (apply / x-parts) + (apply / y-parts)))) + +;; More complex vector functions +(export vector-magnitude vector-normalize vector-dot + vector-angle-between) + +;; Magnitude +(define (vector-magnitude vec) + (assert ((disjoin vec2?) vec)) + (cond + ((vec2? vec) + (sqrt (+ (expt (v-x vec) 2) + (expt (v-y vec) 2)))))) + +;; Dot product of vectors +(define (vector-dot vec1 vec2) + (assert (and (record? vec1) + (record? vec2))) + (assert (eq? (rtd-name (record-rtd vec1)) + (rtd-name (record-rtd vec2)))) + (assert ((disjoin vec2?) vec1)) + (cond + ((vec2? vec1) + (+ (* (v-x vec1) (v-x vec2)) + (* (v-y vec1) (v-y vec2)))))) + +;; Angle between vectors +(define (vector-angle-between vec1 vec2) + (assert (and (record? vec1) + (record? vec2))) + (assert (eq? (rtd-name (record-rtd vec1)) + (rtd-name (record-rtd vec2)))) + (assert ((disjoin vec2?) vec1)) + (cond + ((vec2? vec1) + (acos (/ (vector-dot vec1 vec2) + (* (vector-magnitude vec1) + (vector-magnitude vec2))))))) + +;; Normalization +(define (vector-normalize v) + (assert ((disjoin vec2?) v)) ;; TODO: This assertion should be moved out of here + (let ((magnitude (vector-magnitude v))) + (cond + ((vec2? v) + (vec (/ (v-x v) + magnitude) + (/ (v-y v) + magnitude)))))) ) diff --git a/samples/bounce.scm b/samples/bounce.scm index a6b9e91..4543a4c 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -4,6 +4,7 @@ raylib (engine core) (engine components core) + (engine math) (srfi 1) (srfi 99)) @@ -28,8 +29,8 @@ ((if (circle-2d-filled? circle) draw-circle draw-circle-lines) - (vector-x draw-pos) - (vector-y draw-pos) + (v-x draw-pos) + (v-y draw-pos) (circle-2d-radius circle) (visual-2d-color vis-2d)))))))))) @@ -39,7 +40,7 @@ rigidbody-2d? (velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!)) -(define +gravity+ (vector 0 9.8)) +(define +gravity+ (vec 0 9.8)) (define +friction+ -0.1) (add-system @@ -59,10 +60,10 @@ 'entity '( ) (lambda (_ rbody transform) - (when (> (vector-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) + (when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) (set-rigidbody-2d-velocity! rbody (v* (rigidbody-2d-velocity rbody) - (vector 1 -1))))))) + (vec 1 -1))))))) (add-system (make-system 'apply-wall-bounce @@ -70,11 +71,11 @@ 'entity '( ) (lambda (_ rbody transform) - (when (or (> (vector-x (position transform)) (- (car (*window-size*)) +ball-radius+)) - (< (vector-x (position transform)) (+ 0 +ball-radius+))) + (when (or (> (v-x (position transform)) (- (car (*window-size*)) +ball-radius+)) + (< (v-x (position transform)) (+ 0 +ball-radius+))) (set-rigidbody-2d-velocity! rbody (v* (rigidbody-2d-velocity rbody) - (vector -1 1))))))) + (vec -1 1))))))) (add-system (make-system 'apply-friction @@ -115,30 +116,30 @@ (create-entity (make-visual-2d (make-circle-2d - (vector 0 0) + (vec 0 0) +ball-radius+ #t) color 0) (make-screen-transform position - (vector 0 0) + (vec 0 0) 0 - (vector 1 1) + (vec 1 1) 'center 'none) (make-rigidbody-2d velocity))) -(make-ball (vector 100 100) - (vector 5 1) +(make-ball (vec 100 100) + (vec 5 1) (make-color 0 0 1 1)) -(make-ball (vector 300 300) - (vector -2 -2) +(make-ball (vec 300 300) + (vec -2 -2) (make-color 0 1 0 1)) -(make-ball (vector 600 600) - (vector -2 -2) +(make-ball (vec 600 600) + (vec -2 -2) (make-color 1 0 0 1)) (create-window) diff --git a/test/components.scm b/test/components.scm index d297f0e..317ab9c 100644 --- a/test/components.scm +++ b/test/components.scm @@ -7,24 +7,24 @@ (srfi 78) (srfi 99)) -(define v1 (make-vector2 0 0)) -(define v2 (make-vector2 10 10)) +(define v1 (vec 0 0)) +(define v2 (vec 10 10)) -(check (vector-= v2 (make-vector2 10 10)) => #t) -(check (vector-= (make-vector2 20 20) - (vector-+ v2 (make-vector2 10 10))) => #t) -(check (vector-= v1 - (vector-- v2 (make-vector2 10 10))) => #t) -(check (vector-= (make-vector2 100 100) - (vector-* v2 (make-vector2 10 10))) => #t) -(check (vector-= (make-vector2 1 1) - (vector-/ v2 (make-vector2 10 10))) => #t) -(check (vector-magnitude (make-vector2 100 0)) => 100) -(check (vector-= (make-vector2 1 0) - (vector-normalize (make-vector2 100 0))) => #t) -(check (vector-dot (make-vector2 1 2) - (make-vector2 3 4)) => 11) +(check (v= v2 (vec 10 10)) => #t) +(check (v= (vec 20 20) + (v+ v2 (vec 10 10))) => #t) +(check (v= v1 + (v- v2 (vec 10 10))) => #t) +(check (v= (vec 100 100) + (v* v2 (vec 10 10))) => #t) +(check (v= (vec 1 1) + (v/ v2 (vec 10 10))) => #t) +(check (vector-magnitude (vec 100 0)) => 100) +(check (v= (vec 1 0) + (vector-normalize (vec 100 0))) => #t) +(check (vector-dot (vec 1 2) + (vec 3 4)) => 11) (check (rad-to-deg - (vector-angle-between (make-vector2 1 2) - (make-vector2 3 4))) (=> approx-=) 10.305) + (vector-angle-between (vec 1 2) + (vec 3 4))) (=> approx-=) 10.305) )