X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fengine.scm;h=3d05c9c4ce67037c6014a27b532f2b05802494a9;hb=8864bc71fcf9fd551bdb417a1b22655a9097dd30;hp=13b5dc83ff6c80db717656fd10d28d97263161a9;hpb=3b8bea0edf160748d20a12e3b1e7e3503a33da7b;p=gacela.git diff --git a/src/engine.scm b/src/engine.scm index 13b5dc8..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,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,16 +93,117 @@ (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 -(define (with-engine engine . changes) +(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))) + +(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-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) - (let ((entities (engine-entities engine))) - (receive (e c) (modify-entities changes (car entities) (cadr entities)) - (set-engine-entities! engine (list e c)))))) + (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 ((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 with-engine) +(export start-engine + stop-engine + engine-stopping?)