X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fengine.scm;h=dd8a8b2c5f45eeb107c400248a938ce628f3baaf;hb=52af2b21c93a97e9ff5b8a22d0ba5df2cba766ec;hp=13b5dc83ff6c80db717656fd10d28d97263161a9;hpb=3b8bea0edf160748d20a12e3b1e7e3503a33da7b;p=gacela.git

diff --git a/src/engine.scm b/src/engine.scm
index 13b5dc8..dd8a8b2 100644
--- a/src/engine.scm
+++ b/src/engine.scm
@@ -16,34 +16,44 @@
 
 
 (define-module (gacela engine)
+  #:use-module (gacela misc)
   #:use-module (gacela system)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 threads)
   #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-9 gnu))
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (system repl server)
+  #:use-module (system repl coop-server))
+
+
+;;; Engine Inner Properties
+
+(define (default-step) 0.1)
+
+(define (default-engine-inner-properties)
+  `(engine-inner-properties (step . ,(default-step))))
 
 
 ;;; Engine definitions
 
 (define-record-type engine
-  (make-engine-record entities mutex system)
+  (make-engine-record entities mutex running-mutex systems)
   engine?
   (entities engine-entities set-engine-entities!)
-  (mutex engine-mutex set-engine-mutex!)
-  (system engine-system set-engine-system!))
+  (running-mutex engine-running-mutex set-engine-running-mutex!)
+  (systems engine-systems set-engine-systems!))
 
 (set-record-type-printer! engine
   (lambda (record port)
-    (format port "#<[engine] entities: ~a>"
-	    (length (car (engine-entities record))))))
+    (format port "#<[engine] state: ~a, entities: ~a>"
+	    (if (engine-running? record) "Running" "Stopped")
+	    (entity-count (engine-entities record)))))
 
 (define (make-engine . systems)
   (make-engine-record
-   '(() ())
+   (make-entity-set (new-entity (default-engine-inner-properties)))
    (make-mutex)
-   (if (not (= (length systems) 1))
-       (join-systems systems)
-       (car systems))))
+   systems))
 
 (define-syntax define-engine
   (syntax-rules ()
@@ -51,16 +61,105 @@
      (define name
        (make-engine system ...)))))
 
+(define (engine-running? engine)
+  (mutex-locked? (engine-running-mutex engine)))
+
 (export make-engine
-	define-engine)
+	define-engine
+	engine-running?)
+
+
+;;; Engine execution
+
+(define* (start-engine engine #:optional (socket #f))
+  (catch
+   #t
+   (lambda ()
+     (with-mutex (engine-running-mutex engine)
+       (let loop ((coop-server (if socket (spawn-coop-repl-server socket) #f)))
+	 (let ((t (current-utime))
+	       (delay 0)
+	       (halt #f))
+	   (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? engine #:clean #t))
+	   (if coop-server
+	       (poll-coop-repl-server coop-server))
+	   (cond ((not halt)
+		  (cond ((> delay 0)
+			 (usleep delay)))
+		  (loop coop-server))
+		 (else
+		  (if coop-server
+		      (stop-server-and-clients!))))))))
+   (lambda (key args)
+     #f)))
+
+(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 ()
+    (entities-changes
+     (list
+      (new-entity '(engine-halt . #t)))))
+  'engine-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
+	with-engine
+	stop-engine)
+
 
+;;; Properties
 
-;;; Engine Access Protocol Interface
+(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 (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 (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 with-engine)
+(export engine-property
+	set-engine-property!)