From 85b34025ccd4e13188f3c2b88cd039a8cc636d93 Mon Sep 17 00:00:00 2001
From: Javier Sancho <jsf@jsancho.org>
Date: Sun, 20 Oct 2013 21:50:00 +0200
Subject: [PATCH] Engine Access Protocol Interface

* src/engine.scm: functions for accessing and modifying engine
                  entities, using a mutex for preventing changes
                  collission if the engine is running

* src/system.scm: now every function that modify entities returns
                  the result of the modification with the resulting
                  entities and components
---
 src/engine.scm | 57 ++++++++++++++++++++++++++++++++++++++++++++------
 src/system.scm | 17 +++++++++------
 2 files changed, 62 insertions(+), 12 deletions(-)

diff --git a/src/engine.scm b/src/engine.scm
index 13b5dc8..6d5e0e7 100644
--- a/src/engine.scm
+++ b/src/engine.scm
@@ -57,10 +57,55 @@
 
 ;;; Engine Access Protocol Interface
 
-(define (with-engine engine . changes)
-  (with-mutex (engine-mutex engine)
-    (let ((entities (engine-entities engine)))
-      (receive (e c) (modify-entities changes (car entities) (cadr entities))
-        (set-engine-entities! engine (list e c))))))
+(define current-engine-mutex (make-mutex))
+(define current-engine-list '())
 
-(export with-engine)
+(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-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 ...)
+     (begin
+       (set-current-engine! engine)
+       (let ((res (begin body ...)))
+	 (set-current-engine! #f)
+	 res)))))
+
+(export current-engine
+	set-current-engine!
+	get-entity
+	new-entity!
+	remove-entity!
+	set-entity!
+	set-entity-components!
+	remove-entity-components!
+	with-engine)
diff --git a/src/system.scm b/src/system.scm
index b70bfee..3d5cb2b 100644
--- 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)
-- 
2.39.5