265 lines
11 KiB
Common Lisp
265 lines
11 KiB
Common Lisp
#|
|
|
This file is a part of stoe project.
|
|
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)
|
|
(:import-from :stoe/core/modules
|
|
#:defmodule)
|
|
(:export #:entity #:object-id #:make-entity
|
|
#:component #:owner #:activep
|
|
#:defcomponent #:initialize-component-class
|
|
#:components #:all-components #:with-components
|
|
#:add-component #:remove-component
|
|
#:create-entity #:destroy-entity
|
|
#: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-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 ()
|
|
available-ids)
|
|
|
|
(defun register-entity (entity)
|
|
(let ((available-id (pop available-ids)))
|
|
(unless available-id
|
|
(setf available-id (extend-array *entity-array*)))
|
|
(setf (aref *entity-array* available-id) entity)
|
|
(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)))))
|
|
(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))))
|
|
|
|
(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 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 system-precedence-list (system)
|
|
(labels ((rec (node)
|
|
(cons node (mapcar #'rec (prior-nodes node)))))
|
|
(remove-duplicates (flatten (mapcar #'rec (prior-nodes system))))))
|
|
|
|
(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)
|
|
(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)))))
|
|
|
|
(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 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."
|
|
(declare (ignore argv))
|
|
(format t "Initialize Entity System module~%"))
|
|
|
|
(defun finalize ()
|
|
"Finalize the entity system module."
|
|
(format t "Finalize Entity System module~%"))
|
|
|
|
(defun update (delta-time)
|
|
(declare (ignore delta-time))
|
|
(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/core/entity :game)
|