keith
/
wh-engine
1
1
Fork 0
Code Issues 6 Pull Requests Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

243
wh-engine/actor.lisp
View File

@ -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]
for child = (weak-pointer-value child-ptr)
do [child (parent-activated this)])
(loop for component in [this components]
do [component (parent-activated this)]))
(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)
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)))

30
wh-engine/component.lisp
View File

@ -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."

65
wh-engine/main.lisp
View File

@ -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
wh-engine/package.lisp
View File

@ -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

2
wh-engine/render/drawable.lisp
View File

@ -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)

94
wh-engine/render/view.lisp
View File

@ -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))))

46
wh-engine/scene.lisp
View File

@ -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))))

52
wh-engine/serialization.lisp
View File

@ -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)))