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

wh-engine/actor.lisp

@@ -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])
+    (push component (o! this :slot components))
-    [component (attach this)])
+    (o! component (attach this)))
   component)
 
 (defmethod add-child ((this actor) child)
   "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)
 
 (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 (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)
 
 (defmethod recompute-blocked-p ((this actor))
   "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)
   "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])))
+  (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))
   "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."
-  (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)
-        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)
+  (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)
-        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))
   "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]))))
+    (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
-    (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)
           do (rplaca entry (pointerize (car entry))))
   ;; Restore components
-  (loop for component in [this components]
+  (loop for component in (o! this components)
-        do [component (resume)])
+        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]
+  (loop for component in (o! this components)
-        do [component (suspend)])
+        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 (o! this :slot scene))
-  (referize-setf [this :slot parent]))
+  (referize-setf (o! this :slot parent)))
 
 (defmethod update ((this actor))
   "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))
   "Mark this object for unloading."
-  (unless [this destroyed-p]
+  (unless (o! this destroyed-p)
           ; 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
-          (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)
-                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
 
 (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]))
+  (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)
             (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)
+  (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))
   "The actor's rotation relative to its parent."
   (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))
   "The actor's scale relative to its parent."
   (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))
   "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))
   "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)))

wh-engine/component.lisp

@@ -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)))
+  (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))
   "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."

wh-engine/main.lisp

@@ -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)
+                         (setf (o! a :slot scene) nil)
-                         [scene (add-actor a)]))
+                         (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]
+                         (when (o! a tree-active-p)
-                               [a (activate)])))
+                               (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
+    (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
                                      :name "Child Actor"
                                      :location (vec2 0 0.5)
                                      :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
                                           :name "Grandchild Actor"
                                           :location (vec2 0 1)
                                           :scale (vec2 0.25 0.25)
                                           :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
                                       :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)))
+        (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-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)
+                                  (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))
-                                  [view (render-view *world-drawables*)])))
+                                  (o! view (render-view *world-drawables*)))))
 
                    ;; now draw to window
                    (gl:bind-framebuffer :framebuffer 0)

wh-engine/package.lisp

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

wh-engine/render/drawable.lisp

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

wh-engine/render/view.lisp

@@ -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]
+  (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))
   "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]
+            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)
   "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]))
+  (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*))))
       (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))))

wh-engine/scene.lisp

@@ -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]
+  (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)
 
 (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 (o! this :slot actors) (delete actor (o! this :slot actors) :count 1))
-  (setf [actor :slot scene] nil)
+  (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]
+  (loop for actor in (o! this actors)
-        if (subsetp tags [actor tags])
+        if (subsetp tags (o! actor tags))
           collect actor))
 
 (defmethod update ((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))
   "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]
+          (loop for actor in (o! this actors)
-                do [actor (destroy)])
+                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]
+  (loop for actor in (o! this actors)
-        do [actor (resume)]))
+        do (o! actor (resume))))
 
 (defmethod suspend ((this scene))
   "Prepare this scene for serialization."
   ; Suspend actors
-  (loop for actor in [this actors]
+  (loop for actor in (o! this actors)
-        do [actor (suspend)]))
+        do (o! actor (suspend))))

wh-engine/serialization.lisp

@@ -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]
+       (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
-       (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))))
       )))
 
@@ -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])))
+                     (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"
-                                                    (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)]
+        (o! scene (destroy))
-        [scene (resume)])))
+        (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 (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)
   "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)))