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,7 +390,7 @@
 	  input-actions)))
 
 ;; Default global system for simple input management
-(add-system
+(define push-actions
   (make-system
    'push-actions
    0

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,7 +15,7 @@
 
 (define +ball-radius+ 50)
 
-(add-system
+(define draw-circles
   (make-system 'draw-circles
 	       0
 	       'entity
@@ -42,7 +43,7 @@
 (define +gravity+ (vec 0 9.8))
 (define +friction+ -0.1)
 
-(add-system
+(define apply-gravity
   (make-system 'apply-gravity
 	       0
 	       'entity
@@ -53,7 +54,7 @@
 						 (v* (get-frame-time)
 						     +gravity+))))))
 
-(add-system
+(define apply-bounce
   (make-system 'apply-bounce
 	       1
 	       'entity
@@ -64,7 +65,7 @@
 					       (v* (rigidbody-2d-velocity rbody)
 						   (vec 1 -1)))))))
 
-(add-system
+(define apply-wall-bounce
   (make-system 'apply-wall-bounce
 	       1
 	       'entity
@@ -76,7 +77,7 @@
 					       (v* (rigidbody-2d-velocity rbody)
 						   (vec -1 1)))))))
 
-(add-system
+(define apply-friction
   (make-system 'apply-friction
 	       2
 	       'entity
@@ -88,7 +89,7 @@
 						     +friction+
 						     (rigidbody-2d-velocity rbody)))))))
 
-(add-system
+(define move-rigidbody
   (make-system 'move-rigidbody
 	       3
 	       'entity
@@ -99,8 +100,9 @@
 				    (position transform))))))
 
 (register-action 'boost 'key-press KEY_SPACE)
+(register-action 'reset 'key-press KEY_R)
 
-(add-system
+(define boost-rigidbody
   (make-system 'boost-rigidbody
 	       2
 	       'entity
@@ -111,7 +113,7 @@
 					       (v* 2
 						   (rigidbody-2d-velocity rbody)))))))
 
-(add-system
+(define clear-boost
   (make-system 'clear-boost
 	       4
 	       'global
@@ -119,8 +121,18 @@
 	       (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)
+(*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)
+    (make-ball (vec 200 200)
 	       (vec -2 -2)
 	       (make-color 0 1 0 1))
 
-(make-ball (vec 300 300)
+    (make-ball (vec 300 300)
 	       (vec -2 -2)
-	   (make-color 1 0 0 1))
+	       (make-color 1 0 0 1)))))
 
+
+(((*bounce-scene*)))
 (create-window)
 )