From b1ade28aa0eab723292491d20d5841e4cb8da37c Mon Sep 17 00:00:00 2001
From: Javier Sancho <jsf@jsancho.org>
Date: Thu, 27 Feb 2014 15:31:16 +0100
Subject: [PATCH] Entity sets and engine api through systems

* src/system.scm: entities and components in a cons-pair of two hash
                  tables and systems returning entities changes
                  directly

* src/engine.scm: modifying an engine is possible only using systems
                  and each system modify engine entities when runs

* src/examples/entity-componentfunctions.scm,
  src/examples/making-systems.scm,
  src/examples/composing-systems.scm,
  src/examples/engine-conway-game.scm:
        modifications for correct execution with the new state of art
---
 src/engine.scm                              | 195 ++++++-----------
 src/examples/composing-systems.scm          |  44 ++--
 src/examples/engine-conway-game.scm         |   9 -
 src/examples/entity-component-functions.scm |  51 ++---
 src/examples/making-systems.scm             |  18 +-
 src/system.scm                              | 225 ++++++++++----------
 6 files changed, 231 insertions(+), 311 deletions(-)

diff --git a/src/engine.scm b/src/engine.scm
index 27c4b4f..7831ff3 100644
--- a/src/engine.scm
+++ b/src/engine.scm
@@ -24,37 +24,6 @@
   #:use-module (srfi srfi-9 gnu))
 
 
