219 lines
8.5 KiB
Common Lisp
219 lines
8.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))
|
|
|
|
(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 [target scene id]
|
|
:actor [target id]))
|
|
(component
|
|
(make-id-ref :scene [target scene id]
|
|
:actor [target actor id]
|
|
: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 (append 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)])))
|
|
))
|