Revamp and simplify entity system
This commit is contained in:
parent
08706de1f4
commit
c1ff827070
2 changed files with 260 additions and 315 deletions
440
core/entity.lisp
440
core/entity.lisp
|
|
@ -1,27 +1,34 @@
|
|||
#|
|
||||
This file is a part of stoe project.
|
||||
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|
||||
Copyright (c) 2017 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|
||||
|#
|
||||
|
||||
(uiop:define-package :stoe/core/entity
|
||||
(:use :cl :alexandria :blackbird
|
||||
:stoe/core/utils
|
||||
:stoe/core/graph
|
||||
:stoe/core/jobs)
|
||||
(:export #:entity #:object-id
|
||||
(:import-from :stoe/core/modules
|
||||
#:defmodule)
|
||||
(:export #:entity #:object-id #:make-entity
|
||||
#:component #:owner #:activep
|
||||
#:components #:component #:all-components
|
||||
#:defcomponent #:with-components
|
||||
#:defcomponent #:initialize-component-class
|
||||
#:components #:all-components #:with-components
|
||||
#:add-component #:remove-component
|
||||
#:create-entity #:destroy-entity
|
||||
#:entity-system #:defesystem
|
||||
#:esystem-initialize #:esystem-finalize
|
||||
#:esystem-update #:run-esystem))
|
||||
#:entity-system #:make-entity-system
|
||||
#:defesystem #:run-esystem))
|
||||
(in-package :stoe/core/entity)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defvar *entity-array* (make-array 10 :adjustable t :fill-pointer 0))
|
||||
(defvar *components-table-table* (make-hash-table))
|
||||
(defvar *system-list* '()))
|
||||
(defvar *system-dependency-graph* (make-graph-node)))
|
||||
|
||||
(defclass entity ()
|
||||
((name :initarg :name :reader name)
|
||||
(object-id :initform 0 :reader object-id))
|
||||
(:documentation "Class for an entity comprised of a unique identifier and a name."))
|
||||
|
||||
(let (available-ids)
|
||||
(defun get-available-ids ()
|
||||
|
|
@ -32,268 +39,227 @@
|
|||
(unless available-id
|
||||
(setf available-id (extend-array *entity-array*)))
|
||||
(setf (aref *entity-array* available-id) entity)
|
||||
(prog1
|
||||
available-id
|
||||
(setf available-ids (delete available-id available-ids)))))
|
||||
(setf available-ids (delete available-id available-ids))
|
||||
available-id))
|
||||
|
||||
(defun unregister-entity (entity)
|
||||
(let ((id (object-id entity)))
|
||||
(push id available-ids)
|
||||
(if (= id (1- (fill-pointer *entity-array*)))
|
||||
(let ((new-fill-pointer (loop for index = (1- id) then (decf index)
|
||||
while (member index available-ids)
|
||||
finally (return (1+ index)))))
|
||||
while (member index available-ids)
|
||||
finally (return (1+ index)))))
|
||||
(shrink-array *entity-array* new-fill-pointer)
|
||||
(setf available-ids (delete-if (lambda (x) (>= x new-fill-pointer)) available-ids)))
|
||||
(setf (aref *entity-array* id) nil))
|
||||
(values))))
|
||||
|
||||
(defclass entity ()
|
||||
((name :initarg :name :reader name)
|
||||
(object-id :initform 0 :reader object-id)
|
||||
(components :initform nil))
|
||||
(:documentation "Class for an entity comprised of a unique identifier."))
|
||||
|
||||
(defmethod initialize-instance :after ((entity entity) &key)
|
||||
(with-slots (object-id) entity
|
||||
(setf object-id (register-entity entity))))
|
||||
|
||||
(defun make-entity (name)
|
||||
(make-instance 'entity :name name))
|
||||
|
||||
(defun entity (id)
|
||||
(aref *entity-array* id))
|
||||
|
||||
(defclass component ()
|
||||
((owner :initarg :owner :reader owner)
|
||||
(activep :initarg :activep :initform t :accessor activep))
|
||||
(:documentation "Base class for a component linked to an entity, its owner."))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defun components-table (classname)
|
||||
(gethash classname *components-table-table*))
|
||||
|
||||
(defun push-components-table (classname)
|
||||
(assert (null (gethash classname *components-table-table*)))
|
||||
(setf (gethash classname *components-table-table*) (make-hash-table)))
|
||||
|
||||
(defun ensure-components-table (classname)
|
||||
(let ((components-table (components-table classname)))
|
||||
(if components-table
|
||||
components-table
|
||||
(push-components-table classname))))
|
||||
|
||||
(ensure-components-table 'component))
|
||||
|
||||
(defun initialize-component-class (name)
|
||||
(closer-mop:finalize-inheritance (find-class name))
|
||||
(ensure-components-table name))
|
||||
|
||||
(defmacro defcomponent (name superclasses slots &rest options)
|
||||
"Define a new component NAME with its SUPERCLASSES and SLOTS like in defclass.
|
||||
class OPTIONS are supported together with the option :NEEDS used to define the dependencies of the component."
|
||||
(unless (every (lambda (superclass) (components-table superclass)) superclasses)
|
||||
(error (format nil "not every superclasses of ~a is a component~%with superclasses = ~a~%" name superclasses)))
|
||||
(unless superclasses
|
||||
(setf superclasses '(component)))
|
||||
`(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defclass ,name ,superclasses
|
||||
,slots
|
||||
,@options)
|
||||
(initialize-component-class ',name)))
|
||||
|
||||
(defun component (entity classname)
|
||||
"Return the first component of entity from classname."
|
||||
(let ((components-table (components-table classname)))
|
||||
(unless (null components-table)
|
||||
(safe-first (gethash (object-id entity) components-table)))))
|
||||
|
||||
(defun components (entity classname)
|
||||
"Return a list of entity's components from classname."
|
||||
(let ((components-table (components-table classname)))
|
||||
(unless (null components-table)
|
||||
(safe-list (gethash (object-id entity) components-table)))))
|
||||
|
||||
(defun all-components (entity)
|
||||
(components entity 'component))
|
||||
|
||||
(defmacro with-components (components entity &body body)
|
||||
(once-only (entity)
|
||||
`(let (,@(loop for comp in components
|
||||
collect (let ((var (safe-first comp))
|
||||
(comp-symb (or (second (safe-list comp))
|
||||
(safe-first comp)))
|
||||
(listp (eq (third (safe-list comp)) :all)))
|
||||
(if listp
|
||||
`(,var (components ,entity ',comp-symb))
|
||||
`(,var (component ,entity ',comp-symb))))))
|
||||
,@body)))
|
||||
|
||||
(defun add-component (entity component)
|
||||
"Add a component to entity."
|
||||
(let ((classlist (mapcar (lambda (class) (class-name class))
|
||||
(closer-mop:class-precedence-list (class-of component))))
|
||||
(id (object-id entity)))
|
||||
(rplacd (member 'component classlist) nil)
|
||||
(mapc (lambda (classname)
|
||||
(let ((components-table (components-table classname)))
|
||||
(when components-table
|
||||
(push component (gethash id components-table)))))
|
||||
classlist))
|
||||
component)
|
||||
|
||||
(defun remove-component (entity component)
|
||||
"Remove a component from entity."
|
||||
(let ((classlist (mapcar (lambda (class) (class-name class))
|
||||
(closer-mop:class-precedence-list (class-of component))))
|
||||
(id (object-id entity)))
|
||||
(rplacd (member 'component classlist) nil)
|
||||
(mapc (lambda (class)
|
||||
(let ((components-table (components-table class)))
|
||||
(when components-table
|
||||
(let ((place (gethash id components-table)))
|
||||
(setf place (delete component place))
|
||||
(unless place
|
||||
(remhash place components-table))))))
|
||||
classlist))
|
||||
(values))
|
||||
|
||||
(defmethod initialize-instance :after ((comp component) &key owner)
|
||||
(add-component owner comp))
|
||||
|
||||
(defmacro create-entity (name &body component-specs)
|
||||
(with-gensyms (entity)
|
||||
`(ret ,entity (make-entity ,name)
|
||||
,@(mapcar (lambda (spec)
|
||||
(let* ((spec-list (safe-list spec))
|
||||
(comp-symb (first spec-list))
|
||||
(comp-options (rest spec-list)))
|
||||
`(make-instance ',comp-symb
|
||||
,@(append `(:owner ,entity) comp-options))))
|
||||
component-specs))))
|
||||
|
||||
(defun destroy-entity (entity)
|
||||
(mapc (lambda (component) (remove-component entity component)) (all-components entity))
|
||||
(unregister-entity entity))
|
||||
|
||||
(defmethod print-object ((entity entity) stream)
|
||||
(print-unreadable-object (entity stream :identity t)
|
||||
(format stream "~a: ~@<~{~:_~a~^ ~}~:>" (name entity) (all-components entity))))
|
||||
|
||||
(defclass component ()
|
||||
((owner :initarg :owner :reader owner)
|
||||
(activep :initarg :activep :initform t :accessor activep)
|
||||
(allow-multiple-p :initform t :reader allow-multiple-p :allocation :class))
|
||||
(:documentation "Base class for a component linked to an entity, its owner."))
|
||||
(defclass entity-system (graph-node)
|
||||
((name :initarg :name :reader name)
|
||||
(components :initarg :components)
|
||||
(body :initarg :body)
|
||||
(promise :initform nil :accessor promise))
|
||||
(:documentation "Class for an entity system."))
|
||||
|
||||
(defun push-component-table (classname)
|
||||
(setf (gethash classname *components-table-table*) (make-hash-table)))
|
||||
(defun system-precedence-list (system)
|
||||
(labels ((rec (node)
|
||||
(cons node (mapcar #'rec (prior-nodes node)))))
|
||||
(remove-duplicates (flatten (mapcar #'rec (prior-nodes system))))))
|
||||
|
||||
(defun components (entity classname &optional (recursivep t))
|
||||
"Return a list of entity's components from classname."
|
||||
(let* ((components-table (gethash classname *components-table-table*))
|
||||
(components (unless (null components-table)
|
||||
(safe-list (gethash (object-id entity) components-table)))))
|
||||
(when recursivep
|
||||
(append components
|
||||
(flatten (remove-if #'null (loop for subclass in (component-subclasses classname)
|
||||
collect (components entity subclass))))))))
|
||||
|
||||
(defun component (entity classname &optional (recursivep t))
|
||||
"Return the first component of entity from classname."
|
||||
(let* ((components-table (gethash classname *components-table-table*))
|
||||
(component (unless (null components-table)
|
||||
(safe-first (gethash (object-id entity) components-table)))))
|
||||
(or component (when recursivep
|
||||
(loop for subclass in (component-subclasses classname)
|
||||
do (setf component (component entity subclass))
|
||||
when component
|
||||
return component)))))
|
||||
|
||||
(defun all-components (entity)
|
||||
"Return a list of all entity's components."
|
||||
(with-slots (components) entity
|
||||
(flatten (loop for comp-name in components
|
||||
collect (components entity comp-name)))))
|
||||
(defun make-entity-system (name before after components body)
|
||||
(ret instance (make-instance 'entity-system :name name :components components :body body)
|
||||
(attach-node instance :prior (or after *system-dependency-graph*) :next before)
|
||||
(when before
|
||||
(let ((precedence-list (system-precedence-list instance)))
|
||||
(mapc (lambda (system)
|
||||
(with-slots (prior-nodes) system
|
||||
(setf prior-nodes (remove-if (lambda (node)
|
||||
(member node precedence-list))
|
||||
prior-nodes))))
|
||||
(safe-list before))))
|
||||
(assert (not (cyclic-graph-p instance)))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defvar *component-subclasses* (make-hash-table)
|
||||
"Contains lists of component subclasses.")
|
||||
(defvar *component-dependencies* (make-hash-table)
|
||||
"Contains lists of component dependencies.")
|
||||
(defun parse-defesystem (args)
|
||||
(setf args (copy-sequence 'list args))
|
||||
(let (before after)
|
||||
(loop for i from 0 below 2
|
||||
do (when (member (first args) '(:before :after))
|
||||
(ecase (first args)
|
||||
(:before (assert (null before)) (setf before (second args)))
|
||||
(:after (assert (null after)) (setf after (second args))))
|
||||
(setf args (cddr args))))
|
||||
(assert (= (length args) 2))
|
||||
(assert (> (length (first args)) 1))
|
||||
(values before after (caar args) (cdar args) (cdr args)))))
|
||||
|
||||
(defun component-subclasses (component)
|
||||
(gethash component *component-subclasses*))
|
||||
|
||||
(defun component-dependencies (component)
|
||||
(gethash component *component-dependencies*))
|
||||
|
||||
(defun register-component-subclass (classname superclass)
|
||||
(let ((subclass-list (component-subclasses superclass)))
|
||||
(unless (member classname subclass-list)
|
||||
(setf (gethash superclass *component-subclasses*)
|
||||
(pushnew classname subclass-list)))))
|
||||
|
||||
(defun register-component-subclasses (classname superclasses)
|
||||
(mapc (lambda (superclass)
|
||||
(when (nth-value 1 (component-subclasses superclass))
|
||||
(register-component-subclass classname superclass)))
|
||||
superclasses)
|
||||
(setf (gethash classname *component-subclasses*) nil))
|
||||
|
||||
(defun register-component-dependency (classname dependency)
|
||||
(let ((dep-list (component-dependencies classname)))
|
||||
(unless (member dependency dep-list)
|
||||
(setf (gethash classname *component-dependencies*)
|
||||
(push dependency dep-list)))))
|
||||
|
||||
(defun register-component-dependencies (classname dependencies)
|
||||
(loop for dep in dependencies
|
||||
do (register-component-dependency classname dep))))
|
||||
|
||||
(defmacro defcomponent (name superclasses slots &rest options)
|
||||
"Define a new component NAME with its SUPERCLASSES and SLOTS like in defclass.
|
||||
class OPTIONS are supported together with the option :NEEDS used to define the dependencies of the component."
|
||||
(let ((dependencies (cdr (first (member :needs options :key #'car)))))
|
||||
;; when no superclass derives from component, we need to add it to make the new class a component.
|
||||
(unless (member-if (lambda (elt) (gethash elt *component-subclasses*))
|
||||
superclasses)
|
||||
(setf superclasses (append superclasses '(component))))
|
||||
(prog1
|
||||
`(defclass ,name ,superclasses
|
||||
,slots
|
||||
,@(remove-if (lambda (elt) (eq (car elt) :needs))
|
||||
options))
|
||||
(register-component-subclasses `,name `,superclasses)
|
||||
(register-component-dependencies `,name `,dependencies)
|
||||
(push-component-table `,name))))
|
||||
|
||||
(defmacro with-components (components entity &body body)
|
||||
(once-only (entity)
|
||||
`(let (,@(loop for comp in components
|
||||
collect (let ((var (safe-first comp))
|
||||
(comp-symb (or (second (safe-list comp))
|
||||
(safe-first comp)))
|
||||
(listp (eq (third (safe-list comp)) :all)))
|
||||
(if listp
|
||||
`(,var (components ,entity ',comp-symb))
|
||||
`(,var (component ,entity ',comp-symb))))))
|
||||
,@body)))
|
||||
|
||||
(defun ensure-components-table (component)
|
||||
(let ((comp-symb (class-name (class-of component))))
|
||||
(ret components-table (gethash comp-symb *components-table-table*)
|
||||
(unless components-table
|
||||
(setf components-table (push-component-table comp-symb))))))
|
||||
|
||||
(defun add-component (entity component)
|
||||
"Add a component to entity."
|
||||
(with-slots (components) entity
|
||||
(let ((components-table (ensure-components-table component)))
|
||||
(if (allow-multiple-p component)
|
||||
(progn
|
||||
(unless (gethash (object-id entity) components-table)
|
||||
(push (class-name (class-of component)) components))
|
||||
(push component (gethash (object-id entity) components-table)))
|
||||
(if (gethash (object-id entity) components-table)
|
||||
(error "A component of the same type already exists for this entity.")
|
||||
(progn
|
||||
(push (class-name (class-of component)) components)
|
||||
(setf (gethash (object-id entity) components-table) component))))
|
||||
component)))
|
||||
|
||||
(defun remove-component (entity component)
|
||||
"Remove a component from entity."
|
||||
(with-slots (components) entity
|
||||
(let* ((components-table (ensure-components-table component))
|
||||
(place (gethash (object-id entity) components-table)))
|
||||
(if (allow-multiple-p component)
|
||||
(progn
|
||||
(setf place (delete component place))
|
||||
(unless place
|
||||
(delete (class-name (class-of component)) components)))
|
||||
(progn
|
||||
(remhash place components-table)
|
||||
(delete (class-name (class-of component)) components))))))
|
||||
|
||||
(defmethod initialize-instance :after ((comp component) &key owner)
|
||||
(add-component owner comp))
|
||||
|
||||
(defun make-entity (name)
|
||||
(make-instance 'entity :name name))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defun resolve-dependencies (component-specs)
|
||||
(let ((all-deps '()))
|
||||
(labels ((process-deps (processing-specs specs)
|
||||
(let* ((comp (first processing-specs))
|
||||
(comp-deps (component-dependencies (safe-first comp))))
|
||||
(when comp
|
||||
(loop for dep in comp-deps
|
||||
do (unless (or (member dep processing-specs :key #'safe-first)
|
||||
(member dep all-deps :key #'safe-first))
|
||||
(process-deps (cons (or (first (member dep specs :key #'safe-first)) dep) processing-specs)
|
||||
(delete dep specs :test (lambda (dep spec) (eql dep (first spec)))))))
|
||||
(push comp all-deps)))
|
||||
(when specs
|
||||
(process-deps (cons (first specs) processing-specs) (rest specs)))))
|
||||
(process-deps (list (first component-specs)) (rest component-specs))
|
||||
(reverse all-deps)))))
|
||||
|
||||
(defmacro create-entity (name &body component-specs)
|
||||
(let ((sorted-specs (resolve-dependencies component-specs)))
|
||||
(with-gensyms (entity)
|
||||
`(ret ,entity (make-entity ,name)
|
||||
,@(loop for spec in sorted-specs
|
||||
collect (let* ((spec-list (safe-list spec))
|
||||
(comp-symb (first spec-list))
|
||||
(comp-options (rest spec-list)))
|
||||
`(make-instance ',comp-symb
|
||||
,@(if comp-options
|
||||
(append `(:owner ,entity)
|
||||
comp-options)
|
||||
`(:owner ,entity)))))))))
|
||||
|
||||
(defun destroy-entity (entity)
|
||||
(loop for comp in (all-components entity)
|
||||
do (remove-component entity comp))
|
||||
(unregister-entity entity))
|
||||
|
||||
(defclass entity-system ()
|
||||
((components :initarg :components)
|
||||
(method-arglists :initarg :arglists))
|
||||
(:documentation "Base class for an entity system."))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defun register-entity-system (classname components arglists)
|
||||
(let ((instance (make-instance classname :components components :arglists arglists)))
|
||||
(push instance *system-list*)
|
||||
instance)))
|
||||
|
||||
(defgeneric esystem-initialize (system &key &allow-other-keys))
|
||||
(defgeneric esystem-finalize (system &key &allow-other-keys))
|
||||
(defgeneric esystem-update (system &key entity component &allow-other-keys))
|
||||
|
||||
(defmacro defesystem (name (&rest components) slots &body body)
|
||||
(flet ((filter-option (option)
|
||||
(member (first option) '(:default-initargs :documentation :metaclass)))
|
||||
(options-to-arglists (options)
|
||||
(flatten (mapcar (lambda (option)
|
||||
(list (first option) (second option)))
|
||||
options))))
|
||||
(let ((esystem-options (remove-if #'filter-option body)))
|
||||
`(progn
|
||||
(defclass ,name (entity-system)
|
||||
,slots
|
||||
,@(remove-if-not #'filter-option body))
|
||||
(register-entity-system ',name ',components ,(options-to-arglists esystem-options))))))
|
||||
(defmacro defesystem (name &body args)
|
||||
(multiple-value-bind (before after entity components body) (parse-defesystem args)
|
||||
(let ((fun `(lambda (,entity ,@(mapcar (lambda (component)
|
||||
(first (safe-list component))) components))
|
||||
,@body)))
|
||||
`(defparameter ,name
|
||||
(make-entity-system ',name ,before ,after
|
||||
',(mapcar (lambda (component)
|
||||
(or (and (listp component) (second component))
|
||||
component)) components) ,fun)))))
|
||||
|
||||
(defun run-esystem (system)
|
||||
(with-slots (components) system
|
||||
(wait (all (flatten
|
||||
(loop for classname in components
|
||||
collect (loop for component being the hash-value of (gethash classname *components-table-table*)
|
||||
collect (async-job (system component)
|
||||
(esystem-update system :entity (owner component) :component component)))))))))
|
||||
(with-slots (components body promise) system
|
||||
(setf promise (all (flatten
|
||||
(loop for object-id being the hash-key of (components-table (first components))
|
||||
collect (let* ((entity (entity object-id))
|
||||
(entity-components (mapcar (lambda (classname)
|
||||
(components entity classname))
|
||||
components)))
|
||||
(unless (some #'null entity-components)
|
||||
(async-job (system entity entity-components)
|
||||
(apply body system entity entity-components))))))))))
|
||||
|
||||
(defun initialize (&optional argv)
|
||||
"Initialize the entity system module."
|
||||
(format t "Initialize Entity System module~%")
|
||||
(loop for system in *system-list*
|
||||
do (esystem-initialize system)))
|
||||
(declare (ignore argv))
|
||||
(format t "Initialize Entity System module~%"))
|
||||
|
||||
(defun finalize ()
|
||||
"Finalize the entity system module."
|
||||
(format t "Finalize Entity System module~%")
|
||||
(loop for system in *system-list*
|
||||
do (esystem-finalize system)))
|
||||
(format t "Finalize Entity System module~%"))
|
||||
|
||||
(defun update (delta-time)
|
||||
(declare (ignore delta-time))
|
||||
(wait (all (loop for system in *system-list*
|
||||
collect (async-job (system)
|
||||
(run-esystem system))))))
|
||||
(let ((systems (next-nodes *system-dependency-graph*)))
|
||||
(mapc #'run-esystem systems)
|
||||
(loop while systems
|
||||
do (setf systems (mapc (lambda (system)
|
||||
(wait (all (mapcar #'promise (prior-nodes system)))
|
||||
(run-esystem system)))
|
||||
(delete-duplicates
|
||||
(flatten (mapcar #'next-nodes systems))))))))
|
||||
|
||||
(defmodule stoe/engine/entity :game)
|
||||
(defmodule stoe/core/entity :game)
|
||||
|
|
|
|||
135
test/entity.lisp
135
test/entity.lisp
|
|
@ -6,81 +6,39 @@
|
|||
(uiop:define-package :stoe/test/entity
|
||||
(:use :cl :prove
|
||||
:stoe/core/utils
|
||||
:stoe/core/graph
|
||||
:stoe/core/entity))
|
||||
(in-package :stoe/test/entity)
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
(defparameter old-component-subclasses stoe/core/entity::*component-subclasses*)
|
||||
(defparameter old-component-dependencies stoe/core/entity::*component-dependencies*)
|
||||
(clrhash stoe/core/entity::*component-subclasses*)
|
||||
(stoe/core/entity::register-component-subclasses 'component nil)
|
||||
(clrhash stoe/core/entity::*component-dependencies*))
|
||||
(defparameter *old-entity-array* stoe/core/entity::*entity-array*)
|
||||
(defparameter *old-components-table-table* stoe/core/entity::*components-table-table*)
|
||||
(defparameter *old-system-dependency-graph* stoe/core/entity::*system-dependency-graph*)
|
||||
(setf stoe/core/entity::*entity-array* (make-array 10 :adjustable t :fill-pointer 0))
|
||||
(setf stoe/core/entity::*components-table-table* (make-hash-table))
|
||||
(setf stoe/core/entity::*system-dependency-graph* (make-graph-node))
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
(plan 21)
|
||||
(diag "Define components"))
|
||||
(stoe/core/entity::ensure-components-table 'component)
|
||||
|
||||
(plan 21)
|
||||
(diag "Define components")
|
||||
|
||||
(defcomponent comp-base1 ()
|
||||
())
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
(is (stoe/core/entity::component-subclasses 'component) '(comp-base1)
|
||||
"component subclass defined."))
|
||||
(ok (stoe/core/entity::components-table 'comp-base1)
|
||||
"define component 1")
|
||||
|
||||
(defcomponent comp-base2 (component)
|
||||
())
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
(is (stoe/core/entity::component-subclasses 'component) '(comp-base2 comp-base1)
|
||||
"component subclasses defined."))
|
||||
(ok (stoe/core/entity::components-table 'comp-base2)
|
||||
"define component 2")
|
||||
|
||||
(defcomponent comp-derived1 (comp-base1)
|
||||
(defcomponent comp-derived (comp-base1)
|
||||
())
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
(is (stoe/core/entity::component-subclasses 'component)
|
||||
'(comp-derived1 comp-base2 comp-base1)
|
||||
"component subclasses defined.")
|
||||
|
||||
(is (stoe/core/entity::component-subclasses 'comp-base1) '(comp-derived1)
|
||||
"comp-base1 subclass defined."))
|
||||
|
||||
(defcomponent comp-derived2 (comp-base2)
|
||||
()
|
||||
(:needs comp-derived1))
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
(is (stoe/core/entity::component-subclasses 'component)
|
||||
'(comp-derived2 comp-derived1 comp-base2 comp-base1)
|
||||
"component subclasses defined.")
|
||||
|
||||
(is (stoe/core/entity::component-dependencies 'comp-derived2)
|
||||
'(comp-derived1)
|
||||
"comp-derived2 dependency."))
|
||||
|
||||
(defcomponent comp-derived1 ()
|
||||
()
|
||||
(:needs comp-derived2))
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
(is (stoe/core/entity::component-subclasses 'component)
|
||||
'(comp-derived2 comp-derived1 comp-base2 comp-base1)
|
||||
"component subclasses defined.")
|
||||
|
||||
(is (stoe/core/entity::component-dependencies 'comp-derived2)
|
||||
'(comp-derived1)
|
||||
"comp-derived2 dependency.")
|
||||
|
||||
(is (stoe/core/entity::component-dependencies 'comp-derived1)
|
||||
'(comp-derived2)
|
||||
"comp-derived1 dependency."))
|
||||
|
||||
(defcomponent comp1 ()
|
||||
())
|
||||
(defcomponent comp2 ()
|
||||
())
|
||||
(defcomponent comp3 ()
|
||||
())
|
||||
(ok (stoe/core/entity::components-table 'comp-derived)
|
||||
"define subcomponent")
|
||||
|
||||
(diag "Entity Creation")
|
||||
(defparameter ent1 (create-entity "ent1"))
|
||||
|
|
@ -95,33 +53,54 @@
|
|||
(is (length (components ent2 'comp-base1)) 1 "get-component comp-base1")
|
||||
|
||||
(defparameter ent3 (create-entity "ent3"
|
||||
comp-derived2))
|
||||
comp-derived))
|
||||
|
||||
(is (object-id ent3) 2 "Object ID 2")
|
||||
(is (length (all-components ent3)) 2 "all-components 3")
|
||||
(is (length (components ent3 'comp-derived1)) 1 "get-component comp-derived1")
|
||||
(is (length (components ent3 'comp-derived2)) 1 "get-component comp-derived2")
|
||||
(is (length (all-components ent3)) 1 "all-components 3")
|
||||
(is (length (components ent3 'comp-derived)) 1 "get-component comp-derived")
|
||||
(is (length (components ent3 'comp-base1)) 1 "get-components comp-base1")
|
||||
(is (length (components ent3 'comp-base2)) 1 "get-components comp-base2")
|
||||
(is (length (components ent3 'comp-base1 nil)) 0 "get-components comp-base1 non-recursive")
|
||||
|
||||
(defparameter ent4 (create-entity "ent4"
|
||||
comp1
|
||||
comp2
|
||||
comp3))
|
||||
comp-base1
|
||||
comp-base2
|
||||
comp-derived))
|
||||
|
||||
(is (object-id ent4) 3 "Object ID 3")
|
||||
(is (length (all-components ent4)) 3 "all-components 4")
|
||||
(is (length (components ent4 'comp-base1)) 2 "get-components comp-base1")
|
||||
(is (length (components ent4 'comp-base2)) 1 "get-components comp-base2")
|
||||
(is (length (components ent4 'comp-derived)) 1 "get-component comp-derived")
|
||||
|
||||
;; (defesystem render-mesh (mesh-component)
|
||||
;; ()
|
||||
;; ())
|
||||
(diag "Entity Systems")
|
||||
(defesystem system1 (entity (comp comp-base1))
|
||||
(declare (ignore entity comp)))
|
||||
|
||||
;; (defmethod esystem-update ((system render-mesh) &key component)
|
||||
;; (render component))
|
||||
(is (first (prior-nodes system1)) stoe/core/entity::*system-dependency-graph*
|
||||
"defesystem 1")
|
||||
|
||||
(destroy-entity ent1)
|
||||
(destroy-entity ent2)
|
||||
(destroy-entity ent3)
|
||||
(destroy-entity ent4)
|
||||
(defesystem system2 (entity (comp comp-base1))
|
||||
(declare (ignore entity comp)))
|
||||
|
||||
(is (length (stoe/core/entity::system-precedence-list system2)) 1
|
||||
"defesystem 2")
|
||||
|
||||
(defesystem system3 :after system2 (entity (comp comp-base2))
|
||||
(declare (ignore entity comp)))
|
||||
|
||||
(is (length (prior-nodes system3)) 1
|
||||
"defesystem 3")
|
||||
|
||||
(defesystem system4 :before system3 :after system2 (entity (comp comp-base2))
|
||||
(declare (ignore entity comp)))
|
||||
|
||||
(is (length (stoe/core/entity::system-precedence-list system4)) 2
|
||||
"defesystem 4")
|
||||
|
||||
(is (length (stoe/core/entity::system-precedence-list system3)) 3
|
||||
"system3 precedence-list")
|
||||
|
||||
(finalize)
|
||||
|
||||
(setf stoe/core/entity::*entity-array* *old-entity-array*)
|
||||
(setf stoe/core/entity::*components-table-table* *old-components-table-table*)
|
||||
(setf stoe/core/entity::*system-dependency-graph* *old-system-dependency-graph*)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue