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