Prune symbols in serialized object code (for #4)

wh-engine/serialization.lisp

@@ -59,7 +59,6 @@
   tree)
 
 (defun copy-replace-tree (tree atom-fun)
-  (when tree
   (let ((new-car (car tree)) (new-cdr (cdr tree)))
     (if (consp new-car)
         (setf new-car (copy-replace-tree new-car atom-fun))
@@ -67,21 +66,22 @@
     (if (consp new-cdr)
         (setf new-cdr (copy-replace-tree new-cdr atom-fun))
         (setf new-cdr (funcall atom-fun new-cdr)))
-      (cons new-car new-cdr))))
+    (cons new-car new-cdr)))
 
 (defun process-load-forms (obj table)
+  "Update table with the forms necessary to generate obj."
   (multiple-value-bind (cons-form init-form)
       (make-load-form obj)
-    (let ((sym (gensym))
+    (let ((sym (gensym)))
-          (output-cons-forms ())
+      (setf (gethash obj table) (cons sym (cons cons-form nil)))
-          (output-init-forms ()))
+      (when init-form
-      (setf (gethash obj table) sym)
         (setf init-form
               (copy-replace-tree init-form
                                  (lambda (x)
                                    (cond
                                      ;; x has already been processed
-                                   ((gethash x table))
+                                     ((gethash x table)
+                                      (car (gethash x table)))
                                      ;; x is an id-ref, just serialize it like this
                                      ((typep x 'id-ref)
                                       `(make-id-ref :scene ,(id-ref-scene x)
@@ -89,23 +89,69 @@
                                                     :component ,(id-ref-component x)))
                                      ;; x needs to be run through process-load-forms
                                      ((typep x '(or standard-object structure-object condition class))
-                                    (multiple-value-bind (x-cons-forms x-init-forms x-sym)
+                                      (process-load-forms x table))
-                                        (process-load-forms x table)
-                                      (setf output-cons-forms (nconc output-cons-forms x-cons-forms))
-                                      (when x-init-forms
-                                        (setf output-init-forms (nconc output-init-forms x-init-forms)))
-                                      x-sym))
                                      ;; x doesn't need processing
                                      (t x)))))
-      (setf output-cons-forms (nconc output-cons-forms `((,sym ,cons-form))))
+        (setf (gethash obj table) (cons sym (cons cons-form init-form))))
-      (when init-form
+      sym)))
-        (setf output-init-forms (nconc output-init-forms `(,init-form))))
-      (values output-cons-forms output-init-forms sym))))
 
-(defun generate-load-forms (obj)
+(defun apply-in-tree (tree atom-fun)
-  (multiple-value-bind (cons-forms init-forms sym)
+  "Run atom-fun on everything in tree. Stop if atom-fun returns nil."
-      (process-load-forms obj (make-hash-table :test #'eq))
+  (when tree
-    `(let ,cons-forms
+    (if (if (consp (car tree))
+            (apply-in-tree (car tree) atom-fun)
+            (funcall atom-fun (car tree)))
+        (if (consp (cdr tree))
+            (apply-in-tree (cdr tree) atom-fun)
+            (funcall atom-fun (cdr tree)))
+        nil)
+    ))
+
+(defun prune-form-symbols (table init-forms)
+  "Replace symbols in init-forms with their cons-form from table if they're only referenced once."
+  (let ((count-table (make-hash-table)))
+    ;; collect symbols without an init-form
+    (loop for entry being each hash-value in table
+          using (hash-key key)
+          unless (cddr entry)
+            do (setf (gethash (car entry) count-table) (cons 0 key)))
+    ;; count occurences of prunable symbols
+    (apply-in-tree init-forms
+                   (lambda (x)
+                     (when (and (symbolp x) (gethash x count-table))
+                       (incf (car (gethash x count-table)) 1))
+                     t))
+    ;; replace symbols that occur exactly once
+    (replace-in-tree init-forms
+                     (lambda (x)
+                       (if (symbolp x)
+                           (let ((pair (gethash x count-table)))
+                             (if (and pair (= (car pair) 1))
+                                 (prog1
+                                     (cadr (gethash (cdr pair) table))
+                                   (remhash (cdr pair) table))
+                                 x))
+                           x)))
+    ))
+
+(defun generate-load-forms (obj &key (prune t))
+  "Generate code that restores the current state of obj."
+  (declare (type boolean prune))
+
+  (let ((table (make-hash-table :test #'eq))
+        sym init-forms)
+    ;; serialize
+    (setf sym (process-load-forms obj table))
+    ;; collect init-forms
+    (setf init-forms (loop for entry being each hash-value in table
+                           when (cddr entry)
+                             collect it))
+    ;; prune if requested
+    (when prune (setf init-forms (prune-form-symbols table init-forms)))
+    ;; generate final form
+    `(let ,(loop for entry being each hash-value in table
+                 ;; (sym cons-form)
+                 collect (list (car entry) (cadr entry)))
        ,@init-forms
-       ,sym)))
+       ,sym)
-
+    ))