wh-engine/wh-engine/serialization.lisp

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

(defstruct id-ref
  (scene 0 :type fixnum)
  (actor nil :type (or fixnum null))
  (component nil :type (or symbol null)))

(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)))
    (etypecase target
      (scene
       (make-id-ref :scene [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]))
      (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])))
                    :component (class-name (class-of target))))
      )))

(defun pointerize (ref)
  "Convert id-ref ref into a weak-pointer."
  (declare (type id-ref ref))

  (let ((scene (get-scene (id-ref-scene ref))) actor component)
    (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 (id-ref-component ref)
                (if (setf component [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))
            (error "can't pointerize ~S (actor not found)" ref))
        (make-weak-pointer scene))))

(defmacro referize-setf (place)
  `(when (typep ,place 'weak-pointer)
     (setf ,place (referize ,place))))
(defmacro pointerize-setf (place)
  `(when (typep ,place 'id-ref)
     (setf ,place (pointerize ,place))))

(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" [obj :slot id])))
                     (actor (gensym (format nil "A~a-G" [obj :slot id])))
                     (component (gensym (if (typep [obj :slot actor] 'id-ref)
                                            (format nil "C~a-~a-G"
                                                    (id-ref-actor [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 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))

  [scene (suspend)]
  (prog1 (generate-load-forms scene :prune prune :nice-syms nice-syms)
    (if destroy-after
        [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 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 [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)])))
    ))

(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)]
    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 [actor (resume)]
          collect actor)))