-;;; Engine Properties
-
-(define* (get-property property-path #:key (engine (current-engine)))
-  (let ((entities (get-entities-by-components (list (car property-path)) #:engine engine)))
-    (cond ((null? entities)
-	   #f)
-	  (else
-	   (let loop ((property (get-component (car property-path) (car entities)))
-		      (path (cdr property-path)))
-	     (cond ((or (null? path) (not property))
-		    property)
-		   (else
-		    (loop (assoc-ref property (car path)) (cdr path)))))))))
-
-(define* (set-property! property-path value #:key (engine (current-engine)))
-  (define (loop property path)
-    (cond ((null? path)
-	   value)
-	  (else
-	   (assoc-set! (or property '()) (car path) (loop (assoc-ref property (car path)) (cdr path))))))
-
-  (let ((entities (get-entities-by-components (list (car property-path)) #:engine engine)))
-    (cond ((null? entities)
-	   (new-entity! `(,(car property-path) . ,(loop '() (cdr property-path)))))
-	  (else
-	   (set-entity-components! (get-key (car entities)) `(,(car property-path) . ,(loop (get-component (car property-path) (car entities)) (cdr property-path))))))))
-
-(export get-property
-	set-property!)
-
-
 ;;; Engine Inner Properties
 
 (define (default-step) 0.1)
@@ -66,26 +35,25 @@
 ;;; Engine definitions
 
 (define-record-type engine
-  (make-engine-record entities mutex running-mutex system)
+  (make-engine-record entities mutex running-mutex systems)
   engine?
   (entities engine-entities set-engine-entities!)
   (mutex engine-mutex set-engine-mutex!)
   (running-mutex engine-running-mutex set-engine-running-mutex!)
-  (system engine-system set-engine-system!))
+  (systems engine-systems set-engine-systems!))
 
 (set-record-type-printer! engine
   (lambda (record port)
     (format port "#<[engine] state: ~a, entities: ~a>"
 	    (if (engine-running? record) "Running" "Stopped")
-	    (length (car (engine-entities record))))))
+	    (entity-count (engine-entities record)))))
 
 (define (make-engine . systems)
   (make-engine-record
-   (receive (e c) ((new-entity (default-engine-inner-properties)) '() '())
-     (list e c))
+   (make-entity-set (new-entity (default-engine-inner-properties)))
    (make-mutex)
    (make-mutex)
-   (apply group-systems systems)))
+   systems))
 
 (define-syntax define-engine
   (syntax-rules ()
@@ -101,75 +69,6 @@
 	engine-running?)
 
 
-;;; Engine Access Protocol Interface
-
-(define current-engine-mutex (make-mutex))
-(define current-engine-list '())
-
-(define (current-engine)
-  (with-mutex current-engine-mutex
-    (assoc-ref current-engine-list (current-thread))))
-
-(define (set-current-engine! engine)
-  (with-mutex current-engine-mutex
-    (set! current-engine-list
-	  (cond (engine
-		 (assoc-set! current-engine-list (current-thread) engine))
-		(else
-		 (assoc-remove! current-engine-list (current-thread)))))))
-
-(define* (get-entity key #:key (engine (current-engine)))
-  (assoc key (car (engine-entities engine))))
-
-(define* (get-entities-by-components component-types #:key (engine (current-engine)))
-  (map (lambda (e)
-	 (get-entity e #:engine engine))
-       (find-entities-by-components (cadr (engine-entities engine)) component-types)))
-
-(define-syntax define-entity-setter
-  (syntax-rules ()
-    ((_ name! name)
-     (define (name! . args)
-       (let ((f (apply name args))
-	     (engine (current-engine)))
-	 (receive (e c r) (f (car (engine-entities engine)) (cadr (engine-entities engine)))
-	   (set-engine-entities! engine (list e c))
-	   r))))))
-
-(define-entity-setter new-entity! new-entity)
-(define-entity-setter remove-entity! remove-entity)
-(define-entity-setter set-entity! set-entity)
-(define-entity-setter set-entity-components! set-entity-components)
-(define-entity-setter remove-entity-components! remove-entity-components)
-
-(define-syntax with-engine
-  (syntax-rules ()
-    ((_ engine body ...)
-     (let ((old-engine (current-engine)))
-       (set-current-engine! engine)
-       (let ((res (with-mutex (engine-mutex engine)
-		    body
-		    ...)))
-	 (set-current-engine! old-engine)
-	 res)))))
-
-(define (set-engine-systems! engine . systems)
-  (with-mutex (engine-mutex engine)
-    (set-engine-system! engine (apply group-systems systems))))
-
-(export current-engine
-	set-current-engine!
-	get-entity
-	get-entities-by-components
-	new-entity!
-	remove-entity!
-	set-entity!
-	set-entity-components!
-	remove-entity-components!
-	with-engine
-	set-engine-systems!)
-
-
 ;;; Engine execution
 
 (define (start-engine engine)
@@ -179,32 +78,80 @@
 	     (let ((t (current-utime))
 		   (delay 0)
 		   (halt #f))
-	       (with-engine engine
-	         (receive (e c) ((apply (engine-system engine) (engine-entities engine)))
-		   (set-engine-entities! engine (list e c)))
-		 (set! delay (- (inexact->exact (* (get-property '(engine-inner-properties step)) 1000000))
+	       (with-mutex (engine-mutex engine)
+	         (for-each
+		  (lambda (s) (eval-system s engine))
+		  (engine-systems engine))
+		 (set! delay (- (inexact->exact (* (engine-property engine 'step) 1000000))
 				(- (current-utime) t)))
-		 (set! halt (engine-stopping? #:clean #t)))
+		 (set! halt (engine-stopping? engine #:clean #t)))
 	       (cond ((not halt)
 		      (cond ((> delay 0)
 			     (usleep delay)))
 		      (loop)))))))))
 
+(define (eval-system system engine)
+  (call-with-values
+      (lambda () (system (engine-entities engine)))
+    (lambda vals
+      (let ((changes (car vals)))
+	(cond ((entities-changes? changes)
+	       (set-engine-entities! engine
+	         (modify-entities (engine-entities engine)
+				  (get-entities-changes changes))))))
+      (apply values vals))))
+
+(define-syntax with-engine
+  (syntax-rules ()
+    ((_ engine component-types form ...)
+     (with-mutex (engine-mutex engine)
+       (eval-system (make-system component-types form ...) engine)))))
+
 (define (stop-engine engine)
-  (with-engine engine
-    (new-entity! '(engine-halt . #t)))
+  (with-engine engine ()
+    (entities-changes
+     (list
+      (new-entity '(engine-halt . #t)))))
   'engine-halt)
 
-(define* (engine-stopping? #:key (engine (current-engine)) (clean #f))
-  (let ((halt #f))
-    (let halt-engine ((halts (get-entities-by-components '(engine-halt))))
-      (cond ((not (null? halts))
-	     (set! halt #t)
-	     (cond (clean
-		    (remove-entity! (caar halts))
-		    (halt-engine (cdr halts)))))))
-    halt))
+(define* (engine-stopping? engine #:key (clean #f))
+  (let ((halts (eval-system
+		(make-system ((halt (engine-halt))) halt)
+		engine)))
+    (cond ((and clean (not (null? halts)))
+	   (eval-system
+	    (make-system () (entities-changes (map (lambda (h) (remove-entity (car h))) halts)))
+	    engine)))
+    (not (null? halts))))
 
 (export start-engine
-	stop-engine
-	engine-stopping?)
+	with-engine
+	stop-engine)
+
+
+;;; Properties
+
+(define (engine-property engine name)
+  (eval-system
+   (make-system ((props (engine-inner-properties)))
+     (assoc-ref
+      (assoc-ref (cdar props) 'engine-inner-properties)
+      name))
+   engine))
+
+(define (set-engine-property! engine name value)
+  (eval-system
+   (make-system ((props (engine-inner-properties)))
+     (entities-changes
+      (list
+       (set-entity (caar props)
+		   (car
+		    (assoc-set! (cdar props) 'engine-inner-properties
+				(assoc-set! (assoc-ref (cdar props) 'engine-inner-properties)
+					    name
+					    value)))))))
+   engine)
+  value)
+
+(export engine-property
+	set-engine-property!)
diff --git a/src/examples/composing-systems.scm b/src/examples/composing-systems.scm
index ef6e1e0..1d775c1 100644
--- a/src/examples/composing-systems.scm
+++ b/src/examples/composing-systems.scm
@@ -24,47 +24,41 @@
   (sleep 3)
   (entities-changes
    (map (lambda (e)
-	  (set-entity-components (get-key e) `(l . ,(cons 1 (get-component 'l e)))))
+	  (set-entity-components (get-key e) '(l1 . 1)))
 	with-l)))
 
 (define-system s2 ((with-l (l)))
   (sleep 4)
   (entities-changes
    (map (lambda (e)
-	  (set-entity-components (get-key e) `(l . ,(cons 2 (get-component 'l e)))))
+	  (set-entity-components (get-key e) '(l2 . 2)))
 	with-l)))
 
 (define (composing-with-join)
-  (let ((entities '())
-	(components '()))
-    (receive (e c) (modify-entities (list (new-entity '(l . ())) (new-entity '(l . ()))) entities components)
-      (((join-systems s1 s2) e c)))))
+  (let ((entities (make-entity-set (new-entity '(l . ())) (new-entity '(l . ())) (new-entity '(a . #f)))))
+    (set! entities (modify-entities entities (get-entities-changes ((join-systems s1 s2) entities))))
+    (entity-list entities)))
 
 (export composing-with-join)
 
 
-(define (composing-with-threaded)
-  (let ((entities '())
-	(components '()))
-    (receive (e c) (modify-entities (list (new-entity '(l . ())) (new-entity '(l . ()))) entities components)
-      (((threaded-systems s1 s2) e c)))))
+(define (composing-with-thread)
+  (let ((entities (make-entity-set (new-entity '(l . ())) (new-entity '(l . ())) (new-entity '(a . #f)))))
+    (set! entities (modify-entities entities (get-entities-changes ((thread-systems s1 s2) entities))))
+    (entity-list entities)))
+  
+(export composing-with-thread)
 
-(export composing-with-threaded)
 
-
-(define (join-vs-threaded)
-  (let ((entities '())
-	(components '())
+(define (join-vs-thread)
+  (let ((entities (make-entity-set (new-entity '(l . ())) (new-entity '(l . ())) (new-entity '(a . #f))))
 	(t (current-time)))
-    (receive (e c) (modify-entities (list (new-entity '(l . ())) (new-entity '(l . ()))) entities components)
-      (receive (e c) (((join-systems s1 s2) e c))
-	(format #t "~a~%~a~%Time: ~a~%~%" e c (- (current-time) t)))))
+    (set! entities (modify-entities entities (get-entities-changes ((join-systems s1 s2) entities))))
+    (format #t "~a~%Time: ~a~%~%" entities (- (current-time) t)))
 
-  (let ((entities '())
-	(components '())
+  (let ((entities (make-entity-set (new-entity '(l . ())) (new-entity '(l . ())) (new-entity '(a . #f))))
 	(t (current-time)))
-    (receive (e c) (modify-entities (list (new-entity '(l . ())) (new-entity '(l . ()))) entities components)
-      (receive (e c) (((threaded-systems s1 s2) e c))
-	(format #t "~a~%~a~%Time: ~a~%~%" e c (- (current-time) t))))))
+    (set! entities (modify-entities entities (get-entities-changes ((thread-systems s1 s2) entities))))
+    (format #t "~a~%Time: ~a~%~%" entities (- (current-time) t))))
 
-(export join-vs-threaded)
+(export join-vs-thread)
diff --git a/src/examples/engine-conway-game.scm b/src/examples/engine-conway-game.scm
index 1bd848c..24e23be 100644
--- a/src/examples/engine-conway-game.scm
+++ b/src/examples/engine-conway-game.scm
@@ -80,15 +80,6 @@
 
 (define-engine conway-game lives-or-deads print-world)
 
-(with-engine conway-game
-  (let ((cells '((4 1) (4 2) (5 1) (5 2)
-		 (11 3) (11 4) (11 5) (12 2) (12 6) (13 1) (13 7) (14 1) (14 7)
-		 (15 4) (16 2) (16 6) (17 3) (17 4) (17 5) (18 4)
-		 (21 5) (21 6) (21 7) (22 5) (22 6) (22 7) (23 4) (23 8)
-		 (25 3) (25 4) (25 8) (25 9)
-		 (35 6) (35 7) (36 6) (36 7))))
-    (for-each (lambda (c) (new-entity! `(coord . ,c))) cells)))
-
 (with-engine conway-game ()
   (let ((cells '((4 1) (4 2) (5 1) (5 2)
 		 (11 3) (11 4) (11 5) (12 2) (12 6) (13 1) (13 7) (14 1) (14 7)
diff --git a/src/examples/entity-component-functions.scm b/src/examples/entity-component-functions.scm
index 43316fc..03617ca 100644
--- a/src/examples/entity-component-functions.scm
+++ b/src/examples/entity-component-functions.scm
@@ -24,47 +24,32 @@
 (define-component b)
 
 (define (entity-component-functions)
-  (let ((entities '())
-	(components '())
+  (let ((entities (make-entity-set))
 	(key #f))
-    (receive (e c k) ((new-entity (make-a 1 2) (make-b)) entities components)
+    (receive (e k) ((new-entity (make-a 1 2) (make-b)) entities)
       (set! entities e)
-      (set! components c)
-      (set! key k)
-      (display k) (newline))
-    (format #t "New entity with a and b:~%~a~%~a~%~%" entities components)
+      (set! key (car k)))
+    (format #t "New entity with a and b:~%~a~%~%" (entity-list entities))
 
-    (receive (e c k) ((new-entity (make-a 10 20)) entities components)
-      (set! entities e)
-      (set! components c)
-      (display k) (newline))
-    (format #t "New entity with a:~%~a~%~a~%~%" entities components)
+    (receive (e k) ((new-entity (make-a 10 20)) entities)
+      (set! entities e))
+    (format #t "New entity with a:~%~a~%~%" (entity-list entities))
 
-    (receive (e c) (modify-entities (list (set-entity-components key (make-a 50 50)) (remove-entity-components key 'b)) entities components)
-      (set! entities e)
-      (set! components c))
-    (format #t "First entity removes b and changes a:~%~a~%~a~%~%" entities components)
+    (set! entities (modify-entities entities (list (set-entity-components key (make-a 50 50)) (remove-entity-components key 'b))))
+    (format #t "First entity removes b and changes a:~%~a~%~%" (entity-list entities))
 
-    (receive (e c) ((remove-entity key) entities components)
-      (set! entities e)
-      (set! components c))
-    (format #t "Removes first entity:~%~a~%~a~%~%" entities components)
+    (set! entities ((remove-entity key) entities))
+    (format #t "Removes first entity:~%~a~%~%" (entity-list entities))
 
-    (receive (e c k) ((new-entity (make-a 1 2) (make-b)) entities components)
+    (receive (e k) ((new-entity (make-a 1 2) (make-b)) entities)
       (set! entities e)
-      (set! components c)
-      (set! key k)
-      (display k) (newline))
-    (format #t "New entity with a and b:~%~a~%~a~%~%" entities components)
+      (set! key (car k)))
+    (format #t "New entity with a and b:~%~a~%~%" (entity-list entities))
 
-    (receive (e c) (modify-entities (list (set-entity-components key (make-a 50 50)) (remove-entity-components key 'b) (new-entity (make-a 1000 1000))) entities components)
-      (set! entities e)
-      (set! components c))
-    (format #t "Last entity removes b and changes a, and new entity with a:~%~a~%~a~%~%" entities components)
+    (set! entities (modify-entities entities (list (set-entity-components key (make-a 50 50)) (remove-entity-components key 'b) (new-entity (make-a 1000 1000)))))
+    (format #t "Last entity removes b and changes a, and new entity with a:~%~a~%~%" (entity-list entities))
 
-    (receive (e c) (modify-entities (list (remove-entity key)) entities components)
-      (set! entities e)
-      (set! components c))
-    (format #t "Remove last entity:~%~a~%~a~%~%" entities components)))
+    (set! entities (modify-entities entities (list (remove-entity key))))
+    (format #t "Remove last entity:~%~a~%~%" (entity-list entities))))
 
 (export entity-component-functions)
diff --git a/src/examples/making-systems.scm b/src/examples/making-systems.scm
index 545b7e7..e844087 100644
--- a/src/examples/making-systems.scm
+++ b/src/examples/making-systems.scm
@@ -24,8 +24,9 @@
 
 (define-system s1 ()
   (entities-changes
-   (list (new-entity (make-a 1 2))
-	 (new-entity (make-a 10 20)))))
+   (list
+    (new-entity (make-a 1 2))
+    (new-entity (make-a 10 20)))))
 
 (define-system s2 ((with-a (a)))
   (for-each
@@ -34,13 +35,10 @@
    with-a))
   
 (define (making-systems)
-  (let ((entities '())
-	(components '()))
-    (receive (e c) ((s1 entities components))
-	     (set! entities e)
-	     (set! components c))
-    (format #t "Two new entities with a:~%~a~%~a~%~%" entities components)
-
-    ((s2 entities components))))
+  (let ((entities (make-entity-set)))
+    (set! entities (modify-entities entities (get-entities-changes (s1 entities))))
+    (format #t "Two new entities with a:~%~a~%~%" (entity-list entities))
+
+    (s2 entities)))
 
 (export making-systems)
diff --git a/src/system.scm b/src/system.scm
index 5a70cb5..e6feb4e 100644
--- a/src/system.scm
+++ b/src/system.scm
@@ -83,6 +83,17 @@
 
 ;;; Entities and components
 
+(define (make-entity-set . changes)
+  (modify-entities
+   (cons (make-hash-table) (make-hash-table))
+   changes))
+
+(define (entity-list entity-set)
+  (hash-map->list (lambda (k v) (cons k v)) (car entity-set)))
+
+(define (entity-count entity-set)
+  (hash-count (const #t) (car entity-set)))
+
 (define (normalize-components components)
   (map
    (lambda (c)
@@ -95,89 +106,105 @@
   (cond ((null? components) clist)
 	(else
 	 (let* ((type (car components))
-		(elist (assoc-ref clist type)))
-	   (register-components entity (cdr components)
-	     (assoc-set! clist type
-	       (cond (elist
-		      (lset-adjoin eq? elist entity))
-		     (else
-		      (list entity)))))))))
+		(elist (hash-ref clist type)))
+	   (hash-set! clist type
+	     (cond (elist
+		    (lset-adjoin eq? elist entity))
+		   (else
+		    (list entity))))
+	   (register-components entity (cdr components) clist)))))
 
 (define (unregister-components entity components clist)
   (cond ((null? components) clist)
 	(else
 	 (let* ((type (car components))
-		(elist (lset-difference eq? (assoc-ref clist type) (list entity))))
-	   (unregister-components entity (cdr components)
-	     (cond ((null? elist)
-		    (assoc-remove! clist type))
-		   (else
-		    (assoc-set! clist type elist))))))))
+		(elist (lset-difference eq? (hash-ref clist type) (list entity))))
+	   (cond ((null? elist)
+		  (hash-remove! clist type))
+		 (else
+		  (hash-set! clist type elist)))
+	   (unregister-components entity (cdr components) clist)))))
+
+(define (component-names components)
+  (map (lambda (c) (car c)) components))
+
+(define (entity-component-names key entity-set)
+  (component-names
+   (hash-ref (car entity-set) key)))
+
+(define (entity-ref key entity-set)
+  (hash-get-handle (car entity-set) key))
 
 (define (new-entity . new-components)
-  (lambda (entities components)
+  (lambda (entity-set)
     (let ((key (gensym))
 	  (nc (normalize-components new-components)))
+      (hash-set! (car entity-set) key nc)
+      (register-components key (component-names nc) (cdr entity-set))
       (values
-       (acons key nc entities)
-       (register-components key
-			    (map (lambda (c) (car c)) nc)
-			    components)
+       entity-set
        (cons key nc)))))
 
 (define (remove-entity key)
-  (lambda (entities components)
-    (let ((clist (map (lambda (c) (car c)) (assoc-ref entities key)))
-	  (entity (assoc key entities)))
+  (lambda (entity-set)
+    (let ((clist (entity-component-names key entity-set))
+	  (entity (entity-ref key entity-set)))
+      (hash-remove! (car entity-set) key)
+      (unregister-components key clist (cdr entity-set))
       (values
-       (assoc-remove! entities key)
-       (unregister-components key clist components)
+       entity-set
        entity))))
 
 (define (set-entity key . new-components)
-  (lambda (entities components)
+  (lambda (entity-set)
     (let* ((nc (normalize-components new-components))
-	   (clist (map (lambda (c) (car c)) (assoc-ref entities key)))
-	   (nclist (map (lambda (c) (car c)) nc)))
+	   (clist (entity-component-names key entity-set))
+	   (nclist (component-names nc)))
+      (hash-set! (car entity-set) key nc)
+      (register-components key
+       (lset-difference eq? nclist clist)
+       (unregister-components key (lset-difference eq? clist nclist) (cdr entity-set)))
       (values
-       (assoc-set! entities key nc)
-       (register-components key (lset-difference eq? nclist clist)
-			    (unregister-components key (lset-difference eq? clist nclist) components))
+       entity-set
        (cons key nc)))))
 
 (define (set-entity-components key . new-components)
-  (lambda (entities components)
+  (lambda (entity-set)
     (let ((nc (normalize-components new-components))
-	  (clist (alist-copy (assoc-ref entities key))))
+	  (clist (alist-copy (hash-ref (car entity-set) key))))
       (for-each
        (lambda (c)
-	 (assoc-set! clist (car c) (cdr c)))
+	 (set! clist (assoc-set! clist (car c) (cdr c))))
        nc)
+      (hash-set! (car entity-set) key clist)
+      (register-components key (component-names nc) (cdr entity-set))
       (values
-       (assoc-set! entities key clist)
-       (register-components key (map (lambda (c) (car c)) nc) components)
+       entity-set
        (cons key clist)))))
 
 (define (remove-entity-components key . old-components)
-  (lambda (entities components)
-    (let ((clist (alist-copy (assoc-ref entities key))))
+  (lambda (entity-set)
+    (let ((clist (alist-copy (hash-ref (car entity-set) key))))
       (for-each
        (lambda (c)
-	 (assoc-remove! clist c))
+	 (set! clist (assoc-remove! clist c)))
        old-components)
+      (hash-set! (car entity-set) key clist)
+      (unregister-components key old-components (cdr entity-set))
       (values
-       (assoc-set! entities key clist)
-       (unregister-components key old-components components)
+       entity-set
        (cons key clist)))))
 
-(define (modify-entities changes entities components)
+(define (modify-entities entity-set changes)
   (cond ((null? changes)
-	 (values entities components))
+	 entity-set)
 	(else
-	 (receive (e c) ((car changes) entities components)
-	   (modify-entities (cdr changes) e c)))))
+	 (modify-entities ((car changes) entity-set) (cdr changes)))))
 
-(export new-entity
+(export make-entity-set
+	entity-list
+	entity-count
+	new-entity
 	remove-entity
 	set-entity
 	set-entity-components
@@ -192,33 +219,35 @@
   entities-changes?
   (changes get-entities-changes))
 
-(define* (find-entities-by-components c t)
-  (cond ((null? t) '())
+(define (append-changes changes)
+  (entities-changes
+   (apply append
+	  (map get-entities-changes changes))))
+
+(define (find-entities-by-components entity-set clist)
+  (cond ((null? clist) '())
 	(else
-	 (let* ((e (assoc-ref c (car t)))
-		(e* (if e e '())))
-	   (cond ((null? (cdr t)) e*)
-		 (else
-		  (lset-intersection eq? e* (find-entities-by-components c (cdr t)))))))))
+	 (let ((e (hash-ref (cdr entity-set) (car clist) '()))
+	       (e* (find-entities-by-components entity-set (cdr clist))))
+	   (if (null? e*)
+	       e
+	       (lset-intersection eq? e e*))))))
 
 (define-syntax make-system
   (syntax-rules ()
     ((_ ((name (component-type ...)) ...) form ...)
-     (lambda (entities components)
+     (lambda (entity-set)
        (let ((name (map (lambda (x)
 			  (cons (car x)
 				(filter (lambda (x)
 					  (memq (car x) '(component-type ...)))
 					(cdr x))))
 			(map (lambda (x)
-			       (assoc x entities))
-			     (find-entities-by-components components '(component-type ...)))))
+			       (entity-ref x entity-set))
+			     (find-entities-by-components entity-set '(component-type ...)))))
 	     ...)
-	 (let ((res (begin form ...)))
-	   (lambda* (#:optional (entities2 #f) (components2 #f))
-	     (let ((e (if (and entities2 components2) entities2 entities))
-		   (c (if (and entities2 components2) components2 components)))
-	       (modify-entities (if (entities-changes? res) (get-entities-changes res) '()) e c)))))))))
+	 form
+	 ...)))))
 
 (define-syntax define-system
   (syntax-rules ()
@@ -228,56 +257,33 @@
          form
 	 ...)))))
 
+(define (composed-systems-result results)
+  (let ((changes (filter (lambda (r) (entities-changes? r)) results)))
+    (cond ((null? changes)
+	   (car results))
+	  (else
+	   (append-changes changes)))))
+
 (define (join-systems . systems)
-  (lambda (entities components)
-    (let ((changes
-	   (let run ((s systems) (e (alist-copy entities)) (c (alist-copy components)) (res '()))
-	     (cond ((null? s)
-		    res)
-		   (else
-		    (let ((r ((car s) e c)))
-		      (receive (e2 c2) (r)
-		        (run (cdr s) e2 c2 (cons r res)))))))))
-      (lambda* (#:optional (entities2 #f) (components2 #f))
-        (let modify ((e (if (and entities2 components2) entities2 entities))
-		     (c (if (and entities2 components2) components2 components))
-		     (ch (reverse changes)))
-	  (cond ((null? ch)
-		 (values e c))
-		(else
-		 (receive (e2 c2) ((car ch) e c)
-		   (modify e2 c2 (cdr ch))))))))))
-
-(define (threaded-systems . systems)
-  (lambda (entities components)
-    (let ((changes
-	   (let run-wait ((thd
-			   (map (lambda (s)
-				  (call-with-new-thread
-				   (lambda () (s entities components))))
-				systems))
-			  (res '()))
-	     (cond ((null? thd)
-		    res)
-		   (else
-		    (run-wait (cdr thd) (cons (join-thread (car thd)) res)))))))
-      (lambda* (#:optional (entities2 #f) (components2 #f))
-        (let modify ((e (if (and entities2 components2) entities2 entities))
-		     (c (if (and entities2 components2) components2 components))
-		     (ch changes))
-	  (cond ((null? ch)
-		 (values e c))
-		(else
-		 (receive (e2 c2) ((car ch) e c)
-		   (modify e2 c2 (cdr ch))))))))))
-
-(define (group-systems . systems)
-  (cond ((null? systems)
-	 (make-system ()))
-	((= (length systems) 1)
-	 (car systems))
-	(else
-	 (apply join-systems systems))))
+  (lambda (entity-set)
+    (let run ((s systems) (res '()))
+      (cond ((null? s)
+	     (composed-systems-result res))
+	    (else
+	     (run (cdr s) (cons ((car s) entity-set) res)))))))
+
+(define (thread-systems . systems)
+  (lambda (entity-set)
+    (let run-wait ((thd
+		    (map (lambda (s)
+			   (call-with-new-thread
+			    (lambda () (s entity-set))))
+			 systems))
+		   (res '()))
+      (cond ((null? thd)
+	     (composed-systems-result res))
+	    (else
+	     (run-wait (cdr thd) (cons (join-thread (car thd)) res)))))))
 
 (export entities-changes
 	entities-changes?
@@ -286,8 +292,7 @@
 	define-system
 	make-system
 	join-systems
-	threaded-systems
-	group-systems)
+	thread-systems)
 
 
 ;;; Entities and components access inside systems
-- 
2.39.2