;;;; 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)
  (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))
          (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)
  (multiple-value-bind (cons-form init-form)
      (make-load-form obj)
    (let ((sym (gensym))
          (output-cons-forms ())
          (output-init-forms ()))
      (setf (gethash obj table) sym)
      (setf init-form
            (copy-replace-tree init-form
                               (lambda (x)
                                 (cond
                                   ;; x has already been processed
                                   ((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))
                                    (multiple-value-bind (x-cons-forms x-init-forms x-sym)
                                        (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))))
      (when init-form
        (setf output-init-forms (nconc output-init-forms `(,init-form))))
      (values output-cons-forms output-init-forms sym))))

(defun generate-load-forms (obj)
  (multiple-value-bind (cons-forms init-forms sym)
      (process-load-forms obj (make-hash-table :test #'eq))
    `(let ,cons-forms
       ,@init-forms
       ,sym)))