Systems, bug fixes, and first samples

engine/components.scm

@@ -2,12 +2,14 @@
 (import scheme
 	(chicken base)
 	(chicken module)
+	(engine guards)
 	(srfi 1)
+	(srfi 4)
 	(srfi 99))
 
 ;; Vector exports
-(export make-vector2 vector2? vector2-x
+(export make-vector2 vector2? vector-x
-	set-vector2-x! vector2-y set-vector2-y!)
+	set-vector-x! vector-y set-vector-y!)
 
 ;; 2D Vector type
 ;; TODO: this could be done with a macro to save some definitions
@@ -162,7 +164,7 @@
 		       magnitude))))))
 
 ;; Color exports
-(export make-color color-r color-g color-b color-a
+(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
@@ -174,6 +176,14 @@
   (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)))
@@ -222,7 +232,7 @@
   (parent screen-transform-parent int:set-screen-transform-parent!))
 
 ;; Type safe constructor
-(define (make-screen-transform position rotation scale anchor parent)
+(define (make-screen-transform position pivot rotation scale anchor parent)
   (assert (vector2? position))
   (assert (real? rotation))
   (assert (vector2? scale))
@@ -230,7 +240,7 @@
 							  center-left center center-right
 							  bottom-left bottom-middle bottom-right))))
   (assert (and (symbol? parent)))
-  (int:make-screen-transform position rotation scale anchor 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
@@ -344,7 +354,7 @@
 
 (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!)
+	circle-2d-filled? set-circle-2d-filled!)
 (define-record-type <circle-2d>
   (int:make-circle-2d center radius filled)
   circle-2d?
@@ -368,7 +378,7 @@
 ;; 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
+	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)
@@ -399,15 +409,15 @@
   (guarded-mutator rectangle-2d? 'thickness (conjoin integer? positive?)))
 
 (export triangle-2d? make-triangle-2d triangle-2d-vertex-1
-	triangle-2d-set-vertex-1! triangle-2d-vertex-2 triangle-2d-set-vertex-2!
+	set-triangle-2d-vertex-1! triangle-2d-vertex-2 set-triangle-2d-vertex-2!
-	triangle-2d-vertex-3 triangle-2d-set-vertex-3! triangle-2d-filled set-triangle-2d-filled!)
+	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!))
+  (filled triangle-2d-filled? int:set-triangle-2d-filled!))
 
 (define (make-triangle-2d vertex-1 vertex-2 vertex-3 filled)
   (assert (vector2? vertex-1))
@@ -422,7 +432,7 @@
   (guarded-mutator triangle-2d? 'vertex-2 vector2?))
 (define set-triangle-2d-vertex-3!
   (guarded-mutator triangle-2d? 'vertex-3 vector2?))
-(define set-triangle-2d-vertex-filled!
+(define set-triangle-2d-filled!
   (guarded-mutator triangle-2d? 'filled boolean?))
 
 ;; Visual component
@@ -436,12 +446,13 @@
   (layer visual-2d-layer int:set-visual-2d-layer!))
 
 (define (make-visual-2d draw color layer)
-  (assert ((conjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?) draw))
+  (assert ((disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?) draw))
   (assert (color? color))
-  (assert (integer? layer)))
+  (assert (integer? layer))
+  (int:make-visual-2d draw color layer))
 
 (define set-visual-2d-draw!
-  (guarded-mutator visual-2d? 'draw (conjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?)))
+  (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!

engine/core.scm

@@ -22,6 +22,8 @@
 ;; The component-sets hash table
 (define component-sets (make-hash-table))
 
+(define component-eq-comparator (make-eq-comparator))
+
 ;; Insert an entity into component-sets, either creating
 ;; a new set or updating an existing one for the component
 ;; type provided.
@@ -36,7 +38,7 @@
 				       id)))
 	(hash-table-set! component-sets
 			 component-type
-			 (set (make-eq-comparator) id)))))
+			 (set component-eq-comparator id)))))
 
 ;; Create an entity in the world immediately,
 ;; and add it to the requisite component-sets
