8597527d94a5

Clean up project layout
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Thu, 08 Sep 2016 13:27:02 +0000
parents b4fab641f442
children 305a8a394b64
branches/tags (none)
files Makefile beast.asd beast.lisp make-quickutils.lisp quickutils.lisp src/beast.lisp test-run.lisp test.lisp test/header.sh test/test-run.lisp test/test.lisp vendor/make-quickutils.lisp vendor/quickutils.lisp

Changes

diff -r b4fab641f442 -r 8597527d94a5 Makefile
--- a/Makefile	Wed Aug 17 16:00:24 2016 +0000
+++ b/Makefile	Thu Sep 08 13:27:02 2016 +0000
@@ -1,16 +1,19 @@
-.PHONY: pubdocs test-sbcl test-ccl test-ecl test
-
-quickutils.lisp: make-quickutils.lisp
-	sbcl --noinform --load make-quickutils.lisp  --eval '(quit)'
+.PHONY: pubdocs test-sbcl test-ccl test-ecl test vendor
 
 sourcefiles = $(shell ffind --full-path --literal .lisp)
 docfiles = $(shell ls docs/*.markdown)
 apidoc = docs/04-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
 	sbcl --noinform --load docs/api.lisp  --eval '(quit)'
 
-
 docs/build/index.html: $(docfiles) $(apidoc) docs/title
 	cd docs && ~/.virtualenvs/d/bin/d
 
@@ -22,17 +25,21 @@
 	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
+# Testing ---------------------------------------------------------------------
+test: test-sbcl test-ccl test-ecl test-abcl
 
 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/header.sh computer 'SBCL'
+	ros run -L sbcl --load test/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/header.sh slant 'CCL'
+	ros run -L ccl-bin --load test/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
+	./test/header.sh roman 'ECL'
+	ros run -L ecl --load test/test-run.lisp
+
+test-abcl:
+	./test/header.sh broadway 'ABCL'
+	abcl --load test/test-run.lisp
diff -r b4fab641f442 -r 8597527d94a5 beast.asd
--- a/beast.asd	Wed Aug 17 16:00:24 2016 +0000
+++ b/beast.asd	Thu Sep 08 13:27:02 2016 +0000
@@ -10,9 +10,13 @@
   :depends-on ()
 
   :serial t
-  :components ((:file "quickutils")
+  :components ((:module "vendor"
+                :serial t
+                :components ((:file "quickutils")))
                (:file "package")
-               (:file "beast"))
+               (:module "src"
+                :serial t
+                :components ((:file "beast"))))
 
   :in-order-to ((asdf:test-op (asdf:test-op #:beast-test))))
 
@@ -24,7 +28,9 @@
 
   :serial t
   :components ((:file "package-test")
-               (:file "test"))
+               (:module "test"
+                :serial t
+                :components ((:file "test"))))
 
-  :perform (asdf:test-op (op system)
-             (uiop:symbol-call :beast-test :run-tests)))
+  :perform
+  (asdf:test-op (op system) (uiop:symbol-call :beast-test :run-tests)))
diff -r b4fab641f442 -r 8597527d94a5 beast.lisp
--- a/beast.lisp	Wed Aug 17 16:00:24 2016 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,360 +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.
-
-
-;;;; Entities
-(defvar *entity-id-counter* 0)
-(defvar *entity-index* (make-hash-table))
-
-
-(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 (function arity 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
-(defvar *aspect-index* (make-hash-table))
-
-(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)
-           (etypecase 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
-(defvar *system-index* (make-hash-table))
-(defvar *systems* (make-hash-table))
-
-
-(defun rebuild-system-index (arglist)
-  (loop
-    :for (argument-name . 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))))
-
diff -r b4fab641f442 -r 8597527d94a5 make-quickutils.lisp
--- a/make-quickutils.lisp	Wed Aug 17 16:00:24 2016 +0000
+++ /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")
diff -r b4fab641f442 -r 8597527d94a5 quickutils.lisp
--- a/quickutils.lisp	Wed Aug 17 16:00:24 2016 +0000
+++ /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 ;;;;
diff -r b4fab641f442 -r 8597527d94a5 src/beast.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/beast.lisp	Thu Sep 08 13:27:02 2016 +0000
@@ -0,0 +1,360 @@
+(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.
+
+
+;;;; Entities
+(defvar *entity-id-counter* 0)
+(defvar *entity-index* (make-hash-table))
+
+
+(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 (function arity 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
+(defvar *aspect-index* (make-hash-table))
+
+(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)
+           (etypecase 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
+(defvar *system-index* (make-hash-table))
+(defvar *systems* (make-hash-table))
+
+
+(defun rebuild-system-index (arglist)
+  (loop
+    :for (argument-name . 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))))
+
diff -r b4fab641f442 -r 8597527d94a5 test-run.lisp
--- a/test-run.lisp	Wed Aug 17 16:00:24 2016 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,3 +0,0 @@
-(ql:quickload 'beast)
-(time (asdf:test-system 'beast))
-(quit)
diff -r b4fab641f442 -r 8597527d94a5 test.lisp
--- a/test.lisp	Wed Aug 17 16:00:24 2016 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,120 +0,0 @@
-(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)))))))
diff -r b4fab641f442 -r 8597527d94a5 test/header.sh
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/header.sh	Thu Sep 08 13:27:02 2016 +0000
@@ -0,0 +1,14 @@
+#!/usr/bin/env bash
+
+set -e
+
+which figlet >/dev/null && FIG="figlet -kf $1" || FIG="echo"
+which lolcat >/dev/null && LOL="lolcat --freq=0.25" || LOL="cat"
+
+shift
+
+echo
+
+$FIG "$@" | sed -Ee 's/ +$$//' | tr -s '\n' | $LOL
+
+echo
diff -r b4fab641f442 -r 8597527d94a5 test/test-run.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/test-run.lisp	Thu Sep 08 13:27:02 2016 +0000
@@ -0,0 +1,3 @@
+(ql:quickload 'beast)
+(time (asdf:test-system 'beast))
+(quit)
diff -r b4fab641f442 -r 8597527d94a5 test/test.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/test.lisp	Thu Sep 08 13:27:02 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 (beast::get-entity (entity-id a))))
+    (is (eq b (beast::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)))))))
diff -r b4fab641f442 -r 8597527d94a5 vendor/make-quickutils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/make-quickutils.lisp	Thu Sep 08 13:27:02 2016 +0000
@@ -0,0 +1,12 @@
+(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")
diff -r b4fab641f442 -r 8597527d94a5 vendor/quickutils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils.lisp	Thu Sep 08 13:27:02 2016 +0000
@@ -0,0 +1,194 @@
+;;;; 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 ;;;;