;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: GILT; 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Gilt is a simple interface builder for Garnet.  It lets a user
;;; construct a user interface by selecting gadgets in the gadget window
;;; and then drawing them in the work window.  The work window can be
;;; exercised and written out.
;;;
;;; Designed and implemented by Brad Myers

#|
============================================================
Change log:
   10/5/92  Andrew Mickish - In Create-New-Gadget, clear new object's :known-as
    9/1/92  Andrew Mickish - Removed defun of opal:convert-coordinates
    5/1/92  Andrew Mickish - Added with-constants-disabled in Fix-Known-As,
              added destroy of text-edit in do-stop.
    4/4/92  Brad Myers - fixed so control- doesn't work for selection
                         (required fixes to fix-all-interactors)
                       - fixed so items slot not shared for Motif.
    3/25/92 Andrew Mickish - Get-Local-Values ---> G-Local-Value
    3/25/92 Brad Myers - fix bugs with save.  :control-xxx
    3/04/92 Andrew Mickish - Bound kr::*constants-disabled* in Do-Read-File
    2/24/92 Andrew Mickish - Added :visible formula to *Text-Feedback-Obj*;
              Added mark-as-changed to Restore-Temp-Value
    2/21/92 Andrew Mickish - Fixed To-Bottom-Func to look at first component
    2/7/92  Brad Myers - fixed for constant slots
    2/5/92  Ed Pervin - Made control characters :control-* for CMUCL
    7/16/91 Andrew Mickish - Changed LinepForm so objects don't need a
                             :gilt-type slot
    5/15/91 Andrew Mickish - Added probe-file checks to Do-Read-File and
                             Do-Save-File
    4/14/91 Brad Myers - Made fix-all-interactors only work on local slots
                       - Also fixed duplicate to not copy the :known-as slot
    3/20/91 Brad Myers - Made *work-win*'s aggregate, *top-agg*, global
    3/14/91 Andrew Mickish - Defined Is-A-Motif-Background and called from
              To-Top-Func, To-Bottom-Func, and Duplicate-Func
    3/13/91 Osamu Hashimoto - Moved Show-Save-Dailog & Show-Read-Dialog
              to gilt-gadgets.lisp and motif-gilt-gadgets.lisp
    3/07/91 Osamu Hashimoto - Moved *prop-sheet* to gilt-gadgets.lisp and
              motif-gilt-gadgets.lisp
    3/04/91 Osamu Hashimoto - Moved Make-Main-Menu to gilt-gadgets.lisp and
              motif-gilt-gadgets.lisp
    2/28/91 Andrew Mickish - Uncommented "export" code in Show-Save-Dialog;
              Put formulas in :min-width and :min-height of Creator inter;
              Since Export-p part of Save-Menu is now a single button, all
              Car's of Export-p's :value were removed;
    2/27/91 Andrew Mickish - Changed Load-File-Name to use assoc;
              Moved *load-file* parameter into gilt-gadgets.lisp;
              Put check for MOTIF-BACKGROUND in Generate-Uses-List;
              *ib-win* is now an instance of IB-WINDOW created in gilt-gadgets
    2/21/91 Andrew Mickish - Moved IB-OBJS into gilt-gadgets.lisp
    1/23/91 Andrew Mickish - Removed ~% from error-gadget messages
    12/5/90 Brad Myers - New save and read dialog boxes
    11/27/90 Brad Myers - Added multiple selection
    11/15/90 Brad Myers - Released
    6/18/90 Brad Myers - Started
============================================================
|#

;;  **** BUGS:
;;  Opal: windows should appear in new place
;;  ?X or Opal? : bitmaps don't look right
;;  Gilt: Make new bitmaps for gauge, slider, etc.
;;  Gadgets: In Prop-Sheet-Finish, just call notice-items-changed on the object
;;    since methods now exist for all gadgets.
;;  Gilt: Align menu can't center both row and column
;;  Gilt: Should be easier to switch between Motif and Garnet gadget styles
;;  Gilt: Should be easier to add the user's own gadgets
;;  Gilt: Font menu doesn't work perfectly - Bold, Italic, and Large -> ignores
;;    large and will only go to large if first select very-large and go back
;;    to large
;;  Gilt: The dialog boxes that were created with Gilt (like line-props) should
;;    be split up into multiple code segments instead of one big c-i call.
;;    This will make them easier to compile.
;;  Gilt: Need to write out "in-package" info line as first executable instr.

;;**** In Read, save other parts of main aggregate, such as interactors

;;*** Make prop-sheet not set all slots, only those that change.
;;    Now, setting all the settable slots causes an enormous number of formulas
;;    to be reevaluated


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

