204 lines
8.1 KiB
Common Lisp
204 lines
8.1 KiB
Common Lisp
;;;; wh-engine/serialization.lisp
|
|
(in-package wh-engine)
|
|
|
|
(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" (o! obj :slot id))))
|
|
(actor (gensym (format nil "A~a-G" (o! obj :slot id))))
|
|
(component (gensym (if (typep (o! obj :slot actor) 'id-ref)
|
|
(format nil "C~a-~a-G"
|
|
(id-ref-actor (o! 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 make-generic-load-form (obj &key environment)
|
|
"Make a generic load form that works for most objects."
|
|
(declare (ignore environment))
|
|
(values
|
|
;; cons form
|
|
`(allocate-instance (find-class ',(class-name (class-of obj))))
|
|
;; init form
|
|
(loop for slot in (sb-mop:class-slots (class-of obj))
|
|
for slot-name = (sb-mop:slot-definition-name slot)
|
|
nconc `((slot-value ,obj ',slot-name)
|
|
,(make-value-init-form (slot-value obj slot-name)))
|
|
into setfs
|
|
finally (return `(setf ,@setfs)))
|
|
))
|
|
|
|
(defun make-value-init-form (x)
|
|
(typecase x
|
|
;; One case for both T and NIL/()
|
|
(boolean x)
|
|
;; this will fail with circular lists. don't serialize circular lists.
|
|
(list (if (cdr (last x))
|
|
`(cons ,(make-value-init-form (car x))
|
|
,(make-value-init-form (cdr x)))
|
|
(cons 'list (loop for y in x collect (make-value-init-form y)))))
|
|
(symbol `(quote ,x))
|
|
(t 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))
|
|
|
|
(o! scene (suspend))
|
|
(prog1 (generate-load-forms scene :prune prune :nice-syms nice-syms)
|
|
(if destroy-after
|
|
(o! scene (destroy))
|
|
(o! scene (resume)))))
|
|
|
|
(defun collect-descendents (actor)
|
|
"Recursively collect actor and all its descendents."
|
|
(declare (type actor actor))
|
|
|
|
(cons actor
|
|
(loop for child in (o! actor children)
|
|
nconc (collect-descendents child))))
|
|
|
|
(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 (o! 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 (o! actor (destroy)))
|
|
(loop for actor in actors do (o! 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)
|
|
(o! scene (resume))
|
|
(loop for actor in (o! scene actors)
|
|
when (and (not (o! actor parent)) (o! actor active-p))
|
|
do (o! actor (activate)))
|
|
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 (o! actor (resume))
|
|
collect actor)))
|