Global and local position

engine/components.scm

@@ -2,220 +2,12 @@
 (import scheme
 	(chicken base)
 	(chicken module)
+	(engine core)
 	(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!)
-
-;; Color type
-(define-record-type <color>
-  (int:make-color r g b a)
-  color?
-  (r color-r int:set-color-r!)
-  (g color-g int:set-color-g!)
-  (b color-b int:set-color-b!)
-  (a color-a int:set-color-a!))
-
-;; Get a raylib color vector from a color
-(define (use-color col)
-  (assert (color? col))
-  (u8vector (floor (* 255 (color-r col)))
-	    (floor (* 255 (color-g col)))
-	    (floor (* 255 (color-b col)))
-	    (floor (* 255 (color-a col)))))
-
-;; Type safe color constructor
-(define (make-color r g b a)
-  (assert (and (number? r) (<= 0 r 1)))
-  (assert (and (number? g) (<= 0 g 1)))
-  (assert (and (number? b) (<= 0 b 1)))
-  (assert (and (number? a) (<= 0 a 1)))
-  (int:make-color r g b a))
-
-;; Type safe color setter
-(define (set-color-r! color r)
-  (assert (color? color))
-  (assert (and (number? r) (<= 0 r 1)))
-  (int:set-color-r! color r))
-
-;; Type safe color setter
-(define (set-color-g! color g)
-  (assert (color? color))
-  (assert (and (number? g) (<= 0 g 1)))
-  (int:set-color-g! color g))
-
-;; Type safe color setter
-(define (set-color-b! color b)
-  (assert (color? color))
-  (assert (and (number? b) (<= 0 b 1)))
-  (int:set-color-b! color b))
-
-;; Type safe color setter
-(define (set-color-a! color a)
-  (assert (color? color))
-  (assert (and (number? a) (<= 0 a 1)))
-  (int:set-color-a! color a))
-
 ;; Screen transform record and exports
 (export make-screen-transform screen-transform?)
 
@@ -233,20 +25,28 @@
 
 ;; 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))))
-  (assert (and (symbol? parent)))
+  (assert (or (null? parent) (screen-transform? parent)))
   (int:make-screen-transform position pivot rotation scale anchor parent))
 
 ;; Generic accessors and mutators for position, rotation, scale, anchor, and parent
 ;; This allows us to abstract across different transform types - (position) will work for
 ;; screen-transform and 2D-transform, with type checking
