keith/wh-engine
1
0
Fork 0
Code Issues 6 Pull requests Projects Releases Wiki Activity

Fix issue with (process-load-forms) overwriting slot values, error checking on (referize) and (pointerize) (for #3)

Browse source
This commit is contained in:
~keith 2021-12-15 14:54:33 +00:00
parent 01b787e7bf
commit 67d6fe13b2
Signed by: keith
GPG key ID: 5BEBEEAB2C73D520
5 changed files with 102 additions and 60 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
wh-engine/actor.lisp
View file

@ -72,6 +72,9 @@
:initform (meye 3)))
(:documentation "Base class for entities in the game."))
(defmethod make-load-form ((this actor) &optional environment)
(make-load-form-saving-slots this :environment environment))
(defmethod scene ((this actor))
"The scene containing this actor."
(deref-pointer [this :slot scene]))
@ -185,11 +188,11 @@
(defmethod resume ((this actor))
"Initialize or restore this actor's state."
; Restore self
(resume-setf [this :slot scene])
(resume-setf [this :slot parent])
(pointerize-setf [this :slot scene])
(pointerize-setf [this :slot parent])
(loop for entry on [this :slot children]
when (typep (car entry) 'id-ref)
do (rplaca entry (resume-ptr (car entry))))
do (rplaca entry (pointerize (car entry))))
; Restore components
(loop for component in [this components]
do [component (resume)]))
@ -202,9 +205,9 @@
; Suspend self
(loop for entry on [this :slot children]
when (typep (car entry) 'weak-pointer)
do (rplaca entry (suspend-ptr (car entry))))
(suspend-setf [this :slot scene])
(suspend-setf [this :slot parent]))
do (rplaca entry (referize (car entry))))
(referize-setf [this :slot scene])
(referize-setf [this :slot parent]))
(defmethod update ((this actor))
"Update this actor's components."

11
wh-engine/component.lisp
View file

@ -17,6 +17,9 @@
:initform nil))
(:documentation "Base class for components attached to game entities."))
(defmethod make-load-form ((this component) &optional environment)
(make-load-form-saving-slots this :environment environment))
(defmethod actor ((this component))
"The actor this component belongs to."
(deref-pointer [this :slot actor]))
@ -61,8 +64,8 @@
when (and (eq (sb-mop:slot-definition-allocation slot) :instance)
(slot-boundp this slot-name))
do (let ((value (slot-value this slot-name)))
(when (typep value id-ref)
(setf (slot-value this slot-name) (resume-ptr value))))
(when (typep value 'id-ref)
(setf (slot-value this slot-name) (pointerize value))))
))
(defmethod suspend ((this component))
@ -71,8 +74,8 @@
for slot-name = (sb-mop:slot-definition-name slot)
when (slot-boundp this slot-name)
do (let ((value (slot-value this slot-name)))
(when (typep value weak-pointer)
(setf (slot-value this slot-name) (suspend-ptr value))))
(when (typep value 'weak-pointer)
(setf (slot-value this slot-name) (referize value))))
))
(defmethod start ((this component))

5
wh-engine/package.lisp
View file

@ -21,8 +21,8 @@
;; serialization.lisp
id-ref make-id-ref
pointer
suspend-ptr resume-ptr
suspend-setf resume-setf
referize pointerize
referize-setf pointerize-setf
generate-load-forms
;; actor.lisp
@ -70,6 +70,7 @@
get-actor get-tagged-actors
update
destroy
resume suspend
;; render/drawable.lisp
drawable

15
wh-engine/scene.lisp
View file

@ -22,6 +22,9 @@
:initform nil))
(:documentation "A scene containing game entities."))
(defmethod make-load-form ((this scene) &optional environment)
(make-load-form-saving-slots this :environment environment))
(defmethod print-object ((this scene) stream)
(print-unreadable-object (this stream :type t :identity t)
(prin1 [this :slot id] stream)
@ -68,3 +71,15 @@
do [actor (destroy)])
(remove-scene this))
(setf [this :slot destroyed-p] t))
(defmethod resume ((this scene))
"Initialize or restore this scene's state."
; Restore actors
(loop for actor in [this actors]
do [actor (resume)]))
(defmethod suspend ((this scene))
"Prepare this scene for serialization."
; Suspend actors
(loop for actor in [this actors]
do [actor (suspend)]))

116
wh-engine/serialization.lisp
View file

@ -8,34 +8,47 @@
(deftype pointer () '(or id-ref weak-pointer null))
(defun suspend-ptr (ptr)
"Convert weak-pointer ptr to an id-ref."
(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 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 resume-ptr (ref)
"Convert id-ref ref to a weak-pointer."
(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)
(if (setf actor [scene (get-actor (id-ref-actor ref))])
(if (setf component [actor (get-component (find-class (id-ref-component ref)))])
(make-weak-pointer component)
(make-weak-pointer actor))
(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)
@ -45,29 +58,48 @@
(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) (cons sym cons-form))
(replace-in-tree init-form (lambda (x)
(cond
; x has already been processed
((gethash x table)
(car (gethash x table)))
; 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))
(setf output-init-forms (nconc output-init-forms x-init-forms))
x-sym))
; x is a type that doesn't need processing
(t x))))
(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))))
(setf output-init-forms (nconc output-init-forms `(,init-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)
@ -77,15 +109,3 @@
,@init-forms
,sym)))
(defun serialize-instance (obj)
"Serialize obj into a Lisp expression that evaluates back to it."
(let ((obj-sym (gensym)) forms)
(setf forms `(let ((,obj-sym (make-instance ',(class-name (class-of obj)))))))
))
(defmacro suspend-setf (place)
`(when (typep ,place 'weak-pointer)
(setf ,place (suspend-ptr ,place))))
(defmacro resume-setf (place)
`(when (typep ,place 'id-ref)
(setf ,place (resume-ptr ,place))))