X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fengine.scm;h=3d05c9c4ce67037c6014a27b532f2b05802494a9;hb=8864bc71fcf9fd551bdb417a1b22655a9097dd30;hp=4e311a0d9db97ca872e2cf9bfa162bca67d9e262;hpb=0cf99813777069f2fce8fe895fbbdcaaf98699eb;p=gacela.git

diff --git a/src/engine.scm b/src/engine.scm
index 4e311a0..3d05c9c 100644
--- 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,12 +24,46 @@
   #:use-module (srfi srfi-9 gnu))
 
 
-;;; Engine definitions
+;;; 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!)
+
 
-(define (default-delay) 0.1)
+;;; Engine Inner Properties
 
-(define-component engine-inner-properties
-  delay)
+(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 running-mutex system)
@@ -46,13 +81,11 @@
 
 (define (make-engine . systems)
   (make-engine-record
-   (receive (e c) ((new-entity (make-engine-inner-properties (default-delay))) '() '())
+   (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 ()
@@ -67,8 +100,6 @@
 	define-engine
 	engine-running?)
 
-(export-component engine-inner-properties)
-
 
 ;;; Engine Access Protocol Interface
 
@@ -122,6 +153,10 @@
 	 (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
@@ -131,7 +166,8 @@
 	set-entity!
 	set-entity-components!
 	remove-entity-components!
-	with-engine)
+	with-engine
+	set-engine-systems!)
 
 
 ;;; Engine execution
@@ -140,12 +176,15 @@
   (cond ((not (engine-running? engine))
 	 (with-mutex (engine-running-mutex engine)
 	   (let loop ()
-	     (let ((delay 0))
+	     (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 (engine-inner-properties-delay (get-component 'engine-inner-properties (car (get-entities-by-components '(engine-inner-properties)))))))
-	       (usleep (inexact->exact (* delay 1000000))))
+		 (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)))))))