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

(defun referize (ptr)
  "Convert weak-pointer ptr into an id-ref."
  (declare (type weak-pointer ptr))

  (let ((target (weak-pointer-value ptr)))
    (cond
      ((typep target 'scene)
       (make-id-ref :scene [target id]))
      ((typep target 'actor)
       (make-id-ref :scene [target scene id]
                    :actor [target id]))
      ((typep target 'component)
       (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."
  (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)
  "Update table with the forms necessary to generate obj."
  (multiple-value-bind (cons-form init-form)
      (make-load-form obj)
    (let ((sym (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))
                                     ;; 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))
  "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)
    ))