Roll (parent-activated) into (activate) (for #9), and update objective-lisp syntax
This commit is contained in:
parent
0f8fe16fc3
commit
738da6f74b
8 changed files with 289 additions and 249 deletions
|
@ -78,202 +78,191 @@
|
|||
|
||||
(defmethod scene ((this actor))
|
||||
"The scene containing this actor."
|
||||
(deref-sus-pointer [this :slot scene]))
|
||||
(deref-sus-pointer (o! this :slot scene)))
|
||||
|
||||
(defmethod parent ((this actor))
|
||||
"This actor's parent."
|
||||
(deref-sus-pointer [this :slot parent]))
|
||||
(deref-sus-pointer (o! 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])))
|
||||
(and (o! this active-p) (not (o! this :slot blocked-p))))
|
||||
|
||||
(defmethod apply-to-tree ((this actor) fun)
|
||||
(funcall fun this)
|
||||
(loop for child-ptr in [this children]
|
||||
(loop for child-ptr in (o! this children)
|
||||
when (typep child-ptr 'weak-pointer)
|
||||
do [(weak-pointer-value child-ptr) (apply-to-tree fun)]))
|
||||
do (o! (weak-pointer-value child-ptr) (apply-to-tree fun))))
|
||||
|
||||
(defmethod print-object ((this actor) stream)
|
||||
(print-unreadable-object (this stream :type t :identity t)
|
||||
(prin1 [this :slot id] stream)
|
||||
(prin1 (o! this :slot id) stream)
|
||||
(princ " ")
|
||||
(prin1 [this :slot name] stream)))
|
||||
(prin1 (o! 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]))
|
||||
(o! 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)]
|
||||
(when (o! 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)])
|
||||
(push component (o! this :slot components))
|
||||
(o! 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)]
|
||||
(when (o! child parent)
|
||||
(error "~S is already a child of ~S" child (o! child parent)))
|
||||
(push (make-weak-pointer child) (o! this :slot children))
|
||||
(setf (o! child :slot parent) (make-weak-pointer this))
|
||||
(o! child (parent-changed))
|
||||
child)
|
||||
|
||||
(defmethod remove-child ((this actor) child)
|
||||
"Remove a child from this object."
|
||||
(unless (eq [child parent] this)
|
||||
(unless (eq (o! 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)]
|
||||
(setf (o! this :slot children) (delete child (o! this :slot children) :key #'deref-sus-pointer :count 1))
|
||||
(setf (o! child :slot parent) nil)
|
||||
(o! 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]))))
|
||||
(setf (o! this :slot blocked-p)
|
||||
(when (o! this parent) (or (not (o! this parent active-p)) (o! this parent :slot blocked-p)))))
|
||||
|
||||
(defmethod has-tag ((this actor) tag)
|
||||
"Check if this object has the specified tag."
|
||||
(find tag [this tags]))
|
||||
(find tag (o! this tags)))
|
||||
|
||||
(defmethod add-tag ((this actor) tag)
|
||||
"Add a tag to this object."
|
||||
(pushnew tag [this :slot tags]))
|
||||
(pushnew tag (o! 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)])))
|
||||
(setf (o! this :slot tags) (remove tag (o! this :slot tags))))
|
||||
|
||||
(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)]))
|
||||
(o! this (recompute-blocked-p))
|
||||
(loop for component in (o! this components)
|
||||
do (o! component (parent-changed))))
|
||||
|
||||
(defmethod deactivate ((this actor))
|
||||
(defmethod deactivate ((this actor) &key origin)
|
||||
"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]
|
||||
(o! this (recompute-blocked-p))
|
||||
(unless origin
|
||||
(setf (o! this :slot active-p) nil))
|
||||
(loop for component in (o! this components)
|
||||
do (o! component (deactivate :origin (or origin this))))
|
||||
(loop for child-ptr in (o! this children)
|
||||
for child = (weak-pointer-value child-ptr)
|
||||
do [child (parent-deactivated this)]))
|
||||
do (o! child (deactivate :origin (or origin this)))))
|
||||
|
||||
(defmethod activate ((this actor))
|
||||
(defmethod activate ((this actor) &key origin)
|
||||
"Activate this object."
|
||||
(setf [this :slot active-p] t)
|
||||
(loop for child-ptr in [this children]
|
||||
(o! this (recompute-blocked-p))
|
||||
(unless origin
|
||||
(setf (o! this :slot active-p) t))
|
||||
(when (o! this tree-active-p)
|
||||
(loop for child-ptr in (o! 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)]))
|
||||
when (o! child active-p)
|
||||
do (o! child (activate :origin (or origin this))))
|
||||
(loop for component in (o! this components)
|
||||
when (o! component active-p)
|
||||
do (o! 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)
|
||||
(when (typep (o! 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)
|
||||
(let ((scene (get-scene (id-ref-scene (o! this :slot scene)))))
|
||||
(setf (o! this :slot scene) nil)
|
||||
(o! scene (add-actor this))))
|
||||
(when (typep (o! 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]
|
||||
(let ((parent (o! this scene (get-actor (id-ref-actor (o! this :slot parent))))))
|
||||
(setf (o! this :slot parent) nil)
|
||||
(o! parent (add-child this))))
|
||||
(loop for entry on (o! 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)])
|
||||
(loop for component in (o! this components)
|
||||
do (o! component (resume)))
|
||||
;; Restore children
|
||||
(loop for child-ptr in [this children]
|
||||
(loop for child-ptr in (o! this children)
|
||||
for child = (weak-pointer-value child-ptr)
|
||||
do [child (resume)]))
|
||||
do (o! child (resume))))
|
||||
|
||||
(defmethod suspend ((this actor))
|
||||
"Prepare this actor for serialization."
|
||||
;; Suspend children
|
||||
(loop for child-ptr in [this children]
|
||||
(loop for child-ptr in (o! this children)
|
||||
for child = (weak-pointer-value child-ptr)
|
||||
do [child (suspend)])
|
||||
do (o! child (suspend)))
|
||||
;; Suspend components
|
||||
(loop for component in [this components]
|
||||
do [component (suspend)])
|
||||
(loop for component in (o! this components)
|
||||
do (o! component (suspend)))
|
||||
;; Suspend self
|
||||
(loop for child-cell on [this :slot children]
|
||||
(loop for child-cell on (o! 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]))
|
||||
(referize-setf (o! this :slot scene))
|
||||
(referize-setf (o! 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)]))
|
||||
(loop for component in (o! this components)
|
||||
do (when (o! component active-p)
|
||||
(unless (o! component started-p) (o! component (start)))
|
||||
(o! component (update))))
|
||||
; (loop for child in (o! this children)
|
||||
; do (when (o! child active-p)
|
||||
; (o! child (update))))
|
||||
)
|
||||
|
||||
(defmethod destroy ((this actor))
|
||||
"Mark this object for unloading."
|
||||
(unless [this destroyed-p]
|
||||
(unless (o! this destroyed-p)
|
||||
; Cleanup on aisle 5!
|
||||
(loop for component in [this components]
|
||||
when [component active-p]
|
||||
do [component (destroy)])
|
||||
(loop for component in (o! this components)
|
||||
when (o! component active-p)
|
||||
do (o! component (destroy)))
|
||||
; Remove from parent
|
||||
(when [this parent]
|
||||
[this parent (remove-child this)])
|
||||
(loop for child-ptr in [this children]
|
||||
(when (o! this parent)
|
||||
(o! this parent (remove-child this)))
|
||||
(loop for child-ptr in (o! 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))
|
||||
do (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)])
|
||||
(o! 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)
|
||||
(let ((rs (sin (o! this rotation)))
|
||||
(rc (cos (o! this rotation)))
|
||||
(sx (vx2 (o! this scale)))
|
||||
(sy (vy2 (o! this scale)))
|
||||
(tx (vx2 (o! this location)))
|
||||
(ty (vy2 (o! this location))))
|
||||
(with-fast-matref (m (o! this :slot matrix) 3)
|
||||
(setf (m 0 0) (* sx rc)
|
||||
(m 0 1) (* sy (- rs))
|
||||
(m 0 2) tx
|
||||
|
@ -286,83 +275,83 @@
|
|||
"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)])
|
||||
(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 [this :slot rotation] new-val)
|
||||
[this (recompute-matrix)])
|
||||
(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 [this :slot scale]) (vx2 new-val)
|
||||
(vy2 [this :slot scale]) (vy2 new-val))
|
||||
[this (recompute-matrix)])
|
||||
(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 [this parent]
|
||||
(m* [this parent world-matrix] [this matrix])
|
||||
[this matrix]))
|
||||
(if (o! this parent)
|
||||
(m* (o! this parent world-matrix) (o! this matrix))
|
||||
(o! this matrix)))
|
||||
|
||||
(defmethod local-matrix ((this actor))
|
||||
"The world-to-local-space transformation matrix for this actor."
|
||||
(minv [this world-matrix]))
|
||||
(minv (o! this world-matrix)))
|
||||
|
||||
(defmethod world-location ((this actor))
|
||||
"The world-space location of this actor."
|
||||
(vxy (m* [this world-matrix] (vec3 0 0 1))))
|
||||
(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* [this matrix] (vxy1 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* [this world-matrix] (vxy1 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* [this local-matrix] (vxy1 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* [this matrix] (vxy_ 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 [this (transform-svector vector)] (vlength 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 [this location] (v+ [this location] 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 [this rotation] (+ [this rotation] 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 [this scale] (v* [this scale] factor)))
|
||||
(setf (o! this scale) (v* (o! this scale) factor)))
|
||||
|
|
|
@ -22,40 +22,34 @@
|
|||
|
||||
(defmethod actor ((this component))
|
||||
"The actor this component belongs to."
|
||||
(deref-sus-pointer [this :slot actor]))
|
||||
(deref-sus-pointer (o! this :slot actor)))
|
||||
|
||||
(defmethod scene ((this component))
|
||||
"The scene this component belongs to."
|
||||
[this actor scene])
|
||||
(o! this actor scene))
|
||||
|
||||
(defmethod destroyed-p ((this component))
|
||||
"If true, this component will be unloaded."
|
||||
[this actor destroyed-p])
|
||||
(o! this actor destroyed-p))
|
||||
|
||||
(defmethod attach ((this component) actor)
|
||||
"Attach this component to an actor."
|
||||
(setf [this :slot actor] (make-weak-pointer (ensure-live actor)))
|
||||
[this (parent-changed)])
|
||||
|
||||
(defmethod parent-deactivated ((this component) parent)
|
||||
"Called when the component's actor is deactivated."
|
||||
nil)
|
||||
|
||||
(defmethod parent-activated ((this component) parent)
|
||||
"Called when the component's actor is activated."
|
||||
nil)
|
||||
(setf (o! this :slot actor) (make-weak-pointer (ensure-live actor)))
|
||||
(o! this (parent-changed)))
|
||||
|
||||
(defmethod parent-changed ((this component))
|
||||
"Called when the component's actor's parent is changed."
|
||||
nil)
|
||||
|
||||
(defmethod deactivate ((this component))
|
||||
(defmethod deactivate ((this component) &key origin)
|
||||
"Deactivate this component."
|
||||
(setf [this :slot active-p] nil))
|
||||
(unless origin
|
||||
(setf (o! this :slot active-p) nil)))
|
||||
|
||||
(defmethod activate ((this component))
|
||||
(defmethod activate ((this component) &key origin)
|
||||
"Activate this component."
|
||||
(setf [this :slot active-p] t))
|
||||
(unless origin
|
||||
(setf (o! this :slot active-p) t)))
|
||||
|
||||
(defmethod resume ((this component))
|
||||
"Initialize or restore this component's state."
|
||||
|
@ -80,7 +74,7 @@
|
|||
|
||||
(defmethod start ((this component))
|
||||
"Called before (update) the first time this component is processed."
|
||||
(setf [this :slot started-p] t))
|
||||
(setf (o! this :slot started-p) t))
|
||||
|
||||
(defmethod update ((this component))
|
||||
"Called every game tick while this component and its actor are active."
|
||||
|
|
|
@ -36,7 +36,7 @@
|
|||
|
||||
(defun ensure-live (obj)
|
||||
"Ensure obj is live (non-destroyed)."
|
||||
(when [obj destroyed-p]
|
||||
(when (o! obj destroyed-p)
|
||||
(error "~S was used after it was destroyed" obj))
|
||||
obj)
|
||||
|
||||
|
@ -96,20 +96,20 @@
|
|||
|
||||
(defun get-scene (scene-id)
|
||||
"Get a scene by its ID."
|
||||
(find-if (lambda (scene) (eq [scene id] scene-id)) *world-scenes*))
|
||||
(find-if (lambda (scene) (eq (o! scene id) scene-id)) *world-scenes*))
|
||||
|
||||
(defun attach-actor-to-world (actor scene)
|
||||
"Properly attach actor and its descendents to scene, and initialize them."
|
||||
;; attach actors to scene
|
||||
(apply-to-tree actor (lambda (a)
|
||||
(setf [a :slot scene] nil)
|
||||
[scene (add-actor a)]))
|
||||
(setf (o! a :slot scene) nil)
|
||||
(o! scene (add-actor a))))
|
||||
;; (resume) -> automatically resumes children
|
||||
[actor (resume)]
|
||||
(o! actor (resume))
|
||||
;; FIXME make (activate) call itself recursively on children
|
||||
(apply-to-tree actor (lambda (a)
|
||||
(when [a tree-active-p]
|
||||
[a (activate)])))
|
||||
(when (o! a tree-active-p)
|
||||
(o! a (activate)))))
|
||||
)
|
||||
|
||||
(defvar *view-width* 384
|
||||
|
@ -136,51 +136,48 @@
|
|||
|
||||
(setf test-actor (make-instance 'actor
|
||||
:name "Actor"))
|
||||
;; [test-scene (add-actor test-actor)]
|
||||
;; (o! test-scene (add-actor test-actor))
|
||||
|
||||
(setf test-drawable (make-instance 'drawable-test))
|
||||
[test-actor (add-component test-drawable)]
|
||||
(o! test-actor (add-component test-drawable))
|
||||
|
||||
(setf test-actor-2 (make-instance 'actor
|
||||
:name "Actor 2"
|
||||
:location (vec2 0.5 0.5)
|
||||
:rotation (coerce (/ pi 4) 'single-float)
|
||||
:z-layer -1))
|
||||
;; [test-scene (add-actor test-actor-2)]
|
||||
;; (o! test-scene (add-actor test-actor-2))
|
||||
|
||||
[test-actor-2 (add-component (make-instance 'drawable-test
|
||||
:colour (vec4 0.0 1.0 0.0 1.0)))
|
||||
]
|
||||
(o! test-actor-2 (add-component (make-instance 'drawable-test
|
||||
:colour (vec4 0.0 1.0 0.0 1.0))))
|
||||
|
||||
(setf child-actor (make-instance 'actor
|
||||
:name "Child Actor"
|
||||
:location (vec2 0 0.5)
|
||||
:z-layer -2))
|
||||
;; [test-scene (add-actor child-actor)]
|
||||
[test-actor-2 (add-child child-actor)]
|
||||
;; (o! test-scene (add-actor child-actor))
|
||||
(o! test-actor-2 (add-child child-actor))
|
||||
|
||||
[child-actor (add-component (make-instance 'drawable-test
|
||||
:colour (vec4 0.0 1.0 1.0 1.0)))
|
||||
]
|
||||
(o! child-actor (add-component (make-instance 'drawable-test
|
||||
:colour (vec4 0.0 1.0 1.0 1.0))))
|
||||
|
||||
(setf grandchild-actor (make-instance 'actor
|
||||
:name "Grandchild Actor"
|
||||
:location (vec2 0 1)
|
||||
:scale (vec2 0.25 0.25)
|
||||
:z-layer 1))
|
||||
;; [test-scene (add-actor grandchild-actor)]
|
||||
[child-actor (add-child grandchild-actor)]
|
||||
;; (o! test-scene (add-actor grandchild-actor))
|
||||
(o! child-actor (add-child grandchild-actor))
|
||||
|
||||
[grandchild-actor (add-component (make-instance 'drawable-test
|
||||
:colour (vec4 1.0 1.0 0.0 0.0)))
|
||||
]
|
||||
(o! grandchild-actor (add-component (make-instance 'drawable-test
|
||||
:colour (vec4 1.0 1.0 0.0 0.0))))
|
||||
|
||||
(setf camera-actor (make-instance 'actor
|
||||
:name "Camera"))
|
||||
;; [test-scene (add-actor camera-actor)]
|
||||
;; (o! test-scene (add-actor camera-actor))
|
||||
|
||||
(setf camera-view (make-instance 'view))
|
||||
[camera-actor (add-component camera-view)]
|
||||
(o! camera-actor (add-component camera-view))
|
||||
|
||||
(attach-actor-to-world test-actor test-scene)
|
||||
(attach-actor-to-world test-actor-2 test-scene)
|
||||
|
@ -202,9 +199,9 @@
|
|||
+version+))
|
||||
(sdl2:with-gl-context (gl-context win)
|
||||
(sdl2:gl-make-current win gl-context)
|
||||
(let ((framebuf (car (gl:gen-framebuffers 1)))
|
||||
(renderbuf (car (gl:gen-renderbuffers 1)))
|
||||
(render-texture (car (gl:gen-textures 1)))
|
||||
(let ((framebuf (gl:gen-framebuffer))
|
||||
(renderbuf (gl:gen-renderbuffer))
|
||||
(render-texture (gl:gen-texture))
|
||||
(win-width (nth-value 0 (sdl2:get-window-size win)))
|
||||
(win-height (nth-value 1 (sdl2:get-window-size win))))
|
||||
;; set up framebuffer
|
||||
|
@ -231,6 +228,8 @@
|
|||
(unless (gl::enum= result :framebuffer-complete)
|
||||
(error "Failed to create framebuffer: ~S" result)))
|
||||
|
||||
(format t "texture-resident-p: ~S~%" (gl:texture-resident-p render-texture))
|
||||
|
||||
;; set up gl
|
||||
(gl:matrix-mode :projection)
|
||||
(gl:ortho 0 *view-width*
|
||||
|
@ -247,7 +246,7 @@
|
|||
(:idle ()
|
||||
;; update
|
||||
(loop for scene in *world-scenes*
|
||||
do [scene (update)])
|
||||
do (o! scene (update)))
|
||||
;; draw to render texture
|
||||
(gl:bind-framebuffer :framebuffer framebuf)
|
||||
(gl:viewport 0 0 *view-width* *view-height*)
|
||||
|
@ -256,12 +255,12 @@
|
|||
(let ((render-pass nil))
|
||||
(loop for view-ptr in *world-views*
|
||||
for view = (ensure-live (weak-pointer-value view-ptr))
|
||||
when (and [view active-p] [view actor tree-active-p])
|
||||
when (and (o! view active-p) (o! view actor tree-active-p))
|
||||
do (progn
|
||||
(unless (eq [view render-pass] render-pass)
|
||||
(setf render-pass [view render-pass])
|
||||
(unless (eq (o! view render-pass) render-pass)
|
||||
(setf render-pass (o! view render-pass))
|
||||
(gl:clear :depth-buffer))
|
||||
[view (render-view *world-drawables*)])))
|
||||
(o! view (render-view *world-drawables*)))))
|
||||
|
||||
;; now draw to window
|
||||
(gl:bind-framebuffer :framebuffer 0)
|
||||
|
|
|
@ -6,6 +6,7 @@
|
|||
(:use common-lisp 3d-vectors 3d-matrices)
|
||||
(:import-from sb-ext
|
||||
weak-pointer weak-pointer-p make-weak-pointer weak-pointer-value)
|
||||
(:import-from objective-lisp O!)
|
||||
(:export
|
||||
;; main.lisp
|
||||
+version+ ensure-version
|
||||
|
@ -14,6 +15,7 @@
|
|||
make-id fixed-id
|
||||
*running-scenes*
|
||||
add-scene remove-scene get-scene update-all-scenes
|
||||
attach-actor-to-world
|
||||
*view-width* *view-height* *view-ppu* *pixel-scale*
|
||||
register-test-scene
|
||||
run
|
||||
|
@ -42,7 +44,7 @@
|
|||
get-component add-component
|
||||
add-child remove-child
|
||||
has-tag add-tag remove-tag
|
||||
parent-deactivated parent-activated parent-changed
|
||||
parent-changed
|
||||
deactivate activate
|
||||
resume suspend
|
||||
update
|
||||
|
@ -59,7 +61,7 @@
|
|||
scene destroyed-p
|
||||
; methods
|
||||
attach
|
||||
parent-deactivated parent-activated parent-changed
|
||||
parent-changed
|
||||
deactivate activate
|
||||
resume suspend
|
||||
start update
|
||||
|
|
|
@ -33,7 +33,7 @@
|
|||
(cons (vec2 -0.5 -0.5) (vec2 0.5 0.5)))
|
||||
|
||||
(defmethod draw ((this drawable-test) view)
|
||||
(gl:color (vx4 [this colour]) (vy4 [this colour]) (vz4 [this colour]) (vw4 [this colour]))
|
||||
(gl:color (vx4 (o! this colour)) (vy4 (o! this colour)) (vz4 (o! this colour)) (vw4 (o! this colour)))
|
||||
(gl:with-primitives :quads
|
||||
(gl:vertex -0.5 -0.5 0.0 1.0)
|
||||
(gl:vertex 0.5 -0.5 0.0 1.0)
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
(defun sort-world-views ()
|
||||
"Re-sort the *world-views* list by render pass."
|
||||
(sort *world-views* #'< :key (lambda (v) [(deref-pointer v) render-pass])))
|
||||
(sort *world-views* #'< :key (lambda (v) (o! (deref-pointer v) render-pass))))
|
||||
|
||||
(defclass view (component)
|
||||
((render-pass :documentation "The render pass this view should be drawn in."
|
||||
|
@ -20,23 +20,79 @@
|
|||
:accessor cull-p
|
||||
:type boolean
|
||||
:initarg :cull-p
|
||||
:initform t))
|
||||
:initform t)
|
||||
(framebuffer :documentation "The GL framebuffer this view renders to."
|
||||
:reader framebuffer
|
||||
:type (or fixnum null)
|
||||
:initform nil)
|
||||
(renderbuffer :documentation "The GL renderbuffer this view renders depth & stencil data to."
|
||||
:reader renderbuffer
|
||||
:type (or fixnum null)
|
||||
:initform nil)
|
||||
(render-texture :documentation "The GL render texture this view renders color data to."
|
||||
:reader render-texture
|
||||
:type (or fixnum null)
|
||||
:initform nil))
|
||||
(:documentation "Defines a view into the scene, and rendering settings for objects drawn by the view."))
|
||||
|
||||
(defmethod (setf render-pass) (new-val (this view))
|
||||
"The render pass this view should be drawn in."
|
||||
(setf [this :slot render-pass] new-val)
|
||||
(setf (o! this :slot render-pass) new-val)
|
||||
(sort-world-views))
|
||||
|
||||
(defmethod start :after ((this view))
|
||||
(defmethod resume :after ((this view))
|
||||
;; create render texture & framebuffer
|
||||
(unless (and (o! this render-texture) (gl:texture-resident-p (o! this render-texture))
|
||||
(o! this renderbuffer) (gl:is-renderbuffer (o! this renderbuffer))
|
||||
(o! this framebuffer) (gl:is-framebuffer (o! this framebuffer)))
|
||||
;; ensure the old ones are deleted if they exist
|
||||
(when (o! this framebuffer)
|
||||
(gl:delete-framebuffers (list (o! this framebuffer))))
|
||||
(when (o! this render-texture)
|
||||
(gl:delete-texture (o! this render-texture)))
|
||||
(when (o! this renderbuffer)
|
||||
(gl:delete-renderbuffers (list (o! this renderbuffer))))
|
||||
;; create render texture
|
||||
(setf (o! this :slot render-texture) (gl:gen-texture))
|
||||
(gl:bind-texture :texture-2d (o! this render-texture))
|
||||
(gl:tex-image-2d :texture-2d 0 :rgba
|
||||
*view-width* *view-height*
|
||||
0 :rgba :unsigned-byte (cffi:null-pointer))
|
||||
(gl:tex-parameter :texture-2d :texture-wrap-s :clamp-to-edge)
|
||||
(gl:tex-parameter :texture-2d :texture-wrap-t :clamp-to-edge)
|
||||
(gl:tex-parameter :texture-2d :texture-min-filter :linear)
|
||||
(gl:tex-parameter :texture-2d :texture-mag-filter :linear)
|
||||
(gl:bind-texture :texture-2d 0)
|
||||
;; create renderbuffer
|
||||
(setf (o! this :slot renderbuffer) (gl:gen-renderbuffer))
|
||||
(gl:bind-renderbuffer :renderbuffer (o! this renderbuffer))
|
||||
(gl:renderbuffer-storage :renderbuffer :depth24-stencil8 *view-width* *view-height*)
|
||||
(gl:bind-renderbuffer 0)
|
||||
;; create framebuffer
|
||||
(setf (o! this :slot framebuffer) (gl:gen-framebuffer))
|
||||
(gl:bind-framebuffer :framebuffer (o! this framebuffer))
|
||||
(gl:framebuffer-texture-2d :framebuffer :color-attachment0 :texture-2d (o! this render-texture) 0)
|
||||
(gl:framebuffer-renderbuffer :framebuffer :depth-stencil-attachment :renderbuffer (o! this renderbuffer))
|
||||
(gl:bind-framebuffer 0)
|
||||
))
|
||||
|
||||
(defmethod activate :after ((this view) &key)
|
||||
; Register
|
||||
(pushnew (make-weak-pointer this) *world-views*)
|
||||
(sort-world-views))
|
||||
|
||||
(defmethod destroy :before ((this view))
|
||||
(unless [this destroyed-p]
|
||||
; Unregister
|
||||
(setf *world-views* (delete this *world-views* :key #'weak-pointer-value))))
|
||||
(unless (o! this destroyed-p)
|
||||
;; Unregister
|
||||
(setf *world-views* (delete this *world-views* :key #'weak-pointer-value))
|
||||
;; Destroy buffers
|
||||
(when (o! this framebuffer)
|
||||
(gl:delete-framebuffers (list (o! this framebuffer))))
|
||||
(when (o! this render-texture)
|
||||
(gl:delete-texture (o! this render-texture)))
|
||||
(when (o! this renderbuffer)
|
||||
(gl:delete-renderbuffers (list (o! this renderbuffer))))
|
||||
))
|
||||
|
||||
(defmethod view-matrix ((this view))
|
||||
"The world-to-view-space transformation matrix for this object."
|
||||
|
@ -45,35 +101,35 @@
|
|||
(m* (mat *view-ppu* 0 (/ *view-width* 2)
|
||||
0 *view-ppu* (/ *view-height* 2)
|
||||
0 0 1)
|
||||
[this actor local-matrix]))
|
||||
(o! this actor local-matrix)))
|
||||
|
||||
(defmethod world-matrix ((this view))
|
||||
"The view-to-world-space transformation matrix for this object."
|
||||
(minv [this view-matrix]))
|
||||
(minv (o! this view-matrix)))
|
||||
|
||||
(defmethod view-point ((this view) point)
|
||||
"Transform point from world space to view space."
|
||||
(declare (type vec2 point))
|
||||
|
||||
(vxy-trunc (m* [this view-matrix] (vxy1 point))))
|
||||
(vxy-trunc (m* (o! this view-matrix) (vxy1 point))))
|
||||
|
||||
(defmethod render-view ((this view) drawables)
|
||||
"Render everything in this view, given all drawables in the world."
|
||||
(let ((view-matrix [this view-matrix]))
|
||||
(let ((view-matrix (o! this view-matrix)))
|
||||
;; Apply view matrix
|
||||
(gl:matrix-mode :modelview)
|
||||
(gl:load-transpose-matrix (opengl-matrix view-matrix))
|
||||
(loop for drawable-ptr in drawables
|
||||
for drawable = (deref-pointer drawable-ptr)
|
||||
when (and drawable (ensure-live drawable))
|
||||
when (and [drawable active-p] [drawable actor tree-active-p]
|
||||
(some (lambda (x) [drawable actor (has-tag x)]) [this render-mask]))
|
||||
do [this (render-drawable drawable view-matrix)])
|
||||
when (and (o! drawable active-p) (o! drawable actor tree-active-p)
|
||||
(some (lambda (x) (o! drawable actor (has-tag x))) (o! this render-mask)))
|
||||
do (o! this (render-drawable drawable view-matrix)))
|
||||
))
|
||||
|
||||
(defun in-view-p (drawable drawable-matrix view-matrix view-box)
|
||||
"Determine if drawable is in the view defined by view-matrix and view-box."
|
||||
(let ((drawable-culling-box [drawable culling-box])
|
||||
(let ((drawable-culling-box (o! drawable culling-box))
|
||||
box-a box-b)
|
||||
(setf box-a (vxy-trunc (m* view-matrix
|
||||
(m* drawable-matrix (vxy1 (car drawable-culling-box))))))
|
||||
|
@ -86,11 +142,11 @@
|
|||
|
||||
(defmethod render-drawable ((this view) drawable view-matrix)
|
||||
"Render drawable with the precomputed view-matrix."
|
||||
(let ((drawable-matrix [drawable actor world-matrix]))
|
||||
(when (or (not [this cull-p]) (in-view-p drawable drawable-matrix view-matrix
|
||||
(let ((drawable-matrix (o! drawable actor world-matrix)))
|
||||
(when (or (not (o! this cull-p)) (in-view-p drawable drawable-matrix view-matrix
|
||||
(cons (vec2 0 0) (vec2 *view-width* *view-height*))))
|
||||
(gl:push-matrix)
|
||||
(gl:translate 0 0 [drawable actor z-layer])
|
||||
(gl:translate 0 0 (o! drawable actor z-layer))
|
||||
(gl:mult-transpose-matrix (opengl-matrix drawable-matrix))
|
||||
[drawable (draw this)]
|
||||
(o! drawable (draw this))
|
||||
(gl:pop-matrix))))
|
||||
|
|
|
@ -27,59 +27,59 @@
|
|||
|
||||
(defmethod print-object ((this scene) stream)
|
||||
(print-unreadable-object (this stream :type t :identity t)
|
||||
(prin1 [this :slot id] stream)
|
||||
(prin1 (o! this :slot id) stream)
|
||||
(princ " ")
|
||||
(prin1 [this :slot name] stream)))
|
||||
(prin1 (o! this :slot name) stream)))
|
||||
|
||||
(defmethod add-actor ((this scene) actor)
|
||||
"Add an actor to this scene."
|
||||
(when [actor scene]
|
||||
(error "~S is already in scene ~S" actor [actor scene]))
|
||||
(push actor [this :slot actors])
|
||||
(setf [actor :slot scene] (make-weak-pointer this))
|
||||
(when (o! actor scene)
|
||||
(error "~S is already in scene ~S" actor (o! actor scene)))
|
||||
(push actor (o! this :slot actors))
|
||||
(setf (o! actor :slot scene) (make-weak-pointer this))
|
||||
actor)
|
||||
|
||||
(defmethod remove-actor ((this scene) actor)
|
||||
"Remove an actor from this scene."
|
||||
(unless (eq [actor scene] this)
|
||||
(unless (eq (o! actor scene) this)
|
||||
(error "~S is not in scene ~S" actor this))
|
||||
(setf [this :slot actors] (delete actor [this :slot actors] :count 1))
|
||||
(setf [actor :slot scene] nil)
|
||||
(setf (o! this :slot actors) (delete actor (o! this :slot actors) :count 1))
|
||||
(setf (o! actor :slot scene) nil)
|
||||
actor)
|
||||
|
||||
(defmethod get-actor ((this scene) actor-id)
|
||||
"Get the actor with the specified ID in this scene."
|
||||
(find-if (lambda (actor) (eq [actor id] actor-id)) [this actors]))
|
||||
(find-if (lambda (actor) (eq (o! actor id) actor-id)) (o! this actors)))
|
||||
|
||||
(defmethod get-tagged-actors ((this scene) tags)
|
||||
"Get all actors tagged with the given set of tags."
|
||||
(loop for actor in [this actors]
|
||||
if (subsetp tags [actor tags])
|
||||
(loop for actor in (o! this actors)
|
||||
if (subsetp tags (o! actor tags))
|
||||
collect actor))
|
||||
|
||||
(defmethod update ((this scene))
|
||||
"Update all actors in this scene."
|
||||
(loop for actor in [this actors]
|
||||
unless (or [actor destroyed-p] (not [actor tree-active-p]))
|
||||
do [actor (update)]))
|
||||
(loop for actor in (o! this actors)
|
||||
unless (or (o! actor destroyed-p) (not (o! actor tree-active-p)))
|
||||
do (o! actor (update))))
|
||||
|
||||
(defmethod destroy ((this scene))
|
||||
"Mark this scene for unloading."
|
||||
(unless [this destroyed-p]
|
||||
(unless (o! this destroyed-p)
|
||||
; We're dead, clean up actors
|
||||
(loop for actor in [this actors]
|
||||
do [actor (destroy)])
|
||||
(loop for actor in (o! this actors)
|
||||
do (o! actor (destroy)))
|
||||
(remove-scene this))
|
||||
(setf [this :slot destroyed-p] t))
|
||||
(setf (o! this :slot destroyed-p) t))
|
||||
|
||||
(defmethod resume ((this scene))
|
||||
"Initialize or restore this scene's state."
|
||||
; Restore actors
|
||||
(loop for actor in [this actors]
|
||||
do [actor (resume)]))
|
||||
(loop for actor in (o! this actors)
|
||||
do (o! actor (resume))))
|
||||
|
||||
(defmethod suspend ((this scene))
|
||||
"Prepare this scene for serialization."
|
||||
; Suspend actors
|
||||
(loop for actor in [this actors]
|
||||
do [actor (suspend)]))
|
||||
(loop for actor in (o! this actors)
|
||||
do (o! actor (suspend))))
|
||||
|
|
|
@ -25,19 +25,19 @@
|
|||
(let ((target (weak-pointer-value ptr)))
|
||||
(etypecase target
|
||||
(scene
|
||||
(make-id-ref :scene [target id]))
|
||||
(make-id-ref :scene (o! target id)))
|
||||
(actor
|
||||
(make-id-ref :scene (etypecase [target :slot scene]
|
||||
(weak-pointer [target scene id])
|
||||
(id-ref (id-ref-scene [target :slot scene])))
|
||||
:actor [target id]))
|
||||
(make-id-ref :scene (etypecase (o! target :slot scene)
|
||||
(weak-pointer (o! target scene id))
|
||||
(id-ref (id-ref-scene (o! target :slot scene))))
|
||||
:actor (o! target id)))
|
||||
(component
|
||||
(make-id-ref :scene (etypecase [target :slot actor]
|
||||
(weak-pointer [target scene id])
|
||||
(id-ref (id-ref-scene [target :slot actor])))
|
||||
:actor (etypecase [target :slot actor]
|
||||
(weak-pointer [target actor id])
|
||||
(id-ref (id-ref-actor [target :slot actor])))
|
||||
(make-id-ref :scene (etypecase (o! target :slot actor)
|
||||
(weak-pointer (o! target scene id))
|
||||
(id-ref (id-ref-scene (o! target :slot actor))))
|
||||
:actor (etypecase (o! target :slot actor)
|
||||
(weak-pointer (o! target actor id))
|
||||
(id-ref (id-ref-actor (o! target :slot actor))))
|
||||
:component (class-name (class-of target))))
|
||||
)))
|
||||
|
||||
|
@ -49,9 +49,9 @@
|
|||
(unless scene
|
||||
(error "can't pointerize ~S (scene not found)" ref))
|
||||
(if (id-ref-actor ref)
|
||||
(if (setf actor [scene (get-actor (id-ref-actor ref))])
|
||||
(if (setf actor (o! scene (get-actor (id-ref-actor ref))))
|
||||
(if (id-ref-component ref)
|
||||
(if (setf component [actor (get-component (find-class (id-ref-component ref)))])
|
||||
(if (setf component (o! actor (get-component (find-class (id-ref-component ref)))))
|
||||
(make-weak-pointer component)
|
||||
(error "can't pointerize ~S (component not found)" ref))
|
||||
(make-weak-pointer actor))
|
||||
|
@ -90,11 +90,11 @@
|
|||
(make-load-form obj)
|
||||
(let ((sym (if nice-syms
|
||||
(typecase obj
|
||||
(scene (gensym (format nil "S~a-G" [obj :slot id])))
|
||||
(actor (gensym (format nil "A~a-G" [obj :slot id])))
|
||||
(component (gensym (if (typep [obj :slot actor] 'id-ref)
|
||||
(scene (gensym (format nil "S~a-G" (o! obj :slot id))))
|
||||
(actor (gensym (format nil "A~a-G" (o! obj :slot id))))
|
||||
(component (gensym (if (typep (o! obj :slot actor) 'id-ref)
|
||||
(format nil "C~a-~a-G"
|
||||
(id-ref-actor [obj :slot actor]) (class-name (class-of obj)))
|
||||
(id-ref-actor (o! obj :slot actor)) (class-name (class-of obj)))
|
||||
(format nil "C-~a-G" (class-name (class-of obj))))))
|
||||
(t (gensym)))
|
||||
(gensym))))
|
||||
|
@ -213,18 +213,18 @@
|
|||
(declare (type scene scene))
|
||||
(declare (type boolean destroy-after prune nice-syms))
|
||||
|
||||
[scene (suspend)]
|
||||
(o! scene (suspend))
|
||||
(prog1 (generate-load-forms scene :prune prune :nice-syms nice-syms)
|
||||
(if destroy-after
|
||||
[scene (destroy)]
|
||||
[scene (resume)])))
|
||||
(o! scene (destroy))
|
||||
(o! scene (resume)))))
|
||||
|
||||
(defun collect-descendents (actor)
|
||||
"Recursively collect actor and all its descendents."
|
||||
(declare (type actor actor))
|
||||
|
||||
(cons actor
|
||||
(loop for child-ptr in [actor children]
|
||||
(loop for child-ptr in (o! actor children)
|
||||
nconc (collect-descendents (weak-pointer-value child-ptr)))))
|
||||
|
||||
(defun dump-actors (actors &key (destroy-after t) (prune t) (nice-syms nil))
|
||||
|
@ -237,22 +237,22 @@
|
|||
nconc (collect-descendents actor))))
|
||||
;; Suspend
|
||||
(loop for actor in actors
|
||||
do [actor (suspend)])
|
||||
do (o! actor (suspend)))
|
||||
;; Serialize
|
||||
(prog1
|
||||
(loop for actor in all-actors
|
||||
collect (generate-load-forms actor :prune prune :nice-syms nice-syms))
|
||||
;; Resume/destroy
|
||||
(if destroy-after
|
||||
(loop for actor in actors do [actor (destroy)])
|
||||
(loop for actor in actors do [actor (resume)])))
|
||||
(loop for actor in actors do (o! actor (destroy)))
|
||||
(loop for actor in actors do (o! actor (resume)))))
|
||||
))
|
||||
|
||||
(defun load-resume-scene (scene-form)
|
||||
"Load and resume the scene saved in scene-form."
|
||||
(let ((scene (eval scene-form)))
|
||||
(add-scene scene)
|
||||
[scene (resume)]
|
||||
(o! scene (resume))
|
||||
scene))
|
||||
|
||||
(defun load-resume-actors (actor-forms)
|
||||
|
@ -260,5 +260,5 @@
|
|||
(let ((actors (loop for actor-form in actor-forms
|
||||
collect (eval actor-form))))
|
||||
(loop for actor in actors
|
||||
do [actor (resume)]
|
||||
do (o! actor (resume))
|
||||
collect actor)))
|
||||
|
|
Loading…
Reference in a new issue