--- 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
--- 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)))
--- 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))))
-
--- 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")
--- 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 ;;;;
--- /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))))
+
--- 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)
--- 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)))))))
--- /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
--- /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)
--- /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)))))))
--- /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")
--- /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 ;;;;