X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fengine.scm;h=dd8a8b2c5f45eeb107c400248a938ce628f3baaf;hb=52af2b21c93a97e9ff5b8a22d0ba5df2cba766ec;hp=33c8a6f0f190b02ddb3ef4cac12568bc6bfebf13;hpb=c62dceb1471afb94efa57eef5506fbdf6f2ef679;p=gacela.git diff --git a/src/engine.scm b/src/engine.scm index 33c8a6f..dd8a8b2 100644 --- a/src/engine.scm +++ b/src/engine.scm @@ -16,41 +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 definitions +;;; Engine Inner Properties + +(define (default-step) 0.1) -(define (default-delay) 0.1) +(define (default-engine-inner-properties) + `(engine-inner-properties (step . ,(default-step)))) -(define-component engine-inner-properties - delay) + +;;; Engine definitions (define-record-type engine - (make-engine-record entities mutex running-mutex system) + (make-engine-record entities mutex running-mutex systems) 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!)) + (systems engine-systems set-engine-systems!)) (set-record-type-printer! engine (lambda (record port) (format port "#<[engine] state: ~a, entities: ~a>" (if (engine-running? record) "Running" "Stopped") - (length (car (engine-entities record)))))) + (entity-count (engine-entities record))))) (define (make-engine . systems) (make-engine-record - (receive (e c) ((new-entity (make-engine-inner-properties (default-delay))) '() '()) - (list e c)) - (make-mutex) + (make-entity-set (new-entity (default-engine-inner-properties))) (make-mutex) - (apply group-systems systems))) + systems)) (define-syntax define-engine (syntax-rules () @@ -65,109 +68,98 @@ define-engine engine-running?) -(export-component engine-inner-properties) - - -;;; Engine Access Protocol Interface - -(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* (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))) +;;; Engine execution -(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* (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))))) - -(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 - set-engine-systems!) - - -;;; Engine execution - -(define (start-engine engine) - (cond ((not (engine-running? engine)) - (with-mutex (engine-running-mutex engine) - (let loop () - (let ((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)))) - (if (not (engine-stopping? engine #:clean #t)) - (loop))))))) + ((_ engine component-types form ...) + (with-mutex (engine-mutex engine) + (eval-system (make-system component-types form ...) engine))))) (define (stop-engine engine) - (with-engine engine - (new-entity! '(engine-halt . #t))) + (with-engine engine () + (entities-changes + (list + (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)) + (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 - stop-engine - engine-stopping?) + 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!)