floss/stoe
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Rework entity system API using macros

Browse source
This commit is contained in:
Renaud Casenave-Péré 2016-01-13 08:18:32 +01:00
parent dfe1b3940c
commit fe1d32b079
4 changed files with 238 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

156
core/entity.lisp
View file

@ -4,13 +4,14 @@
|#
(uiop:define-package :stoe/core/entity
(:use :cl :alexandria
:stoe/core/utils)
(:export #:entity #:object-id
#:component #:owner #:activep #:category
#:get-components #:get-first-component #:get-all-components
#:add-component #:remove-component
#:make-entity #:create-entity #:destroy-entity))
(:use :cl :alexandria
:stoe/core/utils)
(:export #:entity #:object-id
#:component #:owner #:activep
#:components #:component #:all-components
#:defcomponent #:with-components
#:add-component #:remove-component
#:create-entity #:destroy-entity))
(in-package :stoe/core/entity)
(eval-when (:compile-toplevel :load-toplevel :execute)
@ -20,6 +21,7 @@
(let (available-ids)
(defun get-available-ids ()
available-ids)
(defun register-entity (entity)
(let ((available-id (pop available-ids)))
(unless available-id
@ -53,35 +55,102 @@
(defclass component ()
((owner :initarg :owner :reader owner)
(activep :initarg :activep :initform t :accessor activep)
(category :initform :component :reader category :allocation :class)
(allow-multiple-p :initform t :reader allow-multiple-p :allocation :class))
(:documentation "Base class for a component linked to an entity, its owner."))
(defun push-component-table (category)
(setf (gethash category *components-table-table*) (make-hash-table)))
(defun push-component-table (classname)
(setf (gethash classname *components-table-table*) (make-hash-table)))
(defun get-components (entity category)
"Return a list of entity's components from category."
(let ((components-table (gethash category *components-table-table*)))
(defun components (entity classname)
"Return a list of entity's components from classname."
(let ((components-table (gethash classname *components-table-table*)))
(unless (null components-table)
(safe-list (gethash (object-id entity) components-table)))))
(defun get-first-component (entity category)
"Return the first component of entity from category."
(let ((components-table (gethash category *components-table-table*)))
(defun component (entity classname)
"Return the first component of entity from classname."
(let ((components-table (gethash classname *components-table-table*)))
(unless (null components-table)
(safe-first (gethash (object-id entity) components-table)))))
(defun get-all-components (entity)
(defun all-components (entity)
"Return a list of all entity's components."
(flatten (loop for components-table being the hash-value in *components-table-table*
collect (gethash (object-id entity) components-table))))
(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 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*)
(push 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."
(let ((components-table (gethash (category component) *components-table-table*)))
(when (null components-table)
(setf components-table (push-component-table (category component))))
(let ((components-table (ensure-components-table component)))
(if (allow-multiple-p component)
(push component (gethash (object-id entity) components-table))
(if (gethash (object-id entity) components-table)
@ -90,12 +159,11 @@
(defun remove-component (entity component)
"Remove a component from entity."
(let ((components-table (gethash (category component) *components-table-table*)))
(unless (null components-table)
(let ((place (gethash (object-id entity) components-table)))
(if (allow-multiple-p component)
(setf place (delete component place))
(remhash place components-table))))))
(let ((components-table (ensure-components-table component)))
(let ((place (gethash (object-id entity) components-table)))
(if (allow-multiple-p component)
(setf place (delete component place))
(remhash place components-table)))))
(defmethod initialize-instance :after ((comp component) &key owner)
(add-component owner comp))
@ -103,14 +171,38 @@
(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) (member dep all-deps))
(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)
(with-gensyms (entity)
`(ret ,entity (make-entity ,name)
,@(loop for specs in component-specs
collect (let* ((spec (safe-list specs)))
`(make-instance ',(first spec) ,@(append `(:owner ,entity) (rest spec))))))))
(let ((sorted-specs (resolve-dependencies component-specs)))
(with-gensyms (entity)
`(ret ,entity (make-entity ,name)
,@(loop for specs in sorted-specs
collect (let* ((spec (safe-list specs))
(comp-symb (first spec))
(comp-options (rest spec)))
`(make-instance ',comp-symb
,@(if comp-options
(append `(:owner ,entity)
comp-options)
`(:owner ,entity)))))))))
(defun destroy-entity (entity)
(loop for comp in (get-all-components entity)
(loop for comp in (all-components entity)
do (remove-component entity comp))
(unregister-entity entity))

1
stoe.asd
View file

@ -45,6 +45,7 @@
"bordeaux-threads"
"blackbird"
"cl-opengl"
"closer-mop"
"glop"
#+stoe-foreign-assets
"classimp"

3
test/all.lisp
View file

@ -8,4 +8,5 @@
(:use-reexport
:stoe/test/job-utils
:stoe/test/jobs
:stoe/test/resources))
:stoe/test/resources
:stoe/test/entity))

111
test/entity.lisp Normal file
View file

@ -0,0 +1,111 @@
#|
This file is a part of stoe project.
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#
(uiop:define-package :stoe/test/entity
(:use :cl :prove
:stoe/core/utils
:stoe/core/entity))
(in-package :stoe/test/entity)
(clrhash stoe/core/entity::*component-subclasses*)
(clrhash stoe/core/entity::*component-dependencies*)
(plan 18)
(diag "Define a base component.")
(defcomponent comp-base1 ()
())
(is (stoe/core/entity::component-subclasses 'component) '(comp-base1)
"1 component subclass defined.")
(diag "Define another base component.")
(defcomponent comp-base2 (component)
())
(is (stoe/core/entity::component-subclasses 'component) '(comp-base2 comp-base1)
"2 component subclasses defined.")
(diag "Define a derived component.")
(defcomponent comp-derived1 (comp-base1)
())
(is (stoe/core/entity::component-subclasses 'component)
'(comp-derived1 comp-base2 comp-base1)
"3 component subclasses defined.")
(is (stoe/core/entity::component-subclasses 'comp-base1) '(comp-derived1)
"1 comp-base1 subclass defined.")
(diag "Define another derived component with dependency.")
(defcomponent comp-derived2 (comp-base2)
()
(:needs comp-derived1))
(is (stoe/core/entity::component-subclasses 'component)
'(comp-derived2 comp-derived1 comp-base2 comp-base1)
"4 component subclasses defined.")
(is (stoe/core/entity::component-dependencies 'comp-derived2)
'(comp-derived1)
"1 comp-derived2 dependency.")
(diag "Redefine a component")
(defcomponent comp-derived1 ()
()
(:needs comp-derived2))
(is (stoe/core/entity::component-subclasses 'component)
'(comp-derived2 comp-derived1 comp-base2 comp-base1)
"4 component subclasses defined.")
(is (stoe/core/entity::component-dependencies 'comp-derived2)
'(comp-derived1)
"1 comp-derived2 dependency.")
(is (stoe/core/entity::component-dependencies 'comp-derived1)
'(comp-derived2)
"1 comp-derived1 dependency.")
(defcomponent comp1 ()
())
(defcomponent comp2 ()
())
(defcomponent comp3 ()
())
(diag "Entity Creation")
(defparameter ent1 (create-entity "ent1"))
(is (object-id ent1) 0 "Object ID 0")
(defparameter ent2 (create-entity "ent2"
comp-base1))
(is (object-id ent2) 1 "Object ID 1")
(is (length (all-components ent2)) 1 "all-components 1")
(is (length (components ent2 'comp-base1)) 1 "get-component comp-base1")
(defparameter ent3 (create-entity "ent3"
comp-derived2))
(is (object-id ent3) 2 "Object ID 2")
(is (length (all-components ent3)) 2 "all-components 2")
(is (length (components ent3 'comp-derived1)) 1 "get-component comp-derived1")
(is (length (components ent3 'comp-derived2)) 1 "get-component comp-derived2")
(defparameter ent4 (create-entity "ent4"
comp1
comp2
comp3))
(is (length (all-components ent4)) 3 "all-components 3")
(destroy-entity ent1)
(destroy-entity ent2)
(destroy-entity ent3)
(destroy-entity ent4)
(finalize)