beast.lisp @ 73e5c322e496

Special-case arity 1/2 systems for speed
author Steve Losh <>
date Tue, 09 Aug 2016 19:14:27 +0000
parents dfc719d3ed02
children 939570d22350
(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.
;;; 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*))

(defun index-entity-systems (entity)
  (flet ((satisfies-system-type-specifier-p (entity specifier)
           (every (lambda (aspect) (typep entity aspect))
      :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 (satisfies-system-type-specifier-p entity specifier)
                :do (setf (gethash id argument-index) entity)))))

(defun unindex-entity (id)
  (remhash id *entity-index*))

(defun unindex-entity-aspects (id)
    :for index :being :the hash-values :of *aspect-index*
    :do (remhash id index)))

(defun unindex-entity-systems (id)
    :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))

(defgeneric entity-destroyed (entity)
  (:method ((entity entity)) nil))

(defun create-entity (class &rest initargs)
  (let ((entity (apply #'make-instance class initargs)))
    (index-entity entity)
    (index-entity-aspects entity)
    (index-entity-systems entity)
    (entity-created entity)

(defun destroy-entity (entity)
  (let ((id (entity-id entity)))
    (unindex-entity id)
    (unindex-entity-aspects id)
    (unindex-entity-systems id))
  (entity-destroyed entity)

(defmacro define-entity (name aspects &rest slots)
    (defclass ,name (entity ,@aspects)
      ((%beast/aspects :allocation :class :initform ',aspects)
    (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))))
      (defclass ,name ()
           :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*

      (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*)
        (list function (length arglist) (mapcar #'cdr arglist))

        (gethash name *system-index*)
        (loop :repeat (length arglist)
              :collect (make-hash-table))))

(defmacro define-system (name arglist &body body)
  (flet ((system-type-signature (arglist)
           `(function (,@(mapcar (lambda (arg)
                                   `(and entity ,@(cdr arg)))
             (values null &optional))))
      (declaim (ftype ,(system-type-signature arglist) ,name))
      (defun ,name (,@(mapcar #'car arglist))

      (initialize-system-index ',name #',name ',arglist)


(defun run-system-fast-1 (system system-function)
  (let ((argument-indexes (gethash system *system-index*)))
    (loop :for entity :being :the hash-values :of (first argument-indexes)
          :do (funcall system-function entity))))

(defun run-system-fast-2 (system system-function)
  (let ((argument-indexes (gethash system *system-index*)))
      :for e1 :being :the hash-values :of (first argument-indexes)
      :do (loop :for e2 :being :the hash-values :of (second argument-indexes)
                :do (funcall system-function e1 e2)))))

(defun run-system (system)
  (destructuring-bind (system-function arity type-specifiers)
      (gethash system *systems*)
    (declare (ignore type-specifiers))
    (case arity
      ;; Special-case systems of arity 1/2 for speed
      (0 nil)
      (1 (run-system-fast-1 system system-function))
      (2 (run-system-fast-2 system system-function))
      (t (apply #'map-product system-function
                (mapcar #'hash-table-values (gethash system *system-index*)))))