Roll (parent-activated) into (activate) (for #9), and update objective-lisp syntax

This commit is contained in:
~keith 2022-02-22 14:32:48 +00:00
parent 0f8fe16fc3
commit 738da6f74b
Signed by: keith
GPG key ID: 5BEBEEAB2C73D520
8 changed files with 289 additions and 249 deletions

View file

@ -78,202 +78,191 @@
(defmethod scene ((this actor)) (defmethod scene ((this actor))
"The scene containing this actor." "The scene containing this actor."
(deref-sus-pointer [this :slot scene])) (deref-sus-pointer (o! this :slot scene)))
(defmethod parent ((this actor)) (defmethod parent ((this actor))
"This actor's parent." "This actor's parent."
(deref-sus-pointer [this :slot parent])) (deref-sus-pointer (o! this :slot parent)))
(defmethod tree-active-p ((this actor)) (defmethod tree-active-p ((this actor))
"Whether or not this actor and all its parents are active." "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) (defmethod apply-to-tree ((this actor) fun)
(funcall fun this) (funcall fun this)
(loop for child-ptr in [this children] (loop for child-ptr in (o! this children)
when (typep child-ptr 'weak-pointer) 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) (defmethod print-object ((this actor) stream)
(print-unreadable-object (this stream :type t :identity t) (print-unreadable-object (this stream :type t :identity t)
(prin1 [this :slot id] stream) (prin1 (o! this :slot id) stream)
(princ " ") (princ " ")
(prin1 [this :slot name] stream))) (prin1 (o! this :slot name) stream)))
(defmethod get-component ((this actor) component-class) (defmethod get-component ((this actor) component-class)
"Get a component of the specified class attached to this object." "Get a component of the specified class attached to this object."
(find-if (lambda (component) (typep component component-class)) (find-if (lambda (component) (typep component component-class))
[this components])) (o! this components)))
(defmethod add-component ((this actor) component) (defmethod add-component ((this actor) component)
"Add a component to this object." "Add a component to this object."
(let ((component-class (class-of component))) (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)) (error "~S already has a component of class ~S" this component-class))
(push component [this :slot components]) (push component (o! this :slot components))
[component (attach this)]) (o! component (attach this)))
component) component)
(defmethod add-child ((this actor) child) (defmethod add-child ((this actor) child)
"Add a child to this object." "Add a child to this object."
(when [child parent] (when (o! child parent)
(error "~S is already a child of ~S" child [child parent])) (error "~S is already a child of ~S" child (o! child parent)))
(push (make-weak-pointer child) [this :slot children]) (push (make-weak-pointer child) (o! this :slot children))
(setf [child :slot parent] (make-weak-pointer this)) (setf (o! child :slot parent) (make-weak-pointer this))
[child (parent-changed)] (o! child (parent-changed))
child) child)
(defmethod remove-child ((this actor) child) (defmethod remove-child ((this actor) child)
"Remove a child from this object." "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)) (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 (o! this :slot children) (delete child (o! this :slot children) :key #'deref-sus-pointer :count 1))
(setf [child :slot parent] nil) (setf (o! child :slot parent) nil)
[child (parent-changed)] (o! child (parent-changed))
child) child)
(defmethod recompute-blocked-p ((this actor)) (defmethod recompute-blocked-p ((this actor))
"Determine if any ancestors of this actor are deactivated." "Determine if any ancestors of this actor are deactivated."
(setf [this :slot blocked-p] (setf (o! this :slot blocked-p)
(when [this parent] (or (not [this parent active-p]) [this parent :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) (defmethod has-tag ((this actor) tag)
"Check if this object has the specified tag." "Check if this object has the specified tag."
(find tag [this tags])) (find tag (o! this tags)))
(defmethod add-tag ((this actor) tag) (defmethod add-tag ((this actor) tag)
"Add a tag to this object." "Add a tag to this object."
(pushnew tag [this :slot tags])) (pushnew tag (o! this :slot tags)))
(defmethod remove-tag ((this actor) tag) (defmethod remove-tag ((this actor) tag)
"Remove a tag from this object." "Remove a tag from this object."
(setf [this :slot tags] (remove tag [this :slot tags]))) (setf (o! this :slot tags) (remove tag (o! 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)) (defmethod parent-changed ((this actor))
"Called when the actor's parent is changed." "Called when the actor's parent is changed."
[this (recompute-blocked-p)] (o! this (recompute-blocked-p))
(loop for component in [this components] (loop for component in (o! this components)
do [component (parent-changed)])) do (o! component (parent-changed))))
(defmethod deactivate ((this actor)) (defmethod deactivate ((this actor) &key origin)
"Deactivate this object." "Deactivate this object."
(setf [this :slot active-p] nil) (o! this (recompute-blocked-p))
(loop for component in [this components] (unless origin
do [component (parent-deactivated this)]) (setf (o! this :slot active-p) nil))
(loop for child-ptr in [this children] (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) 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." "Activate this object."
(setf [this :slot active-p] t) (o! this (recompute-blocked-p))
(loop for child-ptr in [this children] (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) for child = (weak-pointer-value child-ptr)
do [child (parent-activated this)]) when (o! child active-p)
(loop for component in [this components] do (o! child (activate :origin (or origin this))))
do [component (parent-activated 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)) (defmethod resume ((this actor))
"Initialize or restore this actor's state." "Initialize or restore this actor's state."
;; Restore self ;; Restore self
(when (typep [this :slot scene] 'id-ref) (when (typep (o! this :slot scene) 'id-ref)
;; relink to scene ;; relink to scene
(let ((scene (get-scene (id-ref-scene [this :slot scene])))) (let ((scene (get-scene (id-ref-scene (o! this :slot scene)))))
(setf [this :slot scene] nil) (setf (o! this :slot scene) nil)
[scene (add-actor this)])) (o! scene (add-actor this))))
(when (typep [this :slot parent] 'id-ref) (when (typep (o! this :slot parent) 'id-ref)
;; relink to parent ;; relink to parent
(let ((parent [this scene (get-actor (id-ref-actor [this :slot parent]))])) (let ((parent (o! this scene (get-actor (id-ref-actor (o! this :slot parent))))))
(setf [this :slot parent] nil) (setf (o! this :slot parent) nil)
[parent (add-child this)])) (o! parent (add-child this))))
(loop for entry on [this :slot children] (loop for entry on (o! this :slot children)
when (typep (car entry) 'id-ref) when (typep (car entry) 'id-ref)
do (rplaca entry (pointerize (car entry)))) do (rplaca entry (pointerize (car entry))))
;; Restore components ;; Restore components
(loop for component in [this components] (loop for component in (o! this components)
do [component (resume)]) do (o! component (resume)))
;; Restore children ;; Restore children
(loop for child-ptr in [this children] (loop for child-ptr in (o! this children)
for child = (weak-pointer-value child-ptr) for child = (weak-pointer-value child-ptr)
do [child (resume)])) do (o! child (resume))))
(defmethod suspend ((this actor)) (defmethod suspend ((this actor))
"Prepare this actor for serialization." "Prepare this actor for serialization."
;; Suspend children ;; Suspend children
(loop for child-ptr in [this children] (loop for child-ptr in (o! this children)
for child = (weak-pointer-value child-ptr) for child = (weak-pointer-value child-ptr)
do [child (suspend)]) do (o! child (suspend)))
;; Suspend components ;; Suspend components
(loop for component in [this components] (loop for component in (o! this components)
do [component (suspend)]) do (o! component (suspend)))
;; Suspend self ;; 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) when (typep (car child-cell) 'weak-pointer)
do (rplaca child-cell (referize (car child-cell)))) do (rplaca child-cell (referize (car child-cell))))
(referize-setf [this :slot scene]) (referize-setf (o! this :slot scene))
(referize-setf [this :slot parent])) (referize-setf (o! this :slot parent)))
(defmethod update ((this actor)) (defmethod update ((this actor))
"Update this actor's components." "Update this actor's components."
(loop for component in [this components] (loop for component in (o! this components)
do (when [component active-p] do (when (o! component active-p)
(unless [component started-p] [component (start)]) (unless (o! component started-p) (o! component (start)))
[component (update)])) (o! component (update))))
; (loop for child in [this children] ; (loop for child in (o! this children)
; do (when [child active-p] ; do (when (o! child active-p)
; [child (.update)])) ; (o! child (update))))
) )
(defmethod destroy ((this actor)) (defmethod destroy ((this actor))
"Mark this object for unloading." "Mark this object for unloading."
(unless [this destroyed-p] (unless (o! this destroyed-p)
; Cleanup on aisle 5! ; Cleanup on aisle 5!
(loop for component in [this components] (loop for component in (o! this components)
when [component active-p] when (o! component active-p)
do [component (destroy)]) do (o! component (destroy)))
; Remove from parent ; Remove from parent
(when [this parent] (when (o! this parent)
[this parent (remove-child this)]) (o! this parent (remove-child this)))
(loop for child-ptr in [this children] (loop for child-ptr in (o! this children)
for child = (deref-sus-pointer child-ptr) for child = (deref-sus-pointer child-ptr)
do [child (destroy)]) do (o! child (destroy)))
(when [this scene] (when (o! this scene)
[this scene (remove-actor this)])) (o! this scene (remove-actor this))))
(setf [this :slot destroyed-p] t)) (setf (o! this :slot destroyed-p) t))
;; Transform ;; Transform
(defmethod initialize-instance :after ((this actor) &key) (defmethod initialize-instance :after ((this actor) &key)
[this (recompute-matrix)]) (o! this (recompute-matrix)))
(defmethod recompute-matrix ((this actor)) (defmethod recompute-matrix ((this actor))
"Recompute the local-to-parent-space matrix." "Recompute the local-to-parent-space matrix."
(let ((rs (sin [this rotation])) (let ((rs (sin (o! this rotation)))
(rc (cos [this rotation])) (rc (cos (o! this rotation)))
(sx (vx2 [this scale])) (sx (vx2 (o! this scale)))
(sy (vy2 [this scale])) (sy (vy2 (o! this scale)))
(tx (vx2 [this location])) (tx (vx2 (o! this location)))
(ty (vy2 [this location]))) (ty (vy2 (o! this location))))
(with-fast-matref (m [this :slot matrix] 3) (with-fast-matref (m (o! this :slot matrix) 3)
(setf (m 0 0) (* sx rc) (setf (m 0 0) (* sx rc)
(m 0 1) (* sy (- rs)) (m 0 1) (* sy (- rs))
(m 0 2) tx (m 0 2) tx
@ -286,83 +275,83 @@
"The actor's location relative to its parent." "The actor's location relative to its parent."
(declare (type vec2 new-val)) (declare (type vec2 new-val))
(setf (vx2 [this :slot location]) (vx2 new-val) (setf (vx2 (o! this :slot location)) (vx2 new-val)
(vy2 [this :slot location]) (vy2 new-val)) (vy2 (o! this :slot location)) (vy2 new-val))
[this (recompute-matrix)]) (o! this (recompute-matrix)))
(defmethod (setf rotation) (new-val (this actor)) (defmethod (setf rotation) (new-val (this actor))
"The actor's rotation relative to its parent." "The actor's rotation relative to its parent."
(declare (type single-float new-val)) (declare (type single-float new-val))
(setf [this :slot rotation] new-val) (setf (o! this :slot rotation) new-val)
[this (recompute-matrix)]) (o! this (recompute-matrix)))
(defmethod (setf scale) (new-val (this actor)) (defmethod (setf scale) (new-val (this actor))
"The actor's scale relative to its parent." "The actor's scale relative to its parent."
(declare (type vec2 new-val)) (declare (type vec2 new-val))
(setf (vx2 [this :slot scale]) (vx2 new-val) (setf (vx2 (o! this :slot scale)) (vx2 new-val)
(vy2 [this :slot scale]) (vy2 new-val)) (vy2 (o! this :slot scale)) (vy2 new-val))
[this (recompute-matrix)]) (o! this (recompute-matrix)))
(defmethod world-matrix ((this actor)) (defmethod world-matrix ((this actor))
"The local-to-world-space transformation matrix for this actor." "The local-to-world-space transformation matrix for this actor."
(if [this parent] (if (o! this parent)
(m* [this parent world-matrix] [this matrix]) (m* (o! this parent world-matrix) (o! this matrix))
[this matrix])) (o! this matrix)))
(defmethod local-matrix ((this actor)) (defmethod local-matrix ((this actor))
"The world-to-local-space transformation matrix for 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)) (defmethod world-location ((this actor))
"The world-space location of 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) (defmethod transform-point ((this actor) point)
"Transform point from local space to parent space." "Transform point from local space to parent space."
(declare (type vec2 point)) (declare (type vec2 point))
(vxy (m* [this matrix] (vxy1 point)))) (vxy (m* (o! this matrix) (vxy1 point))))
(defmethod world-point ((this actor) point) (defmethod world-point ((this actor) point)
"Transform point from local space to world space." "Transform point from local space to world space."
(declare (type vec2 point)) (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) (defmethod local-point ((this actor) point)
"Transform point from world space to local space." "Transform point from world space to local space."
(declare (type vec2 point)) (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) (defmethod transform-svector ((this actor) vector)
"Transform vector from local space to parent space." "Transform vector from local space to parent space."
(declare (type vec2 vector)) (declare (type vec2 vector))
(vxy (m* [this matrix] (vxy_ vector)))) (vxy (m* (o! this matrix) (vxy_ vector))))
(defmethod transform-vector ((this actor) vector) (defmethod transform-vector ((this actor) vector)
"Transform vector from local space to parent space, without changing its length." "Transform vector from local space to parent space, without changing its length."
(declare (type vec2 vector)) (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) (defmethod translate-by ((this actor) vector)
"Translate this actor by the given vector in parent space." "Translate this actor by the given vector in parent space."
(declare (type vec2 vector)) (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) (defmethod rotate-by ((this actor) angle)
"Rotate this actor by the given angle." "Rotate this actor by the given angle."
(declare (type single-float 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) (defmethod scale-by ((this actor) factor)
"Scale this actor by the given factor (either a scalar or a vector)." "Scale this actor by the given factor (either a scalar or a vector)."
(declare (type (or single-float vec2) factor)) (declare (type (or single-float vec2) factor))
(setf [this scale] (v* [this scale] factor))) (setf (o! this scale) (v* (o! this scale) factor)))

View file

@ -22,40 +22,34 @@
(defmethod actor ((this component)) (defmethod actor ((this component))
"The actor this component belongs to." "The actor this component belongs to."
(deref-sus-pointer [this :slot actor])) (deref-sus-pointer (o! this :slot actor)))
(defmethod scene ((this component)) (defmethod scene ((this component))
"The scene this component belongs to." "The scene this component belongs to."
[this actor scene]) (o! this actor scene))
(defmethod destroyed-p ((this component)) (defmethod destroyed-p ((this component))
"If true, this component will be unloaded." "If true, this component will be unloaded."
[this actor destroyed-p]) (o! this actor destroyed-p))
(defmethod attach ((this component) actor) (defmethod attach ((this component) actor)
"Attach this component to an actor." "Attach this component to an actor."
(setf [this :slot actor] (make-weak-pointer (ensure-live actor))) (setf (o! this :slot actor) (make-weak-pointer (ensure-live actor)))
[this (parent-changed)]) (o! 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)
(defmethod parent-changed ((this component)) (defmethod parent-changed ((this component))
"Called when the component's actor's parent is changed." "Called when the component's actor's parent is changed."
nil) nil)
(defmethod deactivate ((this component)) (defmethod deactivate ((this component) &key origin)
"Deactivate this component." "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." "Activate this component."
(setf [this :slot active-p] t)) (unless origin
(setf (o! this :slot active-p) t)))
(defmethod resume ((this component)) (defmethod resume ((this component))
"Initialize or restore this component's state." "Initialize or restore this component's state."
@ -80,7 +74,7 @@
(defmethod start ((this component)) (defmethod start ((this component))
"Called before (update) the first time this component is processed." "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)) (defmethod update ((this component))
"Called every game tick while this component and its actor are active." "Called every game tick while this component and its actor are active."

View file

@ -36,7 +36,7 @@
(defun ensure-live (obj) (defun ensure-live (obj)
"Ensure obj is live (non-destroyed)." "Ensure obj is live (non-destroyed)."
(when [obj destroyed-p] (when (o! obj destroyed-p)
(error "~S was used after it was destroyed" obj)) (error "~S was used after it was destroyed" obj))
obj) obj)
@ -96,20 +96,20 @@
(defun get-scene (scene-id) (defun get-scene (scene-id)
"Get a scene by its 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) (defun attach-actor-to-world (actor scene)
"Properly attach actor and its descendents to scene, and initialize them." "Properly attach actor and its descendents to scene, and initialize them."
;; attach actors to scene ;; attach actors to scene
(apply-to-tree actor (lambda (a) (apply-to-tree actor (lambda (a)
(setf [a :slot scene] nil) (setf (o! a :slot scene) nil)
[scene (add-actor a)])) (o! scene (add-actor a))))
;; (resume) -> automatically resumes children ;; (resume) -> automatically resumes children
[actor (resume)] (o! actor (resume))
;; FIXME make (activate) call itself recursively on children ;; FIXME make (activate) call itself recursively on children
(apply-to-tree actor (lambda (a) (apply-to-tree actor (lambda (a)
(when [a tree-active-p] (when (o! a tree-active-p)
[a (activate)]))) (o! a (activate)))))
) )
(defvar *view-width* 384 (defvar *view-width* 384
@ -136,51 +136,48 @@
(setf test-actor (make-instance 'actor (setf test-actor (make-instance 'actor
:name "Actor")) :name "Actor"))
;; [test-scene (add-actor test-actor)] ;; (o! test-scene (add-actor test-actor))
(setf test-drawable (make-instance 'drawable-test)) (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 (setf test-actor-2 (make-instance 'actor
:name "Actor 2" :name "Actor 2"
:location (vec2 0.5 0.5) :location (vec2 0.5 0.5)
:rotation (coerce (/ pi 4) 'single-float) :rotation (coerce (/ pi 4) 'single-float)
:z-layer -1)) :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 (o! test-actor-2 (add-component (make-instance 'drawable-test
:colour (vec4 0.0 1.0 0.0 1.0))) :colour (vec4 0.0 1.0 0.0 1.0))))
]
(setf child-actor (make-instance 'actor (setf child-actor (make-instance 'actor
:name "Child Actor" :name "Child Actor"
:location (vec2 0 0.5) :location (vec2 0 0.5)
:z-layer -2)) :z-layer -2))
;; [test-scene (add-actor child-actor)] ;; (o! test-scene (add-actor child-actor))
[test-actor-2 (add-child child-actor)] (o! test-actor-2 (add-child child-actor))
[child-actor (add-component (make-instance 'drawable-test (o! child-actor (add-component (make-instance 'drawable-test
:colour (vec4 0.0 1.0 1.0 1.0))) :colour (vec4 0.0 1.0 1.0 1.0))))
]
(setf grandchild-actor (make-instance 'actor (setf grandchild-actor (make-instance 'actor
:name "Grandchild Actor" :name "Grandchild Actor"
:location (vec2 0 1) :location (vec2 0 1)
:scale (vec2 0.25 0.25) :scale (vec2 0.25 0.25)
:z-layer 1)) :z-layer 1))
;; [test-scene (add-actor grandchild-actor)] ;; (o! test-scene (add-actor grandchild-actor))
[child-actor (add-child grandchild-actor)] (o! child-actor (add-child grandchild-actor))
[grandchild-actor (add-component (make-instance 'drawable-test (o! grandchild-actor (add-component (make-instance 'drawable-test
:colour (vec4 1.0 1.0 0.0 0.0))) :colour (vec4 1.0 1.0 0.0 0.0))))
]
(setf camera-actor (make-instance 'actor (setf camera-actor (make-instance 'actor
:name "Camera")) :name "Camera"))
;; [test-scene (add-actor camera-actor)] ;; (o! test-scene (add-actor camera-actor))
(setf camera-view (make-instance 'view)) (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 test-scene)
(attach-actor-to-world test-actor-2 test-scene) (attach-actor-to-world test-actor-2 test-scene)
@ -202,9 +199,9 @@
+version+)) +version+))
(sdl2:with-gl-context (gl-context win) (sdl2:with-gl-context (gl-context win)
(sdl2:gl-make-current win gl-context) (sdl2:gl-make-current win gl-context)
(let ((framebuf (car (gl:gen-framebuffers 1))) (let ((framebuf (gl:gen-framebuffer))
(renderbuf (car (gl:gen-renderbuffers 1))) (renderbuf (gl:gen-renderbuffer))
(render-texture (car (gl:gen-textures 1))) (render-texture (gl:gen-texture))
(win-width (nth-value 0 (sdl2:get-window-size win))) (win-width (nth-value 0 (sdl2:get-window-size win)))
(win-height (nth-value 1 (sdl2:get-window-size win)))) (win-height (nth-value 1 (sdl2:get-window-size win))))
;; set up framebuffer ;; set up framebuffer
@ -231,6 +228,8 @@
(unless (gl::enum= result :framebuffer-complete) (unless (gl::enum= result :framebuffer-complete)
(error "Failed to create framebuffer: ~S" result))) (error "Failed to create framebuffer: ~S" result)))
(format t "texture-resident-p: ~S~%" (gl:texture-resident-p render-texture))
;; set up gl ;; set up gl
(gl:matrix-mode :projection) (gl:matrix-mode :projection)
(gl:ortho 0 *view-width* (gl:ortho 0 *view-width*
@ -247,7 +246,7 @@
(:idle () (:idle ()
;; update ;; update
(loop for scene in *world-scenes* (loop for scene in *world-scenes*
do [scene (update)]) do (o! scene (update)))
;; draw to render texture ;; draw to render texture
(gl:bind-framebuffer :framebuffer framebuf) (gl:bind-framebuffer :framebuffer framebuf)
(gl:viewport 0 0 *view-width* *view-height*) (gl:viewport 0 0 *view-width* *view-height*)
@ -256,12 +255,12 @@
(let ((render-pass nil)) (let ((render-pass nil))
(loop for view-ptr in *world-views* (loop for view-ptr in *world-views*
for view = (ensure-live (weak-pointer-value view-ptr)) 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 do (progn
(unless (eq [view render-pass] render-pass) (unless (eq (o! view render-pass) render-pass)
(setf render-pass [view render-pass]) (setf render-pass (o! view render-pass))
(gl:clear :depth-buffer)) (gl:clear :depth-buffer))
[view (render-view *world-drawables*)]))) (o! view (render-view *world-drawables*)))))
;; now draw to window ;; now draw to window
(gl:bind-framebuffer :framebuffer 0) (gl:bind-framebuffer :framebuffer 0)

View file

@ -6,6 +6,7 @@
(:use common-lisp 3d-vectors 3d-matrices) (:use common-lisp 3d-vectors 3d-matrices)
(:import-from sb-ext (:import-from sb-ext
weak-pointer weak-pointer-p make-weak-pointer weak-pointer-value) weak-pointer weak-pointer-p make-weak-pointer weak-pointer-value)
(:import-from objective-lisp O!)
(:export (:export
;; main.lisp ;; main.lisp
+version+ ensure-version +version+ ensure-version
@ -14,6 +15,7 @@
make-id fixed-id make-id fixed-id
*running-scenes* *running-scenes*
add-scene remove-scene get-scene update-all-scenes add-scene remove-scene get-scene update-all-scenes
attach-actor-to-world
*view-width* *view-height* *view-ppu* *pixel-scale* *view-width* *view-height* *view-ppu* *pixel-scale*
register-test-scene register-test-scene
run run
@ -42,7 +44,7 @@
get-component add-component get-component add-component
add-child remove-child add-child remove-child
has-tag add-tag remove-tag has-tag add-tag remove-tag
parent-deactivated parent-activated parent-changed parent-changed
deactivate activate deactivate activate
resume suspend resume suspend
update update
@ -59,7 +61,7 @@
scene destroyed-p scene destroyed-p
; methods ; methods
attach attach
parent-deactivated parent-activated parent-changed parent-changed
deactivate activate deactivate activate
resume suspend resume suspend
start update start update

View file

@ -33,7 +33,7 @@
(cons (vec2 -0.5 -0.5) (vec2 0.5 0.5))) (cons (vec2 -0.5 -0.5) (vec2 0.5 0.5)))
(defmethod draw ((this drawable-test) view) (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:with-primitives :quads
(gl:vertex -0.5 -0.5 0.0 1.0) (gl:vertex -0.5 -0.5 0.0 1.0)
(gl:vertex 0.5 -0.5 0.0 1.0) (gl:vertex 0.5 -0.5 0.0 1.0)

View file

@ -3,7 +3,7 @@
(defun sort-world-views () (defun sort-world-views ()
"Re-sort the *world-views* list by render pass." "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) (defclass view (component)
((render-pass :documentation "The render pass this view should be drawn in." ((render-pass :documentation "The render pass this view should be drawn in."
@ -20,23 +20,79 @@
:accessor cull-p :accessor cull-p
:type boolean :type boolean
:initarg :cull-p :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.")) (:documentation "Defines a view into the scene, and rendering settings for objects drawn by the view."))
(defmethod (setf render-pass) (new-val (this view)) (defmethod (setf render-pass) (new-val (this view))
"The render pass this view should be drawn in." "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)) (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 ; Register
(pushnew (make-weak-pointer this) *world-views*) (pushnew (make-weak-pointer this) *world-views*)
(sort-world-views)) (sort-world-views))
(defmethod destroy :before ((this view)) (defmethod destroy :before ((this view))
(unless [this destroyed-p] (unless (o! this destroyed-p)
; Unregister ;; Unregister
(setf *world-views* (delete this *world-views* :key #'weak-pointer-value)))) (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)) (defmethod view-matrix ((this view))
"The world-to-view-space transformation matrix for this object." "The world-to-view-space transformation matrix for this object."
@ -45,35 +101,35 @@
(m* (mat *view-ppu* 0 (/ *view-width* 2) (m* (mat *view-ppu* 0 (/ *view-width* 2)
0 *view-ppu* (/ *view-height* 2) 0 *view-ppu* (/ *view-height* 2)
0 0 1) 0 0 1)
[this actor local-matrix])) (o! this actor local-matrix)))
(defmethod world-matrix ((this view)) (defmethod world-matrix ((this view))
"The view-to-world-space transformation matrix for this object." "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) (defmethod view-point ((this view) point)
"Transform point from world space to view space." "Transform point from world space to view space."
(declare (type vec2 point)) (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) (defmethod render-view ((this view) drawables)
"Render everything in this view, given all drawables in the world." "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 ;; Apply view matrix
(gl:matrix-mode :modelview) (gl:matrix-mode :modelview)
(gl:load-transpose-matrix (opengl-matrix view-matrix)) (gl:load-transpose-matrix (opengl-matrix view-matrix))
(loop for drawable-ptr in drawables (loop for drawable-ptr in drawables
for drawable = (deref-pointer drawable-ptr) for drawable = (deref-pointer drawable-ptr)
when (and drawable (ensure-live drawable)) when (and drawable (ensure-live drawable))
when (and [drawable active-p] [drawable actor tree-active-p] when (and (o! drawable active-p) (o! drawable actor tree-active-p)
(some (lambda (x) [drawable actor (has-tag x)]) [this render-mask])) (some (lambda (x) (o! drawable actor (has-tag x))) (o! this render-mask)))
do [this (render-drawable drawable view-matrix)]) do (o! this (render-drawable drawable view-matrix)))
)) ))
(defun in-view-p (drawable drawable-matrix view-matrix view-box) (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." "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) box-a box-b)
(setf box-a (vxy-trunc (m* view-matrix (setf box-a (vxy-trunc (m* view-matrix
(m* drawable-matrix (vxy1 (car drawable-culling-box)))))) (m* drawable-matrix (vxy1 (car drawable-culling-box))))))
@ -86,11 +142,11 @@
(defmethod render-drawable ((this view) drawable view-matrix) (defmethod render-drawable ((this view) drawable view-matrix)
"Render drawable with the precomputed view-matrix." "Render drawable with the precomputed view-matrix."
(let ((drawable-matrix [drawable actor world-matrix])) (let ((drawable-matrix (o! drawable actor world-matrix)))
(when (or (not [this cull-p]) (in-view-p drawable drawable-matrix view-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*)))) (cons (vec2 0 0) (vec2 *view-width* *view-height*))))
(gl:push-matrix) (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)) (gl:mult-transpose-matrix (opengl-matrix drawable-matrix))
[drawable (draw this)] (o! drawable (draw this))
(gl:pop-matrix)))) (gl:pop-matrix))))

View file

@ -27,59 +27,59 @@
(defmethod print-object ((this scene) stream) (defmethod print-object ((this scene) stream)
(print-unreadable-object (this stream :type t :identity t) (print-unreadable-object (this stream :type t :identity t)
(prin1 [this :slot id] stream) (prin1 (o! this :slot id) stream)
(princ " ") (princ " ")
(prin1 [this :slot name] stream))) (prin1 (o! this :slot name) stream)))
(defmethod add-actor ((this scene) actor) (defmethod add-actor ((this scene) actor)
"Add an actor to this scene." "Add an actor to this scene."
(when [actor scene] (when (o! actor scene)
(error "~S is already in scene ~S" actor [actor scene])) (error "~S is already in scene ~S" actor (o! actor scene)))
(push actor [this :slot actors]) (push actor (o! this :slot actors))
(setf [actor :slot scene] (make-weak-pointer this)) (setf (o! actor :slot scene) (make-weak-pointer this))
actor) actor)
(defmethod remove-actor ((this scene) actor) (defmethod remove-actor ((this scene) actor)
"Remove an actor from this scene." "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)) (error "~S is not in scene ~S" actor this))
(setf [this :slot actors] (delete actor [this :slot actors] :count 1)) (setf (o! this :slot actors) (delete actor (o! this :slot actors) :count 1))
(setf [actor :slot scene] nil) (setf (o! actor :slot scene) nil)
actor) actor)
(defmethod get-actor ((this scene) actor-id) (defmethod get-actor ((this scene) actor-id)
"Get the actor with the specified ID in this scene." "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) (defmethod get-tagged-actors ((this scene) tags)
"Get all actors tagged with the given set of tags." "Get all actors tagged with the given set of tags."
(loop for actor in [this actors] (loop for actor in (o! this actors)
if (subsetp tags [actor tags]) if (subsetp tags (o! actor tags))
collect actor)) collect actor))
(defmethod update ((this scene)) (defmethod update ((this scene))
"Update all actors in this scene." "Update all actors in this scene."
(loop for actor in [this actors] (loop for actor in (o! this actors)
unless (or [actor destroyed-p] (not [actor tree-active-p])) unless (or (o! actor destroyed-p) (not (o! actor tree-active-p)))
do [actor (update)])) do (o! actor (update))))
(defmethod destroy ((this scene)) (defmethod destroy ((this scene))
"Mark this scene for unloading." "Mark this scene for unloading."
(unless [this destroyed-p] (unless (o! this destroyed-p)
; We're dead, clean up actors ; We're dead, clean up actors
(loop for actor in [this actors] (loop for actor in (o! this actors)
do [actor (destroy)]) do (o! actor (destroy)))
(remove-scene this)) (remove-scene this))
(setf [this :slot destroyed-p] t)) (setf (o! this :slot destroyed-p) t))
(defmethod resume ((this scene)) (defmethod resume ((this scene))
"Initialize or restore this scene's state." "Initialize or restore this scene's state."
; Restore actors ; Restore actors
(loop for actor in [this actors] (loop for actor in (o! this actors)
do [actor (resume)])) do (o! actor (resume))))
(defmethod suspend ((this scene)) (defmethod suspend ((this scene))
"Prepare this scene for serialization." "Prepare this scene for serialization."
; Suspend actors ; Suspend actors
(loop for actor in [this actors] (loop for actor in (o! this actors)
do [actor (suspend)])) do (o! actor (suspend))))

View file

@ -25,19 +25,19 @@
(let ((target (weak-pointer-value ptr))) (let ((target (weak-pointer-value ptr)))
(etypecase target (etypecase target
(scene (scene
(make-id-ref :scene [target id])) (make-id-ref :scene (o! target id)))
(actor (actor
(make-id-ref :scene (etypecase [target :slot scene] (make-id-ref :scene (etypecase (o! target :slot scene)
(weak-pointer [target scene id]) (weak-pointer (o! target scene id))
(id-ref (id-ref-scene [target :slot scene]))) (id-ref (id-ref-scene (o! target :slot scene))))
:actor [target id])) :actor (o! target id)))
(component (component
(make-id-ref :scene (etypecase [target :slot actor] (make-id-ref :scene (etypecase (o! target :slot actor)
(weak-pointer [target scene id]) (weak-pointer (o! target scene id))
(id-ref (id-ref-scene [target :slot actor]))) (id-ref (id-ref-scene (o! target :slot actor))))
:actor (etypecase [target :slot actor] :actor (etypecase (o! target :slot actor)
(weak-pointer [target actor id]) (weak-pointer (o! target actor id))
(id-ref (id-ref-actor [target :slot actor]))) (id-ref (id-ref-actor (o! target :slot actor))))
:component (class-name (class-of target)))) :component (class-name (class-of target))))
))) )))
@ -49,9 +49,9 @@
(unless scene (unless scene
(error "can't pointerize ~S (scene not found)" ref)) (error "can't pointerize ~S (scene not found)" ref))
(if (id-ref-actor 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 (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) (make-weak-pointer component)
(error "can't pointerize ~S (component not found)" ref)) (error "can't pointerize ~S (component not found)" ref))
(make-weak-pointer actor)) (make-weak-pointer actor))
@ -90,11 +90,11 @@
(make-load-form obj) (make-load-form obj)
(let ((sym (if nice-syms (let ((sym (if nice-syms
(typecase obj (typecase obj
(scene (gensym (format nil "S~a-G" [obj :slot id]))) (scene (gensym (format nil "S~a-G" (o! obj :slot id))))
(actor (gensym (format nil "A~a-G" [obj :slot id]))) (actor (gensym (format nil "A~a-G" (o! obj :slot id))))
(component (gensym (if (typep [obj :slot actor] 'id-ref) (component (gensym (if (typep (o! obj :slot actor) 'id-ref)
(format nil "C~a-~a-G" (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)))))) (format nil "C-~a-G" (class-name (class-of obj))))))
(t (gensym))) (t (gensym)))
(gensym)))) (gensym))))
@ -213,18 +213,18 @@
(declare (type scene scene)) (declare (type scene scene))
(declare (type boolean destroy-after prune nice-syms)) (declare (type boolean destroy-after prune nice-syms))
[scene (suspend)] (o! scene (suspend))
(prog1 (generate-load-forms scene :prune prune :nice-syms nice-syms) (prog1 (generate-load-forms scene :prune prune :nice-syms nice-syms)
(if destroy-after (if destroy-after
[scene (destroy)] (o! scene (destroy))
[scene (resume)]))) (o! scene (resume)))))
(defun collect-descendents (actor) (defun collect-descendents (actor)
"Recursively collect actor and all its descendents." "Recursively collect actor and all its descendents."
(declare (type actor actor)) (declare (type actor actor))
(cons 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))))) nconc (collect-descendents (weak-pointer-value child-ptr)))))
(defun dump-actors (actors &key (destroy-after t) (prune t) (nice-syms nil)) (defun dump-actors (actors &key (destroy-after t) (prune t) (nice-syms nil))
@ -237,22 +237,22 @@
nconc (collect-descendents actor)))) nconc (collect-descendents actor))))
;; Suspend ;; Suspend
(loop for actor in actors (loop for actor in actors
do [actor (suspend)]) do (o! actor (suspend)))
;; Serialize ;; Serialize
(prog1 (prog1
(loop for actor in all-actors (loop for actor in all-actors
collect (generate-load-forms actor :prune prune :nice-syms nice-syms)) collect (generate-load-forms actor :prune prune :nice-syms nice-syms))
;; Resume/destroy ;; Resume/destroy
(if destroy-after (if destroy-after
(loop for actor in actors do [actor (destroy)]) (loop for actor in actors do (o! actor (destroy)))
(loop for actor in actors do [actor (resume)]))) (loop for actor in actors do (o! actor (resume)))))
)) ))
(defun load-resume-scene (scene-form) (defun load-resume-scene (scene-form)
"Load and resume the scene saved in scene-form." "Load and resume the scene saved in scene-form."
(let ((scene (eval scene-form))) (let ((scene (eval scene-form)))
(add-scene scene) (add-scene scene)
[scene (resume)] (o! scene (resume))
scene)) scene))
(defun load-resume-actors (actor-forms) (defun load-resume-actors (actor-forms)
@ -260,5 +260,5 @@
(let ((actors (loop for actor-form in actor-forms (let ((actors (loop for actor-form in actor-forms
collect (eval actor-form)))) collect (eval actor-form))))
(loop for actor in actors (loop for actor in actors
do [actor (resume)] do (o! actor (resume))
collect actor))) collect actor)))