X-Git-Url: https://git.jsancho.org/?p=gacela.git;a=blobdiff_plain;f=src%2Fsystem.scm;h=50e9534b451f34c961150745e30bf49f433133ac;hp=9654cffbafdb4a059aedfc3f3ef33fc58a10b1b2;hb=f3d35ed115ff03f513c93a05325885e44da10891;hpb=a9563e6e38b3a5e8e6ca92607570a92d63237793

diff --git a/src/system.scm b/src/system.scm
index 9654cff..50e9534 100644
--- a/src/system.scm
+++ b/src/system.scm
@@ -16,10 +16,34 @@
 
 
 (define-module (gacela system)
+  #:use-module ((bongodb) #:renamer (symbol-prefix-proc 'bongodb:))
   #:use-module (ice-9 receive)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-9 gnu))
+  #:use-module (srfi srfi-9 gnu)
+  #:export (define-component
+	    export-component
+	    get-component-type
+	    make-entity-set
+	    entity-list
+	    entity-count
+	    new-entity
+	    get-entity
+	    remove-entity
+	    set-entity
+	    set-entity-components
+	    remove-entity-components
+	    modify-entities
+	    entities-changes
+	    entities-changes?
+	    get-entities-changes
+	    find-entities-by-components
+	    define-system
+	    make-system
+	    join-systems
+	    thread-systems
+	    get-key
+	    get-component))
 
 
 ;;; Component definitions
@@ -39,22 +63,31 @@
 		     a
 		     (syntax->datum a)))
 	       args))))
+    (define (filtered-args args)
+      (let ((datum (map (lambda (a) (syntax->datum a)) args)))
+	(map (lambda (a) (datum->syntax x a))
+	     (map (lambda (a) (if (list? a) (car a) a))
+		  (filter (lambda (a) (not (keyword? a))) datum)))))
     (syntax-case x ()
       ((_ name field ...)
        (with-syntax ((make-name (concat "make-" #'name))
+		     (make-name-record (concat "make-" #'name "-record"))
 		     (name? (concat #'name "?"))
-		     ((field-getter ...) (map (lambda (f) (concat #'name "-" f)) #'(field ...)))
-		     ((field-setter ...) (map (lambda (f) (concat "set-" #'name "-" f "!")) #'(field ...))))
+		     ((field-name ...) (filtered-args #'(field ...)))
+		     ((field-getter ...) (map (lambda (f) (concat #'name "-" f)) (filtered-args #'(field ...))))
+		     ((field-setter ...) (map (lambda (f) (concat "set-" #'name "-" f "!")) (filtered-args #'(field ...)))))
          #'(begin
+	     (define* (make-name field ...)
+	       (make-name-record field-name ...))
 	     (define-record-type name
-	       (make-name field ...)
+	       (make-name-record field-name ...)
 	       name?
-	       (field field-getter field-setter)
+	       (field-name field-getter field-setter)
 	       ...)
 	     (set-record-type-printer! name
 	       (lambda (record port)
 		 (format port "#<[~a]" 'name)
-		 (format port " ~a: ~a" 'field (field-getter record))
+		 (format port " ~a: ~a" 'field-name (field-getter record))
 		 ...
 		 (format port ">")))
 	     'name))))))
@@ -76,13 +109,18 @@
 (define (get-component-type component)
   (record-type-name (record-type-descriptor component)))
 
-(export define-component
-	export-component
-	get-component-type)
-
 
 ;;; Entities and components
 
+(define (make-entity-set . changes)
+  (modify-entities (bongodb:make-collection) changes))
+
+(define (entity-list entity-set)
+  (bongodb:find entity-set))
+
+(define (entity-count entity-set)
+  (bongodb:count entity-set))
+
 (define (normalize-components components)
   (map
    (lambda (c)
@@ -91,129 +129,110 @@
 	 c))
    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)
-  (lambda (entities components)
-    (let ((key (gensym))
-	  (nc (normalize-components new-components)))
-      (values
-       (acons key nc entities)
-       (register-components key
-			    (map (lambda (c) (car c)) nc)
-			    components)
-       (cons key nc)))))
+(define (entity-ref key entity-set)
+  (hash-get-handle (car entity-set) key))
+
+(define (new-entity entity-set . new-components)
+  (receive (new-set new-keys) (bongodb:insert entity-set (normalize-components new-components))
+    (values new-set (car new-keys))))
+
+(define (get-entity entity-set key)
+  (let ((entity (bongodb:find entity-set (bongodb:$eq '_id key))))
+    (and entity (car entity))))
 
 (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)))))
-
-(export new-entity
-	remove-entity
-	set-entity
-	set-entity-components
-	remove-entity-components
-	modify-entities)
+	 (modify-entities ((car changes) entity-set) (cdr changes)))))
 
 
 ;;; Making systems
 
-(define* (find-entities-by-components c t)
-  (cond ((null? t) '())
+(define-record-type entities-changes-type
+  (entities-changes changes)
+  entities-changes?
+  (changes get-entities-changes))
+
+(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 res e c)))))))))
+	 form
+	 ...)))))
 
 (define-syntax define-system
   (syntax-rules ()
@@ -223,63 +242,33 @@
          form
 	 ...)))))
 
-(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))))
+(define (composed-systems-result results)
+  (let ((changes (filter (lambda (r) (entities-changes? r)) results)))
+    (cond ((null? changes)
+	   (car results))
+	  (else
+	   (append-changes changes)))))
 
-(export find-entities-by-components
-	define-system
-	make-system
-	join-systems
-	threaded-systems
-	group-systems)
+(define (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)))))))
 
 
 ;;; Entities and components access inside systems
@@ -289,6 +278,3 @@
 
 (define (get-component component-name entity)
   (assoc-ref (cdr entity) component-name))
-
-(export get-key
-	get-component)