X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fengine.scm;h=dd8a8b2c5f45eeb107c400248a938ce628f3baaf;hb=52af2b21c93a97e9ff5b8a22d0ba5df2cba766ec;hp=0770e09c217bc7446312c90db6ded657c794e14f;hpb=2a4f421a74b6e31e7718d206be704f1d42a268a2;p=gacela.git diff --git a/src/engine.scm b/src/engine.scm index 0770e09..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,63 +61,105 @@ (define name (make-engine system ...))))) -(export make-engine - define-engine) - - -;;; Engine Access Protocol Interface +(define (engine-running? engine) + (mutex-locked? (engine-running-mutex engine))) -(define current-engine-mutex (make-mutex)) -(define current-engine-list '()) - -(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) +(export make-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 body ...) - (let ((old-engine (current-engine))) - (set-current-engine! engine) - (let ((res (with-mutex (engine-mutex engine) - body - ...))) - (set-current-engine! old-engine) - res))))) - -(export current-engine - set-current-engine! - get-entity - new-entity! - remove-entity! - set-entity! - set-entity-components! - remove-entity-components! - with-engine) + ((_ 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 + +(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 (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 engine-property + set-engine-property!)