Composed systems return as single systems

[gacela.git] / src / system.scm

diff --git a/src/system.scm b/src/system.scm
index 26e31c6f52dc66b419341a75b62d226c9c33426c..9654cffbafdb4a059aedfc3f3ef33fc58a10b1b2 100644 (file)
--- a/src/system.scm
+++ b/src/system.scm
@@ -123,14 +123,16 @@
        (register-components key
                            (map (lambda (c) (car c)) nc)
                            components)
-       key))))
+       (cons key nc)))))
 
 (define (remove-entity key)
   (lambda (entities components)
-    (let ((clist (map (lambda (c) (car c)) (assoc-ref entities key))))
+    (let ((clist (map (lambda (c) (car c)) (assoc-ref entities key)))
+         (entity (assoc key entities)))
       (values
        (assoc-remove! entities key)
-       (unregister-components key clist components)))))
+       (unregister-components key clist components)
+       entity))))
 
 (define (set-entity key . new-components)
   (lambda (entities components)
@@ -140,7 +142,8 @@
       (values
        (assoc-set! entities key nc)
        (register-components key (lset-difference eq? nclist clist)
-                           (unregister-components key (lset-difference eq? clist nclist) components))))))
+                           (unregister-components key (lset-difference eq? clist nclist) components))
+       (cons key nc)))))
 
 (define (set-entity-components key . new-components)
   (lambda (entities components)
@@ -152,7 +155,8 @@
        nc)
       (values
        (assoc-set! entities key clist)
-       (register-components key (map (lambda (c) (car c)) nc) components)))))
+       (register-components key (map (lambda (c) (car c)) nc) components)
+       (cons key clist)))))
 
 (define (remove-entity-components key . old-components)
   (lambda (entities components)
@@ -163,7 +167,8 @@
        old-components)
       (values
        (assoc-set! entities key clist)
-       (unregister-components key old-components components)))))
+       (unregister-components key old-components components)
+       (cons key clist)))))
 
 (define (modify-entities changes entities components)
   (cond ((null? changes)
@@ -193,51 +198,88 @@
 
 (define-syntax make-system
   (syntax-rules ()
-    ((_ component-types system-func)
+    ((_ ((name (component-type ...)) ...) form ...)
      (lambda (entities components)
-       (let* ((e (find-entities-by-components components 'component-types))
-             (e* (map (lambda (x) (assoc x entities)) e))
-             (e** (map (lambda (x) (cons (car x) (filter (lambda (x) (memq (car x) 'component-types)) (cdr x)))) e*))
-             (res (system-func e**)))
-        (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))))))))
+       (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 ...)))))
+            ...)
+        (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 res e c)))))))))
 
 (define-syntax define-system
   (syntax-rules ()
-    ((_ (name . component-types) system-func)
-     (define name (make-system component-types system-func)))))
+    ((_ system-name ((name (component-type ...)) ...) form ...)
+     (define system-name
+       (make-system ((name (component-type ...)) ...)
+         form
+        ...)))))
 
 (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)
+        (make-system ()))
+       ((= (length systems) 1)
+        (car systems))
+       (else
+        (apply join-systems systems))))
 
 (export find-entities-by-components
        define-system
        make-system
        join-systems
-       threaded-systems)
+       threaded-systems
+       group-systems)
 
 
 ;;; Entities and components access inside systems