Add scene system and update example

engine/core.scm

@@ -293,7 +293,7 @@
 
 ;; Event bus interface
 (export register-event-bus remove-event-bus fetch-event-bus
-	push-event peek-event pop-event)
+	clear-event-bus push-event peek-event pop-event)
 
 ;; Register a new event bus
 (define (register-event-bus name)
@@ -315,6 +315,18 @@
 	name)
       #f))
 
+(define (clear-event-bus name)
+  (assert (symbol? name))
+  (let ((event-bus (fetch-event-bus name)))
+    (if event-bus
+	(begin
+	  (for-each
+	   (lambda (key)
+	     (hash-table-delete! event-bus key))
+	   (hash-table-keys event-bus))
+	  #t)
+	#f)))
+
 ;; Fetch an event bus by name, or #f if it doesn't exist
 (define (fetch-event-bus name)
   (assert (symbol? name))
@@ -366,7 +378,7 @@
   (key key-press-key))
 
 ;; Add a new action to the input actions alist
-(export register-action)
+(export register-action push-actions)
 (define (register-action name type . data)
   (assert (symbol? name))
   (assert (member type '(key-press)))
@@ -378,22 +390,22 @@
 	  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))))
+(define push-actions
+  (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/scene.scm

@@ -0,0 +1,42 @@
+(module (engine scene) ()
+(import scheme
+	(chicken base)
+	(chicken module)
+	(engine core)
+	(srfi 1)
+	(srfi 99))
+
+;; This is just for easier serialization
+(define-record-type <entity>
+  (make-entity name components)
+  entity?
+  (name entity-name)
+  (components entity-components))
+
+(export entity named-entity)
+(define (entity . components)
+  (apply make-entity (cons '() (list components))))
+
+(define (named-entity name . components)
+  (apply make-entity (cons name (list components))))
+
+(export scene)
+;; Every element of items here is either an entity record or system
+(define (scene . items)
+  (lambda ()
+    (clear-world)
+    (clear-systems)
+    (clear-event-bus 'input)
+    (for-each
+     (lambda (entity)
+       (if (null? (entity-name entity))
+	   (apply create-entity (entity-components entity))
+	   (apply create-named-entity (cons (entity-name entity)
+					    (entity-components entity)))))
+     (filter entity? items))
+    (for-each
+     (lambda (system)
+       (add-system system))
+     (filter system? items))))
+
+)

samples/bounce.scm

@@ -6,6 +6,7 @@
 	(engine components core)
 	(engine math)
 	(engine drawing)
+	(engine scene)
 	(srfi 1)
 	(srfi 99))
 
@@ -14,24 +15,24 @@
 
 (define +ball-radius+ 50)
 
-(add-system
- (make-system 'draw-circles
-	      0
-	      'entity
-	      '(<visual-2d> <screen-transform>)
-	      (lambda (_ vis-2d transform)
-		(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 ()
-					  (let ((draw-pos (v+ (position transform)
-							      (circle-2d-center circle))))
-					    (draw-circle-2d
-					     draw-pos
-					     (circle-2d-radius circle)
-					     (visual-2d-color vis-2d)
-					     (circle-2d-filled? circle))))))))))
+(define draw-circles
+  (make-system 'draw-circles
+	       0
+	       'entity
+	       '(<visual-2d> <screen-transform>)
+	       (lambda (_ vis-2d transform)
+		 (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 ()
+					   (let ((draw-pos (v+ (position transform)
+							       (circle-2d-center circle))))
+					     (draw-circle-2d
+					      draw-pos
+					      (circle-2d-radius circle)
+					      (visual-2d-color vis-2d)
+					      (circle-2d-filled? circle))))))))))
 
 
 (define-record-type <rigidbody-2d>
@@ -42,85 +43,96 @@
 (define +gravity+ (vec 0 9.8))
 (define +friction+ -0.1)
 
-(add-system
- (make-system 'apply-gravity
-	      0
-	      'entity
-	      '(<rigidbody-2d>)
-	      (lambda (_ rbody)
-		(set-rigidbody-2d-velocity! rbody
-					    (v+ (rigidbody-2d-velocity rbody)
-						(v* (get-frame-time)
-						    +gravity+))))))
+(define apply-gravity
+  (make-system 'apply-gravity
+	       0
+	       'entity
+	       '(<rigidbody-2d>)
+	       (lambda (_ rbody)
+		 (set-rigidbody-2d-velocity! rbody
+					     (v+ (rigidbody-2d-velocity rbody)
+						 (v* (get-frame-time)
+						     +gravity+))))))
 
-(add-system
- (make-system 'apply-bounce
-	      1
-	      'entity
-	      '(<rigidbody-2d> <screen-transform>)
-	      (lambda (_ rbody transform)
-		(when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+))
-		  (set-rigidbody-2d-velocity! rbody
-					      (v* (rigidbody-2d-velocity rbody)
-						  (vec 1 -1)))))))
+(define apply-bounce
+  (make-system 'apply-bounce
+	       1
+	       'entity
+	       '(<rigidbody-2d> <screen-transform>)
+	       (lambda (_ rbody transform)
+		 (when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+))
+		   (set-rigidbody-2d-velocity! rbody
+					       (v* (rigidbody-2d-velocity rbody)
+						   (vec 1 -1)))))))
 
-(add-system
- (make-system 'apply-wall-bounce
-	      1
-	      'entity
-	      '(<rigidbody-2d> <screen-transform>)
-	      (lambda (_ rbody transform)
-		(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)
-						  (vec -1 1)))))))
+(define apply-wall-bounce
+  (make-system 'apply-wall-bounce
+	       1
+	       'entity
+	       '(<rigidbody-2d> <screen-transform>)
+	       (lambda (_ rbody transform)
+		 (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)
+						   (vec -1 1)))))))
 
-(add-system
- (make-system 'apply-friction
-	      2
-	      'entity
-	      '(<rigidbody-2d>)
-	      (lambda (_ rbody)
-		(set-rigidbody-2d-velocity! rbody
-					    (v+ (rigidbody-2d-velocity rbody)
-						(v* (get-frame-time)
-						    +friction+
-						    (rigidbody-2d-velocity rbody)))))))
+(define apply-friction
+  (make-system 'apply-friction
+	       2
+	       'entity
+	       '(<rigidbody-2d>)
+	       (lambda (_ rbody)
+		 (set-rigidbody-2d-velocity! rbody
+					     (v+ (rigidbody-2d-velocity rbody)
+						 (v* (get-frame-time)
+						     +friction+
+						     (rigidbody-2d-velocity rbody)))))))
 
-(add-system
- (make-system 'move-rigidbody
-	      3
-	      'entity
-	      '(<rigidbody-2d> <screen-transform>)
-	      (lambda (_ rbody transform)
-		(set-position! transform
-			       (v+ (rigidbody-2d-velocity rbody)
-				   (position transform))))))
+(define move-rigidbody
+  (make-system 'move-rigidbody
+	       3
+	       'entity
+	       '(<rigidbody-2d> <screen-transform>)
+	       (lambda (_ rbody transform)
+		 (set-position! transform
+				(v+ (rigidbody-2d-velocity rbody)
+				    (position transform))))))
 
 (register-action 'boost 'key-press KEY_SPACE)
+(register-action 'reset 'key-press KEY_R)
 
-(add-system
- (make-system 'boost-rigidbody
-	      2
-	      'entity
-	      '(<rigidbody-2d>)
-	      (lambda (_ rbody)
-		(when (peek-event 'input 'boost)
-		  (set-rigidbody-2d-velocity! rbody
-					      (v* 2
-						  (rigidbody-2d-velocity rbody)))))))
+(define boost-rigidbody
+  (make-system 'boost-rigidbody
+	       2
+	       'entity
+	       '(<rigidbody-2d>)
+	       (lambda (_ rbody)
+		 (when (peek-event 'input 'boost)
+		   (set-rigidbody-2d-velocity! rbody
+					       (v* 2
+						   (rigidbody-2d-velocity rbody)))))))
 
-(add-system
- (make-system 'clear-boost
-	      4
-	      'global
-	      '()
-	      (lambda ()
-		(pop-event 'input 'boost))))
+(define clear-boost
+  (make-system 'clear-boost
+	       4
+	       'global
+	       '()
+	       (lambda ()
+		 (pop-event 'input 'boost))))
+
+(define *bounce-scene* (make-parameter (lambda () #f)))
+(define reload-scene
+  (make-system 'reload-scene
+	       4
+	       'global
+	       '()
+	       (lambda ()
+		 (when (pop-event 'input 'reset)
+		   (((*bounce-scene*)))))))
 
 (define (make-ball position velocity color)
-  (create-entity
+  (entity
    (make-visual-2d
     (make-circle-2d
      (vec 0 0)
@@ -134,20 +146,36 @@
     0
     (vec 1 1)
     'center
-    'none)
+    '())
    (make-rigidbody-2d velocity)))
 
-(make-ball (vec 100 100)
-	   (vec 5 1)
-	   (make-color 0 0 1 1))
+(*bounce-scene*
+ (lambda ()
+   (scene
+    push-actions
+    draw-circles
+    apply-gravity
+    apply-bounce
+    apply-wall-bounce
+    apply-friction
+    move-rigidbody
+    boost-rigidbody
+    clear-boost
+    reload-scene
+    
+    (make-ball (vec 100 100)
+	       (vec 5 1)
+	       (make-color 0 0 1 1))
 
-(make-ball (vec 200 200)
-	   (vec -2 -2)
-	   (make-color 0 1 0 1))
+    (make-ball (vec 200 200)
+	       (vec -2 -2)
+	       (make-color 0 1 0 1))
 
-(make-ball (vec 300 300)
-	   (vec -2 -2)
-	   (make-color 1 0 0 1))
+    (make-ball (vec 300 300)
+	       (vec -2 -2)
+	       (make-color 1 0 0 1)))))
 
+
+(((*bounce-scene*)))
 (create-window)
 )