;;;;; utility/entity.lisp

(in-package #:ostvingkel-sewers)

(declaim (optimize (speed 3)
                   (space 3)
                   (safety 0)))

(defstruct entity
  (components (make-hash-table :test 'eq)
              :type hash-table
              :read-only t))

(let ((component-types (make-hash-table :test 'eq))
      (component-dependencies (make-hash-table :test 'eq)))
  (defun get-component-type (name)
    (declare (type symbol name))
    ([av]if (gethash name component-types)
        it
      (error "Attempt to find type of undefined component ~A"
             name)))
  (defun (setf get-component-type)
      (type name)
    (declare (type symbol name))
    ([av]when (gethash name component-types)
      (unless (equal type it)
        (warn "Redefining type of component ~A"
              name)))
    (setf (gethash name component-types)
          type))
  (defun get-component-dependencies (name)
    (declare (type symbol name))
    (the list
         ([av]if (gethash name component-dependencies)
             it
           (error "Attempt to find dependencies of undefined component ~A"
                  name))))
  (defun (setf get-component-dependencies)
      (dependencies name)
    (declare (type symbol name)
             (type (or cons symbol)
                   dependencies))
    (let ((dependencies (mapcar #'ensure-list
                                dependencies)))
      (declare (type list dependencies))
      ([av]when (gethash name component-dependencies)
        (unless (equal dependencies it)
          (warn "Redefining dependencies of component ~A"
                name)))
      (setf (gethash name component-dependencies)
            dependencies))))

(defmacro define-component-type (name type &body dependencies)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (setf (get-component-type ',name)
           ',type)
     (setf (get-component-dependencies ',name)
           ',dependencies)
     (defgeneric ,name (entity)
       (:method ((entity entity))
         (with-components entity (,name)
           ,name))
       (:method (component)
         (if (typep component ',type)
             (values component t)
             (values nil nil))))
     ',name))

(defmacro define-component-struct (name-and-options (&rest dependencies)
                                   &body slot-descriptions)
  (let ((name (car-or-x name-and-options)))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (defstruct ,name-and-options
         ,@slot-descriptions)
       (setf (get-component-type ',name)
             ',name)
       (setf (get-component-dependencies ',name)
             ',dependencies)
       ,@(loop for slot-description in slot-descriptions
            collect
              (let ((slot (car-or-x slot-description)))
                `(progn
                   (defmethod ,slot ((entity ,name))
                     (values (,(symb name '- slot)
                               entity)
                             t))
                   (defmethod ,slot ((entity entity))
                     (with-components entity (,name)
                       (,slot ,name)))
                   (defmethod ,slot (entity)
                     (declare (ignore entity))
                     (values nil nil))
                   ,(unless (getf (cddr slot-description)
                                  :read-only)
                      `(progn
                         (defmethod (setf ,slot)
                             (value (entity ,name))
                           (setf (,(symb name '- slot)
                                   entity)
                                 value))
                         (defmethod (setf ,slot)
                             (value (entity entity))
                           (with-components entity (,name)
                             (setf (,slot ,name)
                                   value)))
                         (defmethod (setf ,slot)
                             (value entity)
                           (declare (ignore value entity))))))))
       ',name)))

(defmacro define-component-class (name superclasses (&rest dependencies)
                                  (&body slots)
                                  &body options)
  (let ((slots (mapcar #'ensure-list
                       slots)))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (defclass ,name (,@superclasses)
         (,@(mapcar (lambda (slot)
                      (cons (first slot)
                            (plist-rem '(:accessor :reader :writer)
                                       (rest slot))))
                    slots))
         ,@options)
       (setf (get-component-type ',name)
             ',name)
       (setf (get-component-dependencies ',name)
             ',dependencies)
       ,@(loop for slot
            in (remove-if-not (lambda (slot)
                                (let ((slot-options (rest slot)))
                                  (or (getf slot-options :accessor)
                                      (getf slot-options :reader)
                                      (getf slot-options :writer))))
                              slots)
            collect
              (destructuring-bind (slot-name &key accessor reader writer
                                             &allow-other-keys)
                  slot
                `(progn
                   ,([a]when accessor
                      `(progn
                         (defmethod ,it ((entity ,name))
                           (values (slot-value entity ',slot-name)
                                   t))
                         (defmethod ,it ((entity entity))
                           (with-components entity (,name)
                             (,it ,name)))
                         (defmethod (setf ,it)
                             (value (entity ,name))
                           (setf (slot-value entity ',slot-name)
                                 value))
                         (defmethod (setf ,it)
                             (value (entity entity))
                           (with-components entity (,name)
                             (setf (,it ,name)
                                   value)))))
                   ,([a]when reader
                      `(progn
                         (defmethod ,it ((entity ,name))
                           (values (slot-value entity ',slot-name)
                                   t))
                         (defmethod ,it ((entity entity))
                           (with-components entity (,name)
                             (,it ,name)))))
                   ,([a]when writer
                      `(progn
                         (defmethod (setf ,it)
                             (value (entity ,name))
                           (setf (slot-value entity ',slot-name)
                                 value))
                         (defmethod (setf ,it)
                             (value (entity entity))
                           (with-components entity (,name)
                             (setf (,it ,name)
                                   value))))))))
       ',name)))

(defmacro entity (&body components)
  (let ((g!entity (gensym "entity"))
        (g!hash (gensym "hash"))
        (g!init (gensym "init")))
    `(the entity
          (let* ((,g!entity (make-entity))
                 (,g!hash (entity-components ,g!entity)))
            (declare (ignorable ,g!hash)
                     (type entity ,g!entity)
                     (type hash-table ,g!hash))
            ,@(loop for (component init)
                 on components by #'cddr
                 collect
                   `(let ((,g!init ,init))
                      (check-type ,g!init ,(get-component-type component))
                      ,@(loop for dependency
                           in (get-component-dependencies component)
                           collect
                             `(unless
                                  (or ,@(loop for dep in dependency
                                           collect
                                             `(nth-value
                                               1 (gethash ',dep ,g!hash))))
                                (error "Component ~A depends on one of ~
    components ~A being present, but the dependency is not satisfied"
                                       ',component ',dependency)))
                      (setf (gethash ',component ,g!hash)
                            ,g!init)))
            ,g!entity))))

(defmacro add-component (entity component &body init)
  (let ((g!entity (gensym "entity"))
        (g!init (gensym "init")))
    `(the entity
          (let ((,g!entity ,entity)
                (,g!init (progn
                           ,@init)))
            (check-type ,g!init ,(get-component-type component))
            ,@(loop for dependency in (get-component-dependencies component)
                 collect
                   `(assert (or ,@(loop for dep in dependency
                                     collect
                                       `(has-component ,g!entity ,dep)))))
            (setf (gethash ',component (entity-components ,g!entity))
                  ,g!init)
            ,g!entity))))

(defmacro rem-component (entity component)
  (let ((g!entity (gensym "entity")))
    ;; TODO: Check that removing the specified component doesn't violate
    ;; dependencies. Provide a parameter to decide whether to throw an error or
    ;; remove all dependent components. The latter might be very useful for
    ;; killing – just make all components responsible for behavior dependent on
    ;; the component holding information about the status of the actor.
    `(the entity
          (let ((,g!entity ,entity))
            (check-type ,g!entity entity)
            (remhash ',component (entity-components ,g!entity))
            ,g!entity))))

(defmacro has-component? (entity component)
  (let ((g!entity (gensym "entity")))
    `(the boolean
          (let ((,g!entity ,entity))
            (check-type ,g!entity entity)
            (nth-value 1
                       (gethash ',component (entity-components ,g!entity)))))))

(defmacro ensure-component (entity component &body init)
  (let ((g!entity (gensym "entity")))
    `(the entity
          (let ((,g!entity ,entity))
            (check-type ,g!entity entity)
            (unless (has-component? ,g!entity ,component)
              (add-component ,g!entity ,component
                ,@init))
            ,g!entity))))

(defmacro get-component (entity component &optional default)
  (let ((g!entity (gensym "entity")))
    `(let ((,g!entity ,entity))
       (check-type ,g!entity entity)
       (gethash ',component (entity-components ,g!entity)
                ,default))))

(defmacro with-components (entity (&rest components)
                                  &body body)
  (let ((g!entity (gensym "entity")))
    (labels ((_rec (components)
               (if components
                   (let* ((g!found? (gensym "found?"))
                          (curr (first components))
                          (type (second-or-x curr)))
                     `(multiple-value-bind (,(car-or-x curr)
                                            ,g!found?)
                          (get-component ,g!entity ,type)
                        (declare (ignorable ,(car-or-x curr))
                                 (type boolean ,g!found?))
                        (the (values t boolean)
                             (if ,g!found?
                                 ,(_rec (rest components))
                                 (values nil nil)))))
                   `(the (values t boolean)
                         (values (progn
                                   ,@body)
                                 t)))))
      `(the (values t boolean)
            (let ((,g!entity ,entity))
              (check-type ,g!entity entity)
              ,(_rec components))))))

(defmacro define-entity-method (name (&rest args)
                                &body body)
  (let ((declarations (loop for form in body
                         while (and (consp form)
                                    (eq (first form)
                                        'declare))
                         collect form)))
    (labels ((_build-component-form (args)
               ([a]if (first args)
                   (if (and (consp it)
                            (eq (second it)
                                'entity)
                            (cddr it))
                       `(with-components ,(first it)
                            (,@(cddr it))
                          ,(_build-component-form (rest args)))
                       (_build-component-form (rest args)))
                 (if declarations
                     `(locally
                          ,@declarations
                        ,@(loop for form in body
                             unless (and (consp form)
                                         (eq (first form)
                                             'declare))
                             collect form))
                     `(progn
                        ,@body)))))
      `(defmethod ,name (,@(mapcar (lambda (arg)
                                     (if (consp arg)
                                         (take 2 arg)
                                         arg))
                                   args))
         ,@declarations
         ,(_build-component-form args)))))

(defun copy-entity* (entity)
  (check-type entity entity)
  (the entity
       (make-entity :components (copy-hash-table (entity-components entity)))))