wh-engine/wh-engine/actor.lisp

;;;; 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
          :initarg :scene
          :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 (or actor id-ref))
             :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))
   (world-matrix :documentation "Local-to-world-space transformation matrix."
                 :reader world-matrix
                 :type mat3
                 :initform (meye 3)))
  (:documentation "Base class for entities in the game."))

(defmethod make-load-form ((this actor) &optional environment)
  (make-generic-load-form 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 apply-to-tree ((this actor) fun)
  "Apply fun to this actor and all its children recursively."
  (funcall fun this)
  (loop for child in #[this children]
        when (typep child 'actor)
          do #[child (apply-to-tree fun)]))

(defmethod print-object ((this actor) stream)
  (print-unreadable-object (this stream :type t :identity t)
    (format stream "~D ~S"
            #[this :slot id] #[this :slot name])))

(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]))
  (unless (find-if (lambda (x) (etypecase x
                                 (actor (eq x child))
                                 (id-ref (eql (id-ref-actor x) #[child id]))))
                   #[this :slot children])
    (push 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-if (lambda (x) (etypecase x
                                 (actor (eq x child))
                                 (id-ref (eql (id-ref-actor x) #[child id]))))
                   #[this :slot children] :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-changed ((this actor))
  "Called when the actor's parent is changed."
  #[this (recompute-blocked-p)]
  #[this (recompute-matrix)]
  (loop for component in #[this components]
        do #[component (parent-changed)]))

(defmethod deactivate ((this actor) &key origin)
  "Deactivate this object."
  #[this (recompute-blocked-p)]
  (unless origin
    (setf #[this :slot active-p] nil))
  (loop for component in #[this components]
        do #[component (deactivate :origin (or origin this))])
  (loop for child in #[this children]
        do #[child (deactivate :origin (or origin this))]))

(defmethod activate ((this actor) &key origin)
  "Activate this object."
  #[this (recompute-blocked-p)]
  (unless origin
    (setf #[this :slot active-p] t))
  (when #[this tree-active-p]
    (loop for child in #[this children]
          when #[child active-p]
            do #[child (activate :origin (or origin this))])
    (loop for component in #[this components]
          when #[component active-p]
            do #[component (activate :origin (or origin this))])
    ))

(defmethod resume ((this actor))
  "Initialize or restore this actor's state."
  ;; Restore self
  (when (typep #[this :slot scene] 'id-ref)
    ;; relink to scene
    (let ((scene (get-scene (id-ref-scene #[this :slot scene]))))
      (setf #[this :slot scene] nil)
      #[scene (add-actor this)]))
  (when (typep #[this :slot parent] 'id-ref)
    ;; relink to parent
    (let ((parent #[this scene (get-actor (id-ref-actor #[this :slot parent]))]))
      (setf #[this :slot parent] nil)
      #[parent (add-child this)]))
  (loop for entry on #[this :slot children]
        when (typep (car entry) 'id-ref)
          do (rplaca entry (dereferize (car entry))))
  ;; Restore components
  (loop for component in #[this components]
        do #[component (resume)])
  ;; Restore children
  (loop for child in #[this children]
        do #[child (resume)]))

(defmethod suspend ((this actor))
  "Prepare this actor for serialization."
  ;; Suspend children
  (loop for child in #[this children]
        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) 'actor)
          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)])))

(defmethod destroy ((this actor))
  "Mark this object for unloading."
  (unless (o! this destroyed-p)
          ; Cleanup on aisle 5!
          (loop for component in (o! this components)
                when (o! component active-p)
                  do (o! component (destroy)))
          ; Remove from parent
          (when (o! this parent)
                (o! this parent (remove-child this)))
          (loop for child in (o! this children)
                do (typecase child
                     (id-ref (o! (dereferize child) (destroy)))
                     (t (o! child (destroy)))))
          (when (o! this scene)
                (o! this scene (remove-actor this))))
  (setf (o! 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 and local-to-world-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)
      ))
  ;; world matrix
  (setf #[this :slot world-matrix]
        (if #[this parent]
            (m* #[this parent world-matrix] #[this matrix])
            (mcopy3 #[this matrix])))
  ;; make children update world matrix too
  (loop for child in #[this children]
        do #[child (recompute-matrix)]))

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

  (setf (vx2 (o! this :slot location)) (vx2 new-val)
        (vy2 (o! this :slot location)) (vy2 new-val))
  (o! 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 (o! this :slot rotation) new-val)
  (o! 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 (o! this :slot scale)) (vx2 new-val)
        (vy2 (o! this :slot scale)) (vy2 new-val))
  (o! this (recompute-matrix)))

(defmethod world-matrix ((this actor))
  "The local-to-world-space transformation matrix for this actor."
  (if (o! this parent)
      (nm* (o! this parent world-matrix) (o! this matrix))
      (mcopy3 (o! this matrix))))

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

(defmethod world-location ((this actor))
  "The world-space location of this actor."
  (vxy (m* (o! 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* (o! this matrix) (vxy1 point))))

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

  (vxy (m* (o! 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* (o! 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* (o! 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 (o! 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 (o! this location) (v+ (o! this location) vector)))

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

  (setf (o! this rotation) (+ (o! 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 (o! this scale) (v* (o! this scale) factor)))