# HG changeset patch # User Steve Losh # Date 1470713804 0 # Node ID 5b0b6db792efa86fedb6195b7dee6dc6a4634b50 Initial commit diff -r 000000000000 -r 5b0b6db792ef .hgignore --- /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 diff -r 000000000000 -r 5b0b6db792ef .lispwords diff -r 000000000000 -r 5b0b6db792ef Makefile --- /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)' + diff -r 000000000000 -r 5b0b6db792ef README.markdown --- /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:** +* **Mercurial:** +* **Git:** diff -r 000000000000 -r 5b0b6db792ef beast.asd --- /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 " + + :license "MIT/X11" + :version "0.0.1" + + :depends-on () + + :serial t + :components ((:file "quickutils") + (:file "package") + (:file "beast"))) diff -r 000000000000 -r 5b0b6db792ef beast.lisp --- /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))) diff -r 000000000000 -r 5b0b6db792ef make-quickutils.lisp --- /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") diff -r 000000000000 -r 5b0b6db792ef package.lisp --- /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)) diff -r 000000000000 -r 5b0b6db792ef quickutils.lisp --- /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 ;;;;