--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore Tue Aug 09 03:36:44 2016 +0000
@@ -0,0 +1,1 @@
+scratch.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile Tue Aug 09 03:36:44 2016 +0000
@@ -0,0 +1,5 @@
+.PHONY:
+
+quickutils.lisp: make-quickutils.lisp
+ sbcl --noinform --load make-quickutils.lisp --eval '(quit)'
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown Tue Aug 09 03:36:44 2016 +0000
@@ -0,0 +1,17 @@
+# Basic Entity/Aspect/System Toolkit
+
+ @@@@@@@ @@@@@@@@ @@@@@@ @@@@@@ @@@@@@@
+ @@@@@@@@ @@@@@@@@ @@@@@@@@ @@@@@@@ @@@@@@@
+ @@! @@@ @@! @@! @@@ !@@ @@!
+ !@ @!@ !@! !@! @!@ !@! !@!
+ @!@!@!@ @!!!:! @!@!@!@! !!@@!! @!!
+ !!!@!!!! !!!!!: !!!@!!!! !!@!!! !!!
+ !!: !!! !!: !!: !!! !:! !!:
+ :!: !:! :!: :!: !:! !:! :!:
+ :: :::: :: :::: :: ::: :::: :: ::
+ :: : :: : :: :: : : : :: : : :
+
+* **License:** MIT/X11
+* **Documentation:** <http://sjl.bitbucket.org/beast/>
+* **Mercurial:** <http://bitbucket.org/sjl/beast/>
+* **Git:** <http://github.com/sjl/beast/>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/beast.asd Tue Aug 09 03:36:44 2016 +0000
@@ -0,0 +1,15 @@
+(asdf:defsystem #:beast
+ :name "beast"
+ :description "Basic Entity/Aspect/System Toolkit"
+
+ :author "Steve Losh <steve@stevelosh.com>"
+
+ :license "MIT/X11"
+ :version "0.0.1"
+
+ :depends-on ()
+
+ :serial t
+ :components ((:file "quickutils")
+ (:file "package")
+ (:file "beast")))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/beast.lisp Tue Aug 09 03:36:44 2016 +0000
@@ -0,0 +1,183 @@
+(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 -> (cons system-function type-specifier-list)}
+;;;
+;;; TODO: Figure out the distinct problem.
+;;; TODO: Unfuck redefining of systems.
+
+
+;;;; Entities
+(defvar *entity-id-counter* 0)
+(defvar *entity-index* (make-hash-table))
+
+
+(defclass entity ()
+ ((id :reader entity-id :initform (incf *entity-id-counter*))
+ (%beast/aspects :allocation :class :initform nil)))
+
+(defmethod print-object ((e entity) stream)
+ (print-unreadable-object (e stream :type t :identity nil)
+ (format stream "~D" (entity-id e))))
+
+
+(defun get-entity (id)
+ (gethash id *entity-index*))
+
+(defun map-entities (function &optional (type 'entity))
+ (mapcar function
+ (remove-if-not (lambda (entity) (typep entity type))
+ (hash-table-values *entity-index*))))
+
+(defun clear-entities ()
+ (mapc #'destroy-entity (hash-table-values *entity-index*)))
+
+
+(defun index-entity (entity)
+ (setf (gethash (entity-id entity) *entity-index*) entity))
+
+(defun index-entity-aspects (entity)
+ (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)
+ (flet ((satisfies-system-type-specifier-p (entity specifier)
+ (every (lambda (aspect) (typep entity aspect))
+ specifier)))
+ (loop
+ :with id = (entity-id entity)
+ :for system :being :the hash-keys :of *systems*
+ :using (hash-value (function . type-specifiers))
+ :do (loop :for argument-index :in (gethash system *system-index*)
+ :for specifier :in type-specifiers
+ :when (satisfies-system-type-specifier-p entity specifier)
+ :do (setf (gethash id argument-index) entity)))))
+
+
+(defmethod initialize-instance :after ((e entity) &key)
+ (index-entity e)
+ (index-entity-aspects e)
+ (index-entity-systems e))
+
+
+(defgeneric entity-created (entity)
+ (:method ((entity entity)) entity))
+
+(defgeneric entity-destroyed (entity)
+ (:method ((entity entity)) entity))
+
+
+(defun create-entity (class &rest initargs)
+ (entity-created (apply #'make-instance class initargs)))
+
+(defun destroy-entity (entity)
+ (let ((id (entity-id entity)))
+ (remhash id *entity-index*)
+ (loop
+ :for index :being :the hash-values :of *aspect-index*
+ :do (remhash id index))
+ (loop
+ :for argument-indexes :being :the hash-values :of *system-index*
+ :do (loop :for index :in argument-indexes
+ :do (remhash id index))))
+ (entity-destroyed entity))
+
+
+(defmacro define-entity (name aspects &rest slots)
+ `(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)
+ (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 initialize-system-index (name function arglist)
+ (setf (gethash name *systems*)
+ (cons function (mapcar #'cdr arglist))
+
+ (gethash name *system-index*)
+ (loop :repeat (length arglist)
+ :collect (make-hash-table))))
+
+
+(defun system-type-signature (arglist)
+ `(function (,@(mapcar (lambda (arg)
+ `(and entity ,@(cdr arg)))
+ arglist))
+ (values null &optional)))
+
+(defmacro define-system (name arglist &body body)
+ `(progn
+ (declaim (ftype ,(system-type-signature arglist) ,name))
+ (defun ,name (,@(mapcar #'car arglist))
+ ,@body
+ nil)
+
+ (initialize-system-index ',name #',name ',arglist)
+
+ ',name))
+
+
+(defun run-system (system)
+ (destructuring-bind (system-function . type-specifiers)
+ (gethash system *systems*)
+ (declare (ignore type-specifiers))
+ ;; TODO: make this iteration less awful
+ (apply #'map-product system-function
+ (mapcar #'hash-table-values (gethash system *system-index*)))
+ (values)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/make-quickutils.lisp Tue Aug 09 03:36:44 2016 +0000
@@ -0,0 +1,10 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+ "quickutils.lisp"
+ :utilities '(:map-product
+ :hash-table-key-exists-p
+ :hash-table-values
+ :symb
+ :ensure-keyword)
+ :package "BEAST.QUICKUTILS")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp Tue Aug 09 03:36:44 2016 +0000
@@ -0,0 +1,21 @@
+(defpackage #:beast
+ (:use
+ #:cl
+ #:beast.quickutils)
+ (:export
+ #:entity
+ #:entity-id
+
+ #:get-entity
+ #:map-entities
+ #:clear-entities
+
+ #:entity-created
+ #:entity-destroyed
+
+ #:define-entity
+
+ #:define-aspect
+
+ #:define-system
+ #:run-system))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/quickutils.lisp Tue Aug 09 03:36:44 2016 +0000
@@ -0,0 +1,141 @@
+;;;; 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 :SYMB :ENSURE-KEYWORD) :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
+ :MKSTR :SYMB :ENSURE-KEYWORD))))
+(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))
+
+
+ (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)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(map-product hash-table-key-exists-p hash-table-values symb
+ ensure-keyword)))
+
+;;;; END OF quickutils.lisp ;;;;