-(export position set-position! rotation set-rotation! scale set-scale!
+(export global-position position set-position! rotation
-	anchor set-anchor! parent set-parent!)
+	set-rotation! scale set-scale! anchor set-anchor!
+	parent set-parent!)
+
+(define (global-position component)
+  (assert (record? component))
+  (if (null? (parent component))
+      ((rtd-accessor (record-rtd component) 'position) component)
+      (v+ ((rtd-accessor (record-rtd component) 'position) component)
+	  (global-position (parent component)))))
 
 (define (position component)
   (assert (record? component))
@@ -255,7 +55,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 +65,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 +85,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)
@@ -312,149 +112,4 @@
    ((screen-transform? component)
     (assert (symbol? anchor))))
   ((rtd-mutator (record-rtd component) 'parent) component parent))
-
-;; Visuals
-;; Primitive shape visual types
-(export pixel-2d? make-pixel-2d
-	pixel-2d-position set-pixel-2d-position!)
-(define-record-type <pixel-2d>
-  (int:make-pixel-2d position)
-  pixel-2d?
-  (position pixel-2d-position int:set-pixel-2d-position!))
-
-(define (make-pixel-2d position)
-  (assert (vector2? position))
-  (int:make-pixel-2d position))
-
-(define set-pixel-2d-position!
-  (guarded-mutator pixel-2d? 'position vector2?))
-
-(export line-2d? make-line-2d line-2d-start-pos
-	set-line-2d-start-pos! line-2d-end-pos set-line-2d-end-pos!
-	line-2d-thickness set-line-2d-thickness!)
-(define-record-type <line-2d>
-  (int:make-line-2d start-pos end-pos thickness)
-  line-2d?
-  (start-pos line-2d-start-pos int:set-line-2d-start-pos!)
-  (end-pos line-2d-end-pos int:set-line-2d-end-pos!)
-  (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 ((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?))
-(define set-line-2d-end-pos!
-  (guarded-mutator line-2d? 'end-pos vector2?))
-(define set-line-2d-thickness!
-  (guarded-mutator line-2d? 'start-pos (conjoin integer? positive?)))
-
-(export circle-2d? make-circle-2d circle-2d-center
-	set-circle-2d-center! circle-2d-radius set-circle-2d-radius!
-	circle-2d-filled? set-circle-2d-filled!)
-(define-record-type <circle-2d>
-  (int:make-circle-2d center radius filled)
-  circle-2d?
-  (center circle-2d-center int:set-circle-2d-center!)
-  (radius circle-2d-radius int:set-circle-2d-radius!)
-  (filled circle-2d-filled? int:set-circle-2d-filled!))
-
-(define (make-circle-2d center radius filled)
-  (assert (vector2? 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?))
-(define set-circle-2d-radius!
-  (guarded-mutator circle-2d? 'radius (conjoin integer? positive?)))
-(define set-circle-2d-filled!
-  (guarded-mutator circle-2d? 'filled boolean?))
-
-;; TODO: might be nicer to have the origin and width/height inside a rect-2d type or similar
-(export rectangle-2d? make-rectangle-2d rectangle-2d-origin
-	set-rectangle-2d-origin! rectangle-2d-width set-rectangle-2d-width!
-	rectangle-2d-height set-rectangle-2d-height! rectangle-2d-filled?
-	set-rectangle-2d-filled! rectangle-2d-thickness set-rectangle-2d-thickness!)
-(define-record-type <rectangle-2d>
-  (int:make-rectangle-2d origin width height filled thickness)
-  rectangle-2d?
-  (origin rectangle-2d-origin int:set-rectangle-2d-origin!)
-  (width rectangle-2d-width int:set-rectangle-2d-width!)
-  (height rectangle-2d-height int:set-rectangle-2d-height!)
-  (filled rectangle-2d-filled? int:set-rectangle-2d-filled!)
-  (thickness rectangle-2d-thickness int:set-rectangle-2d-thickness))
-
-(define (make-rectangle-2d origin width height filled thickness)
-  (assert (vector2? origin))
-  (assert ((conjoin integer? positive?) width))
-  (assert ((conjoin integer? positive?) height))
-  (assert (boolean? filled))
-  (assert ((conjoin integer? positive?) thickness))
-  (int:make-rectangle-2d origin width height filled thickness))
-
-(define set-rectangle-2d-origin!
-  (guarded-mutator rectangle-2d? 'origin vector2?))
-(define set-rectangle-2d-width!
-  (guarded-mutator rectangle-2d? 'width (conjoin integer? positive?)))
-(define set-rectangle-2d-height!
-  (guarded-mutator rectangle-2d? 'height (conjoin integer? positive?)))
-(define set-rectangle-2d-filled!
-  (guarded-mutator rectangle-2d? 'filled boolean?))
-(define set-rectangle-2d-thickness!
-  (guarded-mutator rectangle-2d? 'thickness (conjoin integer? positive?)))
-
-(export triangle-2d? make-triangle-2d triangle-2d-vertex-1
-	set-triangle-2d-vertex-1! triangle-2d-vertex-2 set-triangle-2d-vertex-2!
-	triangle-2d-vertex-3 set-triangle-2d-vertex-3! triangle-2d-filled? set-triangle-2d-filled!)
-(define-record-type <triangle-2d>
-  (int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled)
-  triangle-2d?
-  (vertex-1 triangle-2d-vertex-1 int:set-triangle-2d-vertex-1!)
-  (vertex-2 triangle-2d-vertex-2 int:set-triangle-2d-vertex-2!)
-  (vertex-3 triangle-2d-vertex-3 int:set-triangle-2d-vertex-3!)
-  (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 (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?))
-(define set-triangle-2d-vertex-2!
-  (guarded-mutator triangle-2d? 'vertex-2 vector2?))
-(define set-triangle-2d-vertex-3!
-  (guarded-mutator triangle-2d? 'vertex-3 vector2?))
-(define set-triangle-2d-filled!
-  (guarded-mutator triangle-2d? 'filled boolean?))
-
-;; Visual component
-(export visual-2d? make-visual-2d visual-2d-draw set-visual-2d-draw!
-	visual-2d-color set-visual-2d-color! visual-2d-layer set-visual-2d-layer!)
-(define-record-type <visual-2d>
-  (int:make-visual-2d draw color layer)
-  visual-2d?
-  (draw visual-2d-draw int:set-visual-2d-draw!) ;; NOTE: Typing here: pixel-2d, line-2d, circle-2d, rectangle-2d, triangle-2d etc
-  (color visual-2d-color int:set-visual-2d-color!)
-  (layer visual-2d-layer int:set-visual-2d-layer!))
-
-(define (make-visual-2d draw color layer)
-  (assert ((disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?) draw))
-  (assert (color? color))
-  (assert (integer? layer))
-  (int:make-visual-2d draw color layer))
-
-(define set-visual-2d-draw!
-  (guarded-mutator visual-2d? 'draw (disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?)))
-(define set-visual-2d-color!
-  (guarded-mutator visual-2d? 'color color?))
-(define set-visual-2d-layer!
-  (guarded-mutator visual-2d? 'layer integer?))
 )

engine/core.scm

@@ -271,7 +271,17 @@
       (let ((entities (map get-entity (set->list (apply query-by-components (system-criteria system))))))
 	(cond
 	 ((eqv? (system-mode system) 'batch) ((system-process system) entities))
-	 ((eqv? (system-mode system) 'entity) (for-each (lambda (e) ((system-process system) e)) entities))))))
+	 ((eqv? (system-mode system) 'entity)
+	  (for-each (lambda (e)
+		      (apply (system-process system)
+			     (cons e
+				   (map (lambda (component)
+					  (find (lambda (c)
+						  (eqv? (rtd-name (record-rtd c))
+							component))
+						e))
+					(system-criteria system)))))
+		    entities))))))
 
 (define (execute-systems)
   (for-each
@@ -346,6 +356,45 @@
 	  event)
 	#f)))
 
+;; Input actions alist
+(define input-actions '())
+
+;; Key-press type action
+(define-record-type <key-press>
+  (make-key-press key)
+  key-press?
+  (key key-press-key))
+
+;; Add a new action to the input actions alist
+(export register-action)
+(define (register-action name type . data)
+  (assert (symbol? name))
+  (assert (member type '(key-press)))
+  (set! input-actions
+    (cons (cons name
+		(apply (cond
+			((eqv? type 'key-press) make-key-press))
+		       data))
+	  input-actions)))
+
+;; Default global system for simple input management
+(add-system
+ (make-system
+  'push-actions
+  0
+  'global
+  '()
+  (lambda ()
+    (for-each
+     (lambda (action)
+       (cond
+	((key-press? (cdr action))
+	 (when (key-pressed? (key-press-key (cdr action)))
+	   (push-event 'input
+		       (car action)
+		       (cdr action))))))
+     input-actions))))
+
 ;; Render queue exports
 (export register-render-queue push-render-object evaluate-render-queue)
 

engine/drawing.scm

@@ -0,0 +1,230 @@
+(module (engine drawing) ()
+(import scheme
+	(chicken base)
+	(chicken module)
+	raylib
+	(engine guards)
+	(engine math)
+	(srfi 4)
+	(srfi 99))
+
+;; Color exports
+(export make-color color-r color-g color-b color-a
+	set-color-r! set-color-g! set-color-b! set-color-a!)
+
+;; Color type
+(define-record-type <color>
+  (int:make-color r g b a)
+  color?
+  (r color-r int:set-color-r!)
+  (g color-g int:set-color-g!)
+  (b color-b int:set-color-b!)
+  (a color-a int:set-color-a!))
+
+;; Get a raylib color vec from a color
+(define (use-color col)
+  (assert (color? col))
+  (u8vector (floor (* 255 (color-r col)))
+	    (floor (* 255 (color-g col)))
+	    (floor (* 255 (color-b col)))
+	    (floor (* 255 (color-a col)))))
+
+;; Type safe color constructor
+(define (make-color r g b a)
+  (assert (and (number? r) (<= 0 r 1)))
+  (assert (and (number? g) (<= 0 g 1)))
+  (assert (and (number? b) (<= 0 b 1)))
+  (assert (and (number? a) (<= 0 a 1)))
+  (int:make-color r g b a))
+
+;; Type safe color setter
+(define (set-color-r! color r)
+  (assert (color? color))
+  (assert (and (number? r) (<= 0 r 1)))
+  (int:set-color-r! color r))
+
+;; Type safe color setter
+(define (set-color-g! color g)
+  (assert (color? color))
+  (assert (and (number? g) (<= 0 g 1)))
+  (int:set-color-g! color g))
+
+;; Type safe color setter
+(define (set-color-b! color b)
+  (assert (color? color))
+  (assert (and (number? b) (<= 0 b 1)))
+  (int:set-color-b! color b))
+
+;; Type safe color setter
+(define (set-color-a! color a)
+  (assert (color? color))
+  (assert (and (number? a) (<= 0 a 1)))
+  (int:set-color-a! color a))
+
+
+;; Visuals
+;; Primitive shape visual types
+;; Pixel
+(export pixel-2d? make-pixel-2d
+	pixel-2d-position set-pixel-2d-position!)
+(define-record-type <pixel-2d>
+  (int:make-pixel-2d position)
+  pixel-2d?
+  (position pixel-2d-position int:set-pixel-2d-position!))
+
+(define (make-pixel-2d position)
+  (assert (vec2? position))
+  (int:make-pixel-2d position))
+
+(define set-pixel-2d-position!
+  (guarded-mutator pixel-2d? 'position vec2?))
+
+;; Line2D
+(export line-2d? make-line-2d line-2d-start-pos
+	set-line-2d-start-pos! line-2d-end-pos set-line-2d-end-pos!
+	line-2d-thickness set-line-2d-thickness!)
+(define-record-type <line-2d>
+  (int:make-line-2d start-pos end-pos thickness)
+  line-2d?
+  (start-pos line-2d-start-pos int:set-line-2d-start-pos!)
+  (end-pos line-2d-end-pos int:set-line-2d-end-pos!)
+  (thickness line-2d-thickness int:set-line-2d-thickness!))
+
+(define (make-line-2d start-pos end-pos thickness)
+  (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 vec2?))
+(define set-line-2d-end-pos!
+  (guarded-mutator line-2d? 'end-pos vec2?))
+(define set-line-2d-thickness!
+  (guarded-mutator line-2d? 'start-pos (conjoin integer? positive?)))
+
+;; Circle2D
+(export circle-2d? make-circle-2d circle-2d-center
+	set-circle-2d-center! circle-2d-radius set-circle-2d-radius!
+	circle-2d-filled? set-circle-2d-filled!)
+(define-record-type <circle-2d>
+  (int:make-circle-2d center radius filled)
+  circle-2d?
+  (center circle-2d-center int:set-circle-2d-center!)
+  (radius circle-2d-radius int:set-circle-2d-radius!)
+  (filled circle-2d-filled? int:set-circle-2d-filled!))
+
+(define (make-circle-2d center radius filled)
+  (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 vec2?))
+(define set-circle-2d-radius!
+  (guarded-mutator circle-2d? 'radius (conjoin integer? positive?)))
+(define set-circle-2d-filled!
+  (guarded-mutator circle-2d? 'filled boolean?))
+
+;; Rectangle2D
+;; TODO: might be nicer to have the origin and width/height inside a rect-2d type or similar
+(export rectangle-2d? make-rectangle-2d rectangle-2d-origin
+	set-rectangle-2d-origin! rectangle-2d-width set-rectangle-2d-width!
+	rectangle-2d-height set-rectangle-2d-height! rectangle-2d-filled?
+	set-rectangle-2d-filled! rectangle-2d-thickness set-rectangle-2d-thickness!)
+(define-record-type <rectangle-2d>
+  (int:make-rectangle-2d origin width height filled thickness)
+  rectangle-2d?
+  (origin rectangle-2d-origin int:set-rectangle-2d-origin!)
+  (width rectangle-2d-width int:set-rectangle-2d-width!)
+  (height rectangle-2d-height int:set-rectangle-2d-height!)
+  (filled rectangle-2d-filled? int:set-rectangle-2d-filled!)
+  (thickness rectangle-2d-thickness int:set-rectangle-2d-thickness))
+
+(define (make-rectangle-2d origin width height filled thickness)
+  (assert (vec2? origin))
+  (assert ((conjoin integer? positive?) width))
+  (assert ((conjoin integer? positive?) height))
+  (assert (boolean? filled))
+  (assert ((conjoin integer? positive?) thickness))
+  (int:make-rectangle-2d origin width height filled thickness))
+
+(define set-rectangle-2d-origin!
+  (guarded-mutator rectangle-2d? 'origin vec2?))
+(define set-rectangle-2d-width!
+  (guarded-mutator rectangle-2d? 'width (conjoin integer? positive?)))
+(define set-rectangle-2d-height!
+  (guarded-mutator rectangle-2d? 'height (conjoin integer? positive?)))
+(define set-rectangle-2d-filled!
+  (guarded-mutator rectangle-2d? 'filled boolean?))
+(define set-rectangle-2d-thickness!
+  (guarded-mutator rectangle-2d? 'thickness (conjoin integer? positive?)))
+
+;; Triangle2D
+(export triangle-2d? make-triangle-2d triangle-2d-vertex-1
+	set-triangle-2d-vertex-1! triangle-2d-vertex-2 set-triangle-2d-vertex-2!
+	triangle-2d-vertex-3 set-triangle-2d-vertex-3! triangle-2d-filled? set-triangle-2d-filled!)
+(define-record-type <triangle-2d>
+  (int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled)
+  triangle-2d?
+  (vertex-1 triangle-2d-vertex-1 int:set-triangle-2d-vertex-1!)
+  (vertex-2 triangle-2d-vertex-2 int:set-triangle-2d-vertex-2!)
+  (vertex-3 triangle-2d-vertex-3 int:set-triangle-2d-vertex-3!)
+  (filled triangle-2d-filled? int:set-triangle-2d-filled!))
+
+(define (make-triangle-2d vertex-1 vertex-2 vertex-3 filled)
+  (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 vec2?))
+(define set-triangle-2d-vertex-2!
+  (guarded-mutator triangle-2d? 'vertex-2 vec2?))
+(define set-triangle-2d-vertex-3!
+  (guarded-mutator triangle-2d? 'vertex-3 vec2?))
+(define set-triangle-2d-filled!
+  (guarded-mutator triangle-2d? 'filled boolean?))
+
+;; Visual component
+(export visual-2d? make-visual-2d visual-2d-draw set-visual-2d-draw!
+	visual-2d-color set-visual-2d-color! visual-2d-layer set-visual-2d-layer!)
+(define-record-type <visual-2d>
+  (int:make-visual-2d draw color layer)
+  visual-2d?
+  (draw visual-2d-draw int:set-visual-2d-draw!) ;; NOTE: Typing here: pixel-2d, line-2d, circle-2d, rectangle-2d, triangle-2d etc
+  (color visual-2d-color int:set-visual-2d-color!)
+  (layer visual-2d-layer int:set-visual-2d-layer!))
+
+(define (make-visual-2d draw color layer)
+  (assert ((disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?) draw))
+  (assert (color? color))
+  (assert (integer? layer))
+  (int:make-visual-2d draw color layer))
+
+(define set-visual-2d-draw!
+  (guarded-mutator visual-2d? 'draw (disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?)))
+(define set-visual-2d-color!
+  (guarded-mutator visual-2d? 'color color?))
+(define set-visual-2d-layer!
+  (guarded-mutator visual-2d? 'layer integer?))
+
+;; Drawing functions
+;; Helper wrappers for raylib functions
+(export draw-circle-2d)
+(define (draw-circle-2d pos-vec radius color filled)
+  (assert (vec2? pos-vec))
+  (assert (number? radius))
+  (assert (color? color))
+  (assert (boolean? filled))
+  ((if filled
+       draw-circle
+       draw-circle-2d)
+   (number->integer (v-x pos-vec))
+   (number->integer (v-y pos-vec))
+   (number->integer radius)
+   (use-color color)))
+)

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,163 @@
 ;; Approximately equal - for real number comparison
 (define (approx-= x y)
   (< (abs (- x y)) (*float-precision*)))
+
+;; Somewhat reliable fixnum conversion
+(export number->integer)
+(define (number->integer number)
+  (assert (number? number))
+  (inexact->exact (round number)))
+
+;; 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,8 @@
 	raylib
 	(engine core)
 	(engine components core)
+	(engine math)
+	(engine drawing)
 	(srfi 1)
 	(srfi 99))
 
@@ -17,23 +19,19 @@
 	      0
 	      'entity
 	      '(<visual-2d> <screen-transform>)
-	      (lambda (ball)
+	      (lambda (_ vis-2d transform)
-		(let ((vis-2d (find visual-2d? ball))
+		(when (circle-2d? (visual-2d-draw vis-2d))
-		      (transform (find screen-transform? ball)))
+		  (let ((circle (visual-2d-draw vis-2d)))
-		  (when (circle-2d? (visual-2d-draw vis-2d))
+		    (push-render-object 'screen
-		    (let ((circle (visual-2d-draw vis-2d)))
+					(visual-2d-layer vis-2d)
-		      (push-render-object 'screen
+					(lambda ()
-					  (visual-2d-layer vis-2d)
+					  (let ((draw-pos (v+ (position transform)
-					  (lambda ()
+							      (circle-2d-center circle))))
-					    ((if (circle-2d-filled? circle)
+					    (draw-circle-2d
-						 draw-circle
+					     draw-pos
-						 draw-circle-lines)
-					     (inexact->exact (round (+ (vector-x (position transform))
-								       (vector-x (circle-2d-center circle)))))
-					     (inexact->exact (round (+ (vector-y (position transform))
-								       (vector-y (circle-2d-center circle)))))
 					     (circle-2d-radius circle)
-					     (use-color (visual-2d-color vis-2d)))))))))))
+					     (visual-2d-color vis-2d)
+					     (circle-2d-filled? circle))))))))))
 
 
 (define-record-type <rigidbody-2d>
@@ -41,7 +39,7 @@
   rigidbody-2d?
   (velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!))
 
-(define +gravity+ (make-vector2 0 9.8))
+(define +gravity+ (vec 0 9.8))
 (define +friction+ -0.1)
 
 (add-system
@@ -49,149 +47,107 @@
 	      0
 	      'entity
 	      '(<rigidbody-2d>)
-	      (lambda (body)
+	      (lambda (_ rbody)
-		(let ((rbody (find rigidbody-2d? body)))
+		(set-rigidbody-2d-velocity! rbody
-		  (set-rigidbody-2d-velocity! rbody
+					    (v+ (rigidbody-2d-velocity rbody)
-					      (vector-+ (rigidbody-2d-velocity rbody)
+						(v* (get-frame-time)
-							(vector-*
+						    +gravity+))))))
-							 (make-vector2 (get-frame-time)
-								       (get-frame-time))
-							 +gravity+)))))))
 
 (add-system
  (make-system 'apply-bounce
 	      1
 	      'entity
 	      '(<rigidbody-2d> <screen-transform>)
-	      (lambda (ball)
+	      (lambda (_ rbody transform)
-		(let ((rbody (find rigidbody-2d? ball))
+		(when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+))
-		      (transform (find screen-transform? ball)))
+		  (set-rigidbody-2d-velocity! rbody
-		  (when (> (vector-y (position transform)) (- (cdr (*window-size*)) +ball-radius+))
+					      (v* (rigidbody-2d-velocity rbody)
-		    (set-rigidbody-2d-velocity! rbody
+						  (vec 1 -1)))))))
-						(make-vector2 (vector-x (rigidbody-2d-velocity rbody)) (* -1 (vector-y (rigidbody-2d-velocity rbody))))))))))
 
 (add-system
  (make-system 'apply-wall-bounce
 	      1
 	      'entity
 	      '(<rigidbody-2d> <screen-transform>)
-	      (lambda (ball)
+	      (lambda (_ rbody transform)
-		(let ((rbody (find rigidbody-2d? ball))
+		(when (or (> (v-x (position transform)) (- (car (*window-size*)) +ball-radius+))
-		      (transform (find screen-transform? ball)))
+			  (< (v-x (position transform)) (+ 0 +ball-radius+)))
-		  (when (or (> (vector-x (position transform)) (- (car (*window-size*)) +ball-radius+))
+		  (set-rigidbody-2d-velocity! rbody
-			    (< (vector-x (position transform)) (+ 0 +ball-radius+)))
+					      (v* (rigidbody-2d-velocity rbody)
-		    (set-rigidbody-2d-velocity! rbody
+						  (vec -1 1)))))))
-						(make-vector2 (* -1 (vector-x (rigidbody-2d-velocity rbody))) (vector-y (rigidbody-2d-velocity rbody)))))))))
 
 (add-system
  (make-system 'apply-friction
 	      2
 	      'entity
 	      '(<rigidbody-2d>)
-	      (lambda (ball)
+	      (lambda (_ rbody)
-		(let ((rbody (find rigidbody-2d? ball)))
+		(set-rigidbody-2d-velocity! rbody
-		  (set-rigidbody-2d-velocity! rbody
+					    (v+ (rigidbody-2d-velocity rbody)
-					      (vector-+ (rigidbody-2d-velocity rbody)
+						(v* (get-frame-time)
-							(vector-*
+						    +friction+
-							 (make-vector2 (* (get-frame-time) +friction+) (* (get-frame-time) +friction+))
+						    (rigidbody-2d-velocity rbody)))))))
-							 (rigidbody-2d-velocity rbody))))))))
 
 (add-system
  (make-system 'move-rigidbody
 	      3
 	      'entity
 	      '(<rigidbody-2d> <screen-transform>)
-	      (lambda (ball)
+	      (lambda (_ rbody transform)
-		(let ((rbody (find rigidbody-2d? ball))
+		(set-position! transform
-		      (transform (find screen-transform? ball)))
+			       (v+ (rigidbody-2d-velocity rbody)
-		  (set-position! transform
+				   (position transform))))))
-				 (vector-+ (rigidbody-2d-velocity rbody)
-					   (position transform)))))))
 
-(define-record-type <key-press>
+(register-action 'boost 'key-press KEY_SPACE)
-  (make-key-press key)
-  key-press?
-  (key key-press-key))
-
-(add-system
- (make-system 'input
-	      0
-	      'global
-	      '()
-	      (lambda ()
-		(when (key-pressed? KEY_SPACE)
-		  (push-event 'input 'boost (make-key-press 'space))))))
 
 (add-system
  (make-system 'boost-rigidbody
 	      2
 	      'entity
 	      '(<rigidbody-2d>)
-	      (lambda (ball)
+	      (lambda (_ rbody)
-		(let ((rbody (find rigidbody-2d? ball)))
+		(when (peek-event 'input 'boost)
-		  (when (peek-event 'input 'boost)
+		  (set-rigidbody-2d-velocity! rbody
-		    (set-rigidbody-2d-velocity! rbody
+					      (v* 2
-						(vector-* (make-vector2 2 2)
+						  (rigidbody-2d-velocity rbody)))))))
-							  (rigidbody-2d-velocity rbody))))))))
 
 (add-system
- (make-system 'clear-boost-input
+ (make-system 'clear-boost
-	      10
+	      4
 	      'global
 	      '()
 	      (lambda ()
 		(pop-event 'input 'boost))))
 
-(create-entity
+(define (make-ball position velocity color)
- (make-visual-2d
+  (create-entity
-  (make-circle-2d
+   (make-visual-2d
-   (make-vector2 0 0)
+    (make-circle-2d
-   +ball-radius+
+     (vec 0 0)
-   #t)
+     +ball-radius+
-  (make-color 0 0 1 1)
+     #t)
-  0)
+    color
- (make-screen-transform
+    0)
-  (make-vector2 100 100)
+   (make-screen-transform
-  (make-vector2 0 0)
+    position
-  0
+    (vec 0 0)
-  (make-vector2 1 1)
+    0
-  'center
+    (vec 1 1)
-  'none)
+    'center
- (make-rigidbody-2d (make-vector2 5 1)))
+    'none)
+   (make-rigidbody-2d velocity)))
 
-(create-entity
+(make-ball (vec 100 100)
- (make-visual-2d
+	   (vec 5 1)
-  (make-circle-2d
+	   (make-color 0 0 1 1))
-   (make-vector2 0 0)
-   +ball-radius+
-   #t)
-  (make-color 0 1 0 1)
-  0)
- (make-screen-transform
-  (make-vector2 100 100)
-  (make-vector2 0 0)
-  0
-  (make-vector2 1 1)
-  'center
-  'none)
- (make-rigidbody-2d (make-vector2 -2 -2)))
 
-(create-entity
+(make-ball (vec 200 200)
- (make-visual-2d
+	   (vec -2 -2)
-  (make-circle-2d
+	   (make-color 0 1 0 1))
-   (make-vector2 0 0)
+
-   +ball-radius+
+(make-ball (vec 300 300)
-   #t)
+	   (vec -2 -2)
-  (make-color 1 0 0 1)
+	   (make-color 1 0 0 1))
-  0)
- (make-screen-transform
-  (make-vector2 100 100)
-  (make-vector2 0 0)
-  0
-  (make-vector2 1 1)
-  'center
-  'none)
- (make-rigidbody-2d (make-vector2 10 -5)))
 
 (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)
 )