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

diff --git a/src/engine.scm b/src/engine.scm
index 13b5dc83ff6c80db717656fd10d28d97263161a9..6d5e0e732ec23f56ba85b6e91253a0a88f08fea5 100644 (file)
--- a/src/engine.scm
+++ b/src/engine.scm
@@ -57,10 +57,55 @@
 
 ;;; Engine Access Protocol Interface
 
 
 ;;; 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 b70bfee062527580b7560bcc686d45eb32b13ab5..3d5cb2b9ea482eaaaf65a81946e337d693cd94bb 100644 (file)
--- a/src/system.scm
+++ b/src/system.scm
@@ -123,14 +123,16 @@
        (register-components key
                            (map (lambda (c) (car c)) nc)
                            components)
        (register-components key
                            (map (lambda (c) (car c)) nc)
                            components)

-       key))))
+       (cons key nc)))))

 
 (define (remove-entity key)
   (lambda (entities components)
 
 (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)
       (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)
 
 (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)
       (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)
 
 (define (set-entity-components key . new-components)
   (lambda (entities components)


@@ -152,7 +155,8 @@
        nc)
       (values
        (assoc-set! entities key clist)
        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)
 
 (define (remove-entity-components key . old-components)
   (lambda (entities components)


@@ -163,7 +167,8 @@
        old-components)
       (values
        (assoc-set! entities key clist)
        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)
 
 (define (modify-entities changes entities components)
   (cond ((null? changes)