#: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)
;;; 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 (default-engine-inner-properties)) '() '())
- (list e c))
+ (make-entity-set (new-entity (default-engine-inner-properties)))
(make-mutex)
(make-mutex)
- (apply group-systems systems)))
+ systems))
(define-syntax define-engine
(syntax-rules ()
engine-running?)
-;;; 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)))
-
-(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)
- (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)
(let ((t (current-utime))
(delay 0)
(halt #f))
- (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))
+ (with-mutex (engine-mutex engine)
+ (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? #:clean #t)))
+ (set! halt (engine-stopping? engine #:clean #t)))
(cond ((not halt)
(cond ((> delay 0)
(usleep delay)))
(loop)))))))))
+(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 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? #:key (engine (current-engine)) (clean #f))
- (let ((halt #f))
- (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))
+(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
- 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!)
(sleep 3)
(entities-changes
(map (lambda (e)
- (set-entity-components (get-key e) `(l . ,(cons 1 (get-component 'l e)))))
+ (set-entity-components (get-key e) '(l1 . 1)))
with-l)))
(define-system s2 ((with-l (l)))
(sleep 4)
(entities-changes
(map (lambda (e)
- (set-entity-components (get-key e) `(l . ,(cons 2 (get-component 'l e)))))
+ (set-entity-components (get-key e) '(l2 . 2)))
with-l)))
(define (composing-with-join)
- (let ((entities '())
- (components '()))
- (receive (e c) (modify-entities (list (new-entity '(l . ())) (new-entity '(l . ()))) entities components)
- (((join-systems s1 s2) e c)))))
+ (let ((entities (make-entity-set (new-entity '(l . ())) (new-entity '(l . ())) (new-entity '(a . #f)))))
+ (set! entities (modify-entities entities (get-entities-changes ((join-systems s1 s2) entities))))
+ (entity-list entities)))
(export composing-with-join)
-(define (composing-with-threaded)
- (let ((entities '())
- (components '()))
- (receive (e c) (modify-entities (list (new-entity '(l . ())) (new-entity '(l . ()))) entities components)
- (((threaded-systems s1 s2) e c)))))
+(define (composing-with-thread)
+ (let ((entities (make-entity-set (new-entity '(l . ())) (new-entity '(l . ())) (new-entity '(a . #f)))))
+ (set! entities (modify-entities entities (get-entities-changes ((thread-systems s1 s2) entities))))
+ (entity-list entities)))
+
+(export composing-with-thread)
-(export composing-with-threaded)
-
-(define (join-vs-threaded)
- (let ((entities '())
- (components '())
+(define (join-vs-thread)
+ (let ((entities (make-entity-set (new-entity '(l . ())) (new-entity '(l . ())) (new-entity '(a . #f))))
(t (current-time)))
- (receive (e c) (modify-entities (list (new-entity '(l . ())) (new-entity '(l . ()))) entities components)
- (receive (e c) (((join-systems s1 s2) e c))
- (format #t "~a~%~a~%Time: ~a~%~%" e c (- (current-time) t)))))
+ (set! entities (modify-entities entities (get-entities-changes ((join-systems s1 s2) entities))))
+ (format #t "~a~%Time: ~a~%~%" entities (- (current-time) t)))
- (let ((entities '())
- (components '())
+ (let ((entities (make-entity-set (new-entity '(l . ())) (new-entity '(l . ())) (new-entity '(a . #f))))
(t (current-time)))
- (receive (e c) (modify-entities (list (new-entity '(l . ())) (new-entity '(l . ()))) entities components)
- (receive (e c) (((threaded-systems s1 s2) e c))
- (format #t "~a~%~a~%Time: ~a~%~%" e c (- (current-time) t))))))
+ (set! entities (modify-entities entities (get-entities-changes ((thread-systems s1 s2) entities))))
+ (format #t "~a~%Time: ~a~%~%" entities (- (current-time) t))))
-(export join-vs-threaded)
+(export join-vs-thread)
(define-engine conway-game lives-or-deads print-world)
-(with-engine conway-game
- (let ((cells '((4 1) (4 2) (5 1) (5 2)
- (11 3) (11 4) (11 5) (12 2) (12 6) (13 1) (13 7) (14 1) (14 7)
- (15 4) (16 2) (16 6) (17 3) (17 4) (17 5) (18 4)
- (21 5) (21 6) (21 7) (22 5) (22 6) (22 7) (23 4) (23 8)
- (25 3) (25 4) (25 8) (25 9)
- (35 6) (35 7) (36 6) (36 7))))
- (for-each (lambda (c) (new-entity! `(coord . ,c))) cells)))
-
(with-engine conway-game ()
(let ((cells '((4 1) (4 2) (5 1) (5 2)
(11 3) (11 4) (11 5) (12 2) (12 6) (13 1) (13 7) (14 1) (14 7)
(define-component b)
(define (entity-component-functions)
- (let ((entities '())
- (components '())
+ (let ((entities (make-entity-set))
(key #f))
- (receive (e c k) ((new-entity (make-a 1 2) (make-b)) entities components)
+ (receive (e k) ((new-entity (make-a 1 2) (make-b)) entities)
(set! entities e)
- (set! components c)
- (set! key k)
- (display k) (newline))
- (format #t "New entity with a and b:~%~a~%~a~%~%" entities components)
+ (set! key (car k)))
+ (format #t "New entity with a and b:~%~a~%~%" (entity-list entities))
- (receive (e c k) ((new-entity (make-a 10 20)) entities components)
- (set! entities e)
- (set! components c)
- (display k) (newline))
- (format #t "New entity with a:~%~a~%~a~%~%" entities components)
+ (receive (e k) ((new-entity (make-a 10 20)) entities)
+ (set! entities e))
+ (format #t "New entity with a:~%~a~%~%" (entity-list entities))
- (receive (e c) (modify-entities (list (set-entity-components key (make-a 50 50)) (remove-entity-components key 'b)) entities components)
- (set! entities e)
- (set! components c))
- (format #t "First entity removes b and changes a:~%~a~%~a~%~%" entities components)
+ (set! entities (modify-entities entities (list (set-entity-components key (make-a 50 50)) (remove-entity-components key 'b))))
+ (format #t "First entity removes b and changes a:~%~a~%~%" (entity-list entities))
- (receive (e c) ((remove-entity key) entities components)
- (set! entities e)
- (set! components c))
- (format #t "Removes first entity:~%~a~%~a~%~%" entities components)
+ (set! entities ((remove-entity key) entities))
+ (format #t "Removes first entity:~%~a~%~%" (entity-list entities))
- (receive (e c k) ((new-entity (make-a 1 2) (make-b)) entities components)
+ (receive (e k) ((new-entity (make-a 1 2) (make-b)) entities)
(set! entities e)
- (set! components c)
- (set! key k)
- (display k) (newline))
- (format #t "New entity with a and b:~%~a~%~a~%~%" entities components)
+ (set! key (car k)))
+ (format #t "New entity with a and b:~%~a~%~%" (entity-list entities))
- (receive (e c) (modify-entities (list (set-entity-components key (make-a 50 50)) (remove-entity-components key 'b) (new-entity (make-a 1000 1000))) entities components)
- (set! entities e)
- (set! components c))
- (format #t "Last entity removes b and changes a, and new entity with a:~%~a~%~a~%~%" entities components)
+ (set! entities (modify-entities entities (list (set-entity-components key (make-a 50 50)) (remove-entity-components key 'b) (new-entity (make-a 1000 1000)))))
+ (format #t "Last entity removes b and changes a, and new entity with a:~%~a~%~%" (entity-list entities))
- (receive (e c) (modify-entities (list (remove-entity key)) entities components)
- (set! entities e)
- (set! components c))
- (format #t "Remove last entity:~%~a~%~a~%~%" entities components)))
+ (set! entities (modify-entities entities (list (remove-entity key))))
+ (format #t "Remove last entity:~%~a~%~%" (entity-list entities))))
(export entity-component-functions)
(define-system s1 ()
(entities-changes
- (list (new-entity (make-a 1 2))
- (new-entity (make-a 10 20)))))
+ (list
+ (new-entity (make-a 1 2))
+ (new-entity (make-a 10 20)))))
(define-system s2 ((with-a (a)))
(for-each
with-a))
(define (making-systems)
- (let ((entities '())
- (components '()))
- (receive (e c) ((s1 entities components))
- (set! entities e)
- (set! components c))
- (format #t "Two new entities with a:~%~a~%~a~%~%" entities components)
-
- ((s2 entities components))))
+ (let ((entities (make-entity-set)))
+ (set! entities (modify-entities entities (get-entities-changes (s1 entities))))
+ (format #t "Two new entities with a:~%~a~%~%" (entity-list entities))
+
+ (s2 entities)))
(export making-systems)
;;; Entities and components
+(define (make-entity-set . changes)
+ (modify-entities
+ (cons (make-hash-table) (make-hash-table))
+ changes))
+
+(define (entity-list entity-set)
+ (hash-map->list (lambda (k v) (cons k v)) (car entity-set)))
+
+(define (entity-count entity-set)
+ (hash-count (const #t) (car entity-set)))
+
(define (normalize-components components)
(map
(lambda (c)
(cond ((null? components) clist)
(else
(let* ((type (car components))
- (elist (assoc-ref clist type)))
- (register-components entity (cdr components)
- (assoc-set! clist type
- (cond (elist
- (lset-adjoin eq? elist entity))
- (else
- (list entity)))))))))
+ (elist (hash-ref clist type)))
+ (hash-set! clist type
+ (cond (elist
+ (lset-adjoin eq? elist entity))
+ (else
+ (list entity))))
+ (register-components entity (cdr components) clist)))))
(define (unregister-components entity components clist)
(cond ((null? components) clist)
(else
(let* ((type (car components))
- (elist (lset-difference eq? (assoc-ref clist type) (list entity))))
- (unregister-components entity (cdr components)
- (cond ((null? elist)
- (assoc-remove! clist type))
- (else
- (assoc-set! clist type elist))))))))
+ (elist (lset-difference eq? (hash-ref clist type) (list entity))))
+ (cond ((null? elist)
+ (hash-remove! clist type))
+ (else
+ (hash-set! clist type elist)))
+ (unregister-components entity (cdr components) clist)))))
+
+(define (component-names components)
+ (map (lambda (c) (car c)) components))
+
+(define (entity-component-names key entity-set)
+ (component-names
+ (hash-ref (car entity-set) key)))
+
+(define (entity-ref key entity-set)
+ (hash-get-handle (car entity-set) key))
(define (new-entity . new-components)
- (lambda (entities components)
+ (lambda (entity-set)
(let ((key (gensym))
(nc (normalize-components new-components)))
+ (hash-set! (car entity-set) key nc)
+ (register-components key (component-names nc) (cdr entity-set))
(values
- (acons key nc entities)
- (register-components key
- (map (lambda (c) (car c)) nc)
- components)
+ entity-set
(cons key nc)))))
(define (remove-entity key)
- (lambda (entities components)
- (let ((clist (map (lambda (c) (car c)) (assoc-ref entities key)))
- (entity (assoc key entities)))
+ (lambda (entity-set)
+ (let ((clist (entity-component-names key entity-set))
+ (entity (entity-ref key entity-set)))
+ (hash-remove! (car entity-set) key)
+ (unregister-components key clist (cdr entity-set))
(values
- (assoc-remove! entities key)
- (unregister-components key clist components)
+ entity-set
entity))))
(define (set-entity key . new-components)
- (lambda (entities components)
+ (lambda (entity-set)
(let* ((nc (normalize-components new-components))
- (clist (map (lambda (c) (car c)) (assoc-ref entities key)))
- (nclist (map (lambda (c) (car c)) nc)))
+ (clist (entity-component-names key entity-set))
+ (nclist (component-names nc)))
+ (hash-set! (car entity-set) key nc)
+ (register-components key
+ (lset-difference eq? nclist clist)
+ (unregister-components key (lset-difference eq? clist nclist) (cdr entity-set)))
(values
- (assoc-set! entities key nc)
- (register-components key (lset-difference eq? nclist clist)
- (unregister-components key (lset-difference eq? clist nclist) components))
+ entity-set
(cons key nc)))))
(define (set-entity-components key . new-components)
- (lambda (entities components)
+ (lambda (entity-set)
(let ((nc (normalize-components new-components))
- (clist (alist-copy (assoc-ref entities key))))
+ (clist (alist-copy (hash-ref (car entity-set) key))))
(for-each
(lambda (c)
- (assoc-set! clist (car c) (cdr c)))
+ (set! clist (assoc-set! clist (car c) (cdr c))))
nc)
+ (hash-set! (car entity-set) key clist)
+ (register-components key (component-names nc) (cdr entity-set))
(values
- (assoc-set! entities key clist)
- (register-components key (map (lambda (c) (car c)) nc) components)
+ entity-set
(cons key clist)))))
(define (remove-entity-components key . old-components)
- (lambda (entities components)
- (let ((clist (alist-copy (assoc-ref entities key))))
+ (lambda (entity-set)
+ (let ((clist (alist-copy (hash-ref (car entity-set) key))))
(for-each
(lambda (c)
- (assoc-remove! clist c))
+ (set! clist (assoc-remove! clist c)))
old-components)
+ (hash-set! (car entity-set) key clist)
+ (unregister-components key old-components (cdr entity-set))
(values
- (assoc-set! entities key clist)
- (unregister-components key old-components components)
+ entity-set
(cons key clist)))))
-(define (modify-entities changes entities components)
+(define (modify-entities entity-set changes)
(cond ((null? changes)
- (values entities components))
+ entity-set)
(else
- (receive (e c) ((car changes) entities components)
- (modify-entities (cdr changes) e c)))))
+ (modify-entities ((car changes) entity-set) (cdr changes)))))
-(export new-entity
+(export make-entity-set
+ entity-list
+ entity-count
+ new-entity
remove-entity
set-entity
set-entity-components
entities-changes?
(changes get-entities-changes))
-(define* (find-entities-by-components c t)
- (cond ((null? t) '())
+(define (append-changes changes)
+ (entities-changes
+ (apply append
+ (map get-entities-changes changes))))
+
+(define (find-entities-by-components entity-set clist)
+ (cond ((null? clist) '())
(else
- (let* ((e (assoc-ref c (car t)))
- (e* (if e e '())))
- (cond ((null? (cdr t)) e*)
- (else
- (lset-intersection eq? e* (find-entities-by-components c (cdr t)))))))))
+ (let ((e (hash-ref (cdr entity-set) (car clist) '()))
+ (e* (find-entities-by-components entity-set (cdr clist))))
+ (if (null? e*)
+ e
+ (lset-intersection eq? e e*))))))
(define-syntax make-system
(syntax-rules ()
((_ ((name (component-type ...)) ...) form ...)
- (lambda (entities components)
+ (lambda (entity-set)
(let ((name (map (lambda (x)
(cons (car x)
(filter (lambda (x)
(memq (car x) '(component-type ...)))
(cdr x))))
(map (lambda (x)
- (assoc x entities))
- (find-entities-by-components components '(component-type ...)))))
+ (entity-ref x entity-set))
+ (find-entities-by-components entity-set '(component-type ...)))))
...)
- (let ((res (begin form ...)))
- (lambda* (#:optional (entities2 #f) (components2 #f))
- (let ((e (if (and entities2 components2) entities2 entities))
- (c (if (and entities2 components2) components2 components)))
- (modify-entities (if (entities-changes? res) (get-entities-changes res) '()) e c)))))))))
+ form
+ ...)))))
(define-syntax define-system
(syntax-rules ()
form
...)))))
+(define (composed-systems-result results)
+ (let ((changes (filter (lambda (r) (entities-changes? r)) results)))
+ (cond ((null? changes)
+ (car results))
+ (else
+ (append-changes changes)))))
+
(define (join-systems . systems)
- (lambda (entities components)
- (let ((changes
- (let run ((s systems) (e (alist-copy entities)) (c (alist-copy components)) (res '()))
- (cond ((null? s)
- res)
- (else
- (let ((r ((car s) e c)))
- (receive (e2 c2) (r)
- (run (cdr s) e2 c2 (cons r res)))))))))
- (lambda* (#:optional (entities2 #f) (components2 #f))
- (let modify ((e (if (and entities2 components2) entities2 entities))
- (c (if (and entities2 components2) components2 components))
- (ch (reverse changes)))
- (cond ((null? ch)
- (values e c))
- (else
- (receive (e2 c2) ((car ch) e c)
- (modify e2 c2 (cdr ch))))))))))
-
-(define (threaded-systems . systems)
- (lambda (entities components)
- (let ((changes
- (let run-wait ((thd
- (map (lambda (s)
- (call-with-new-thread
- (lambda () (s entities components))))
- systems))
- (res '()))
- (cond ((null? thd)
- res)
- (else
- (run-wait (cdr thd) (cons (join-thread (car thd)) res)))))))
- (lambda* (#:optional (entities2 #f) (components2 #f))
- (let modify ((e (if (and entities2 components2) entities2 entities))
- (c (if (and entities2 components2) components2 components))
- (ch changes))
- (cond ((null? ch)
- (values e c))
- (else
- (receive (e2 c2) ((car ch) e c)
- (modify e2 c2 (cdr ch))))))))))
-
-(define (group-systems . systems)
- (cond ((null? systems)
- (make-system ()))
- ((= (length systems) 1)
- (car systems))
- (else
- (apply join-systems systems))))
+ (lambda (entity-set)
+ (let run ((s systems) (res '()))
+ (cond ((null? s)
+ (composed-systems-result res))
+ (else
+ (run (cdr s) (cons ((car s) entity-set) res)))))))
+
+(define (thread-systems . systems)
+ (lambda (entity-set)
+ (let run-wait ((thd
+ (map (lambda (s)
+ (call-with-new-thread
+ (lambda () (s entity-set))))
+ systems))
+ (res '()))
+ (cond ((null? thd)
+ (composed-systems-result res))
+ (else
+ (run-wait (cdr thd) (cons (join-thread (car thd)) res)))))))
(export entities-changes
entities-changes?
define-system
make-system
join-systems
- threaded-systems
- group-systems)
+ thread-systems)
;;; Entities and components access inside systems
projects / gacela.git / commitdiff