112 lines
4.5 KiB
Common Lisp
112 lines
4.5 KiB
Common 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)
|
|
(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)))
|
|
|