de541242aeb3 default tip

Refactor a number of things

1. Removed the (vendored) dependency on Quickutils.
2. Removed dependency on Roswell for running unit tests.
3. All system-running functions are expanded into `ARITY` nested loops, not just those with arity 2 or smaller.
4. Modernized the file/directory structure to match my recent projects.
5. Added more unit tests to cover parts of the code that weren't being tested before.
6. The internal system argument indexes are now vectors instead of lists.
7. Exported `all-entities` for debugging.
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Sun, 29 Aug 2021 14:41:27 -0400
parents 840edf5d4f1a
children (none)
branches/tags default tip
files Makefile README.markdown beast-test.asd beast.asd docs/03-reference.markdown docs/04-changelog.markdown docs/index.markdown package-test.lisp package.lisp src/beast.lisp src/main.lisp src/package.lisp test/package.lisp test/run.lisp test/test-run.lisp test/test.lisp vendor/make-quickutils.lisp vendor/quickutils-package.lisp vendor/quickutils.lisp

Changes

--- a/Makefile	Tue Jan 14 19:51:18 2020 -0500
+++ b/Makefile	Sun Aug 29 14:41:27 2021 -0400
@@ -1,17 +1,12 @@
-.PHONY: pubdocs test-sbcl test-ccl test-ecl test vendor
+.PHONY: pubdocs test-sbcl test-ccl test-ecl test-abcl test
 
