10d0e52e7ef3

--- a/Makefile	Wed Aug 10 16:23:52 2016 +0000
+++ b/Makefile	Thu Aug 11 01:22:39 2016 +0000
@@ -1,4 +1,4 @@
-.PHONY: pubdocs
+.PHONY: pubdocs test-sbcl test-ccl test-ecl test
 
 quickutils.lisp: make-quickutils.lisp
 	sbcl --noinform --load make-quickutils.lisp  --eval '(quit)'
@@ -22,3 +22,17 @@
 	hg -R ~/src/sjl.bitbucket.org commit -Am 'beast: Update site.'
 	hg -R ~/src/sjl.bitbucket.org push
 
+
+test: test-sbcl test-ccl test-ecl
+
+test-sbcl:
+	echo; figlet -kf computer 'SBCL' | sed -Ee 's/ +$$//' | tr -s '\n' | lolcat --freq=0.25; echo
+	ros run -L sbcl --load test-run.lisp
+
+test-ccl:
+	echo; figlet -kf slant 'CCL' | sed -Ee 's/ +$$//' | tr -s '\n' | lolcat --freq=0.25; echo
+	ros run -L ccl-bin --load test-run.lisp
+
+test-ecl:
+	echo; figlet -kf roman 'ECL' | sed -Ee 's/ +$$//' | tr -s '\n' | lolcat --freq=0.25; echo
+	ros run -L ecl --load test-run.lisp

--- a/beast.asd	Wed Aug 10 16:23:52 2016 +0000
+++ b/beast.asd	Thu Aug 11 01:22:39 2016 +0000
@@ -12,4 +12,19 @@
   :serial t
   :components ((:file "quickutils")
                (:file "package")
-               (:file "beast")))
+               (:file "beast"))
+
+  :in-order-to ((asdf:test-op (asdf:test-op #:beast-test))))
+
+
+(asdf:defsystem #:beast-test
+  :name "beast-test"
+
+  :depends-on (#:1am)
+
+  :serial t
+  :components ((:file "package-test")
+               (:file "test"))
+
+  :perform (asdf:test-op (op system)
+             (uiop:symbol-call :beast-test :run-tests)))

--- a/beast.lisp	Wed Aug 10 16:23:52 2016 +0000
+++ b/beast.lisp	Thu Aug 11 01:22:39 2016 +0000
@@ -38,6 +38,9 @@
 (defun get-entity (id)
   (gethash id *entity-index*))
 
+(defun all-entities ()
+  (hash-table-values *entity-index*))
+
 (defun map-entities (function &optional (type 'entity))
   (mapcar function
           (remove-if-not (lambda (entity) (typep entity type))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/package-test.lisp	Thu Aug 11 01:22:39 2016 +0000
@@ -0,0 +1,7 @@
+(defpackage #:beast-test
+  (:use
+    #:cl
+    #:1am
+    #:beast)
+  (:export
+    #:run-tests))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test-run.lisp	Thu Aug 11 01:22:39 2016 +0000
@@ -0,0 +1,3 @@
+(ql:quickload 'beast)
+(time (asdf:test-system 'beast))
+(quit)

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test.lisp	Thu Aug 11 01:22:39 2016 +0000
@@ -0,0 +1,120 @@
+(in-package #:beast-test)
+
+;;;; Boilerplate
+(defmacro define-test (name &body body)
+  `(test ,name
+    (let ((*package* ,*package*))
+      (clear-entities)
+      ,@body)))
+
+(defun run-tests ()
+  (1am:run))
+
+(defun set-equal (a b)
+  (null (set-exclusive-or a b :test 'equal)))
+
+
+;;;; Setup
+(defparameter *results* nil)
+
+(define-aspect a-foo f)
+(define-aspect a-bar b)
+
+(define-system sys-everything ((e))
+  (push e *results*))
+
+(define-system sys-foo ((e a-foo))
+  (push e *results*))
+
+(define-system sys-bar ((e a-bar))
+  (push e *results*))
+
+(define-system sys-foo-bar ((e a-foo a-bar))
+  (push e *results*))
+
+
+(define-system sys2-foo-foo ((x a-foo) (y a-foo))
+  (push (list x y) *results*))
+
+(define-system sys2-foo-bar ((x a-foo) (y a-bar))
+  (push (list x y) *results*))
+
+(define-system sys2-foobar-foo ((x a-foo a-bar) (y a-foo))
+  (push (list x y) *results*))
+
+
+(define-entity e ())
+(define-entity e-foo (a-foo))
+(define-entity e-bar (a-bar))
+(define-entity e-foo-bar (a-foo a-bar))
+
+
+;;;; Tests
+(define-test create-entities
+  (let ((a (create-entity 'e))
+        (b (create-entity 'e)))
+    (is (set-equal (list a b) (beast::all-entities)))
+    (let ((c (create-entity 'e)))
+      (is (set-equal (list a b c) (beast::all-entities))))))
+
+(define-test get-entities
+  (let ((a (create-entity 'e))
+        (b (create-entity 'e)))
+    (is (eq a (get-entity (entity-id a))))
+    (is (eq b (get-entity (entity-id b))))))
+
+(define-test aspect-mixins
+  (let ((f (create-entity 'e-foo :a-foo/f :foo))
+        (b (create-entity 'e-bar :a-bar/b :bar))
+        (fb (create-entity 'e-foo-bar
+                           :a-foo/f :foo
+                           :a-bar/b :bar)))
+    (is (eql (a-foo/f f) :foo))
+    (is (eql (a-bar/b b) :bar))
+    (is (eql (a-foo/f fb) :foo))
+    (is (eql (a-bar/b fb) :bar))))
+
+(define-test system-running-arity-1
+  (let ((f1 (create-entity 'e-foo :a-foo/f :foo))
+        (f2 (create-entity 'e-foo :a-foo/f :foo))
+        (b1 (create-entity 'e-bar :a-bar/b :bar))
+        (b2 (create-entity 'e-bar :a-bar/b :bar))
+        (fb (create-entity 'e-foo-bar :a-foo/f :foo :a-bar/b :bar)))
+    (let ((*results* nil))
+      (run-sys-everything)
+      (is (set-equal *results* (list f1 f2 b1 b2 fb))))
+
+    (let ((*results* nil))
+      (run-sys-foo)
+      (is (set-equal *results* (list f1 f2 fb))))
+
+    (let ((*results* nil))
+      (run-sys-bar)
+      (is (set-equal *results* (list b1 b2 fb))))
+
+    (let ((*results* nil))
+      (run-sys-foo-bar)
+      (is (set-equal *results* (list fb))))))
+
+(define-test system-running-arity-2
+  (let ((f (create-entity 'e-foo :a-foo/f :foo))
+        (b (create-entity 'e-bar :a-bar/b :bar))
+        (fb (create-entity 'e-foo-bar :a-foo/f :foo :a-bar/b :bar)))
+    (let ((*results* nil))
+      (run-sys2-foo-foo)
+      (is (set-equal *results* (list (list f f)
+                                     (list f fb)
+                                     (list fb f)
+                                     (list fb fb)))))
+
+    (let ((*results* nil))
+      (run-sys2-foo-bar)
+      (is (set-equal *results* (list (list f b)
+                                     (list f fb)
+                                     (list fb b)
+                                     (list fb fb)))))
+
+    (let ((*results* nil))
+      (run-sys2-foobar-foo)
+      (is (set-equal *results* (list (list fb f)
+                                     (list fb fb)))))))