;;;; wh-engine/serialization.lisp
(in-package wh-engine)

(defun replace-in-tree (tree atom-fun)
  (if (consp (car tree))
      (replace-in-tree (car tree) atom-fun)
      (rplaca tree (funcall atom-fun (car tree))))
  (if (consp (cdr tree))
      (replace-in-tree (cdr tree) atom-fun)
      (rplacd tree (funcall atom-fun (cdr tree))))
  tree)

(defun copy-replace-tree (tree atom-fun)
  (let ((new-car (car tree)) (new-cdr (cdr tree)))
    (if (consp new-car)
        (setf new-car (copy-replace-tree new-car atom-fun))
        (setf new-car (funcall atom-fun new-car)))
    (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)))

(defun process-load-forms (obj table &key (nice-syms nil))
  "Update table with the forms necessary to generate obj."
  (multiple-value-bind (cons-form init-form)
      (make-load-form obj)
    (let ((sym (if nice-syms
                   (typecase obj
                     (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 (o! obj :slot actor)) (class-name (class-of obj)))
                                            (format nil "C-~a-G" (class-name (class-of obj))))))
                     (t (gensym)))
                   (gensym))))
      (setf (gethash obj table) (cons sym (cons cons-form nil)))
      (when init-form
        (setf init-form
              (copy-replace-tree init-form
                                 (lambda (x)
                                   (cond
                                     ;; x has already been processed
                                     ((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)
                                                    :actor ,(id-ref-actor x)
                                                    :component ,(id-ref-component x)))
                                     ;; x needs to be run through process-load-forms
                                     ((typep x '(or standard-object structure-object condition class))
                                      (process-load-forms x table :nice-syms nice-syms))
                                     ;; x doesn't need processing
                                     (t x)))))
        (setf (gethash obj table) (cons sym (cons cons-form init-form))))
      sym)))

(defun apply-in-tree (tree atom-fun)
  "Run atom-fun on everything in tree. Stop if atom-fun returns nil."
  (when tree
    (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 make-generic-load-form (obj &key environment)
  "Make a generic load form that works for most objects."
  (declare (ignore environment))
  (values
   ;; cons form
   `(allocate-instance (find-class ',(class-name (class-of obj))))
   ;; init form
   (loop for slot in (sb-mop:class-slots (class-of obj))
         for slot-name = (sb-mop:slot-definition-name slot)
         nconc `((slot-value ,obj ',slot-name)
                 ,(make-value-init-form (slot-value obj slot-name)))
           into setfs
         finally (return `(setf ,@setfs)))
   ))

(defun make-value-init-form (x)
  (typecase x
    ;; One case for both T and NIL/()
    (boolean x)
    ;; this will fail with circular lists. don't serialize circular lists.
    (list (if (cdr (last x))
              `(cons ,(make-value-init-form (car x))
                     ,(make-value-init-form (cdr x)))
              (cons 'list (loop for y in x collect (make-value-init-form y)))))
    (symbol `(quote ,x))
    (t x)))

(defun generate-load-forms (obj &key (prune t) (nice-syms nil))
  "Generate code that restores the current state of obj."
  (declare (type boolean prune nice-syms))

  (let ((table (make-hash-table :test #'eq))
        sym init-forms)
    ;; serialize
    (setf sym (process-load-forms obj table :nice-syms nice-syms))
    ;; 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)
    ))

(defun dump-scene (scene &key (destroy-after t) (prune t) (nice-syms nil))
  "Suspend and serialize scene."
  (declare (type scene scene))
  (declare (type boolean destroy-after prune nice-syms))

  (o! scene (suspend))
  (prog1 (generate-load-forms scene :prune prune :nice-syms nice-syms)
    (if destroy-after
        (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 in (o! actor children)
              nconc (collect-descendents child))))

(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 boolean destroy-after prune nice-syms))

  ;; Collect children so we serialize them as well
  (let ((all-actors (loop for actor in actors
                          nconc (collect-descendents actor))))
    ;; Suspend
    (loop for actor in actors
          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 (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)
    (o! scene (resume))
    (loop for actor in (o! scene actors)
          when (and (not (o! actor parent)) (o! actor active-p))
            do (o! actor (activate)))
    scene))

(defun load-resume-actors (actor-forms)
  "Load and resume the actors saved in actor-forms."
  (let ((actors (loop for actor-form in actor-forms
                      collect (eval actor-form))))
    (loop for actor in actors
          do (o! actor (resume))
          collect actor)))