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 <vector2>
-  (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 (vec2? start-pos))
-  (assert (vector2? end-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 (vec2? vertex-1))
-  (assert (vector2? vertex-2))
+  (assert (vec2? vertex-2))
-  (assert (vector2? vertex-3))
+  (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?))
 

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 <vector2>
+  (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))))))
 )

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)
+					     (v-x draw-pos)
-					     (vector-y 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
 	      '(<rigidbody-2d> <screen-transform>)
 	      (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
 	      '(<rigidbody-2d> <screen-transform>)
 	      (lambda (_ rbody transform)
-		(when (or (> (vector-x (position transform)) (- (car (*window-size*)) +ball-radius+))
+		(when (or (> (v-x (position transform)) (- (car (*window-size*)) +ball-radius+))
-			  (< (vector-x (position transform)) (+ 0 +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)
+(make-ball (vec 100 100)
-	   (vector 5 1)
+	   (vec 5 1)
 	   (make-color 0 0 1 1))
 
-(make-ball (vector 300 300)
+(make-ball (vec 300 300)
-	   (vector -2 -2)
+	   (vec -2 -2)
 	   (make-color 0 1 0 1))
 
-(make-ball (vector 600 600)
+(make-ball (vec 600 600)
-	   (vector -2 -2)
+	   (vec -2 -2)
 	   (make-color 1 0 0 1))
 
 (create-window)

test/components.scm

@@ -7,24 +7,24 @@
 	(srfi 78)
 	(srfi 99))
 
-(define v1 (make-vector2 0 0))
+(define v1 (vec 0 0))
-(define v2 (make-vector2 10 10))
+(define v2 (vec 10 10))
 
-(check (vector-= v2 (make-vector2 10 10)) => #t)
+(check (v= v2 (vec 10 10)) => #t)
-(check (vector-= (make-vector2 20 20)
+(check (v= (vec 20 20)
-		 (vector-+ v2 (make-vector2 10 10))) => #t)
+	   (v+ v2 (vec 10 10))) => #t)
-(check (vector-= v1
+(check (v= v1
-		 (vector-- v2 (make-vector2 10 10))) => #t)
+	   (v- v2 (vec 10 10))) => #t)
-(check (vector-= (make-vector2 100 100)
+(check (v= (vec 100 100)
-		 (vector-* v2 (make-vector2 10 10))) => #t)
+	   (v* v2 (vec 10 10))) => #t)
-(check (vector-= (make-vector2 1 1)
+(check (v= (vec 1 1)
-		 (vector-/ v2 (make-vector2 10 10))) => #t)
+	   (v/ v2 (vec 10 10))) => #t)
-(check (vector-magnitude (make-vector2 100 0)) => 100)
+(check (vector-magnitude (vec 100 0)) => 100)
-(check (vector-= (make-vector2 1 0)
+(check (v= (vec 1 0)
-		 (vector-normalize (make-vector2 100 0))) => #t)
+	   (vector-normalize (vec 100 0))) => #t)
-(check (vector-dot (make-vector2 1 2)
+(check (vector-dot (vec 1 2)
-		   (make-vector2 3 4)) => 11)
+		   (vec 3 4)) => 11)
 (check (rad-to-deg
-	(vector-angle-between (make-vector2 1 2)
+	(vector-angle-between (vec 1 2)
-			      (make-vector2 3 4))) (=> approx-=) 10.305)
+			      (vec 3 4))) (=> approx-=) 10.305)
 )