(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 ()
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!)
projects / gacela.git / blobdiff