Fix (dump-actors) child serialization and destruction (for #5)

wh-engine/actor.lisp

@@ -77,11 +77,11 @@
 
 (defmethod scene ((this actor))
   "The scene containing this actor."
-  (deref-pointer [this :slot scene]))
+  (deref-sus-pointer [this :slot scene]))
 
 (defmethod parent ((this actor))
   "This actor's parent."
-  (deref-pointer [this :slot parent]))
+  (deref-sus-pointer [this :slot parent]))
 
 (defmethod tree-active-p ((this actor))
   "Whether or not this actor and all its parents are active."
@@ -120,7 +120,7 @@
   "Remove a child from this object."
   (unless (eq [child parent] this)
     (error "~S is not a child of ~S" child this))
-  (setf [this :slot children] (remove child [this :slot children] :key #'weak-pointer-value))
+  (setf [this :slot children] (delete child [this :slot children] :key #'deref-sus-pointer :count 1))
   (setf [child :slot parent] nil)
   [child (parent-changed)]
   child)
@@ -195,17 +195,25 @@
           do (rplaca entry (pointerize (car entry))))
   ; Restore components
   (loop for component in [this components]
-        do [component (resume)]))
+        do [component (resume)])
+  ; Restore children
+  (loop for child-ptr in [this children]
+        for child = (weak-pointer-value child-ptr)
+        do [child (resume)]))
 
 (defmethod suspend ((this actor))
   "Prepare this actor for serialization."
+  ; Suspend children
+  (loop for child-ptr in [this children]
+        for child = (weak-pointer-value child-ptr)
+        do [child (suspend)])
   ; Suspend components
   (loop for component in [this components]
         do [component (suspend)])
   ; Suspend self
-  (loop for entry on [this :slot children]
-        when (typep (car entry) 'weak-pointer)
-          do (rplaca entry (referize (car entry))))
+  (loop for child-cell on [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]))
 
@@ -231,7 +239,7 @@
           (when [this parent]
                 [this parent (remove-child this)])
           (loop for child-ptr in [this children]
-                for child = (weak-pointer-value child-ptr)
+                for child = (deref-sus-pointer child-ptr)
                 do [child (destroy)])
           (when [this scene]
                 [this scene (remove-actor this)]))

wh-engine/component.lisp

@@ -22,7 +22,7 @@
 
 (defmethod actor ((this component))
   "The actor this component belongs to."
-  (deref-pointer [this :slot actor]))
+  (deref-sus-pointer [this :slot actor]))
 
 (defmethod scene ((this component))
   "The scene this component belongs to."

wh-engine/main.lisp

@@ -25,6 +25,7 @@
 (declaim (inline deref-pointer))
 (defun deref-pointer (ptr)
   "Dereference ptr if it's non-nil."
+  (declare (type (or weak-pointer null) ptr))
   (when ptr (weak-pointer-value ptr)))
 
 (defun points-to (ptr obj)
@@ -71,6 +72,7 @@
 (defun fixed-id (id)
   "Ensure the given ID won't be returned by make-id."
   (declare (type fixnum id))
+
   (when (>= id *id-counter*)
     (setq *id-counter* (+ id 1)))
   id)
@@ -117,7 +119,7 @@
   "List of all known views.")
 
 (defun register-test-scene ()
-  (let (test-scene test-actor test-drawable test-actor-2 camera-actor camera-view)
+  (let (test-scene test-actor test-drawable test-actor-2 camera-actor camera-view child-actor)
     (setf test-scene (make-instance 'scene
                                     :id -1
                                     :name "Test scene"))
@@ -141,9 +143,19 @@
                                                 :colour (vec4 0.0 1.0 0.0 1.0)))
     ]
 
+    (setf child-actor (make-instance 'actor
+                                     :name "Child Actor"
+                                     :location (vec2 0.0 0.5)
+                                     :z-layer -2))
+    [test-scene (add-actor child-actor)]
+    [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)))
+    ]
+
     (setf camera-actor (make-instance 'actor
-                                      :name "Camera"
-                                      :rotation (coerce (/ pi -4) 'single-float)))
+                                      :name "Camera"))
     [test-scene (add-actor camera-actor)]
 
     (setf camera-view (make-instance 'view))

wh-engine/package.lisp

@@ -21,9 +21,11 @@
    ;; serialization.lisp
    id-ref make-id-ref
    pointer
+   deref-sus-pointer
    referize pointerize
    referize-setf pointerize-setf
    generate-load-forms
+   dump-scene dump-actors
 
    ;; actor.lisp
    actor

wh-engine/scene.lisp

@@ -43,7 +43,7 @@
   "Remove an actor from this scene."
   (unless (eq [actor scene] this)
     (error "~S is not in scene ~S" actor this))
-  (setf [this :slot actors] (remove actor [this :slot actors] :key #'weak-pointer-value))
+  (setf [this :slot actors] (delete actor [this :slot actors] :count 1))
   (setf [actor :slot scene] nil)
   actor)
 

wh-engine/serialization.lisp

@@ -8,12 +8,23 @@
 
 (deftype pointer () '(or id-ref weak-pointer null))
 
+(declaim (inline deref-sus-pointer))
+(defun deref-sus-pointer (val)
+  "Dereference val, and warn if it's suspended."
+  (declare (type pointer val))
+  (etypecase val
+    (weak-pointer (weak-pointer-value val))
+    (id-ref (warn "dereferencing sus pointer:~%~S" val)
+     (weak-pointer-value (pointerize val)))
+    (null nil)))
+
+
 (defun referize (ptr)
   "Convert weak-pointer ptr into an id-ref."
   (declare (type weak-pointer ptr))
 
   (let ((target (weak-pointer-value ptr)))
-    (typecase target
+    (etypecase target
       (scene
        (make-id-ref :scene [target id]))
       (actor
@@ -23,7 +34,7 @@
        (make-id-ref :scene [target scene id]
                     :actor [target actor id]
                     :component (class-name (class-of target))))
-      (t (error "can't referize ~S (not an actor, component, or scene)" ptr)))))
+      )))
 
 (defun pointerize (ref)
   "Convert id-ref ref into a weak-pointer."
@@ -176,17 +187,32 @@
         [scene (destroy)]
         [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]
+              nconc (collect-descendents (weak-pointer-value child-ptr)))))
+
 (defun dump-actors (actors &key (destroy-after t) (prune t) (nice-syms nil))
   "Suspend and serialize actors."
-  (declare (type (proper-list actor) actors))
+  ;(declare (type (proper-list actor) actors))
   (declare (type boolean destroy-after prune nice-syms))
 
-  (loop for actor in actors
-        collect
-        (prog2
-            ;; FIXME Children are destroyed with actor, but not serialized with it
-            [actor (suspend)]
-            (generate-load-forms actor :prune prune :nice-syms nice-syms)
-            (if destroy-after
-                [actor (destroy)]
-                [actor (resume)]))))
+  ;; Collect children so we serialize them as well
+  (let ((all-actors (append actors
+                            (loop for actor in actors
+                                  nconc (collect-descendents actor)))))
+    ;; Suspend
+    (loop for actor in actors
+          do [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)])))
+    ))