+heading_printer = $(shell which heading || echo 'true')
 sourcefiles = $(shell ffind --full-path --literal .lisp)
 docfiles = $(shell ls docs/*.markdown)
 apidoc = docs/03-reference.markdown
 
-# Vendor ----------------------------------------------------------------------
-vendor/quickutils.lisp: vendor/make-quickutils.lisp
-	cd vendor && sbcl --noinform --load make-quickutils.lisp  --eval '(quit)'
-
-vendor: vendor/quickutils.lisp
-
 # Documentation ---------------------------------------------------------------
-$(apidoc): $(sourcefiles) docs/api.lisp package.lisp
+$(apidoc): $(sourcefiles) docs/api.lisp
 	sbcl --noinform --load docs/api.lisp  --eval '(quit)'
 
 docs/build/index.html: $(docfiles) $(apidoc) docs/title
@@ -29,17 +24,17 @@
 test: test-sbcl test-ccl test-ecl test-abcl
 
 test-sbcl:
-	./test/header.sh computer 'SBCL'
-	ros run -L sbcl --load test/test-run.lisp
+	$(heading_printer) computer 'SBCL'
+	time sbcl --load test/run.lisp
 
 test-ccl:
-	./test/header.sh slant 'CCL'
-	ros run -L ccl-bin --load test/test-run.lisp
+	$(heading_printer) slant 'CCL'
+	time ccl --load test/run.lisp
 
 test-ecl:
-	./test/header.sh roman 'ECL'
-	ros run -L ecl --load test/test-run.lisp
+	$(heading_printer) roman 'ECL'
+	time ecl -load test/run.lisp
 
 test-abcl:
-	./test/header.sh broadway 'ABCL'
-	abcl --load test/test-run.lisp
+	$(heading_printer) broadway 'ABCL'
+	time abcl --load test/run.lisp
--- a/README.markdown	Tue Jan 14 19:51:18 2020 -0500
+++ b/README.markdown	Sun Aug 29 14:41:27 2021 -0400
@@ -26,7 +26,7 @@
 * **Mercurial:** <https://hg.stevelosh.com/beast/>
 * **Git:** <https://github.com/sjl/beast/>
 
-The test suite currently passes in SBCL, CCL, ECL, and ABCL on OS X and Debian.
+The test suite currently passes in SBCL, CCL, ECL, and ABCL on Ubuntu 20.04.
 Further testing is welcome.
 
 [quicklisp]: https://quicklisp.org/
--- a/beast-test.asd	Tue Jan 14 19:51:18 2020 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,11 +0,0 @@
-(asdf:defsystem :beast-test
-  :depends-on (:1am :beast)
-
-  :serial t
-  :components ((:file "package-test")
-               (:module "test"
-                :serial t
-                :components ((:file "test"))))
-
-  :perform
-  (asdf:test-op (op system) (uiop:symbol-call :beast-test :run-tests)))
--- a/beast.asd	Tue Jan 14 19:51:18 2020 -0500
+++ b/beast.asd	Sun Aug 29 14:41:27 2021 -0400
@@ -4,18 +4,27 @@
   :homepage "https://docs.stevelosh.com/beast/"
 
   :license "MIT"
-  :version "1.1.0"
+  :version "1.2.0"
 
   :depends-on ()
 
   :serial t
-  :components ((:module "vendor"
+  :components ((:module "src"
                 :serial t
-                :components ((:file "quickutils-package")
-                             (:file "quickutils")))
-               (:file "package")
-               (:module "src"
+                :components ((:file "package")
+                             (:file "main"))))
+
+  :in-order-to ((asdf:test-op (asdf:test-op :beast/test))))
+
+
+(asdf:defsystem :beast/test
+  :depends-on (:1am :beast)
+
+  :serial t
+  :components ((:module "test"
                 :serial t
-                :components ((:file "beast"))))
+                :components ((:file "package")
+                             (:file "test"))))
 
-  :in-order-to ((asdf:test-op (asdf:test-op :beast-test))))
+  :perform
+  (asdf:test-op (op system) (uiop:symbol-call :beast/test :run-tests)))
--- a/docs/03-reference.markdown	Tue Jan 14 19:51:18 2020 -0500
+++ b/docs/03-reference.markdown	Sun Aug 29 14:41:27 2021 -0400
@@ -12,6 +12,17 @@
 
 ## Package `BEAST`
 
+### `ALL-ENTITIES` (function)
+
+    (ALL-ENTITIES)
+
+Return a list of all entities.
+
+  Normally you should run code on entities using systems, but this function can
+  be handy for debugging purposes.
+
+  
+
 ### `CLEAR-ENTITIES` (function)
 
     (CLEAR-ENTITIES)
--- a/docs/04-changelog.markdown	Tue Jan 14 19:51:18 2020 -0500
+++ b/docs/04-changelog.markdown	Sun Aug 29 14:41:27 2021 -0400
@@ -5,6 +5,24 @@
 
 [TOC]
 
+v1.2.0
+------
+
+Refactored a chunk of the code to do a few things:
+
+1. Removed the (vendored) dependency on Quickutils.
+2. Removed dependency on Roswell for running unit tests.
+3. All system-running functions are expanded into `ARITY` nested loops, not just
+   those with arity 2 or smaller.
+4. Modernized the file/directory structure to match my recent projects.
+5. Added more unit tests to cover parts of the code that weren't being tested
+   before.
+6. The internal system argument indexes are now vectors instead of lists.
+7. Exported `all-entities` for debugging.
+
+Other than the new `all-entities` function nothing user-visible should have
+changed.  Please file a bug if you see any new or broken behavior.
+
 v1.1.0
 ------
 
--- a/docs/index.markdown	Tue Jan 14 19:51:18 2020 -0500
+++ b/docs/index.markdown	Sun Aug 29 14:41:27 2021 -0400
@@ -12,7 +12,7 @@
 * **Mercurial:** <https://hg.stevelosh.com/beast/>
 * **Git:** <https://github.com/sjl/beast/>
 
-The test suite currently passes in SBCL, CCL, ECL, and ABCL on OS X and Debian.
+The test suite currently passes in SBCL, CCL, ECL, and ABCL on Ubuntu 20.04.
 Further testing is welcome.
 
 [quicklisp]: https://quicklisp.org/
--- a/package-test.lisp	Tue Jan 14 19:51:18 2020 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,7 +0,0 @@
-(defpackage #:beast-test
-  (:use
-    #:cl
-    #:1am
-    #:beast)
-  (:export
-    #:run-tests))
--- a/package.lisp	Tue Jan 14 19:51:18 2020 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,21 +0,0 @@
-(defpackage :beast
-  (:use
-    :cl
-    :beast.quickutils)
-  (:export
-    :entity
-    :entity-id
-
-    :define-entity
-
-    :create-entity
-    :destroy-entity
-    :clear-entities
-    :map-entities
-
-    :entity-created
-    :entity-destroyed
-
-    :define-aspect
-
-    :define-system))
--- a/src/beast.lisp	Tue Jan 14 19:51:18 2020 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,359 +0,0 @@
-(in-package :beast)
-
-
-;;;; Notes
-;;; Entities are stored in an {id -> entity} hash table.
-;;;
-;;; Entities are also indexed by aspect in a nested hash table:
-;;;
-;;;     {aspect-symbol -> {id -> entity}}
-;;;
-;;; Entities are indexed by system too:
-;;;
-;;;     {system-symbol ->
-;;;         ({id -> entity}   ; arg1
-;;;          {id -> entity})  ; arg2
-;;;     }
-;;;
-;;; Systems are stored as:
-;;;
-;;;     {system-symbol -> (system-function arity type-specifier-list)}
-;;;
-;;; TODO: Figure out the distinct problem.
-
-
-;;;; Global Data Structures ---------------------------------------------------
-(defvar *entity-id-counter* 0)
-(defvar *entity-index* (make-hash-table))
-(defvar *aspect-index* (make-hash-table))
-(defvar *system-index* (make-hash-table))
-(defvar *systems* (make-hash-table))
-
-
-;;;; Entities -----------------------------------------------------------------
-(defclass entity ()
-  ((id
-     :reader entity-id :initform (incf *entity-id-counter*)
-     :documentation
-     "The unique ID of the entity.  This may go away in the future.")
-   (%beast/aspects
-     :allocation :class :initform nil
-     :documentation
-     "A list of the aspects this entity class inherits.  **Don't touch this.**"))
-  (:documentation "A single entity in the game world."))
-
-(defmethod print-object ((e entity) stream)
-  (print-unreadable-object (e stream :type t :identity nil)
-    (format stream "~D" (entity-id e))))
-
-
-(defun entity-satisfies-system-type-specifier-p (entity specifier)
-  (every (lambda (aspect) (typep entity aspect))
-         specifier))
-
-(defun index-entity (entity)
-  "Insert `entity` into the entity index."
-  (setf (gethash (entity-id entity) *entity-index*) entity))
-
-(defun index-entity-aspects (entity)
-  "Insert `entity` into appropriate aspect indexes."
-  (loop :for aspect :in (slot-value entity '%beast/aspects)
-        :do (setf (gethash (entity-id entity)
-                           (gethash aspect *aspect-index*))
-                  entity)))
-
-(defun index-entity-systems (entity)
-  "Insert `entity` into appropriate system indexes."
-  (loop
-    :with id = (entity-id entity)
-    :for system :being :the hash-keys :of *systems*
-    :using (hash-value (nil nil type-specifiers))
-    :do (loop :for argument-index :in (gethash system *system-index*)
-              :for specifier :in type-specifiers
-              :when (entity-satisfies-system-type-specifier-p entity specifier)
-              :do (setf (gethash id argument-index) entity))))
-
-
-(defun unindex-entity (id)
-  "Remove `entity` from the entity-level index."
-  (remhash id *entity-index*))
-
-(defun unindex-entity-aspects (id)
-  "Remove `entity` from the aspect indexes."
-  (loop
-    :for index :being :the hash-values :of *aspect-index*
-    :do (remhash id index)))
-
-(defun unindex-entity-systems (id)
-  "Remove `entity` from the system indexes."
-  (loop
-    :for argument-indexes :being :the hash-values :of *system-index*
-    :do (loop :for index :in argument-indexes
-              :do (remhash id index))))
-
-
-(defgeneric entity-created (entity)
-  (:method ((entity entity)) nil)
-  (:documentation
-  "Called after an entity has been created and indexed.
-
-  The default method does nothing, but users can implement their own auxillary
-  methods to run code when entities are created.
-
-  "))
-
-(defgeneric entity-destroyed (entity)
-  (:method ((entity entity)) nil)
-  (:documentation
-  "Called after an entity has been destroyed and unindexed.
-
-  The default method does nothing, but users can implement their own auxillary
-  methods to run code when entities are destroyed.
-
-  "))
-
-
-(defun create-entity (class &rest initargs)
-  "Create an entity of the given entity class and return it.
-
-  `initargs` will be passed along to `make-instance`.
-
-  The `entity-created` generic function will be called just before returning the
-  entity.
-
-  "
-  (let ((entity (apply #'make-instance class initargs)))
-    (index-entity entity)
-    (index-entity-aspects entity)
-    (index-entity-systems entity)
-    (entity-created entity)
-    entity))
-
-(defun destroy-entity (entity)
-  "Destroy `entity` and return it.
-
-  The `entity-destroyed` generic function will be called after the entity has
-  been destroyed and unindexed.
-
-  "
-  (let ((id (entity-id entity)))
-    (unindex-entity id)
-    (unindex-entity-aspects id)
-    (unindex-entity-systems id))
-  (entity-destroyed entity)
-  entity)
-
-(defun clear-entities ()
-  "Destroy all entities.
-
-  `destroy-entity` will be called for each entity.
-
-  Returns a list of all the destroyed entites.
-
-  "
-  (mapc #'destroy-entity (hash-table-values *entity-index*)))
-
-
-(defun get-entity (id)
-  "Return the entity with the given `id`, or `nil` if it is unknown."
-  (gethash id *entity-index*))
-
-(defun all-entities ()
-  "Return a list of all entities."
-  (hash-table-values *entity-index*))
-
-(defun map-entities (function &optional (type 'entity))
-  "Map `function` over all entities that are subtypes of `type`.
-
-  Normally you should run code on entities using systems, but this function can
-  be handy for debugging purposes.
-
-  "
-  (mapcar function
-          (remove-if-not (lambda (entity) (typep entity type))
-                         (hash-table-values *entity-index*))))
-
-
-(defmacro define-entity (name aspects &rest slots)
-  "Define an entity class.
-
-  `name` should be a symbol that will become the name of the class.
-
-  `aspects` should be a list of the aspects this entity should inherit from.
-
-  `slots` can be zero or more extra CLOS slot definitions.
-
-  Examples:
-
-    (define-entity potion (drinkable))
-
-    (define-entity cheese (edible visible)
-      (flavor :accessor cheese-flavor :initarg :flavor))
-
-  "
-  `(progn
-    (defclass ,name (entity ,@aspects)
-      ((%beast/aspects :allocation :class :initform ',aspects)
-       ,@slots))
-    (defun ,(symb name '?) (object)
-      (typep object ',name))
-    (find-class ',name)))
-
-
-;;;; Aspects ------------------------------------------------------------------
-(defun initialize-aspect-index (name)
-  (when (not (hash-table-key-exists-p *aspect-index* name))
-    (setf (gethash name *aspect-index*) (make-hash-table))))
-
-(defmacro define-aspect (name &rest fields)
-  "Define an aspect class.
-
-  `name` should be a symbol that will become the name of the class.
-
-  `fields` should be zero or more field definitions.  Each field definition can
-  be a symbol (the field name), or a list of the field name and extra CLOS slot
-  options.
-
-  Field names will have the aspect name and a slash prepended to them to create
-  the slot names.  `:initarg` and `:accessor` slot options will also be
-  automatically generated.
-
-  Example:
-
-    (define-aspect edible
-      energy
-      (taste :initform nil))
-    =>
-    (defclass edible ()
-      ((edible/energy :initarg :edible/energy
-                      :accessor edible/energy)
-       (edible/taste :initarg :edible/taste
-                     :accessor edible/taste
-                     :initform nil)))
-
-  "
-  (flet ((clean-field (f)
-           (ctypecase f
-             (symbol (list f))
-             (list f))))
-    `(progn
-      (defclass ,name ()
-        ,(loop
-           :for (field . field-options) :in (mapcar #'clean-field fields)
-           :for field-name = (symb name '/ field)
-           :collect `(,field-name
-                      :accessor ,field-name
-                      :initarg ,(ensure-keyword field-name) ; *opens trenchcoat*
-                      ,@field-options)))
-
-      (defun ,(symb name '?) (object)
-        (typep object ',name))
-
-      (initialize-aspect-index ',name)
-
-      (find-class ',name))))
-
-
-;;;; Systems ------------------------------------------------------------------
-(defun rebuild-system-index (arglist)
-  (loop
-    :for (nil . type-specifier) :in arglist
-    :for index = (make-hash-table)
-    :do (loop
-          :for entity :being :the hash-values :of *entity-index*
-          :when (entity-satisfies-system-type-specifier-p entity type-specifier)
-          :do (setf (gethash (entity-id entity) index) entity))
-    :collect index))
-
-(defun initialize-system-index (name function arglist)
-  (setf (gethash name *systems*)
-        (list function (length arglist) (mapcar #'cdr arglist))
-
-        (gethash name *system-index*)
-        (rebuild-system-index arglist)))
-
-
-(defun build-system-runner-1 (name type-specifiers)
-  (with-gensyms (argument-indexes entity)
-    `(let ((,argument-indexes (gethash ',name *system-index*)))
-      (loop :for ,entity :being :the hash-values :of (first ,argument-indexes)
-            :do (locally
-                  (declare (type ,(first type-specifiers) ,entity))
-                  (,name ,entity))))))
-
-(defun build-system-runner-2 (name type-specifiers)
-  (with-gensyms (argument-indexes e1 e2)
-    `(let ((,argument-indexes (gethash ',name *system-index*)))
-      (loop
-        :for ,e1 :being :the hash-values :of (first ,argument-indexes)
-        :do (loop :for ,e2 :being :the hash-values :of (second ,argument-indexes)
-                  :do (locally
-                        (declare (type ,(first type-specifiers) ,e1)
-                                 (type ,(second type-specifiers) ,e2))
-                        (,name ,e1 ,e2)))))))
-
-(defun build-system-runner-n (name)
-  `(apply #'map-product #',name
-    (mapcar #'hash-table-values (gethash ',name *system-index*))))
-
-
-(defun build-system-runner (name arity type-specifiers)
-  (case arity
-    (0 nil)
-    (1 (build-system-runner-1 name type-specifiers))
-    (2 (build-system-runner-2 name type-specifiers))
-    (t (build-system-runner-n name))))
-
-
-(defmacro define-system (name-and-options arglist &body body)
-  "Define a system.
-
-  `name-and-options` should be a list of the system name (a symbol) and any
-  system options.  A bare symbol can be used if no options are needed.
-
-  `arglist` should be a list of system arguments.  Each argument should be
-  a list of the argument name and zero or more aspect/entity classes.
-
-  Defining a system `foo` defines two functions:
-
-  * `foo` runs `body` on a single entity and should only be used for debugging,
-    tracing, or disassembling.
-  * `run-foo` should be called to run the system on all applicable entities.
-
-  Available system options:
-
-  * `:inline`: when true, try to inline the system function into the
-    system-running function to avoid the overhead of a function call for every
-    entity.  Defaults to `nil`.
-
-  Examples:
-
-    (define-system age ((entity lifetime))
-      (when (> (incf (lifetime/age entity))
-               (lifetime/lifespan entity))
-        (destroy-entity entity)))
-
-  "
-  (let ((argument-type-specifiers
-          (loop :for arg :in (mapcar #'ensure-list arglist)
-                :collect `(and entity ,@(cdr arg)))))
-    (destructuring-bind (name &key inline)
-        (ensure-list name-and-options)
-      `(progn
-        (declaim (ftype (function (,@argument-type-specifiers)
-                                  (values null &optional))
-                        ,name)
-                 ,(if inline
-                    `(inline ,name)
-                    `(notinline ,name)))
-        (defun ,name (,@(mapcar #'car arglist))
-          ,@body
-          nil)
-
-        (defun ,(symb 'run- name) ()
-          ,(build-system-runner name (length arglist) argument-type-specifiers))
-
-        (initialize-system-index ',name #',name ',arglist)
-
-        ',name))))
-
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/main.lisp	Sun Aug 29 14:41:27 2021 -0400
@@ -0,0 +1,358 @@
+(in-package :beast)
+
+
+;;;; Notes
+;;; Entities are stored in an {id -> entity} hash table.
+;;;
+;;; Entities are also indexed by aspect in a nested hash table:
+;;;
+;;;     {aspect-symbol -> {id -> entity}}
+;;;
+;;; Entities are indexed by system too, as a vector of hash tables, one entry
+;;; for each of the system's arguments:
+;;;
+;;;     {system-symbol ->
+;;;        #({id -> entity}   ; arg1
+;;;          {id -> entity})  ; arg2
+;;;     }
+;;;
+;;; Systems are stored as:
+;;;
+;;;     {system-symbol -> (system-function arity type-specifier-list)}
+;;;
+;;; TODO: Figure out the distinct problem.
+
+
+;;;; Global Data Structures ---------------------------------------------------
+(defvar *entity-id-counter* 0)
+(defvar *entity-index* (make-hash-table))
+(defvar *aspect-index* (make-hash-table))
+(defvar *system-index* (make-hash-table))
+(defvar *systems* (make-hash-table))
+
+
+;;;; Utils --------------------------------------------------------------------
+(defun symb (&rest args)
+  (values (intern (format nil "~{~A~}" args))))
+
+
+;;;; Entities -----------------------------------------------------------------
+(defclass entity ()
+  ((id
+     :reader entity-id :initform (incf *entity-id-counter*)
+     :documentation
+     "The unique ID of the entity.  This may go away in the future.")
+   (%beast/aspects
+     :allocation :class :initform nil
+     :documentation
+     "A list of the aspects this entity class inherits.  **Don't touch this.**"))
+  (:documentation "A single entity in the game world."))
+
+(defmethod print-object ((e entity) stream)
+  (print-unreadable-object (e stream :type t :identity nil)
+    (format stream "~D" (entity-id e))))
+
+
+(defun entity-satisfies-system-type-specifier-p (entity specifier)
+  (every (lambda (aspect) (typep entity aspect))
+         specifier))
+
+(defun index-entity (entity)
+  "Insert `entity` into the entity index."
+  (setf (gethash (entity-id entity) *entity-index*) entity))
+
+(defun index-entity-aspects (entity)
+  "Insert `entity` into appropriate aspect indexes."
+  (loop :for aspect :in (slot-value entity '%beast/aspects)
+        :do (setf (gethash (entity-id entity)
+                           (gethash aspect *aspect-index*))
+                  entity)))
+
+(defun index-entity-systems (entity)
+  "Insert `entity` into appropriate system indexes."
+  (loop
+    :with id = (entity-id entity)
+    :for system :being :the hash-keys :of *systems*
+    :using (hash-value (nil nil type-specifiers))
+    :do (loop :for argument-index :across (gethash system *system-index*)
+              :for specifier :in type-specifiers
+              :when (entity-satisfies-system-type-specifier-p entity specifier)
+              :do (setf (gethash id argument-index) entity))))
+
+
+(defun unindex-entity (id)
+  "Remove `entity` from the entity-level index."
+  (remhash id *entity-index*))
+
+(defun unindex-entity-aspects (id)
+  "Remove `entity` from the aspect indexes."
+  (loop
+    :for index :being :the :hash-values :of *aspect-index*
+    :do (remhash id index)))
+
+(defun unindex-entity-systems (id)
+  "Remove `entity` from the system indexes."
+  (loop
+    :for argument-indexes :being :the hash-values :of *system-index*
+    :do (loop :for index :across argument-indexes
+              :do (remhash id index))))
+
+
+(defgeneric entity-created (entity)
+  (:method ((entity entity)) nil)
+  (:documentation
+  "Called after an entity has been created and indexed.
+
+  The default method does nothing, but users can implement their own auxillary
+  methods to run code when entities are created.
+
+  "))
+
+(defgeneric entity-destroyed (entity)
+  (:method ((entity entity)) nil)
+  (:documentation
+  "Called after an entity has been destroyed and unindexed.
+
+  The default method does nothing, but users can implement their own auxillary
+  methods to run code when entities are destroyed.
+
+  "))
+
+
+(defun create-entity (class &rest initargs)
+  "Create an entity of the given entity class and return it.
+
+  `initargs` will be passed along to `make-instance`.
+
+  The `entity-created` generic function will be called just before returning the
+  entity.
+
+  "
+  (let ((entity (apply #'make-instance class initargs)))
+    (index-entity entity)
+    (index-entity-aspects entity)
+    (index-entity-systems entity)
+    (entity-created entity)
+    entity))
+
+(defun destroy-entity (entity)
+  "Destroy `entity` and return it.
+
+  The `entity-destroyed` generic function will be called after the entity has
+  been destroyed and unindexed.
+
+  "
+  (let ((id (entity-id entity)))
+    (unindex-entity id)
+    (unindex-entity-aspects id)
+    (unindex-entity-systems id))
+  (entity-destroyed entity)
+  entity)
+
+(defun clear-entities ()
+  "Destroy all entities.
+
+  `destroy-entity` will be called for each entity.
+
+  Returns a list of all the destroyed entites.
+
+  "
+  (let ((entities (all-entities)))
+    (mapc #'destroy-entity entities)
+    entities))
+
+
+(defun get-entity (id)
+  "Return the entity with the given `id`, or `nil` if it is unknown."
+  (gethash id *entity-index*))
+
+(defun all-entities ()
+  "Return a list of all entities.
+
+  Normally you should run code on entities using systems, but this function can
+  be handy for debugging purposes.
+
+  "
+  (loop :for entity :being :the :hash-values :of *entity-index* :collect entity))
+
+(defun map-entities (function &optional (type 'entity))
+  "Map `function` over all entities that are subtypes of `type`.
+
+  Normally you should run code on entities using systems, but this function can
+  be handy for debugging purposes.
+
+  "
+  (loop :for entity :being :the :hash-values :of *entity-index*
+        :when (typep entity type)
+        :collect (funcall function entity)))
+
+
+(defmacro define-entity (name aspects &rest slots)
+  "Define an entity class.
+
+  `name` should be a symbol that will become the name of the class.
+
+  `aspects` should be a list of the aspects this entity should inherit from.
+
+  `slots` can be zero or more extra CLOS slot definitions.
+
+  Examples:
+
+    (define-entity potion (drinkable))
+
+    (define-entity cheese (edible visible)
+      (flavor :accessor cheese-flavor :initarg :flavor))
+
+  "
+  `(progn
+    (defclass ,name (entity ,@aspects)
+      ((%beast/aspects :allocation :class :initform ',aspects)
+       ,@slots))
+    (defun ,(symb name '?) (object)
+      (typep object ',name))
+    (find-class ',name)))
+
+
+;;;; Aspects ------------------------------------------------------------------
+(defun initialize-aspect-index (name)
+  (when (not (gethash name *aspect-index*))
+    (setf (gethash name *aspect-index*) (make-hash-table))))
+
+(defmacro define-aspect (name &rest fields)
+  "Define an aspect class.
+
+  `name` should be a symbol that will become the name of the class.
+
+  `fields` should be zero or more field definitions.  Each field definition can
+  be a symbol (the field name), or a list of the field name and extra CLOS slot
+  options.
+
+  Field names will have the aspect name and a slash prepended to them to create
+  the slot names.  `:initarg` and `:accessor` slot options will also be
+  automatically generated.
+
+  Example:
+
+    (define-aspect edible
+      energy
+      (taste :initform nil))
+    =>
+    (defclass edible ()
+      ((edible/energy :initarg :edible/energy
+                      :accessor edible/energy)
+       (edible/taste :initarg :edible/taste
+                     :accessor edible/taste
+                     :initform nil)))
+
+  "
+  (flet ((clean-field (f)
+           (ctypecase f
+             (symbol (list f))
+             (list f))))
+    `(progn
+      (defclass ,name ()
+        ,(loop
+           :for (field . field-options) :in (mapcar #'clean-field fields)
+           :for field-name = (symb name '/ field)
+           :collect `(,field-name
+                      :accessor ,field-name
+                      :initarg ,(intern (string field-name) :keyword)
+                      ,@field-options)))
+
+      (defun ,(symb name '?) (object)
+        (typep object ',name))
+
+      (initialize-aspect-index ',name)
+
+      (find-class ',name))))
+
+
+;;;; Systems ------------------------------------------------------------------
+(defun rebuild-system-index (arglist)
+  (coerce (loop
+            :for (nil . type-specifier) :in arglist
+            :for index = (make-hash-table)
+            :do (loop
+                  :for entity :being :the :hash-values :of *entity-index*
+                  :when (entity-satisfies-system-type-specifier-p entity type-specifier)
+                  :do (setf (gethash (entity-id entity) index) entity))
+            :collect index)
+          'vector))
+
+(defun initialize-system-index (name function arglist)
+  (setf (gethash name *systems*)
+        (list function (length arglist) (mapcar #'cdr arglist))
+
+        (gethash name *system-index*)
+        (rebuild-system-index arglist)))
+
+
+(defun build-system-runner (name type-specifiers)
+  (unless (null type-specifiers)
+    (let ((argument-indexes (gensym "AI"))
+          (arguments (loop :repeat (length type-specifiers) :collect (gensym "E"))))
+      `(let ((,argument-indexes (gethash ',name *system-index*)))
+         ,(labels ((recur (types args n)
+                     (if (null types)
+                       `(,name ,@arguments)
+                       `(loop
+                          :for ,(first args) :of-type ,(first types)
+                          :being :the :hash-values :of (aref ,argument-indexes ,n)
+                          :do ,(recur (rest types) (rest args) (1+ n))))))
+            (recur type-specifiers arguments 0))))))
+
+
+(defmacro define-system (name-and-options arglist &body body)
+  "Define a system.
+
+  `name-and-options` should be a list of the system name (a symbol) and any
+  system options.  A bare symbol can be used if no options are needed.
+
+  `arglist` should be a list of system arguments.  Each argument should be
+  a list of the argument name and zero or more aspect/entity classes.
+
+  Defining a system `foo` defines two functions:
+
+  * `foo` runs `body` on a single entity and should only be used for debugging,
+    tracing, or disassembling.
+  * `run-foo` should be called to run the system on all applicable entities.
+
+  Available system options:
+
+  * `:inline`: when true, try to inline the system function into the
+    system-running function to avoid the overhead of a function call for every
+    entity.  Defaults to `nil`.
+
+  Examples:
+
+    (define-system age ((entity lifetime))
+      (when (> (incf (lifetime/age entity))
+               (lifetime/lifespan entity))
+        (destroy-entity entity)))
+
+  "
+  (let ((argument-type-specifiers
+          (loop :for arg :in arglist ; either foo or (foo a1 a2)
+                :for classes = (if (listp arg) (rest arg) nil)
+                :collect `(and entity ,@classes))))
+    (destructuring-bind (name &key inline) (if (listp name-and-options)
+                                               name-and-options
+                                               (list name-and-options))
+      `(progn
+        (declaim (ftype (function (,@argument-type-specifiers)
+                                  (values null &optional))
+                        ,name)
+                 ,(if inline
+                    `(inline ,name)
+                    `(notinline ,name)))
+        (defun ,name (,@(mapcar #'car arglist))
+          ,@body
+          nil)
+
+        (defun ,(symb 'run- name) ()
+          ,(build-system-runner name argument-type-specifiers))
+
+        (initialize-system-index ',name #',name ',arglist)
+
+        ',name))))
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/package.lisp	Sun Aug 29 14:41:27 2021 -0400
@@ -0,0 +1,20 @@
+(defpackage :beast
+  (:use :cl)
+  (:export
+    :entity
+    :entity-id
+
+    :define-entity
+
+    :create-entity
+    :destroy-entity
+    :clear-entities
+    :map-entities
+    :all-entities
+
+    :entity-created
+    :entity-destroyed
+
+    :define-aspect
+
+    :define-system))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/package.lisp	Sun Aug 29 14:41:27 2021 -0400
@@ -0,0 +1,3 @@
+(defpackage :beast/test
+  (:use :cl :1am :beast)
+  (:export :run-tests))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/run.lisp	Sun Aug 29 14:41:27 2021 -0400
@@ -0,0 +1,5 @@
+#+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value")
+
+(ql:quickload 'beast :silent t)
+(asdf:test-system 'beast)
+(quit)
--- a/test/test-run.lisp	Tue Jan 14 19:51:18 2020 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,3 +0,0 @@
-(ql:quickload 'beast)
-(time (asdf:test-system 'beast))
-(quit)
--- a/test/test.lisp	Tue Jan 14 19:51:18 2020 -0500
+++ b/test/test.lisp	Sun Aug 29 14:41:27 2021 -0400
@@ -1,9 +1,10 @@
-(in-package :beast-test)
+(in-package :beast/test)
 
-;;;; Boilerplate
+;;;; Boilerplate --------------------------------------------------------------
 (defmacro define-test (name &body body)
-  `(test ,name
-    (let ((*package* ,*package*))
+  `(test ,(beast::symb 'test/ name)
+    (let ((*package* ,*package*)
+          (*callbacks* nil))
       (clear-entities)
       ,@body)))
 
@@ -14,11 +15,15 @@
   (null (set-exclusive-or a b :test 'equal)))
 
 
-;;;; Setup
+;;;; Setup --------------------------------------------------------------------
 (defparameter *results* nil)
+(defparameter *callbacks* nil)
 
 (define-aspect a-foo f)
 (define-aspect a-bar b)
+(define-aspect a-baz z)
+(define-aspect a-callbacks-foo)
+(define-aspect a-callbacks-bar)
 
 (define-system sys-everything ((e))
   (push e *results*))
@@ -32,6 +37,9 @@
 (define-system sys-foo-bar ((e a-foo a-bar))
   (push e *results*))
 
+(define-system sys-foo-bar-baz ((e a-foo a-bar a-baz))
+  (push e *results*))
+
 
 (define-system sys2-foo-foo ((x a-foo) (y a-foo))
   (push (list x y) *results*))
@@ -42,20 +50,101 @@
 (define-system sys2-foobar-foo ((x a-foo a-bar) (y a-foo))
   (push (list x y) *results*))
 
+(define-system sys2-foobar-barbaz ((x a-foo a-bar) (y a-bar a-baz))
+  (push (list x y) *results*))
+
+(define-system sys3-foo-bar-baz ((x a-foo) (y a-bar) (z a-baz))
+  (push (list x y z) *results*))
+
 
 (define-entity e ())
 (define-entity e-foo (a-foo))
 (define-entity e-bar (a-bar))
+(define-entity e-baz (a-baz))
 (define-entity e-foo-bar (a-foo a-bar))
+(define-entity e-foo-bar-baz (a-foo a-bar a-baz))
+
+(define-entity e-callbacks-foo (a-callbacks-foo))
+(define-entity e-callbacks-bar (a-callbacks-bar))
+(define-entity e-callbacks-foobarplus (a-callbacks-foo a-callbacks-bar))
+
+(defmethod entity-created :after ((e a-callbacks-foo))        (push (list :created :foo e) *callbacks*))
+(defmethod entity-created :after ((e a-callbacks-bar))        (push (list :created :bar e) *callbacks*))
+(defmethod entity-created :after ((e e-callbacks-foobarplus)) (push (list :created :ent e) *callbacks*))
+
+(defmethod entity-destroyed :after ((e a-callbacks-foo))        (push (list :destroyed :foo e) *callbacks*))
+(defmethod entity-destroyed :after ((e a-callbacks-bar))        (push (list :destroyed :bar e) *callbacks*))
+(defmethod entity-destroyed :after ((e e-callbacks-foobarplus)) (push (list :destroyed :ent e) *callbacks*))
 
 
-;;;; Tests
+;;;; Tests --------------------------------------------------------------------
 (define-test create-entities
   (let ((a (create-entity 'e))
         (b (create-entity 'e)))
-    (is (set-equal (list a b) (beast::all-entities)))
+    (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 destroy-entities
+  (let ((a (create-entity 'e))
+        (b (create-entity 'e)))
+    (is (set-equal (list a b) (beast:all-entities)))
+    (destroy-entity a)
+    (is (set-equal (list b) (beast:all-entities)))
     (let ((c (create-entity 'e)))
-      (is (set-equal (list a b c) (beast::all-entities))))))
+      (is (set-equal (list b c) (beast:all-entities)))
+      (destroy-entity b)
+      (is (set-equal (list c) (beast:all-entities)))
+      (destroy-entity c)
+      (is (set-equal (list) (beast:all-entities))))))
+
+(define-test clear-entities
+  (let ((a (create-entity 'e))
+        (b (create-entity 'e)))
+    (is (set-equal (list a b) (beast:all-entities)))
+    (clear-entities)
+    (is (set-equal (list) (beast:all-entities)))))
+
+(define-test callbacks
+  (let (*callbacks* f b fbp)
+    (is (set-equal `() *callbacks*))
+
+    (setf f (create-entity 'e-callbacks-foo))
+    (is (set-equal `((:created :foo ,f)) *callbacks*))
+    (setf *callbacks* nil)
+
+    (setf b (create-entity 'e-callbacks-bar))
+    (is (set-equal `((:created :bar ,b)) *callbacks*))
+    (setf *callbacks* nil)
+
+    (setf fbp (create-entity 'e-callbacks-foobarplus))
+    (is (set-equal `((:created :bar ,fbp)
+                     (:created :foo ,fbp)
+                     (:created :ent ,fbp)) *callbacks*))
+    (setf *callbacks* nil)
+
+    (destroy-entity fbp)
+    (is (set-equal `((:destroyed :bar ,fbp)
+                     (:destroyed :foo ,fbp)
+                     (:destroyed :ent ,fbp)) *callbacks*))
+    (setf *callbacks* nil)
+
+    (destroy-entity f)
+    (is (set-equal `((:destroyed :foo ,f)) *callbacks*))
+    (setf *callbacks* nil)
+
+    (destroy-entity b)
+    (is (set-equal `((:destroyed :bar ,b)) *callbacks*))))
+
+(define-test map-entities
+  (create-entity 'e-foo :a-foo/f 1)
+  (create-entity 'e-foo :a-foo/f 2)
+  (is (set-equal (list 1 2) (beast:map-entities #'a-foo/f)))
+  (create-entity 'e-foo :a-foo/f 3)
+  (is (set-equal (list 1 2 3) (beast:map-entities #'a-foo/f)))
+  (create-entity 'e-bar :a-bar/b 0)
+  (is (set-equal (list 1 2 3) (beast:map-entities #'a-foo/f 'a-foo)))
+  (is (set-equal (list 0) (beast:map-entities #'a-bar/b 'a-bar))))
 
 (define-test get-entities
   (let ((a (create-entity 'e))
@@ -118,3 +207,33 @@
       (run-sys2-foobar-foo)
       (is (set-equal *results* (list (list fb f)
                                      (list fb fb)))))))
+
+(define-test system-running-arity-3
+  (let ((f (create-entity 'e-foo))
+        (b (create-entity 'e-bar))
+        (z (create-entity 'e-baz))
+        (fb (create-entity 'e-foo-bar))
+        (fbz (create-entity 'e-foo-bar-baz)))
+    (let ((*results* nil))
+      (run-sys3-foo-bar-baz)
+      (is (set-equal *results* (list
+                                 (list f     b     z)
+                                 (list f     b   fbz)
+                                 (list f    fb     z)
+                                 (list f    fb   fbz)
+                                 (list f    fbz    z)
+                                 (list f    fbz  fbz)
+
+                                 (list fb    b     z)
+                                 (list fb    b   fbz)
+                                 (list fb   fb     z)
+                                 (list fb   fb   fbz)
+                                 (list fb   fbz    z)
+                                 (list fb   fbz  fbz)
+
+                                 (list fbz   b     z)
+                                 (list fbz   b   fbz)
+                                 (list fbz  fb     z)
+                                 (list fbz  fb   fbz)
+                                 (list fbz  fbz    z)
+                                 (list fbz  fbz  fbz)))))))
--- a/vendor/make-quickutils.lisp	Tue Jan 14 19:51:18 2020 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,12 +0,0 @@
-(ql:quickload 'quickutil)
-
-(qtlc:save-utils-as
-  "quickutils.lisp"
-  :utilities '(:map-product
-               :hash-table-key-exists-p
-               :hash-table-values
-               :with-gensyms
-               :symb
-               :ensure-keyword
-               :ensure-list)
-  :package "BEAST.QUICKUTILS")
--- a/vendor/quickutils-package.lisp	Tue Jan 14 19:51:18 2020 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,12 +0,0 @@
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (unless (find-package "BEAST.QUICKUTILS")
-    (defpackage "BEAST.QUICKUTILS"
-      (:documentation "Package that contains Quickutil utility functions.")
-      (:use #:cl))))
-
-(in-package "BEAST.QUICKUTILS")
-
-;; need to define this here so sbcl will shut the hell up about it being
-;; undefined when compiling quickutils.lisp.  computers are trash.
-(defparameter *utilities* nil)
-
--- a/vendor/quickutils.lisp	Tue Jan 14 19:51:18 2020 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,194 +0,0 @@
-;;;; This file was automatically generated by Quickutil.
-;;;; See http://quickutil.org for details.
-
-;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:MAP-PRODUCT :HASH-TABLE-KEY-EXISTS-P :HASH-TABLE-VALUES :WITH-GENSYMS :SYMB :ENSURE-KEYWORD :ENSURE-LIST) :ensure-package T :package "BEAST.QUICKUTILS")
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (unless (find-package "BEAST.QUICKUTILS")
-    (defpackage "BEAST.QUICKUTILS"
-      (:documentation "Package that contains Quickutil utility functions.")
-      (:use #:cl))))
-
-(in-package "BEAST.QUICKUTILS")
-
-(when (boundp '*utilities*)
-  (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
-                                         :CURRY :MAPPEND :MAP-PRODUCT
-                                         :HASH-TABLE-KEY-EXISTS-P
-                                         :MAPHASH-VALUES :HASH-TABLE-VALUES
-                                         :STRING-DESIGNATOR :WITH-GENSYMS
-                                         :MKSTR :SYMB :ENSURE-KEYWORD
-                                         :ENSURE-LIST))))
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun make-gensym-list (length &optional (x "G"))
-    "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
-using the second (optional, defaulting to `\"G\"`) argument."
-    (let ((g (if (typep x '(integer 0)) x (string x))))
-      (loop repeat length
-            collect (gensym g))))
-  )                                        ; eval-when
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  ;;; To propagate return type and allow the compiler to eliminate the IF when
-  ;;; it is known if the argument is function or not.
-  (declaim (inline ensure-function))
-
-  (declaim (ftype (function (t) (values function &optional))
-                  ensure-function))
-  (defun ensure-function (function-designator)
-    "Returns the function designated by `function-designator`:
-if `function-designator` is a function, it is returned, otherwise
-it must be a function name and its `fdefinition` is returned."
-    (if (functionp function-designator)
-        function-designator
-        (fdefinition function-designator)))
-  )                                        ; eval-when
-
-  (defun curry (function &rest arguments)
-    "Returns a function that applies `arguments` and the arguments
-it is called with to `function`."
-    (declare (optimize (speed 3) (safety 1) (debug 1)))
-    (let ((fn (ensure-function function)))
-      (lambda (&rest more)
-        (declare (dynamic-extent more))
-        ;; Using M-V-C we don't need to append the arguments.
-        (multiple-value-call fn (values-list arguments) (values-list more)))))
-
-  (define-compiler-macro curry (function &rest arguments)
-    (let ((curries (make-gensym-list (length arguments) "CURRY"))
-          (fun (gensym "FUN")))
-      `(let ((,fun (ensure-function ,function))
-             ,@(mapcar #'list curries arguments))
-         (declare (optimize (speed 3) (safety 1) (debug 1)))
-         (lambda (&rest more)
-           (apply ,fun ,@curries more)))))
-  
-
-  (defun mappend (function &rest lists)
-    "Applies `function` to respective element(s) of each `list`, appending all the
-all the result list to a single list. `function` must return a list."
-    (loop for results in (apply #'mapcar function lists)
-          append results))
-  
-
-  (defun map-product (function list &rest more-lists)
-    "Returns a list containing the results of calling `function` with one argument
-from `list`, and one from each of `more-lists` for each combination of arguments.
-In other words, returns the product of `list` and `more-lists` using `function`.
-
-Example:
-
-    (map-product 'list '(1 2) '(3 4) '(5 6))
-     => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
-         (2 3 5) (2 3 6) (2 4 5) (2 4 6))"
-    (labels ((%map-product (f lists)
-               (let ((more (cdr lists))
-                     (one (car lists)))
-                 (if (not more)
-                     (mapcar f one)
-                     (mappend (lambda (x)
-                                (%map-product (curry f x) more))
-                              one)))))
-      (%map-product (ensure-function function) (cons list more-lists))))
-  
-
-  (defun hash-table-key-exists-p (hash-table key)
-    "Does `key` exist in `hash-table`?"
-    (nth-value 1 (gethash key hash-table)))
-  
-
-  (declaim (inline maphash-values))
-  (defun maphash-values (function table)
-    "Like `maphash`, but calls `function` with each value in the hash table `table`."
-    (maphash (lambda (k v)
-               (declare (ignore k))
-               (funcall function v))
-             table))
-  
-
-  (defun hash-table-values (table)
-    "Returns a list containing the values of hash table `table`."
-    (let ((values nil))
-      (maphash-values (lambda (v)
-                        (push v values))
-                      table)
-      values))
-  
-
-  (deftype string-designator ()
-    "A string designator type. A string designator is either a string, a symbol,
-or a character."
-    `(or symbol string character))
-  
-
-  (defmacro with-gensyms (names &body forms)
-    "Binds each variable named by a symbol in `names` to a unique symbol around
-`forms`. Each of `names` must either be either a symbol, or of the form:
-
-    (symbol string-designator)
-
-Bare symbols appearing in `names` are equivalent to:
-
-    (symbol symbol)
-
-The string-designator is used as the argument to `gensym` when constructing the
-unique symbol the named variable will be bound to."
-    `(let ,(mapcar (lambda (name)
-                     (multiple-value-bind (symbol string)
-                         (etypecase name
-                           (symbol
-                            (values name (symbol-name name)))
-                           ((cons symbol (cons string-designator null))
-                            (values (first name) (string (second name)))))
-                       `(,symbol (gensym ,string))))
-            names)
-       ,@forms))
-
-  (defmacro with-unique-names (names &body forms)
-    "Binds each variable named by a symbol in `names` to a unique symbol around
-`forms`. Each of `names` must either be either a symbol, or of the form:
-
-    (symbol string-designator)
-
-Bare symbols appearing in `names` are equivalent to:
-
-    (symbol symbol)
-
-The string-designator is used as the argument to `gensym` when constructing the
-unique symbol the named variable will be bound to."
-    `(with-gensyms ,names ,@forms))
-  
-
-  (defun mkstr (&rest args)
-    "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
-
-Extracted from _On Lisp_, chapter 4."
-    (with-output-to-string (s)
-      (dolist (a args) (princ a s))))
-  
-
-  (defun symb (&rest args)
-    "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
-
-Extracted from _On Lisp_, chapter 4.
-
-See also: `symbolicate`"
-    (values (intern (apply #'mkstr args))))
-  
-
-  (defun ensure-keyword (x)
-    "Ensure that a keyword is returned for the string designator `x`."
-    (values (intern (string x) :keyword)))
-  
-
-  (defun ensure-list (list)
-    "If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
-    (if (listp list)
-        list
-        (list list)))
-  
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(map-product hash-table-key-exists-p hash-table-values with-gensyms
-            with-unique-names symb ensure-keyword ensure-list)))
-
-;;;; END OF quickutils.lisp ;;;;