# HG changeset patch # User Steve Losh # Date 1470878559 0 # Node ID 10d0e52e7ef36e189ff935b4539d6419f0d7060e # Parent e6e8c6e2ef91485f0a5cc049756d768884ac3482 Add a couple of simple tests diff -r e6e8c6e2ef91 -r 10d0e52e7ef3 Makefile --- 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 diff -r e6e8c6e2ef91 -r 10d0e52e7ef3 beast.asd --- 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))) diff -r e6e8c6e2ef91 -r 10d0e52e7ef3 beast.lisp --- 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)) diff -r e6e8c6e2ef91 -r 10d0e52e7ef3 package-test.lisp --- /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)) diff -r e6e8c6e2ef91 -r 10d0e52e7ef3 test-run.lisp --- /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) diff -r e6e8c6e2ef91 -r 10d0e52e7ef3 test.lisp --- /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)))))))