systems.lisp 13.7 KB
Newer Older
Andrew Kravchuk's avatar
Andrew Kravchuk committed
1 2 3 4 5
(in-package :d2clone-kit)

(defclass system ()
  ((name
    :type symbol
Andrew Kravchuk's avatar
Andrew Kravchuk committed
6 7
    :reader name
    :documentation "Symbol that denotes system.")
Andrew Kravchuk's avatar
Andrew Kravchuk committed
8
   components
9 10 11
   (order
    :type fixnum
    :initform 0
Andrew Kravchuk's avatar
Andrew Kravchuk committed
12 13
    :reader order
    :documentation "Fixnum representing system's update order."))
14
  (:documentation "Base class for all ECS systems."))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
15 16 17 18 19

;; TODO : defsystem macro with global parameter = system instance?

(defgeneric system-unload (system))

20 21
(defgeneric system-update (system dt)
  (:documentation "Updates system SYSTEM for time step DT (usually fixed by liballegro around 1/60 of second)."))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
22

23 24
(defgeneric system-draw (system renderer)
  (:documentation "Renders system SYSTEM using functional renderer RENDERER.
Andrew Kravchuk's avatar
Andrew Kravchuk committed
25

26 27
See RENDER"))

Andrew Kravchuk's avatar
Andrew Kravchuk committed
28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44
(defmethod system-update ((system system) dt)
  (declare (ignore system) (ignore dt)))

(defmethod system-draw ((system system) renderer)
  (declare (ignore system) (ignore renderer)))

(defvar *systems* (make-hash-table :test #'eq))

(defmethod initialize-instance :after ((system system) &key)
  (with-slots (name components) system
    (if-let (existing-sys (gethash name *systems*))
      (progn
        (log-warn "System ~a was already registered" name)
        (setf components (slot-value existing-sys 'components)))
      (setf components nil))
    (setf (gethash name *systems*) system)))

Andrew Kravchuk's avatar
Andrew Kravchuk committed
45 46 47 48 49 50
(declaim (type (integer 0 #.array-dimension-limit) *entities-count*))
(defvar *entities-count* 0)

(declaim (type (integer 0 #.array-dimension-limit) *entities-allocated*))
(defvar *entities-allocated* 144)

51 52 53
(declaim (type (vector fixnum) *deleted-entities*))
(defvar *deleted-entities* (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t))

Andrew Kravchuk's avatar
Andrew Kravchuk committed
54 55 56
(defun unregister-all-systems ()
  (setf *entities-count* 0
        *entities-allocated* 144)
57 58
  (clrhash *systems*)
  (setf (fill-pointer *deleted-entities*) 0))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
59 60 61

(declaim (inline system-ref))
(defun system-ref (name)
62
  "Returns system instance by its name symbol NAME."
Andrew Kravchuk's avatar
Andrew Kravchuk committed
63
  (values (gethash name *systems*)))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
64

65 66
(defmacro with-systems (var &body body)
  "Executes BODY in loop for each system, binding system instance to variable VAR."
67 68 69 70
  (with-gensyms (systems)
    `(let ((,systems (sort (hash-table-values *systems*)
                           (lambda (s1 s2) (< (order s1) (order s2))))))
       (dolist (,var ,systems) ,@body))))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
71

72 73 74 75 76 77
(defgeneric make-component (system entity &rest parameters)
  (:documentation "Creates new component using PARAMETERS within system SYSTEM for entity ENTITY.

PARAMETERS could include `:PREFAB` key, in which case component is constructed using corresponding prefab.

See MAKE-PREFAB-COMPONENT"))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
78 79 80

(defgeneric system-adjust-components (system new-size))

Andrew Kravchuk's avatar
Andrew Kravchuk committed
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
(defmethod system-adjust-components ((system system) new-size)
  ;; default implementation for componentless systems
  )

(defgeneric delete-component (system entity)
  (:documentation "Deletes SYSTEM's component from ENTITY."))

(defmethod delete-component ((system system) entity)
  (declare (ignore system entity))
  ;; default implementation for componentless systems
  )

;; TODO : automatically delete entities with no components?..

(defgeneric has-component-p (system entity)
  (:documentation "Returns T when ENTITY has the SYSTEM's component in it."))

(defmethod has-component-p ((system system) entity)
  (declare (ignore system entity))
  ;; default implementation for componentless systems
  )
102

Andrew Kravchuk's avatar
Andrew Kravchuk committed
103
(defunl make-entity ()
104
  "Allocates new entity."
105 106 107 108 109 110 111 112 113 114 115 116
  (if (emptyp *deleted-entities*)
      (let ((res *entities-count*))
        (incf *entities-count*)
        (when (= *entities-count* *entities-allocated*)
          (setf *entities-allocated* (round (* *entities-allocated* +array-growth-factor+)))
          (log-debug "Adjusting component allocated size to ~a" *entities-allocated*)
          (with-systems system
            (system-adjust-components system *entities-allocated*)))
        res)
      (vector-pop *deleted-entities*)))

(defun delete-entity (entity)
117
  "Deletes entity ENTITY."
Andrew Kravchuk's avatar
Andrew Kravchuk committed
118
  (loop :for system :being :the :hash-values :of *systems*
Andrew Kravchuk's avatar
Andrew Kravchuk committed
119
        :when (has-component-p system entity)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
120
        :do (delete-component system entity))
121
  (vector-push-extend entity *deleted-entities*))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
122

123 124 125 126 127
(defun make-entity-initializer (spec)
  "Creates FUNCALL'able entity initializer following specification SPEC structured as follows:

```
'((:system-name1 :component-parameter1 \"value1\" :component-parameter2 2.0)
128
  (:system-name2 :prefab :prefab-name)
129 130 131 132 133 134
  ;; ...
  )
```
Corresponding systems are created by initializer function on-demand."
  (let ((component-clauses
          (loop :for component :in spec
Andrew Kravchuk's avatar
Andrew Kravchuk committed
135
                :for system := (ensure-symbol (car component) :d2clone-kit)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
136
                :for parameters := (cdr component)
137 138
                :collect `(let ((system (system-ref ',system)))
                            (unless system
139 140 141 142 143 144 145 146 147 148
                               (setf system (make-instance
                                             ',(format-symbol :d2clone-kit "~a-SYSTEM" system))))
                            (make-component system entity ,@parameters)))))
    (compile
     nil
     `(lambda ()
        (let ((entity (make-entity)))
          ,@component-clauses
          entity)))))

Andrew Kravchuk's avatar
Andrew Kravchuk committed
149
(defmacro defcomponent (system name &rest slots)
150
  "Defines component structure with name NAME and slots SLOTS within system SYSTEM."
Andrew Kravchuk's avatar
Andrew Kravchuk committed
151 152
  ;; TODO : rewrite components storage using sparse array index based on growable vector to
  ;;  remove unnecessary NIL checks and increase cache friendliness
Andrew Kravchuk's avatar
Andrew Kravchuk committed
153
  (let* ((system-name (symbolicate system '-system))
154
         (plural-name (string-upcase (plural-of name)))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
155 156 157 158 159 160 161 162 163 164 165 166 167
         (slot-names (mapcar #'car slots))
         (slot-defaults (mapcar #'cadr slots))
         (slot-types (mapcar #'(lambda (s) (getf s :type 't)) slots))
         (slot-ro (mapcar #'(lambda (s) (getf s :read-only nil)) slots))
         (soa-slots (mapcar #'(lambda (name default type ro)
                                `(,name (make-array *entities-allocated*
                                                    :element-type '(or ,type null)
                                                    :initial-element ,default)
                                        :type (simple-array (or ,type null))
                                        :read-only ,ro))
                            slot-names slot-defaults slot-types slot-ro))
         (slot-accessors (mapcar #'(lambda (s) `(,(symbolicate name '- s '-aref))) slot-names))
         (array-accessors (mapcar #'(lambda (s) `(,(symbolicate name '- s))) slot-names))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
168
         (adjust-assignments (mapcar #'(lambda (a d)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
169
                                         (let ((acc `(,@a components)))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
170 171 172 173
                                           `(setf ,acc
                                                  (adjust-array ,acc new-size
                                                                :initial-element ,d))))
                                     array-accessors slot-defaults))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
         (getter-decls (mapcan
                        #'(lambda (s a type)
                            `((declaim
                               (inline ,@s)
                               (ftype (function (,name (integer 0 ,array-dimension-limit)) ,type)
                                      ,@s))
                              (defun ,@s (objects index) (aref (,@a objects) index))))
                        slot-accessors array-accessors slot-types))
         (setter-decls (mapcan
                        #'(lambda (ro s a type)
                            (unless ro
                              `((declaim
                                 (inline (setf ,@s))
                                 (ftype (function
                                         (,type ,name (integer 0 ,array-dimension-limit)) ,type)
                                        (setf ,@s)))
                                (defun (setf ,@s) (new-value objects index)
                                  (setf (aref (,@a objects) index) new-value)))))
192
                        slot-ro slot-accessors array-accessors slot-types))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
193
         (delete-exprs (mapcan #'(lambda (a) (copy-list `((aref (,@a components) entity) nil)))
194
                               array-accessors)))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
195 196 197 198 199 200 201 202 203 204
    `(progn
       (defstruct ,name ,@soa-slots)
       (defmacro ,(symbolicate 'with- name) (entity bindings &rest body)
         (with-gensyms (components)
           (let ((component-exps (mapcar #'list
                                         (if bindings bindings ',slot-names)
                                         (mapcar #'(lambda (a) `(,@a ,components ,entity))
                                                 ',slot-accessors))))
             `(let ((,components (slot-value (gethash ',',system *systems*) 'components)))
                (symbol-macrolet (,@component-exps) ,@body)))))
205
       (defmacro ,(symbolicate 'with- plural-name) (&rest body)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
206 207 208
         (with-gensyms (components)
           (let ((slot-names ',slot-names)
                 (loop-clauses (mapcan #'(lambda (s a)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
209
                                           `(:for ,s :across ,`(,@a ,components)))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
210 211 212 213 214
                                       ',slot-names ',array-accessors))
                 (component-exps (mapcar #'(lambda (s type a)
                                             `(,s (the ,type (elt ,`(,@a ,components) entity))))
                                         ',slot-names ',slot-types ',array-accessors)))
             `(let ((,components (slot-value (gethash ',',system *systems*) 'components)))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
215
                (loop :for entity :from 0 :below *entities-count*
Andrew Kravchuk's avatar
Andrew Kravchuk committed
216
                      ,@loop-clauses
Andrew Kravchuk's avatar
Andrew Kravchuk committed
217 218
                      :when (and ,@slot-names)
                        :do (symbol-macrolet (,@component-exps) ,@body))))))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
219 220 221
       (defmethod initialize-instance :after ((system ,system-name) &key)
         (with-slots (components) system
           (unless components
Andrew Kravchuk's avatar
Andrew Kravchuk committed
222 223
             (setf components (,(symbolicate 'make- name)))))
         (preload-prefabs system))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
224 225 226 227
       (defmethod system-adjust-components ((system ,system-name) new-size)
         (declare (type (integer 0 ,array-dimension-limit) new-size))
         (with-slots (components) system
           ,@adjust-assignments))
228 229 230
       (defmethod delete-component ((system ,system-name) entity)
         (with-slots (components) system
           (setf ,@delete-exprs)))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
231
       (defmethod has-component-p ((system ,system-name) entity)
232
         (with-slots (components) system
Andrew Kravchuk's avatar
Andrew Kravchuk committed
233 234 235 236 237 238 239
           (and ,@(mapcar
                   #'(lambda (a) `(aref (,@a components) entity))
                   array-accessors))))
       (defmethod make-component :before ((system ,system-name) entity &rest parameters)
         (declare (ignore parameters))
         (when (has-component-p system entity)
           (delete-component system entity)))
240
       (defmethod make-prefab-component :before ((system ,system-name) entity prefab parameters)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
241 242 243
         (declare (ignore parameters))
         (when (has-component-p system entity)
           (delete-component system entity)))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
244 245
       ,@getter-decls ,@setter-decls)))

246 247
(defgeneric prefab (system prefab-name)
  (:documentation "Returns prefab with name symbol PREFAB-NAME within system SYSTEM."))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
248

249 250
(defgeneric (setf prefab) (new-prefab system prefab-name)
  (:documentation "Sets prefab NEW-PREFAB with name symbol PREFAB-NAME within system SYSTEM."))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
251

252 253 254 255
(defgeneric prefab-path (system prefab-name)
  (:documentation "Returns prefab file path for system SYSTEM and prefab name symbol PREFAB-NAME."))
(defgeneric make-prefab (system prefab-name)
  (:documentation "Loads prefab with name symbol PREFAB-NAME within system SYSTEM."))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
256

Andrew Kravchuk's avatar
Andrew Kravchuk committed
257 258 259 260 261
(defgeneric preload-prefabs (system)
  (:documentation "Loads all prefabs for SYSTEM to avoid in-game performance degradations."))

(defmethod preload-prefabs ((system system)))

Andrew Kravchuk's avatar
Andrew Kravchuk committed
262 263 264
(defmethod make-prefab :around (system prefab-name)
  (setf (prefab system prefab-name) (call-next-method)))

265 266 267
(defgeneric make-prefab-component (system entity prefab parameters)
  (:documentation "Creates new component using prefab instance PREFAB as a template and optional
extra parameters PARAMETERS within system SYSTEM for entity ENTITY."))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
268 269

(defmethod make-component :around (system entity &rest parameters)
270
  (destructuring-bind (&rest rest-parameters &key (prefab nil) &allow-other-keys) parameters
Andrew Kravchuk's avatar
Andrew Kravchuk committed
271 272 273 274
    (if prefab
        (make-prefab-component system entity
                               (if-let (prefab-instance (prefab system prefab))
                                 prefab-instance
275
                                 (make-prefab system prefab))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
276
                               rest-parameters)
277 278
        (call-next-method))
    (issue component-created :entity entity :system-name (name system))))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
279 280

(defmacro defprefab (system extension &rest slots)
281
  "Defines prefab structure with slots SLOTS and file name extension EXTENSION within system SYSTEM."
Andrew Kravchuk's avatar
Andrew Kravchuk committed
282 283 284
  (let ((storage-name (symbolicate '* system '- 'prefabs '*))
        (system-name (symbolicate system '- 'system))
        (struct-name (symbolicate system '- 'prefab))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
285
        (path-format (format nil "~(~as/~~(~~a~~).~a~)" system extension))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
286 287 288 289
        (ro-slots (mapcar #'(lambda (s) (append s '(:read-only t))) slots)))
    `(progn
       (defparameter ,storage-name (make-hash-table :test 'eq))
       (defmethod prefab ((system ,system-name) prefab-name)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
290
         (values (gethash prefab-name ,storage-name)))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
291 292
       (defmethod (setf prefab) (new-prefab (system ,system-name) prefab-name)
         (setf (gethash prefab-name ,storage-name) new-prefab))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
293 294 295 296 297 298
       (defmethod prefab-path ((system ,system-name) prefab-name)
         (format nil ,path-format prefab-name))
       (defmethod preload-prefabs ((system ,system-name))
         (enumerate-directory ,(format nil "~(~as~)" system)
           (when (string= ,extension (pathname-type file))
             (make-prefab system (make-keyword (string-upcase (pathname-name file)))))))
299 300
       (defhandler ,system-name quit (event)
         :after '(:end)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
301 302 303
         (clrhash ,storage-name))
       (defstruct ,struct-name
         ,@ro-slots))))