+
+
+;;; Entities and components
+
+(define (register-components entity components clist)
+ (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)))))))))
+
+(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))))))))
+
+(define (new-entity new-components entities components)
+ (let ((key (gensym)))
+ (values
+ (acons key (map (lambda (c) `(,(get-component-type c) . ,c)) new-components) entities)
+ (register-components
+ key
+ (map (lambda (c) (get-component-type c)) new-components)
+ components)
+ key)))
+
+(define (remove-entity key entities components)
+ (let ((clist (map (lambda (c) (car c)) (assoc-ref entities key))))
+ (values
+ (assoc-remove! entities key)
+ (unregister-components key clist components))))
+
+(export new-entity
+ remove-entity)
+
+
+;;; Making systems
+
+(define* (find-entities-by-components c t)
+ (cond ((null? t) '())
+ (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)))))))))
+
+
+(define (make-system component-types system-fun)
+ (lambda (entities components)
+ (let* ((e (find-entities-by-components components component-types))
+ (e* (map (lambda (x) (assoc x entities)) e))
+ (e** (map (lambda (x) (cons (car x) (filter (lambda (x) (memq (get-component-type x) component-types)) (cdr x)))) e*))
+ (res (system-fun e**)))
+ (lambda* (#:optional (entities2 #f) (components2 #f))
+ (let* ((e2 (if (and entities2 components2)
+ (find-entities-by-components components2 component-types)
+ e))
+ (e2* (if (and entities2 components2)
+ (map (lambda (x) (assoc x entities2)) e2)
+ e*))
+ (e2** (if (and entities2 components2)
+ (map (lambda (x) (cons (car x) (filter (lambda (x) (memq (get-component-type x) component-types)) (cdr x)))) e2*)
+ e**)))
+ e2**)))))
+
+; ((1 a b) (2 a b c) (3 c))
+; ((1 a b) (2 a b))
+; ((1 a) (a b))
+; ((1 a) (3 c) (4 a b))
+
+(export find-entities-by-components
+ make-system)