(export '(Do-Go Do-Stop))

(defparameter Gilt-Version "V1.1")

(defparameter *Run-Build-obj* NIL) ; the gadget that determines whether in
                                   ; build or run mode
(defparameter *Selection-obj* NIL) ; The gadget that is the user's selection in
				   ; the work window
(defparameter *Error-Gadget* NIL)  ; A gadget for reporting errors
(defparameter *Text-Feedback-Obj* NIL)  ; Feedback when typing text
(defparameter *Ib-Win* NIL) ; the window that the gadgets are in
(defparameter *work-win* NIL) ; work window
(defparameter *main-win* NIL) ; window containing the main menu and controls
(defparameter *objs-agg* NIL) ; aggregate containing created objects
(defparameter *top-agg* NIL)  ; top aggregate in the work window


(defparameter *Last-Filename* "") ; last file name used to read or save a file
(defparameter *Top-Gadget-Name* "TEMP-GADGET") ; name used for the top gadget

;; These are slots that should not be put into the file from any objects
(defparameter create-time-do-not-dump-slots
  (list :selected :value-obj :value :do-not-dump-slots
	:gg-interim-selected :gg-selected :internally-parented))

(defparameter save-time-extra-do-not-dump-slots
  (list :point-to-leaf :gilt-type :select-function))

(defparameter HourGlassCursor
  (cons (create-instance NIL opal:bitmap
			 (:CONSTANT :image)
			 (:image (Get-Gilt-Bitmap "hourglass.cursor")))
	(create-instance NIL opal:bitmap
			 (:CONSTANT :image)
			 (:image (Get-Gilt-Bitmap "hourglass.mask")))))
(defparameter RegularCursor (g-value opal:window :cursor))

(defparameter user::*gilt-obj* NIL) ; global variable set with current
				    ; selection

(proclaim '(special save-file text-edit))

(defun Gilt-Error (str)
  (opal:update *work-win*)
  (garnet-gadgets:display-error *error-gadget* str))

(defun Set-Up-Special-Slot-With-Value (obj temp-slot orig-slot)
  (let ((old-val (get-value obj orig-slot)))
    (if (formula-p old-val)
	(s-value obj temp-slot (formula old-val)) ; create an instance
        (s-value obj temp-slot old-val)))) ; otherwise, just use old value

(defun Save-Temp-Value (orig-obj orig-slot temp-obj temp-slot 
				  new-value-for-orig)
  (if (has-slot-p orig-obj orig-slot)
      (kr::move-formula orig-obj orig-slot temp-obj temp-slot)
      (s-value temp-obj temp-slot :*no-old-value*))
  (s-value orig-obj orig-slot new-value-for-orig))

(defun Restore-Temp-Value (orig-obj orig-slot temp-obj temp-slot
				    destroy-temp-p)
  (let ((old-val (get-local-value temp-obj temp-slot)))
    (if (eq old-val :*no-old-value*)
	(destroy-slot orig-obj orig-slot)
	(kr::move-formula temp-obj temp-slot orig-obj orig-slot))
    (mark-as-changed orig-obj orig-slot)
    (when destroy-temp-p
      (destroy-slot temp-obj temp-slot))))

(defun SetHourGlassCursor (&optional extrawindows)
  (s-value *work-win* :cursor HourGlassCursor)
  (s-value *ib-win* :cursor HourGlassCursor)
  (s-value *main-win* :cursor HourGlassCursor)
  (opal:update *work-win*)
  (opal:update *ib-win*)
  (opal:update *main-win*)
  (dolist (win extrawindows)
    (s-value win :cursor HourGlassCursor)
    (opal:update win)))


(defun RestoreRegularCursor (&optional extrawindows)
  (s-value *work-win* :cursor RegularCursor)
  (s-value *ib-win* :cursor RegularCursor)
  (s-value *main-win* :cursor RegularCursor)
  (opal:update *work-win*)
  (opal:update *ib-win*)
  (opal:update *main-win*)
  (dolist (win extrawindows)
    (s-value win :cursor RegularCursor)
    (opal:update win)))


(defun Is-A-Motif-Background (obj)
  (and (boundp 'garnet-gadgets::Motif-Background)
       (is-a-p obj garnet-gadgets::Motif-Background)))


;; Goes through all the interactors anywhere in agg and any sub-aggregadgets
;; and sets the :active slot to a formula that depends on the :selected slot
;; of control-obj if fix-p.  If fix-p is NIL, then removes the constraint.
;; If run-p, makes the interactors work when running, else when building
(defun Fix-All-Interactors (agg fix-p run-p)
  (let ((inters (g-local-value agg :behaviors)))
    (dolist (i inters)
      (if fix-p
	  ;; first save the old value, if any, unless already saved.
	  (unless (get-local-value i :saved-active-value)
		  (Set-Up-Special-Slot-With-Value i :gilt-temp-active
						  :active)
		  (Save-Temp-Value i :active i :saved-active-value
				    (formula (if run-p 
					      SpecialRunGadgetActiveForm
					      SpecialBuildGadgetActiveForm))))
	  ; else remove the constraint 
	  (progn
	    (unless (has-slot-p i :saved-active-value)
	      (error "Fix-all-interactors of ~s when not previously saved" i))
	    (Restore-Temp-Value i :active i :saved-active-value T)
	    (Destroy-slot i :gilt-temp-active)))))
  ;; now recursively do any children
  (dolist (child (g-value agg :components))
    (when (is-a-p child opal:aggregate) ; includes aggregadgets and aggrelists
      (Fix-All-Interactors child fix-p run-p))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Main Menu Functions


;;;
;;;
(defun Load-File-Name (item)
  (let ((file-name (cadr (assoc item *load-file* :test #'string=))))
    (if file-name
	file-name
	item)))

(defun Generate-Uses-List ()
  (let (gadgets gadgets-to-load)
    (dolist (obj (g-value *objs-agg* :components))
      (pushnew (car (g-value obj :is-a)) gadgets))
    (Format T ";;; This file uses the following objects:~%")
    (dolist (gad gadgets)
      (let ((item (name-for-schema gad))
	    (pack (package-name (symbol-package (kr::schema-name gad)))))
	(format T ";;;     ~a from package ~a~%" item pack)
	(if (equalp pack "GARNET-GADGETS")
	    (unless (is-a-motif-background gad)
	      (pushnew (string-downcase (Load-File-Name item)) gadgets-to-load)))))
    (when gadgets-to-load
      (format T "(dolist (gadget '(")
      (dolist (gad gadgets-to-load)
	(format T "\"~a-loader\"~%		  " gad))
      (format T "))~%  (load (merge-pathnames gadget
			 user::Garnet-Gadgets-PathName)))~%"))
    (format T ";;;~%")
    (format T ";;;     Functions needed from Gilt~%")
    (format T "(load (merge-pathnames \"gilt-functions-loader\"
			 user::Garnet-Gilt-PathName))~%")
    (format T ";;;~%")))

(defun Write-Standard-Header (package)
  (format T ";;; -*- Mode: LISP; Syntax: Common-Lisp; Package: ~a; Base: 10 -*-~%"
	  package)
  (format T ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;~%")
  (format T ";;; This file created by GILT ~a: The Garnet Interface Builder~%" 
	  Gilt-Version)
  (format T ";;; on ~a~%" (inter::time-to-string))
  (format T ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;~%~%")
  (Generate-Uses-List)
  (format T ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;~%~%")
  (format T "(in-package ~s :use '(\"LISP\" \"KR\"))~%~%" package)
  (format T "(defparameter user::*Used-Gilt-Version* ~s)~%~%" Gilt-Version)
  )

;; determine if the OK function should be asked for.  Return T if gray
;; rectangle should be visible (so no OK button)

(defun Check-Ask-OK ()
  (let (have-ok)
    (setq have-ok (dolist (obj (g-value *objs-agg* :components))
		    (when (or (eq type-okcancel (g-value obj :gilt-type))
			      (eq type-okapplycancel (g-value obj :gilt-type)))
		      (return T))))
    (not have-ok)))


;;; See if the string mentions a package, and if not, put it in the
;;; specified package.  If so, put it in that package (creating that
;;; package first if it does not exist--so no error).  Returns the new symbol.
(defun Check-Atom-In-Package (str package)
  (let ((pos (position #\: str)))
    (setq str (string-upcase str))
    (if pos
	(let ((pack (subseq str 0 pos)))
	  (unless (find-package pack)
	    (make-package pack))
	  (intern (subseq str (1+ pos)) pack))
	;; else no colon; put it into package
	(if (= 0 (length str))  ; use NIL for the empty string
	    NIL
	    (intern str package)))))

;;; Always intern the str in the specified package, even if a package name
;;; is specified.
(defun Move-To-Package (str package)
  (let ((pos (position #\: str)))
    (setq str (string-upcase str))
    (if pos
	(intern (subseq str (1+ pos)) package)
	(intern str package))))

;;;Searches through all objects and if there is a :select-function
;;; slot, moves it into the :selection-function slot.   Do this before the
;;; gadgets are written out
(defun Set-Selection-Functions (package)
  (let (sel-func)
    (dovalues (each-gadget *objs-agg* :components)
	      (when (setq sel-func (g-value each-gadget :select-function))
		
		(cond ((stringp sel-func) ; then package probably not defined
		       (setq sel-func (Check-Atom-In-Package sel-func package))
		       (s-value each-gadget :select-function sel-func))
		      ;; this next clause turns out to be a bad idea, since
		      ;; can't tell if the user explicitly specified a
		      ;; package, or if one just appeared.  Also, the
		      ;; okcancel function is in gilt.
		      ;;((and package
		      ;;    (symbolp sel-func)
		      ;;    (eq (symbol-package sel-func)
		      ;;	(find-package 'user)))
		      ;; ;; then move to the specified package
		      ;;(setq sel-func (intern (symbol-name sel-func) package))
		      ;; (s-value each-gadget :select-function sel-func))
		      (t NIL))
		(s-value each-gadget :selection-function sel-func)))))

(defparameter keywordpackage (find-package 'keyword))

;;;Searches through all objects and makes sure the known-as slots are
;;; filled with keywords, not atoms or strings.
(defun Fix-Known-As ()
  (let (knownas)
    (dovalues (each-gadget *objs-agg* :components)
	      (when (setq knownas (g-local-value each-gadget :known-as))
		(cond ((stringp knownas) ; then package probably not defined
		       (setq knownas (Move-To-Package knownas keywordpackage))
		       (with-constants-disabled
			   (s-value each-gadget :known-as knownas)))
		      ((symbolp knownas) ;; then move to the keyword package
		       (unless (eq keywordpackage (symbol-package knownas)) 
			 (setq knownas (intern (symbol-name knownas) keywordpackage))
			 (with-constants-disabled
			     (s-value each-gadget :known-as knownas))))
		      (t NIL))))))

;;;Sets the do-not-dump slot of all objects correctly for before saving
(defun Set-Do-Not-Dump-Slot-For-Save ()
  (dolist (each-gadget (g-value *objs-agg* :components))
    (s-value each-gadget :do-not-dump-slots 
	     (append save-time-extra-do-not-dump-slots
		     (g-value each-gadget :do-not-dump-slots)))))

;;;Removes the extra values from do-not-dump-slots
(defun Set-Do-Not-Dump-Slot-After-Save ()
  (dolist (each-gadget (g-value *objs-agg* :components))
    (s-value each-gadget :do-not-dump-slots 
	     (set-difference (g-value each-gadget :do-not-dump-slots)
			     save-time-extra-do-not-dump-slots))))

;;;Searches through all objects and if there is a :selection-function
;;; slot, then removes the value from the :selection function slot and puts
;;; it into the :select-function slot.   Do this after the
;;; gadgets are read back in. 
(defun Remove-Selection-Functions ()
  (let (sel-func)
    (dovalues (each-gadget *objs-agg* :components)
	      (when (setq sel-func (g-value each-gadget :selection-function))
		(s-value each-gadget :selection-function NIL)
		(s-value each-gadget :select-function sel-func)))))

;;; This function changes all the references to the gilt type into
;;; something that will save without generating an error
(defun fix-all-gilt-types ()
  (let (gilttype)
    (dovalues (each-gadget *objs-agg* :components)
	      (setq gilttype (g-local-value each-gadget :gilt-type))
	      (when gilttype
		(s-value each-gadget :gilt-ref
			 (name-for-schema gilttype))))))


;;; This function restores all the references to the gilt type
(defun Restore-all-gilt-types ()
  (let (giltref)
    (dovalues (each-gadget *objs-agg* :components)
	      (setq giltref (g-local-value each-gadget :gilt-ref))
	      (if giltref
		(s-value each-gadget :gilt-type (eval (intern giltref 'gilt)))
		;; otherwise, use the generic type
		(s-value each-gadget :gilt-type type-generic))
	      (when (is-a-p each-gadget opal:text)
		(s-value each-gadget :point-to-leaf 'Fake-Point-to-Leaf)))))

;;; This is called by the Save-file dialog box when OK is hit.  Values is a
;;; list of the gadgets and their values
(defun Do-Save-File (gadget values)
  (declare (ignore gadget))
  (let ((filename (value-of :filename values))
	(gadget-name (value-of :gadget-name values))
	(window-title (value-of :win-title values))
	(package (string-upcase (value-of :package-name values)))
	(function-for-ok-name (value-of :FUNCTION-FOR-OK-NAME values))
	(export-p (if (value-of :export-p values)
		      T NIL))) ;use T instead of string name
  (cond ((string= "" filename) (Gilt-Error "Filename must be supplied"))
	((string= "" gadget-name) (Gilt-Error "Gadget name must be supplied"))
	((string= "" package) (Gilt-Error "Package name must be supplied"))
	((probe-directory (directory-namestring filename))
	   (format T "Saving current work window to file ~s...~%" filename)
	   (setq *Last-Filename* filename)
	   (with-open-file (*standard-output* filename :direction :output
					      :if-exists :supersede)
	     (unless (find-package package)
	       (make-package package))
	     ;; first set up objects so they can be dumped successfully
	     (fix-all-gilt-types)
	     (Set-Selection-Functions package)
	     (Fix-Known-As)
	     (Set-Do-Not-Dump-Slot-For-Save)
	     ;; now start dumping
	     (write-standard-header package)
	     (setf (kr::schema-name *objs-agg*)
		   (read-from-string (string-upcase gadget-name)))
	     (when export-p
	       (Format T "~%(export '(~a))~%~%" (kr::schema-name *objs-agg*)))
	     (s-value *objs-agg* :function-for-ok
		      (Check-Atom-In-Package function-for-ok-name package))
	     (s-value *objs-agg* :package-name package)
	     (s-value *objs-agg* :window-height (g-value *work-win* :height))
	     (s-value *objs-agg* :window-width (g-value *work-win* :width))
	     (s-value *objs-agg* :window-top (g-value *work-win* :top))
	     (s-value *objs-agg* :window-left (g-value *work-win* :left))
	     (s-value *objs-agg* :window-title window-title)
	     (s-value *objs-agg* :export-p export-p)
	     (Format T "(defparameter user::*Garnet-Object-Just-Created* ~%")
	     (opal:write-gadget *objs-agg* T T)
	     (Format T ")~%~%"))
	   ;; finished with stuff that goes to the file
	   ;; now clean up from save
	   (Remove-Selection-Functions)
	   (Set-Do-Not-Dump-Slot-After-Save)
	   (format T "...Done saving file~%"))
	(T (Gilt-Error "Cannot save to that file")))))

(proclaim '(special user::*Garnet-Object-Just-Created*))

;;; This is called by the Read-file dialog box when OK is hit.  Values is a
;;; list of the gadgets and their values
(defun Do-Read-File (gadget values)
  (let ((filename (value-of :filename values))
	(addp (and (g-value *objs-agg* :components)
		   (string= (value-of :add-replace values)
			    "Add to existing objects")))
	(readdailogwindow (list (g-value gadget :window)))
	new-obj-list)
  (cond ((string= "" filename) (Gilt-Error "Filename must be supplied"))
	((probe-file filename)
	 (format T "Loading work window from file ~s...~%" filename)
	 (SetHourGlassCursor readdailogwindow)
	 (let ((kr::*constants-disabled* T))
	   (Load filename))
	 (format T "Restoring objects...~%")
	 (s-value *work-win* :width
		  (if addp		; if adding objects, then wider
		      (max (g-value user::*Garnet-Object-Just-Created*
				    :window-width)
			   (g-value *work-win* :width))
		      ;; otherwise, size specified in the file
		      (g-value user::*Garnet-Object-Just-Created*
			       :window-width)))
	 (s-value *work-win* :height
		  (if addp		; if adding objects, then taller
		      (max (g-value user::*Garnet-Object-Just-Created*
				    :window-height)
			   (g-value *work-win* :height))	
		      ;; otherwise, size specified in the file
		      (g-value user::*Garnet-Object-Just-Created*
			       :window-height)))
	 (setq *Last-Filename* filename)
	 (setq *Top-Gadget-Name*
	       (or (name-for-schema user::*Garnet-Object-Just-Created*)
		   *Top-Gadget-Name*))
	 ;; saved as one big aggregadget
	 (unless addp 
	   ;; if not add, then replace, so use new file's values
	   (s-value *objs-agg* :function-for-ok
		(g-value user::*Garnet-Object-Just-Created* :function-for-ok))
	   (s-value *objs-agg* :package-name
		    (g-value user::*Garnet-Object-Just-Created* :package-name))
	   (s-value *objs-agg* :window-title
		    (g-value user::*Garnet-Object-Just-Created* :window-title))
	   (s-value *objs-agg* :export-p
		    (g-value user::*Garnet-Object-Just-Created* :export-p))
	   ;; delete all old objects
	   (Delete-All-Func NIL NIL))
	 ;; now add all objects
	 (dolist (obj (setq new-obj-list
		     (copy-list (g-value user::*Garnet-Object-Just-Created*
						:components))))
	   ;; The user's aggregadget was created with a :parts list, so its
	   ;; :components slot is constant.
	   (let ((kr::*constants-disabled* T))
	     (opal:remove-component user::*Garnet-Object-Just-Created* obj))
	   (s-value obj :do-not-dump-slots 
		    (append create-time-do-not-dump-slots
			    (g-value obj :do-not-dump-slots)))
	   (fix-all-interactors obj T T)
	   (let ((kr::*constants-disabled* T)) ; since adding to an aggregadget
	     (opal:add-component *objs-agg* obj
				 (when (is-a-motif-background obj)
				   :back))))
				 
	 ;; now clean up
	 (Garnet-Gadgets:Set-Selection *Selection-Obj* new-obj-list)
	 (Restore-all-gilt-types)
	 (Remove-Selection-Functions)
	 (RestoreRegularCursor readdailogwindow)
	 (format T "...Done~%"))
	(T (Gilt-Error "That file does not exist")))))

;;; return the list objs sorted by the order of the objects in *objs-agg*
;;; For many operations, it is important to process the objects in their
;;; display order, rather than in their selection order!
(defun sort-objs-display-order (objs)
  (let ((sorted-list (copy-list objs))
	(reference-objs (g-value *objs-agg* :components)))
    (sort sorted-list #'(lambda (o1 o2)
			  (< (position o1 reference-objs)
			     (position o2 reference-objs))))))

(defparameter *deleted-objs* NIL)

(defun Delete-Func (gadget stringsel)
  (declare (ignore gadget stringsel))
  (let ((objs (g-value *Selection-Obj* :value)))
    (if objs
	(progn
	  (push (sort-objs-display-order objs) *deleted-objs*)
	  (let ((kr::*constants-disabled* T)) ; since adding to an aggregadget
	    (dolist (obj objs)
	      (opal:remove-component *objs-agg* obj)))
	  (Garnet-Gadgets:Set-Selection *Selection-Obj* NIL))
	(inter:beep))))

(defun Delete-All-Func (gadget stringsel)
  (declare (ignore gadget stringsel))
  (let ((objs (copy-list (g-value *objs-agg* :components))))
    (Garnet-Gadgets:Set-Selection *Selection-Obj* NIL)
    (push objs *deleted-objs*)
    (let ((kr::*constants-disabled* T)) ; since adding to an aggregadget
      (dolist (o objs)
	(opal:remove-component *objs-agg* o)))))

(defun Undo-Delete-Func (gadget stringsel)
  (declare (ignore gadget stringsel))
  (let ((objs (pop *deleted-objs*)))
    (if objs
	(progn
	  (dolist (o objs)
	    (with-constants-disabled
		(opal:add-component *objs-agg* o
				    (when (is-a-motif-background o)
				      :back))))
	  (Garnet-Gadgets:Set-Selection *Selection-Obj* objs))
	;no obj, so beep
	(inter:beep))))


(defun Prop-Sheet-Finish (prop-sheet)
  (let* ((obj (g-value prop-sheet :obj))
	 (changed-values (g-value prop-sheet :changed-values))
	 (gilt-type (g-value obj :gilt-type))
	 (aggrel-slot (g-value gilt-type :aggrelist-slots))
	 slot aggrel)
    (when (and aggrel-slot 
	       (assoc (setq slot (car aggrel-slot)) changed-values))
      (mark-as-changed obj slot)
      ;; now search through to find the aggrelist. Hope there's only one!
      (block lookforaggrel
	(opal:do-all-components obj 
				#'(lambda (obj)
				    (when (is-a-p obj opal:aggrelist)
				      (setq aggrel obj)
				      (return-from lookforaggrel)))))
      (if aggrel (opal:notice-items-changed aggrel)
	  (error "didn't find the aggrelist for ~s" obj)))))


(defun PopUpPropsWin (obj prop-slots)
  (let (left top)
    (multiple-value-setq (left top)
      (opal:convert-coordinates (g-value obj :window)
			 (g-value obj :left)
			 (opal:bottom obj) NIL))
    (setq top (+ 40 top))
    (Garnet-gadgets:pop-up-win-change-obj *prop-sheet* obj prop-slots 
					  left top
					  (g-value obj :gilt-type :props-title))))

(defun Properties-Func (gadget stringsel)
  (declare (ignore gadget stringsel))
  (let ((objs (g-value *Selection-Obj* :value))
	props obj)
    (setq obj (car objs)) ; just in case everything is OK
    (cond ((null objs) (Gilt-Error "Nothing selected"))
	  ((cdr objs)(Gilt-Error "Only one object can be selected"))
	  ((and (g-value *prop-sheet* :window)
		(g-value *prop-sheet* :window :visible))
	   (Gilt-Error (format NIL "Property sheet already being used for ~s"
			       (g-value *prop-sheet* :obj))))
	  ((setq props (g-value obj :gilt-type :properties-func))
	   (funcall props obj))
	  ((setq props (g-value obj :gilt-type :properties-slots))
	   (PopUpPropsWin obj props))
	  (T (Gilt-Error (format NIL "No Properties for object ~s" obj))))))

(defun Quit-Func (gadget stringsel)
  (declare (ignore gadget stringsel))
  (Do-Stop)
  #-cmu (inter:exit-main-event-loop))

(defun To-Top-Func (gadget stringsel)
  (declare (ignore gadget stringsel))
  (let ((objs (g-value (g-value *Selection-Obj* :value))))
    (if objs
	(dolist (obj (sort-objs-display-order objs))
	  (unless (is-a-motif-background obj)
	    (opal:move-component *objs-agg* obj :where :front)))
	(inter:beep))))

(defun To-Bottom-Func (gadget stringsel)
  (declare (ignore gadget stringsel))
  (let ((objs (g-value (g-value *Selection-Obj* :value))))
    (if objs
	(let* ((first-obj (first (g-value *objs-agg* :components)))
	       (background-p (is-a-motif-background first-obj)))
	  (dolist (obj (reverse (sort-objs-display-order objs)))
	    (if background-p
		(opal:move-component *objs-agg* obj :in-front first-obj)
		(opal:move-component *objs-agg* obj :where :back))))
	(inter:beep))))

(defun Select-All-Func (gadget stringsel)
  (declare (ignore gadget stringsel))
  (Garnet-Gadgets:Set-Selection *Selection-Obj*
				(g-value *objs-agg* :components)))

(defun Duplicate-Func (gadget stringsel)
  (declare (ignore gadget stringsel))
  (let ((objs (g-value (g-value *Selection-Obj* :value))))
    (if objs
	(let (new-objs this-obj)
	  (dolist (obj (sort-objs-display-order objs))
	    (unless (is-a-motif-background obj)
	      (setq this-obj (Create-New-Gadget obj 10))
	      (push this-obj new-objs)))
	  (Garnet-Gadgets:Set-Selection *Selection-Obj* new-objs))
	(inter:beep))))

(defun Align-Func (gadget stringsel)
  (declare (ignore gadget stringsel))
  (Show-Align-DialogBox))

; convert s to an integer or return NIL
(defun Make-Integer (s)
  (let* ((sym (read-from-string s))
	 (number (when (integerp sym) sym)))
    number))


(defun Val-Set-Func (gadget new-val-string line-p slot1 slot2 indx)
  (let ((objs (g-value *Selection-Obj* :value))
	(slot (if line-p slot1 slot2))
	(boxpoints (if line-p :points :box))
	new-val obj)
    (if (and (setq obj (car objs)) ; at least one selection
	     (null (cdr objs)) ; less than two selections
	     (g-value obj slot)
	     (setq new-val (make-integer new-val-string))
	     (nth indx (g-value obj :gilt-type :changeable-slots)))
	(progn
	  (setf (nth indx (g-value obj boxpoints)) new-val)
	  (mark-as-changed obj boxpoints))
	; else not a good number
	(let ((inter (g-value gadget :TEXT-INTER)))
	  (inter:beep)
	  ; go back to original value
	  (s-value gadget :value (g-value inter :original-string))
	  (inter:abort-interactor inter)))))

;; Gadget is the number entry object, not the object to be operated on
(defun LeftX1-Set-Func (gadget new-val-string)
  (val-set-func gadget new-val-string (g-value gadget :line-p)
					  :x1 :left 0))
(defun TopY1-Set-Func (gadget new-val-string)
  (val-set-func gadget new-val-string (g-value gadget :line-p)
					  :y1 :top 1))
(defun WidthX2-Set-Func (gadget new-val-string)
  (val-set-func gadget new-val-string (g-value gadget :line-p)
					  :x2 :width 2))
(defun HeightY2-Set-Func (gadget new-val-string)
  (val-set-func gadget new-val-string (g-value gadget :line-p)
					  :y2 :height 3))

;; If slot is left or top, finds the minimum of all objects.  If width or
;; height, finds maximum.  Uses the fake rectangle inside the
;; multi-graphics-selection object!
(defun Get-Multi-Value (objs slot)
  (declare (ignore objs))
  (let ((fake-rect (gv *selection-obj* :move-grow-it :obj-to-change)))
    (prin1-to-string (gv fake-rect slot))))

(defun Sel-Obj-Value (slot)
  (let* ((objs (gv *selection-obj* :value))
	 (obj (car objs))
	 (multi (cdr objs)))
    (cond ((null obj) "0")
	  (multi (Get-Multi-Value objs slot))
	  (T (prin1-to-string (gv obj slot))))))

(defparameter LinepForm
  (o-formula (let ((objs (gv *selection-obj* :value)) obj)
	       (cond ((cdr objs) NIL) ;not line if multiple
		     ((setq obj (car objs))
		      (let ((gt (g-value obj :gilt-type)))
			(when gt (g-value gt :line-p))))
		     (T NIL)))))


(defparameter stringform (o-formula (gv *Text-Feedback-Obj* :string)))

;; if point-list is a single number, then the existing pointlist is
;; incremented by that amount (this is used when an object is duplicated),
;; otherwise the point-list is copied and then used.
;; Returns the new object
(defun Create-New-Gadget (gadget point-list)
  (let ((init (g-value gadget :maker))
	 newobj slot points)
    (if init
	(progn ; then it is a bitmap pretending to be an object.
	  (unless (boundp (g-value gadget :loaded))
	    (SetHourGlassCursor)
	    (load (merge-pathnames (g-value gadget :load-file)
			 user::Garnet-Gadgets-PathName))
	    (RestoreRegularCursor))
	  (setq newobj (let ((kr::*constants-disabled* T))
			 (eval (first init))))
	  (dolist (slot (g-value gadget :gilt-type :slots-to-copy))
		  (s-value newobj slot (copy-seq (g-value newobj slot))))
	  (if (second init) (Init-Value newobj (second init))))
	(progn ; else not a bitmap of an object
	  (setq newobj
		(let ((kr::*constants-disabled* T))
		  (opal:copy-gadget gadget NIL)))
	  (s-value newobj :known-as NIL)
	  (dolist (slot (g-value gadget :gilt-type :slots-to-copy))
	    (s-value newobj slot (copy-seq (g-value newobj slot))))))
    (setq slot (if (g-value gadget :gilt-type :line-p) :points :box))
    (if (numberp point-list)
	; then copy old and increment appropriately
	(progn (setq points (copy-list (g-value newobj slot)))
	  (incf (first points) point-list)
	  (incf (second points) point-list)
	  (when (g-value gadget :gilt-type :line-p)
	    (incf (third points) point-list)
	    (incf (fourth points) point-list)))
	; else just use a copy of the parameter
	(setq points (copy-list point-list)))
    (s-value newobj slot points)
    (s-value newobj :CONSTANT '(T)) ; when write out, all slots will be const.
    (s-value newobj :do-not-dump-slots 
	     (append create-time-do-not-dump-slots
		     (g-value newobj :do-not-dump-slots)))
    (Fix-All-Interactors newobj T T)
    (opal:add-component *objs-agg* newobj
       (when (is-a-motif-background newobj)
	 :back))
    newobj))

(defun work-win-interactors (work-win)
  ;; interactor to create new objects
  (setq *Text-Feedback-Obj*
	(create-instance NIL opal:cursor-multi-text
		   (:obj-over NIL)
		   (:visible (o-formula (gvl :obj-over)))
		   (:draw-function :xor)
		   (:font (o-formula (gvl :obj-over :font)))
		   (:left (o-formula (gvl :obj-over :left)))
		   (:top (o-formula (gvl :obj-over :top)))))
  (opal:add-components (g-value work-win :aggregate)
		       *Text-Feedback-Obj*  *Selection-Obj*)
  (create-instance 'creator inter:two-point-interactor
	(:window work-win)
	(:start-event :rightdown)
	(:start-where T)
	(:abort-if-too-small NIL)
	(:min-width (o-formula (let ((min-width (gvl :window :current-gadget
						     :min-width)))
				 (if min-width min-width 3))))
	(:min-height (o-formula (let ((min-height (gvl :window :current-gadget
						       :min-height)))
				  (if min-height min-height 3))))
	(:feedback-obj
	 ;;use the feedback objects in the graphics-selection object
	 ;;pick which feedback depending on whether drawing line or box
	 (o-formula
	  (if (gvl :line-p)
	      (gv *Selection-Obj* :line-movegrow-feedback)
	      (gv *Selection-Obj* :rect-movegrow-feedback))))
	(:line-p (o-formula (gvl :window :current-gadget :gilt-type :line-p)))
	;; active if in :build mode
	(:active (formula BuildGadgetActiveForm))
	(:final-function
	 #'(lambda (an-interactor point-list)
	     (when point-list
	       (let ((gadget (g-value an-interactor :window :current-gadget)))
		 (if gadget 
		     (Create-New-Gadget gadget point-list)
		     ; else no gadget
		     (inter:beep)))))))
  ;; interactor to edit the strings in objects
  (create-instance 'text-edit inter:text-interactor
	 (:window work-win)
	   ;; higher priority so this one will go instead of the selection
	 ;; (:waiting-priority inter:high-priority-level)
	 (:start-event :leftdown)
	 (:stop-event (o-formula
		       (let ((obj (gvl :first-obj-over)))
			 (if (or (is-a-p obj opal:text)
				 (is-a-p obj opal:cursor-text))
			     '(:any-mousedown #\return 
					      :control-\n
					      :control-\j)
			     '(:any-mousedown :control-\n
					      :control-\j)))))
	 (:selection-obj *Selection-Obj*)
	 ;; active if in :build mode
	 (:active (o-formula (and (gvl :selection-obj :value)
				  (eq :build (gv *Run-Build-Obj* :value)))))
	 (:start-where (o-formula (list :list-leaf-element-of
					(gvl :selection-obj) :value
					:type opal:text)))
	 (:feedback-obj *Text-Feedback-Obj*)
	 (:start-action
	    ; set the feedback-obj's initial string, temporarily change string
	    ; of the real object, search for the rank and top level object
	  #'(lambda (inter obj start-event)
	      (let ((feedback (g-value inter :feedback-obj)))
		(s-value feedback :string (g-value obj :string)))
	      (Save-Temp-Value obj :string inter :saved-string-form
			       (formula stringform))
	      (Save-Temp-Value obj :draw-function inter :obj-draw :no-op)
	      (Call-prototype-method inter obj start-event)))
	 (:abort-action
	  ;; restore string's original values
	  #'(lambda (inter obj abort-event)
	      (fix-up-string-after-edit obj inter)
	      (Call-prototype-method inter obj abort-event)))
	 (:final-function
	  #'(lambda (inter obj final-event final-string x y)
	      (declare (ignore x y))
	      (fix-up-string-after-edit obj inter)
	      (Set-Item-Slot-Appropriately obj inter final-event 
					   final-string)))))

(defun fix-up-string-after-edit (obj inter)
  (Restore-Temp-Value obj :string inter :saved-string-form NIL)
  (Restore-Temp-Value obj :draw-function inter :obj-draw NIL))

;;; Find a member of the selection set which is or contains text-obj
(defun Find-Top-Obj (text-obj)
  (let ((selected (g-value *selection-obj* :value))
	(obj text-obj))
    (loop
      (if (member obj selected)
	  (return obj)
	  ;; else go to parent
	  (unless (setq obj (g-value obj :parent))
	    (return NIL))))))

;; Called from the final function of the text interactor that edits strings
;; to cause the appropriate string slot to be set.
(defun Set-Item-Slot-Appropriately (obj inter final-event final-string)
  (declare (ignore inter))
  (let* ((top-obj (Find-Top-Obj obj))
	 (string-set-func (when top-obj
			    (g-value top-obj :gilt-type :String-Set-Func))))
    (unless 
	(and string-set-func
	     (funcall string-set-func  top-obj obj final-event final-string))
      ;; error- cannot edit that string
      (Gilt-Error
"You cannot edit that string directly.
Please use the dialog box that pops up when
you give the 'Properties' command or go into Run mode."))))
  
(defun Create-Selection-Obj ()
  (setq *Selection-Obj*
	(create-instance NIL garnet-gadgets:multi-graphics-selection
			 (:start-where `(:element-of-or-none ,*objs-agg*))
			 (:running-where `(:in ,*top-agg*))
			 (:check-grow-p T)   ; only some objects can be grown
			 (:check-move-p NIL) ; all objects can be moved
			 (:check-line T) ; check the :line-p slot of objects
			 (:selection-function
			  #'(lambda (gadget newselection)
			      (declare (ignore gadget))
			      (when newselection
				(if (cdr newselection)
				    (setq user::*gilt-obj* newselection)
				    (setq user::*gilt-obj* (car newselection))
				    ))))))
  ;; only be on if in build mode
  (Fix-All-Interactors *Selection-Obj* T NIL))


(defun do-go ()
  (setq *ib-win* (Make-IB-Window))
  (s-value *ib-win* :aggregate (create-instance NIL IB-OBJS))

  (setq *work-win* (create-instance NIL inter:interactor-window
		      (:title "Gilt Work Window")
		      (:left 0)(:top 0)(:width 450)(:height 300)
		      (:current-gadget (o-formula (gvl :ib-win :aggregate
						       :feedback :obj-over)))
		      (:aggregate
		       (setq *top-agg*
			     (create-instance NIL opal:aggregate
			      (:left 0)(:top 0)
			      (:width (o-formula (gvl :window :width)))
			      (:height (o-formula (gvl :window :height))))))))
  (s-value *work-win* :ib-win *ib-win*)
  (s-value *work-win* :objs-agg
	   (setq *objs-agg*
		 (create-instance NIL opal:aggregadget
				    (:left 0)(:top 0)
				    (:do-not-dump-objects :children)
				    (:width (o-formula (gvl :window :width)))
				    (:height (o-formula (gvl :window :height)))
				    ;; initial values for the Save Dialog box
				    (:package-name "USER")
				    (:window-title "TEMP WINDOW")
				    (:export-p T)
				    (:FUNCTION-FOR-OK NIL)
				    )))

  (s-value *objs-agg* :do-not-dump-slots
	   (append (list :selected :gg-selected
			 :do-not-dump-objects :do-not-dump-slots)
		   (g-value *objs-agg* :do-not-dump-slots)))
  (Create-Selection-Obj)
  (Make-Main-Menu) ; this uses *Selection-Obj* in formulas

  (add-std-gadgets *ib-win*)
  (opal:add-component *top-agg* *objs-agg*)
  (opal:update *work-win*)
  (work-win-interactors *work-win*)
  (opal:update *ib-win*)
  (opal:update *work-win*)
  (setq *Error-Gadget* (create-instance NIL garnet-gadgets:error-gadget
			  (:parent-window *work-win*)))
  *work-win* ; return work-win
    ;;if not CMU CommonLisp, then start the main event loop to look for events
    #-cmu (inter:main-event-loop))
  
(defun do-stop ()
  (opal:destroy *ib-win*) 
  (opal:destroy *work-win*)
  (opal:destroy (g-value *Run-Build-obj* :window))
  (when (and (boundp 'text-edit) (schema-p text-edit))
    (opal:destroy text-edit)))
