From 67d6fe13b2896a1e4502be3cb96df2f59547fccf Mon Sep 17 00:00:00 2001 From: ~keith Date: Wed, 15 Dec 2021 14:54:33 +0000 Subject: [PATCH] Fix issue with (process-load-forms) overwriting slot values, error checking on (referize) and (pointerize) (for #3) --- wh-engine/actor.lisp | 15 +++-- wh-engine/component.lisp | 11 ++-- wh-engine/package.lisp | 5 +- wh-engine/scene.lisp | 15 +++++ wh-engine/serialization.lisp | 116 ++++++++++++++++++++--------------- 5 files changed, 102 insertions(+), 60 deletions(-) diff --git a/wh-engine/actor.lisp b/wh-engine/actor.lisp index abb7855..4d09fcd 100644 --- a/wh-engine/actor.lisp +++ b/wh-engine/actor.lisp @@ -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." diff --git a/wh-engine/component.lisp b/wh-engine/component.lisp index e508779..347991a 100644 --- a/wh-engine/component.lisp +++ b/wh-engine/component.lisp @@ -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)) diff --git a/wh-engine/package.lisp b/wh-engine/package.lisp index 79012a4..2128fd0 100644 --- a/wh-engine/package.lisp +++ b/wh-engine/package.lisp @@ -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 diff --git a/wh-engine/scene.lisp b/wh-engine/scene.lisp index 206992b..ac7a9e5 100644 --- a/wh-engine/scene.lisp +++ b/wh-engine/scene.lisp @@ -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)])) diff --git a/wh-engine/serialization.lisp b/wh-engine/serialization.lisp index e58dddd..b2b8bac 100644 --- a/wh-engine/serialization.lisp +++ b/wh-engine/serialization.lisp @@ -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))))