5b0b6db792ef

Initial commit
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Tue, 09 Aug 2016 03:36:44 +0000
parents
children 401943643e21
branches/tags (none)
files .hgignore .lispwords Makefile README.markdown beast.asd beast.lisp make-quickutils.lisp package.lisp quickutils.lisp

Changes

--- /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 ;;;;