;;;; wh-engine/actor.lisp
(in-package wh-engine)

(defclass actor ()
  ((id :documentation "This actor's unique ID."
       :reader id
       :type fixnum
       :initarg :id
       :initform (make-id))
   (name :documentation "This actor's human-readable name."
         :accessor name
         :type string
         :initarg :name
         :initform "")
   (scene :documentation "The scene containing this actor."
          :reader scene
          :type pointer
          :initform nil)
   (tags :documentation "This actor's tags."
         :reader tags
         :type (proper-list symbol)
         :initarg :tags
         :initform '(:default))
   (active-p :documentation "Whether or not this actor should be processed."
             :reader active-p
             :type boolean
             :initform t)
   (blocked-p :documentation "Whether or not this actor has a deactivated ancestor."
              :type boolean
              :initform nil)
   (parent :documentation "This actor's parent."
           :reader parent
           :type pointer
           :initarg :parent
           :initform nil)
   (children :documentation "The actors this actor is a parent of."
             :reader children
             :type (proper-list pointer)
             :initform nil)
   (components :documentation "The components attached to this actor."
               :reader components
               :type (proper-list component)
               :initform nil)
   (destroyed-p :documentation "If true, this actor will be unloaded."
                :reader destroyed-p
                :type boolean
                :initform nil)
   ;; Transform data
   (location :documentation "The actor's location relative to its parent."
             :reader location
             :type vec2
             :initarg :location
             :initform (vec2 0 0))
   (z-layer :documentation "The actor's Z layer."
            :accessor z-layer
            :type fixnum
            :initarg :z-layer
            :initform 0)
   (rotation :documentation "The actor's rotation relative to its parent."
             :reader rotation
             :type single-float
             :initarg :rotation
             :initform 0.0)
   (scale :documentation "The actor's scale relative to its parent."
          :reader scale
          :type vec2
          :initarg :scale
          :initform (vec2 1 1))
   (matrix :documentation "Local-to-parent-space transformation matrix."
           :reader matrix
           :type mat3
           :initform (meye 3)))
  (:documentation "Base class for entities in the game."))

(defmethod make-load-form ((this actor) &optional environment)
  (make-load-form-saving-slots this :environment environment))

(defmethod scene ((this actor))
  "The scene containing this actor."
  (deref-sus-pointer [this :slot scene]))

(defmethod parent ((this actor))
  "This actor's parent."
  (deref-sus-pointer [this :slot parent]))

(defmethod tree-active-p ((this actor))
  "Whether or not this actor and all its parents are active."
  (and [this active-p] (not [this :slot blocked-p])))

(defmethod print-object ((this actor) stream)
  (print-unreadable-object (this stream :type t :identity t)
    (prin1 [this :slot id] stream)
    (princ " ")
    (prin1 [this :slot name] stream)))

(defmethod get-component ((this actor) component-class)
  "Get a component of the specified class attached to this object."
  (find-if (lambda (component) (typep component component-class))
           [this components]))

(defmethod add-component ((this actor) component)
  "Add a component to this object."
  (let ((component-class (class-of component)))
    (when [this (get-component component-class)]
          (error "~S already has a component of class ~S" this component-class))
    (push component [this :slot components])
    [component (attach this)])
  component)

(defmethod add-child ((this actor) child)
  "Add a child to this object."
  (when [child parent]
        (error "~S is already a child of ~S" child [child parent]))
  (push (make-weak-pointer child) [this :slot children])
  (setf [child :slot parent] (make-weak-pointer this))
  [child (parent-changed)]
  child)

(defmethod remove-child ((this actor) child)
  "Remove a child from this object."
  (unless (eq [child parent] this)
    (error "~S is not a child of ~S" child this))
  (setf [this :slot children] (delete child [this :slot children] :key #'deref-sus-pointer :count 1))
  (setf [child :slot parent] nil)
  [child (parent-changed)]
  child)

(defmethod recompute-blocked-p ((this actor))
  "Determine if any ancestors of this actor are deactivated."
  (setf [this :slot blocked-p]
        (when [this parent] (or (not [this parent active-p]) [this parent :slot blocked-p]))))

(defmethod has-tag ((this actor) tag)
  "Check if this object has the specified tag."
  (find tag [this tags]))

(defmethod add-tag ((this actor) tag)
  "Add a tag to this object."
  (pushnew tag [this :slot tags]))

(defmethod remove-tag ((this actor) tag)
  "Remove a tag from this object."
  (setf [this :slot tags] (remove tag [this :slot tags])))

(defmethod parent-deactivated ((this actor) parent)
  "Called when the actor's parent is deactivated."
  [this (recompute-blocked-p)]
  (loop for component in [this components]
        do [component (parent-deactivated parent)])
  (loop for child-ptr in [this children]
        for child = (weak-pointer-value child-ptr)
        do [child (parent-deactivated parent)]))

(defmethod parent-activated ((this actor) parent)
  "Called when the actor's parent is activated."
  [this (recompute-blocked-p)]
  (when [this tree-active-p]
        (loop for child-ptr in [this children]
              for child = (weak-pointer-value child-ptr)
              do [child (parent-activated parent)])
        (loop for component in [this components]
              do [component (parent-activated parent)])))

(defmethod parent-changed ((this actor))
  "Called when the actor's parent is changed."
  [this (recompute-blocked-p)]
  (loop for component in [this components]
        do [component (parent-changed)]))

(defmethod deactivate ((this actor))
  "Deactivate this object."
  (setf [this :slot active-p] nil)
  (loop for component in [this components]
        do [component (parent-deactivated this)])
  (loop for child-ptr in [this children]
        for child = (weak-pointer-value child-ptr)
        do [child (parent-deactivated this)]))

(defmethod activate ((this actor))
  "Activate this object."
  (setf [this :slot active-p] t)
  (loop for child-ptr in [this children]
        for child = (weak-pointer-value child-ptr)
        do [child (parent-activated this)])
  (loop for component in [this components]
        do [component (parent-activated this)]))

(defmethod resume ((this actor))
  "Initialize or restore this actor's state."
  ; Restore self
  (pointerize-setf [this :slot scene])
  (pointerize-setf [this :slot parent])
  (loop for entry on [this :slot children]
        when (typep (car entry) 'id-ref)
          do (rplaca entry (pointerize (car entry))))
  ; Restore components
  (loop for component in [this components]
        do [component (resume)])
  ; Restore children
  (loop for child-ptr in [this children]
        for child = (weak-pointer-value child-ptr)
        do [child (resume)]))

(defmethod suspend ((this actor))
  "Prepare this actor for serialization."
  ; Suspend children
  (loop for child-ptr in [this children]
        for child = (weak-pointer-value child-ptr)
        do [child (suspend)])
  ; Suspend components
  (loop for component in [this components]
        do [component (suspend)])
  ; Suspend self
  (loop for child-cell on [this :slot children]
        when (typep (car child-cell) 'weak-pointer)
          do (rplaca child-cell (referize (car child-cell))))
  (referize-setf [this :slot scene])
  (referize-setf [this :slot parent]))

(defmethod update ((this actor))
  "Update this actor's components."
  (loop for component in [this components]
        do (when [component active-p]
                 (unless [component started-p] [component (start)])
                 [component (update)]))
;  (loop for child in [this children]
;        do (when [child active-p]
;                 [child (.update)]))
  )

(defmethod destroy ((this actor))
  "Mark this object for unloading."
  (unless [this destroyed-p]
          ; Cleanup on aisle 5!
          (loop for component in [this components]
                when [component active-p]
                  do [component (destroy)])
          ; Remove from parent
          (when [this parent]
                [this parent (remove-child this)])
          (loop for child-ptr in [this children]
                for child = (deref-sus-pointer child-ptr)
                do [child (destroy)])
          (when [this scene]
                [this scene (remove-actor this)]))
  (setf [this :slot destroyed-p] t))

;; Transform

(defmethod initialize-instance :after ((this actor) &key)
  [this (recompute-matrix)])

(defmethod recompute-matrix ((this actor))
  "Recompute the local-to-parent-space matrix."
  (let ((rs (sin [this rotation]))
        (rc (cos [this rotation]))
        (sx (vx2 [this scale]))
        (sy (vy2 [this scale]))
        (tx (vx2 [this location]))
        (ty (vy2 [this location])))
    (with-fast-matref (m [this :slot matrix] 3)
      (setf (m 0 0) (* sx rc)
            (m 0 1) (* sy (- rs))
            (m 0 2) tx
            (m 1 0) (* sx rs)
            (m 1 1) (* sy rc)
            (m 1 2) ty)
      )))

(defmethod (setf location) (new-val (this actor))
  "The actor's location relative to its parent."
  (declare (type vec2 new-val))

  (setf (vx2 [this :slot location]) (vx2 new-val)
        (vy2 [this :slot location]) (vy2 new-val))
  [this (recompute-matrix)])

(defmethod (setf rotation) (new-val (this actor))
  "The actor's rotation relative to its parent."
  (declare (type single-float new-val))

  (setf [this :slot rotation] new-val)
  [this (recompute-matrix)])

(defmethod (setf scale) (new-val (this actor))
  "The actor's scale relative to its parent."
  (declare (type vec2 new-val))

  (setf (vx2 [this :slot scale]) (vx2 new-val)
        (vy2 [this :slot scale]) (vy2 new-val))
  [this (recompute-matrix)])

(defmethod world-matrix ((this actor))
  "The local-to-world-space transformation matrix for this actor."
  (if [this parent]
      (m* [this matrix] [this parent world-matrix])
      [this matrix]))

(defmethod local-matrix ((this actor))
  "The world-to-local-space transformation matrix for this actor."
  (minv [this world-matrix]))

(defmethod world-location ((this actor))
  "The world-space location of this actor."
  (vxy (m* [this world-matrix] (vec3 0 0 1))))

(defmethod transform-point ((this actor) point)
  "Transform point from local space to parent space."
  (declare (type vec2 point))

  (vxy (m* [this matrix] (vxy1 point))))

(defmethod world-point ((this actor) point)
  "Transform point from local space to world space."
  (declare (type vec2 point))

  (vxy (m* [this world-matrix] (vxy1 point))))

(defmethod local-point ((this actor) point)
  "Transform point from world space to local space."
  (declare (type vec2 point))

  (vxy (m* [this local-matrix] (vxy1 point))))

(defmethod transform-svector ((this actor) vector)
  "Transform vector from local space to parent space."
  (declare (type vec2 vector))

  (vxy (m* [this matrix] (vxy_ vector))))

(defmethod transform-vector ((this actor) vector)
  "Transform vector from local space to parent space, without changing its length."
  (declare (type vec2 vector))

  (nvscale [this (transform-svector vector)] (vlength vector)))

(defmethod translate-by ((this actor) vector)
  "Translate this actor by the given vector in parent space."
  (declare (type vec2 vector))

  (setf [this location] (v+ [this location] vector)))

(defmethod rotate-by ((this actor) angle)
  "Rotate this actor by the given angle."
  (declare (type single-float angle))

  (setf [this rotation] (+ [this rotation] angle)))

(defmethod scale-by ((this actor) factor)
  "Scale this actor by the given factor (either a scalar or a vector)."
  (declare (type (or single-float vec2) factor))

  (setf [this scale] (v* [this scale] factor)))