# HG changeset patch # User Steve Losh # Date 1473341222 0 # Node ID 8597527d94a50931a639890db487acf7a1911c83 # Parent b4fab641f442344437bfa35b1cdbfafbb19e5700 Clean up project layout 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 ;;;;