X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fsystem.scm;h=5a70cb5010e34f7db8c0905efd22cbc9b91794f3;hb=405b60cfd27f00e8dda02e19abe09bf7990bfbc2;hp=2bf05208fefb215eec76c28e3075ce0a3f56e218;hpb=c62dceb1471afb94efa57eef5506fbdf6f2ef679;p=gacela.git

diff --git a/src/system.scm b/src/system.scm
index 2bf0520..5a70cb5 100644
--- a/src/system.scm
+++ b/src/system.scm
@@ -187,6 +187,11 @@
 
 ;;; Making systems
 
+(define-record-type entities-changes-type
+  (entities-changes changes)
+  entities-changes?
+  (changes get-entities-changes))
+
 (define* (find-entities-by-components c t)
   (cond ((null? t) '())
 	(else
@@ -213,7 +218,7 @@
 	   (lambda* (#:optional (entities2 #f) (components2 #f))
 	     (let ((e (if (and entities2 components2) entities2 entities))
 		   (c (if (and entities2 components2) components2 components)))
-	       (modify-entities res e c)))))))))
+	       (modify-entities (if (entities-changes? res) (get-entities-changes res) '()) e c)))))))))
 
 (define-syntax define-system
   (syntax-rules ()
@@ -225,27 +230,46 @@
 
 (define (join-systems . systems)
   (lambda (entities components)
-    (let run ((s systems) (e entities) (c components))
-      (cond ((null? s)
-	     (values e c))
-	    (else
-	     (receive (e2 c2) (((car s) e c))
-	       (run (cdr s) e2 c2)))))))
+    (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 run-wait ((thd
-		    (map
-		     (lambda (s)
-		       (call-with-new-thread
-			(lambda () (s entities components))))
-		     systems))
-		   (e entities) (c components))
-      (cond ((null? thd)
-	     (values e c))
-	    (else
-	     (receive (e2 c2) ((join-thread (car thd)) e c)
-	       (run-wait (cdr thd) e2 c2)))))))
+    (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)
@@ -253,9 +277,12 @@
 	((= (length systems) 1)
 	 (car systems))
 	(else
-	 (join-systems systems))))
+	 (apply join-systems systems))))
 
-(export find-entities-by-components
+(export entities-changes
+	entities-changes?
+	get-entities-changes
+	find-entities-by-components
 	define-system
 	make-system
 	join-systems