Do step duration properly

[gacela.git] / src / engine.scm

diff --git a/src/engine.scm b/src/engine.scm
index 0770e09c217bc7446312c90db6ded657c794e14f..3d05c9c4ce67037c6014a27b532f2b05802494a9 100644 (file)
--- a/src/engine.scm
+++ b/src/engine.scm
@@ -16,6 +16,7 @@
 
 
 (define-module (gacela engine)
+  #:use-module (gacela misc)
   #:use-module (gacela system)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 threads)
@@ -23,27 +24,68 @@
   #:use-module (srfi srfi-9 gnu))
 
 
+;;; Engine Properties
+
+(define* (get-property property-path #:key (engine (current-engine)))
+  (let ((entities (get-entities-by-components (list (car property-path)) #:engine engine)))
+    (cond ((null? entities)
+          #f)
+         (else
+          (let loop ((property (get-component (car property-path) (car entities)))
+                     (path (cdr property-path)))
+            (cond ((or (null? path) (not property))
+                   property)
+                  (else
+                   (loop (assoc-ref property (car path)) (cdr path)))))))))
+
+(define* (set-property! property-path value #:key (engine (current-engine)))
+  (define (loop property path)
+    (cond ((null? path)
+          value)
+         (else
+          (assoc-set! (or property '()) (car path) (loop (assoc-ref property (car path)) (cdr path))))))
+
+  (let ((entities (get-entities-by-components (list (car property-path)) #:engine engine)))
+    (cond ((null? entities)
+          (new-entity! `(,(car property-path) . ,(loop '() (cdr property-path)))))
+         (else
+          (set-entity-components! (get-key (car entities)) `(,(car property-path) . ,(loop (get-component (car property-path) (car entities)) (cdr property-path))))))))
+
+(export get-property
+       set-property!)
+
+
+;;; 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 system)
   engine?
   (entities engine-entities set-engine-entities!)
   (mutex engine-mutex set-engine-mutex!)
+  (running-mutex engine-running-mutex set-engine-running-mutex!)
   (system engine-system set-engine-system!))
 
 (set-record-type-printer! engine
   (lambda (record port)
-    (format port "#<[engine] entities: ~a>"
+    (format port "#<[engine] state: ~a, entities: ~a>"
+           (if (engine-running? record) "Running" "Stopped")
            (length (car (engine-entities record))))))
 
 (define (make-engine . systems)
   (make-engine-record
-   '(() ())
+   (receive (e c) ((new-entity (default-engine-inner-properties)) '() '())
+     (list e c))
+   (make-mutex)
    (make-mutex)
-   (if (not (= (length systems) 1))
-       (join-systems systems)
-       (car systems))))
+   (apply group-systems systems)))
 
 (define-syntax define-engine
   (syntax-rules ()
@@ -51,8 +93,12 @@
      (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 Access Protocol Interface
@@ -75,6 +121,11 @@
 (define* (get-entity key #:key (engine (current-engine)))
   (assoc key (car (engine-entities engine))))
 
+(define* (get-entities-by-components component-types #:key (engine (current-engine)))
+  (map (lambda (e)
+        (get-entity e #:engine engine))
+       (find-entities-by-components (cadr (engine-entities engine)) component-types)))
+
 (define-syntax define-entity-setter
   (syntax-rules ()
     ((_ name! name)
@@ -102,12 +153,57 @@
         (set-current-engine! old-engine)
         res)))))
 
+(define (set-engine-systems! engine . systems)
+  (with-mutex (engine-mutex engine)
+    (set-engine-system! engine (apply group-systems systems))))
+
 (export current-engine
        set-current-engine!
        get-entity
+       get-entities-by-components
        new-entity!
        remove-entity!
        set-entity!
        set-entity-components!
        remove-entity-components!
-       with-engine)
+       with-engine
+       set-engine-systems!)
+
+
+;;; Engine execution
+
+(define (start-engine engine)
+  (cond ((not (engine-running? engine))
+        (with-mutex (engine-running-mutex engine)
+          (let loop ()
+            (let ((t (current-utime))
+                  (delay 0))
+              (with-engine engine
+                (receive (e c) ((apply (engine-system engine) (engine-entities engine)))
+                  (set-engine-entities! engine (list e c)))
+                (set! delay (- (inexact->exact (* (get-property '(engine-inner-properties step)) 1000000))
+                               (- (current-utime) t))))
+              (cond ((> delay 0)
+                     (usleep delay))))
+            (if (not (engine-stopping? engine #:clean #t))
+                (loop)))))))
+
+(define (stop-engine engine)
+  (with-engine engine
+    (new-entity! '(engine-halt . #t)))
+  'engine-halt)
+
+(define* (engine-stopping? engine #:key (clean #f))
+  (let ((halt #f))
+    (with-engine engine
+      (let halt-engine ((halts (get-entities-by-components '(engine-halt))))
+       (cond ((not (null? halts))
+              (set! halt #t)
+              (cond (clean
+                     (remove-entity! (caar halts))
+                     (halt-engine (cdr halts))))))))
+    halt))
+
+(export start-engine
+       stop-engine
+       engine-stopping?)