;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: LAPIDARY; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; -*- Mode: Lisp; Package: LAPIDARY -*-
;;;
;;; This file provides the functions that handle the action buttons
;;; in the interactor menus
;;;

#|
==============================================================================
Change log:
    08/25/92: Andrew Mickish - Removed declare ignore of value in
               Write-Interactor  
    07/06/92: Brad Vander Zanden -- changed set-interactor-slots so that
               it sees the name field of an interactor when the user changes
               the name
==============================================================================
|#

 (in-package "LAPIDARY" :use '("LISP" "KR"))

(defun get-start-where (queue inter)
  (let ((start-where (assoc :start-where queue)))
    (if start-where
	(cdr start-where)
        (g-value inter :start-where))))

;;;=================================================================
;;;
;;; is this interactor a garnet defined interactor?
;;;
;;;=================================================================

(defun garnet-inter-p (inter)
  (or (eq inter lapidary-button-interactor)
      (eq inter lapidary-menu-interactor)
      (eq inter lapidary-text-interactor)
      (eq inter directional-move-grow-interactor)
      (eq inter lapidary-angle-interactor)
      (eq inter lapidary-two-point-interactor)))

;;;=================================================================
;;;
;;; is this interactor a choice interactor?
;;;
;;;=================================================================

(defun choice-inter-p (inter)
  (or (eq inter lapidary-button-interactor)
      (eq inter lapidary-menu-interactor)
      (is-a-p inter lapidary-button-interactor)
      (is-a-p inter lapidary-menu-interactor)))

;;;=================================================================
;;;
;;; iterate through the list of slot-value pairs and store the 
;;; values in the correct slots of the interactor
;;;
;;;=================================================================
#|
(defun set-interactor-slots (inter slot-list)

  (dolist (slot-value (reverse slot-list))
    (let ((slot (car slot-value))
	  (value (cdr slot-value)))

      ;; note--slot may be saved more than once but this restoring
      ;; it twice during undo shouldn't be a problem
        ; (undo-save inter slot)

	;; perform slot specific processing
	(case slot
	  ;; destroy the old link to this interactor and create a 
	  ;; new one based on its new name (its new name will be
	  ;; a string so it must be converted to a keyword)
	  (:known-as (let ((operates-on (g-value inter :operates-on)))
		       (when operates-on
			 (destroy-slot operates-on (g-value inter :known-as))
			 (s-value operates-on value inter))
		       (s-value inter :known-as value)
		       
		       ;; change the kr name of this object to the new name
		       (setf (kr::schema-name inter) 
			     (read-from-string (symbol-name value)))
		       ))
	  (:feedback
	   ;; insert list of formulas created in by-demo operation
	   ;; into the objects that this interactor can operate on;
	   ;; if the installation succeeds, set the feedback-obj slot
	   ;; to nil
	   (if (install-by-demo-formulas
		(get-start-where slot-list inter) value)
	       (progn
		 ; (undo-save inter :feedback-obj)
		 (s-value inter :feedback-obj nil))))
	  (:feedback-obj 
	   (destroy-constraint inter :feedback-obj)
	   (cond ((null value)
		   (when (is-a-p inter lapidary-two-point-interactor)
			 (s-value inter :std-feedback-p nil))
		   (s-value inter :feedback-obj nil))
		 ((equal value "standard")
		  (s-value inter :std-feedback-p t)
		  (s-value inter :feedback-obj (o-formula (if (gvl :line-p)
						    (gvl :std-line-feedback)
						    (gvl :std-box-feedback)))))
		 ((eq value :constraint)
		  (when (is-a-p inter lapidary-two-point-interactor)
			(s-value inter :std-feedback-p nil)))
		 (value
		  (cond ((or (is-a-p inter lapidary-menu-interactor)
			     (is-a-p inter lapidary-button-interactor))
			 (create-feedback-obj value slot-list inter))
			;; feedback for move-grow and two-point interactors 
			;; must have constraints to the :box or :points slots
			((or (is-a-p inter lapidary-two-point-interactor)
			     (is-a-p inter lapidary-text-interactor)
			     (is-a-p inter directional-move-grow-interactor))
			 (if (is-a-line-p value)
			     (progn
			       (s-value value :points
					(list (g-value value :x1)
					      (g-value value :y1)
					      (g-value value :x2)
					      (g-value value :y2)))
			       (s-value value :x1 
					(o-formula (first (gvl :points))))
			       (s-value value :y1 
					(o-formula (second (gvl :points))))
			       (s-value value :x2 
				      (o-formula (third (gvl :points))))
			       (s-value value :y2 
					(o-formula (fourth (gvl :points)))))
			     (progn
			       (s-value value :box
					(list (g-value value :left)
					      (g-value value :top)
					      (g-value value :width)
					      (g-value value :height)))
			       (s-value value :left
					(o-formula (first (gvl :box))))
			       (s-value value :top
					(o-formula (second (gvl :box))))
			       (when (or (is-a-p inter lapidary-two-point-interactor)
					 (is-a-p inter directional-move-grow-interactor))
				     (s-value value :width
					      (o-formula (third (gvl :box))))
				     (s-value value :height
					      (o-formula (fourth (gvl :box)))))))
			 (s-value inter :std-feedback-p nil)

			 ;; mark the object as a feedback-object
			 (s-value value :feedback-p t)

			 ;; get rid of the inherited visibility formula, set
			 ;; the visible slot to nil, then install a formula 
			 ;; that sets the visible slot depending on whether 
			 ;; lapidary is in build or test mode (done by 
			 ;; save-value)
			 (destroy-constraint value :visible)
			 (s-value value :visible (o-formula (gvl :obj-over)))
			 (save-value value :visible t)))
	
		  (s-value inter :feedback-obj value))
		 (t (s-value inter :feedback-obj nil))))
	  (:final-feedback-obj
	   (cond ((null value)
		  (s-value inter :final-feedback-obj nil))
		 (value
		  (create-feedback-obj value slot-list inter)
		  (s-value inter :final-feedback-obj value))
		 (t (s-value inter :final-feedback-obj nil)))
	   (s-value inter :final-feed-inuse nil)
	   (s-value inter :final-feed-avail nil))
	  (:obj-to-change
	   (cond ((null value)
		  (s-value inter :obj-to-change nil))
		 (t nil)))
	  (:grow-p
	   (cond ((null value)
		  (s-value inter :grow-p nil))
		 (t (s-value inter :grow-p value))))
	  (:line-p
	   (cond ((null value)
		  (s-value inter :line-p nil))
		 (t (s-value inter :line-p value))))
	  (:move-box-parms
	   (cond ((eq value :constraint) 
		  ; do nothing
		  nil)
		 (t (s-value inter :move-box-parms value))))
	  (:grow-box-parms
	   (cond ((eq value :constraint)
		  ; do nothing
		  nil)
		 (t (s-value inter :grow-box-parms value))))
	  (:center-of-rotation
	   ; (undo-save inter :attach-point)
	   (cond ((and (listp value) (numberp (car value)))
		  (s-value inter :center-of-rotation value)
		  (s-value inter :attach-point :pair))
		 ((eq value :constraint)
		  (s-value inter :attach-point :formula))
		 (t
		  (s-value inter :attach-point value)
		  (case value
			(:nw (o-formula (list (gvl :obj :left) 
					      (gvl :obj :top))))
			(:n (o-formula (list (opal:gv-center-x (gvl :obj)) 
					     (gvl :obj :top))))
			(:ne (o-formula (list (opal:gv-right (gvl :obj)) 
					      (gvl :obj :top))))
			(:w (o-formula (list (gvl :obj :left) 
					     (opal:gv-center-y (gvl :obj)))))
			(:c (o-formula (list (opal:gv-center-x (gvl :obj)) 
					     (opal:gv-center-y (gvl :obj)))))
			(:e (o-formula (list (opal:gv-right (gvl :obj))
					     (opal:gv-center-y (gvl :obj)))))
			(:sw (o-formula (list (gvl :obj :left) 
					      (opal:gv-bottom (gvl :obj)))))
			(:s (o-formula (list (opal:gv-center-x (gvl :obj)) 
					     (opal:gv-bottom (gvl :obj)))))
			(:se (o-formula (list (opal:gv-right (gvl :obj))
					      (opal:gv-bottom (gvl :obj)))))
			(:x1 (o-formula (list (gvl :obj :x1) (gvl :obj :y1))))
			(:line-c (o-formula (list (opal:gv-center-x (gvl :obj))
						  (opal:gv-center-y (gvl :obj)))))
			(:x2 (o-formula (list (gvl :obj :x2) 
					      (gvl :obj :y2))))))))
	  (:attach-point
	   (cond ((eq value :constraint)
		  ;; do nothing
		  nil)
		 (t
		  (s-value inter :attach-point value))))
	;; default-case: set the slot with its new value
	  (t (s-value inter slot value))))))
|#

(defun set-interactor-slots (inter slot-list)

  (dolist (slot-value (reverse slot-list))
    (let ((slot (car slot-value))
	  (value (cdr slot-value)))

      ;; note--slot may be saved more than once but this restoring
      ;; it twice during undo shouldn't be a problem
;        (undo-save inter slot)

	;; perform slot specific processing
	(case slot
	  ;; destroy the old link to this interactor and create a 
	  ;; new one based on its new name (its new name will be
	  ;; a string so it must be converted to a keyword)
	  (:known-as (let ((operates-on (g-value inter :operates-on)))
		       (when operates-on
			 (destroy-slot operates-on (g-value inter :known-as))
			 (s-value operates-on value inter))
		       (s-value inter :known-as value)
		       
		       ;; change the kr name of this object to the new name
		       (setf (kr::schema-name inter) 
			     (read-from-string (symbol-name value)))
		       ))
	  (:feedback
	   ;; insert list of formulas created in by-demo operation
	   ;; into the objects that this interactor can operate on;
	   ;; if the installation succeeds, set the feedback-obj slot
	   ;; to nil
	   (if (install-by-demo-formulas
		(get-start-where slot-list inter) value)
	       (progn
;		 (undo-save inter :feedback-obj)
		 (s-value inter :feedback-obj nil))))
	  (:feedback-obj 
	   (destroy-constraint inter :feedback-obj)
	   (cond ((null value)
		   (when (is-a-p inter lapidary-two-point-interactor)
			 (s-value inter :std-feedback-p nil))
		   (s-value inter :feedback-obj nil))
		 ((equal value "standard")
		  (s-value inter :std-feedback-p t)
		  (s-value inter :feedback-obj (o-formula (if (gvl :line-p)
						    (gvl :std-line-feedback)
						    (gvl :std-box-feedback)))))
		 ((listp value)
		  (install-inter-formula inter slot-value)
		  (when (is-a-p inter lapidary-two-point-interactor)
			(s-value inter :std-feedback-p nil)))
		 (value
		  (cond ((or (is-a-p inter lapidary-menu-interactor)
			     (is-a-p inter lapidary-button-interactor))
			 (create-feedback-obj value slot-list inter))
			;; feedback for move-grow and two-point interactors 
			;; must have constraints to the :box or :points slots
			((or (is-a-p inter lapidary-two-point-interactor)
			     (is-a-p inter lapidary-text-interactor)
			     (is-a-p inter directional-move-grow-interactor))
			 (if (is-a-line-p value)
			     (progn
			       (s-value value :points
					(list (g-value value :x1)
					      (g-value value :y1)
					      (g-value value :x2)
					      (g-value value :y2)))
			       (s-value value :x1 
					(o-formula (first (gvl :points))))
			       (s-value value :y1 
					(o-formula (second (gvl :points))))
			       (s-value value :x2 
				      (o-formula (third (gvl :points))))
			       (s-value value :y2 
					(o-formula (fourth (gvl :points)))))
			     (progn
			       (s-value value :box
					(list (g-value value :left)
					      (g-value value :top)
					      (g-value value :width)
					      (g-value value :height)))
			       (s-value value :left
					(o-formula (first (gvl :box))))
			       (s-value value :top
					(o-formula (second (gvl :box))))
			       (when (or (is-a-p inter lapidary-two-point-interactor)
					 (is-a-p inter directional-move-grow-interactor))
				     (s-value value :width
					      (o-formula (third (gvl :box))))
				     (s-value value :height
					      (o-formula (fourth (gvl :box)))))))
			 (s-value inter :std-feedback-p nil)

			 ;; mark the object as a feedback-object
			 (s-value value :feedback-p t)

			 ;; get rid of the inherited visibility formula, set
			 ;; the visible slot to nil, then install a formula 
			 ;; that sets the visible slot depending on whether 
			 ;; lapidary is in build or test mode (done by 
			 ;; save-value)
			 (destroy-constraint value :visible)
			 (s-value value :visible (o-formula (gvl :obj-over)))
			 (save-value value :visible t)))
	
		  (s-value inter :feedback-obj value))
		 (t (s-value inter :feedback-obj nil))))
	  (:final-feedback-obj
	   (cond ((null value)
		  (s-value inter :final-feedback-obj nil))
		 (value
		  (create-feedback-obj value slot-list inter)
		  (s-value inter :final-feedback-obj value))
		 (t (s-value inter :final-feedback-obj nil)))
	   (s-value inter :final-feed-inuse nil)
	   (s-value inter :final-feed-avail nil))
	  (:obj-to-change
	   (cond ((null value)
		  (s-value inter :obj-to-change nil))
		 ((listp value)
		  (install-inter-formula inter slot-value))
		 (t nil)))
	  (:grow-p
	   (cond ((null value)
		  (s-value inter :grow-p nil))
		 ((listp value)
		  (install-inter-formula inter slot-value))
		 (t (s-value inter :grow-p value))))
	  (:line-p
	   (cond ((null value)
		  (s-value inter :line-p nil))
		 ((listp value)
		  (install-inter-formula inter slot-value))
		 (t (s-value inter :line-p value))))
	  (:move-box-parms
	   (cond ((and (car value)
		       (or (formula-p (car value)) (listp (car value))))
		  (install-inter-formula inter slot-value))
		 (t (s-value inter :move-box-parms value))))
	  (:grow-box-parms
	   (cond ((and (car value)
		       (or (formula-p (car value)) (listp (car value))))
		  (install-inter-formula inter slot-value))
		 (t (s-value inter :grow-box-parms value))))
	  (:center-of-rotation
;	   (undo-save inter :attach-point)
	   (cond ((and (listp value) (numberp (car value)))
		  (s-value inter :center-of-rotation value)
		  (s-value inter :attach-point :pair))
		 ((listp value)
		  (install-inter-formula inter slot-value)
		  (s-value inter :attach-point :formula))
		 (t
		  (s-value inter :attach-point value)
		  (case value
			(:nw (o-formula (list (gvl :obj :left) 
					      (gvl :obj :top))))
			(:n (o-formula (list (opal:gv-center-x (gvl :obj)) 
					     (gvl :obj :top))))
			(:ne (o-formula (list (opal:gv-right (gvl :obj)) 
					      (gvl :obj :top))))
			(:w (o-formula (list (gvl :obj :left) 
					     (opal:gv-center-y (gvl :obj)))))
			(:c (o-formula (list (opal:gv-center-x (gvl :obj)) 
					     (opal:gv-center-y (gvl :obj)))))
			(:e (o-formula (list (opal:gv-right (gvl :obj))
					     (opal:gv-center-y (gvl :obj)))))
			(:sw (o-formula (list (gvl :obj :left) 
					      (opal:gv-bottom (gvl :obj)))))
			(:s (o-formula (list (opal:gv-center-x (gvl :obj)) 
					     (opal:gv-bottom (gvl :obj)))))
			(:se (o-formula (list (opal:gv-right (gvl :obj))
					      (opal:gv-bottom (gvl :obj)))))
			(:x1 (o-formula (list (gvl :obj :x1) (gvl :obj :y1))))
			(:line-c (o-formula (list (opal:gv-center-x (gvl :obj))
						  (opal:gv-center-y (gvl :obj)))))
			(:x2 (o-formula (list (gvl :obj :x2) 
					      (gvl :obj :y2))))))))
	  (:attach-point
	   (cond ((listp value)
		  (install-inter-formula inter slot-value))
		 (t
		  (s-value inter :attach-point value))))
	;; default-case: set the slot with its new value
	  (t (s-value inter slot value))))))

;;;=================================================================
;;;
;;; changes a menu-interactor to a button-interactor or vice
;;; versa
;;;
;;;=================================================================

(defun change-interactor (inter is-a)
  (let ((new-inter (create-instance nil is-a
		     (:start-where (g-value inter :start-where))
		     (:lapidary-p t))))
    (doslots (slot inter)
      (unless (or (eq slot :is-a) (eq slot :generated-running-where))
	(let ((value (get-local-value inter slot)))
	  (s-value new-inter slot (if (formula-p value)
				      (kr::copy-formula value)
				      value)))))
    new-inter))

;;;=================================================================
;;;
;;; This function creates a new interactor and attaches it to
;;; the aggregadget in its start-where slot (if there is an aggregadget in
;;; its start-where slot)
;;;
;;;=================================================================

(defun create-interactor (gadget value)
  (declare (ignore value))
  (let* ((slot-value-list (symbol-value (g-value gadget :queue)))
	 (is-a (or (cdr (assoc :is-a slot-value-list)) 
		   (g-value gadget :inter)))
	 (start-where-pair (assoc :start-where slot-value-list))
	 (start-where (cdr start-where-pair))
	 new-inter type-restriction)
    (when (and (not start-where-pair)
	       (eq (g-value is-a :start-where) :not-supplied))
      (lapidary-error "start-where must be supplied")
      (return-from create-interactor nil))
;    (reset-undo)
    (setf new-inter (create-instance nil is-a
		      (:lapidary-p t)
		      (:start-where start-where)))
    

    ;; get the is-a slot off the slot-value-list if it is there
    (setf slot-value-list (delete :is-a slot-value-list :key #'car))
    
    ;; save this interactor in case it must be deleted by an undo operation
    (push new-inter *undo-added-obj-list*)
#|
    ;; create a formula in the interactor's :window slot that determines
    ;; which window(s) it operates over. save it in the save-values slot
    ;; and put a formula in the windows slot that makes the interactor
    ;; operate in lapidary windows
    (push (cons :window
	     (formula `(if (gvl :operates-on)
			    (gvl :operates-on :window)
			    (let ((start-where (gvl :start-where)))
			      (cond ((eq start-where t) t)
				    ((eq start-where nil) nil)
				    (t (case (first start-where)
				    ;; if the start-where is an element of an
				    ;; aggregate,
				    ;; return the aggregate's window
				     ((:in :in-box :in-but-not-on
					  :element-of :leaf-element-of 
					  :element-of-or-none
					  :leaf-element-of-or-none 
					  :check-leaf-but-return-element
					  :check-leaf-but-return-element-of-or-none)
				     (gv (second start-where) :window))
				    ;; if the start-where is a list of 
				    ;; objects, return the list of windows 
				    ;; that hold these objects
				    ;; (ignore the type argument)
				    ((:list-element-of 
				      :list-leaf-element-of
				      :list-element-of-or-none
				      :list-leaf-element-of-or-none
				      :list-check-leaf-but-return-element
				      :list-check-leaf-but-return-element-or-none)
				     (let ((window-list nil))
				       (dolist (obj (gv (second start-where)
							(third start-where)))
					 (let ((window (g-local-value obj :window)))
					   (when window
						 (pushnew window window-list))))
				       window-list))
				    (t nil))))))))
	  (g-value new-inter :save-values))
|#
    (s-value new-inter :window (o-formula (gv lapidary::*selection-info*
					      :window)))


    ;; determine if this interactor should belong to an aggregate
    (when (and (not (formula-p start-where))
	       (listp start-where)
	       (is-a-p (second start-where) opal:aggregate))
      (opal:add-interactor (second start-where) new-inter)
      ;; store a formula in the interactor's :start-where slot that makes
      ;; the aggregate part of the start where depend on the :operates-on slot
      (setf start-where (copy-list start-where))
      (setf (second start-where) '(gvl :operates-on))
      ;; if the start-where has a type restriction, shove a list
      ;; modifier in front of the type restriction if it is a list
      (when (and (setf type-restriction (member :type start-where))
		 (listp (second type-restriction)))
	    (push 'list (second type-restriction)))
      (s-value new-inter :start-where (formula `(list ,@start-where))))

    ;; set the :active slot of the interactor so that the interactor
    ;; only operates when lapidary is in test mode
    (s-value new-inter :active 
	     (formula `(not (gv lapidary::editor-menu :build-p))))

    ;; save a 't' value for :active in the :save-values portion of the 
    ;; interactor
    (push (cons :active t) (g-value new-inter :save-values))

    ;; set the interactor's slots
    (set-interactor-slots new-inter slot-value-list)
    (setf (symbol-value (g-value gadget :queue)) nil)

    ;; make the interactor menu point to this interactor
    (s-value (g-value gadget :window) :inter new-inter)
#|
    ;; special processing for the move/grow interactor
    (when (is-a-p new-inter inter:move-grow-interactor)
	  (set-up-box-slots new-inter slot-value-list))
|#
    ;; make the window disappear
    (if (is-a-p new-inter inter:move-grow-interactor)
	(s-value (g-value gadget :window :parent :parent) :visible nil)
        (s-value (g-value gadget :window) :visible nil))

    new-inter))

(defun modify-interactor (gadget value)
  (declare (ignore value))
  (let* ((inter (g-value gadget :inter))
	 (slot-value-list (symbol-value (g-value gadget :queue)))
         (is-a (assoc :is-a slot-value-list))
	 new-inter)

    ;; the basic interactors cannot be modified so make sure
    ;; that the user is not trying to modify one of them
    (when (garnet-inter-p inter)
      (lapidary-error "** cannot modify a garnet-defined interactor")
      (return-from modify-interactor))

    (when (and (choice-inter-p inter) is-a)
      (let ((operates-on (g-value inter :operates-on)))
	(setf new-inter (change-interactor inter (cdr is-a)))

	;; get the is-a slot off the slot-value-list if it is there
	(setf slot-value-list (delete :is-a slot-value-list :key #'car))

	;; save the new interactor in case it must be deleted by an undo
	;; operation
	(push new-inter *undo-added-obj-list*)

	;; save the changed interactor in case the user wants to undo
	;; this operation. 	
	(push inter *undo-deleted-obj-list*)
  
	;; remove the interactor from an aggregate if it belong to one
	(when operates-on
	      (opal:remove-interactor operates-on inter))

	;; save the :active slot of the interactor and the aggregate
	;; it used to belong to
	(s-value inter :undo-slots (cons operates-on 
					 (get-value inter :active)))
	
	;; deactivate the interactor
	(destroy-constraint inter :active)
	(inter:change-active inter nil)

	(s-value gadget :inter new-inter)
	(setf inter new-inter)))
      
    (set-interactor-slots inter slot-value-list)
    (setf (symbol-value (g-value gadget :queue)) nil)
#|
    ;; special processing for the move/grow interactor
    (when (is-a-p inter inter:move-grow-interactor)
	  (set-up-box-slots inter slot-value-list))
|#
    ;; make the window disappear
    (if (is-a-p inter inter:move-grow-interactor)
	(s-value (g-value gadget :window :parent :parent) :visible nil)
        (s-value (g-value gadget :window) :visible nil))

))

(defun cancel-interactor-changes (gadget value)
  (declare (ignore value))
  (let ((inter (g-value gadget :inter)))
    ;; discard the set of changes
    (setf (symbol-value (g-value gadget :queue)) nil)
    ;; reset the interactor menu to the old values of the interactor
;    (reset-inter-menu inter)
    ;; make the window disappear
    (if (is-a-p inter inter:move-grow-interactor)
	(s-value (g-value gadget :window :parent :parent) :visible nil)
        (s-value (g-value gadget :window) :visible nil))
))

(defun destroy-interactor (gadget value)
  (declare (ignore value))
  (let* ((inter (g-value gadget :inter))
	 (parent-inter (car (g-value inter :is-a))))
    ;; the basic interactors cannot be destroyed so make sure
    ;; that the user is not trying to destroy one of them
    (when (garnet-inter-p inter)
      (lapidary-error "** cannot destroy a garnet-defined interactor")
      (return-from destroy-interactor))

    ;; store the interactor's :is-a parent in the interactor menu
    (s-value (g-value gadget :window) :inter parent-inter)

    ;; reset the interactor menu so that it displays the information
    ;; associated with the interactor's :is-a parent
    (reset-inter-menu parent-inter)

    ;; reset the slot-value list to nil
    (setf (symbol-value (g-value gadget :queue)) nil)

    ;; destroy the interactor
    (opal:destroy inter)
    ;; make the window disappear
    (if (is-a-p parent-inter inter:move-grow-interactor)
	(s-value (g-value gadget :window :parent :parent) :visible nil)
        (s-value (g-value gadget :window) :visible nil))
))

(defun write-interactor (gadget value)
  (let ((inter (g-value gadget :inter)))
    ;; first create or modify the interactor, then write it out
    (if (garnet-inter-p inter)
	(setf inter (create-interactor gadget value))
	(modify-interactor gadget value))
    (s-value save-file :inter inter)
    ;; make the window disappearvalue gadget :window) :visible nil)
    (if (is-a-p inter inter:move-grow-interactor)
	(s-value (g-value gadget :window :parent :parent) :visible nil)
        (s-value (g-value gadget :window) :visible nil))

    (show-save-dialog nil nil)))

(defun display-interactor-properties (gadget value)
  (declare (ignore value))
  (multiple-value-bind (left top)
       (get-coordinates gadget)
       (c32 (g-value gadget :inter) nil nil :left left :top top)))

(defun read-interactor (gadget value)
  (declare (ignore gadget value))
  (let (file)
    (setf file (lapidary-prompt-for-input 
		"What is the name of the file that contains this interactor? "))
    (load file)
    ;; go through the list of created objects until we find an interactor and
    ;; then instantiate the proper interactor menu with information from this
    ;; interactor
    (dolist (obj *created-instances*)
      (when (is-a-p obj inter:interactor)
	(init-inter-menu obj)
	(return-from read-interactor)))
    (lapidary-error "This file did not contain any interactors")))