@@ -111,6 +113,12 @@
   (assert (symbol? id))
   (hash-table-ref world id))
 
+;; Get all entities by their component types
+(define (query-by-components . components)
+  (assert (every symbol? components))
+  (let ((sets (map (lambda (comp) (hash-table-ref component-sets comp)) components)))
+    (apply set-intersection sets)))
+
 ;; Create an entity in the world and return it's ID
 ;; TODO: consider whether we want to use a hash-table for the entity list. I'm not sure yet how punishing O(n) lookup will be here, so it might be sometihng to look at once we start handling entity execution
 (define (create-named-entity id . components)
@@ -154,7 +162,7 @@
 (define (make-system name priority mode criteria process)
   (assert (symbol? name))
   (assert (integer? priority))
-  (assert (member mode '(enity batch)))
+  (assert (member mode '(entity batch)))
   (assert (every symbol? criteria))
   (assert (procedure? process))
   (int:make-system name priority mode criteria process))
@@ -236,7 +244,7 @@
   (sort-systems))
 
 ;; System creation/removal interface
-(export add-system remove-system clear-systems)
+(export add-system remove-system clear-systems execute-system execute-systems)
 
 ;; Add a system to the state processing and return its name
 (define (add-system system)
@@ -256,10 +264,12 @@
    (map system-name systems)))
 
 ;; Execute a single system
-;; TODO: Implement
 (define (execute-system system)
   (assert (system? system))
-  #t)
+  (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)))))
 
 (define (execute-systems)
   (for-each
@@ -386,7 +396,7 @@
       (when (eq? mode '3d)
 	(begin-mode-3d (*active-camera-3d*)))
       (for-each
-       (lambda (render-obj) (cdr render-obj))
+       (lambda (render-obj) ((cdr render-obj)))
        (sort queue
 	     (lambda (render-obj-a render-obj-b)
 	       (< (car render-obj-a)
@@ -422,10 +432,11 @@
 ;; Generate the next frame, for use in the main game loop
 (define (next-frame)
   (resolve-queues)
+  (execute-systems)
   (perform-render))
 
 ;; Window creation
-(export *window-size* *window-title* create-window)
+(export *window-size* *window-title* *target-fps* create-window)
 
 ;; Window size to use
 (define *window-size* (guarded-parameter '(768 . 576)

samples/bounce.scm

@@ -0,0 +1,53 @@
+(module (bounce) ()
+(import scheme
+	(chicken base)
+	raylib
+	(engine core)
+	(engine components core)
+	(srfi 1))
+
+(*window-title* "Bounce!")
+(*target-fps* 60)
+
+(add-system
+ (make-system 'draw-circles
+	      0
+	      'entity
+	      '(<visual-2d> <screen-transform>)
+	      (lambda (ball)
+		(let ((vis-2d (find visual-2d? ball))
+		      (transform (find screen-transform? ball)))
+		  (when (circle-2d? (visual-2d-draw vis-2d))
+		    (let ((circle (visual-2d-draw vis-2d)))
+		      (push-render-object 'screen
+					  (visual-2d-layer vis-2d)
+					  (lambda ()
+					    ((if (circle-2d-filled? circle)
+						 draw-circle
+						 draw-circle-lines)
+					     (+ (vector-x (position transform))
+						(vector-x (circle-2d-center circle)))
+					     (+ (vector-y (position transform))
+						(vector-y (circle-2d-center circle)))
+					     (circle-2d-radius circle)
+					     (use-color (visual-2d-color vis-2d)))))))))))
+
+
+(create-entity
+ (make-visual-2d
+  (make-circle-2d
+   (make-vector2 0 0)
+   50
+   #t)
+  (make-color 0 0 1 1)
+  0)
+ (make-screen-transform
+  (make-vector2 100 100)
+  (make-vector2 0 0)
+  0
+  (make-vector2 1 1)
+  'center
+  'none))
+
+(create-window)
+)