;;; -*- 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 -*-
;;;
;;;  Support functions for Move/Grow Interactor dialog box
;;;

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

(defvar move-grow-inter-win nil)
(defvar move-grow-inter-agg nil)
(defvar *MOVE-GROW-INTER-QUEUE* NIL)
(defvar *move-grow-box-win* nil)

(defun move-grow-inter-do-stop ()
  (when (and (boundp 'MOVE-GROW-INTER-AGG) MOVE-GROW-INTER-AGG)
	(opal:destroy MOVE-GROW-INTER-AGG)))

(defmacro MOVE-GROW-START-WHERE ()
  `(g-value MOVE-GROW-INTER-MENU :start-where))
(defmacro MOVE-GROW-OBJ-PROTOTYPES ()
  `(g-value MOVE-GROW-INTER-MENU :prototype-objs :obj-prototypes))
(defmacro MOVE-GROW-FEEDBACK-PROTOTYPES ()
  `(g-value MOVE-GROW-INTER-MENU :prototype-objs :feedback-prototypes))
(defmacro MOVE-GROW-FEEDBACK-OBJ ()
  `(g-value MOVE-GROW-INTER-MENU :feedback-obj))
(defmacro MOVE-GROW-GROW-PARM ()
  `(g-value MOVE-GROW-INTER-MENU :grow-parm))
(defmacro MOVE-GROW-MOVE-PARM ()
  `(g-value MOVE-GROW-INTER-MENU :move-parm))
(defmacro MOVE-GROW-OTHER-BOX ()
  `(g-value MOVE-GROW-INTER-MENU :start-where :contents :other-box))
(defmacro MOVE-GROW-OTHER-BUTTON ()
  `(g-value MOVE-GROW-INTER-MENU :start-where :contents :other-button))

;;; determine which slots in the feedback object and the objects that
;;; the interactor operates on should be tied to the :box slot
(defun set-up-box-slots (new-inter slot-value-list)
  (declare (special box-params))
  (let ((feedback-objs
	 (if (formula-p (get-local-value new-inter :feedback-obj))
	     (cdr (assoc :feedback-prototypes slot-value-list))
	     (g-local-value new-inter :feedback-obj)))
	(prototype-objs (or (cdr (assoc :obj-prototypes slot-value-list))
			    (find-start-where-objs 
			     (get-local-value new-inter :start-where)))))
    (s-value box-params :inter new-inter)
    (s-value box-params :feedback-objs feedback-objs)
    (s-value box-params :prototype-objs prototype-objs)
    (s-value (g-value box-params :box-slots) :value nil)
    (setf *move-grow-box-win* (gilt:show-in-window box-params 200 200 t))))

(defvar *box-left-formula* (formula `(first (gvl :box))))
(defvar *box-top-formula* (formula `(second (gvl :box))))
(defvar *box-width-formula* (formula `(third (gvl :box))))
(defvar *box-height-formula* (formula `(fourth (gvl :box))))

;;; place formulas that depend on the box slot in the specified set of
;;; slots for the objects operated on by the current move/grow interactor
(defun set-box-slots (gadget value-list)
  (let ((feedback-objs (g-value gadget :feedback-objs))
	(prototype-objs (g-value gadget :prototype-objs))
	(box-slots (second (car value-list))))
    (dolist (slot box-slots)
	    (let ((box-formula (case slot
				 (:left *box-left-formula*)
				 (:top *box-top-formula*)
				 (:width *box-width-formula*)
				 (:height *box-height-formula*))))
	      (dolist (obj prototype-objs)
		      (undo-save obj slot)
		      (s-value obj slot (formula box-formula)))
	      (if (listp feedback-objs)
		  (dolist (obj feedback-objs)
			  (undo-save obj slot)
			  (s-value obj slot (formula box-formula)))
		  (progn
		    (undo-save feedback-objs slot)
		    (s-value feedback-objs slot (formula box-formula))))))))
	    
(defun MOVE-GROW-INTERACTOR-NAME-FN (gadget interactor-name)
  (declare (ignore gadget))
  (dialog-enqueue :known-as
		  (if (string/= "" interactor-name)
		      (read-from-string
		       (concatenate 'string ":" interactor-name)))
		  *MOVE-GROW-INTER-QUEUE*))

;;;    :start-where is in an aggregate of items
(defun MOVE-GROW-ONE-THIS-AGG-FN (agg-box button-label)
  (declare (special move-grow-inter-menu))
  (declare (ignore agg-box))
  (let ((selection (car (g-value *SELECTION-INFO* :selected)))
	(start-where (MOVE-GROW-START-WHERE)))
    (if selection
	(progn
	  (s-value start-where :field-string (name-for-schema selection))
	  (s-value start-where :value button-label)
	  (s-value start-where :type nil)
	  (dialog-enqueue :start-where
			  `(:element-of ,selection 
					,@(g-value start-where :type-restriction))
			  *MOVE-GROW-INTER-QUEUE*))
	(progn
	  (s-value start-where :field-string nil)
	  (s-value start-where :value nil)
	  (s-value start-where :type nil)))))

;;;    :start-where is in a single object
(defun MOVE-GROW-OBJ-PRESS-OVER-FN (obj-box button-label)
  (declare (special move-grow-inter-menu))
  (declare (ignore obj-box))
  (let ((selection (car (g-value *SELECTION-INFO* :selected)))
	(start-where (MOVE-GROW-START-WHERE)))
    (if selection
	(progn
	  (s-value start-where :field-string (name-for-schema selection))
	  (s-value start-where :value button-label)
	  (s-value start-where :type nil)
	  (dialog-enqueue :start-where
			  `(:in-box ,selection)
			  *MOVE-GROW-INTER-QUEUE*))
	(progn
	  (s-value start-where :field-string nil)
	  (s-value start-where :value nil)
	  (s-value start-where :type nil)))))

(defun move-grow-obj-prototypes-fn (inter button-label)
  (declare (special move-grow-inter-menu))
  (declare (ignore inter button-label))
  (let ((selection (g-value *SELECTION-INFO* :selected)))
    (if selection
	(progn
	  (s-value (MOVE-GROW-OBJ-PROTOTYPES) :value t)
	  (s-value (MOVE-GROW-OBJ-PROTOTYPES) :field-string
		   (let* ((kr::*print-as-structure* nil))
			  (prin1-to-string selection)))
	  (dialog-enqueue :obj-prototypes selection *MOVE-GROW-INTER-QUEUE*))
	(progn
	  (dialog-enqueue :obj-prototypes nil *MOVE-GROW-INTER-QUEUE*)
	  (s-value (MOVE-GROW-OBJ-PROTOTYPES) :field-string nil)
	  (s-value (MOVE-GROW-OBJ-PROTOTYPES) :value nil)))))

(defun move-grow-feedback-prototypes-fn (inter button-label)
  (declare (special move-grow-inter-menu))
  (declare (ignore inter button-label))
  (let ((selection (g-value *SELECTION-INFO* :selected)))
    (if selection
	(progn
	  (s-value (MOVE-GROW-FEEDBACK-PROTOTYPES) :value t)
	  (s-value (MOVE-GROW-FEEDBACK-PROTOTYPES) :field-string
		   (let* ((kr::*print-as-structure* nil))
			  (prin1-to-string selection)))
	  (dialog-enqueue :feedback-prototypes selection 
			  *MOVE-GROW-INTER-QUEUE*))
	(progn
	  (dialog-enqueue :feedback-prototypes nil *MOVE-GROW-INTER-QUEUE*)
	  (s-value (MOVE-GROW-FEEDBACK-PROTOTYPES) :field-string nil)
	  (s-value (MOVE-GROW-FEEDBACK-PROTOTYPES) :value nil)))))

(defun MOVE-GROW-LINE-P-FN (panel value)
  (if (string= value "<Formula>")
      (c32 (g-value panel :window :inter) :line-p '*move-grow-inter-queue*)
      (dialog-enqueue :line-p 
		      (cond ((string= value "Line") t)
			    ((string= value "Box") nil))
		      *MOVE-GROW-INTER-QUEUE*)))

(defun MOVE-GROW-GROW-P-FN (panel value)
  (if (string= value "<Formula>")
      (c32 (g-value panel :window :inter) :grow-p '*move-grow-inter-queue*)
      (dialog-enqueue :grow-p 
		  (cond ((string= value "Grow") t)
			((string= value "Move") nil))
		  *MOVE-GROW-INTER-QUEUE*)))

(defun grow-parms-final-fn (gadget value)
  (if (string= value "<Formula>")
      (progn
	(lapidary-error (format nil "~%the formula must return a value that is valid for :slots-to-set"))
	(c32 (g-value gadget :window :inter) :grow-box-parms 
	     '*move-grow-inter-queue*))
      (dialog-enqueue :grow-box-parms
		  (cond ((string= value "Change Height") 
			 '(nil t nil t))
			((string= value "Change Width") 
			 '(t nil t nil))
			((string= value "Change Width and Height") 
			 '(t t t t)))
		  *MOVE-GROW-INTER-QUEUE*)))

(defun move-parms-final-fn (gadget value)
  (if (string= value "<Formula>")
      (progn
	(lapidary-error (format nil "~%the formula must return a value that is valid for :slots-to-set"))
	(c32 (g-value gadget :window :inter) :move-box-parms 
	     '*move-grow-inter-queue*))
  (dialog-enqueue :move-box-parms
		  (cond ((string= value "Change Left") '(t nil t t))
			((string= value "Change Top") '(nil t t t))
			((string= value "Change Left and Top") 
			 '(t t t t)))
		  *MOVE-GROW-INTER-QUEUE*)))

(defun move-grow-min-length-fn (gadget value)
  (setf *move-grow-inter-queue*
	(enqueue-int-value gadget value :min-length *move-grow-inter-queue*)))

(defun move-grow-min-width-fn (gadget value)
  (setf *move-grow-inter-queue*
	(enqueue-int-value gadget value :min-width *move-grow-inter-queue*)))

(defun move-grow-min-height-fn (gadget value)
  (setf *move-grow-inter-queue*
	(enqueue-int-value gadget value :min-height *move-grow-inter-queue*)))

(defun MOVE-GROW-OBJ-TO-CHANGE-FN (panel value)
  (declare (special move-grow-inter-menu))
  (s-value (g-value panel :parent) :value value) 
  (if (string= value "<Formula>")
      (c32 (g-value panel :window :inter) :obj-to-change
	   '*move-grow-inter-queue*)
      (dialog-enqueue :obj-to-change
		      nil
		      *MOVE-GROW-INTER-QUEUE*)))
  
(defun MOVE-GROW-FEEDBACK-OBJ-FN (feedback-obj-box button-label)
  (declare (special move-grow-inter-menu))
  (declare (ignore feedback-obj-box))
  (let ((selection (car (g-value *SELECTION-INFO* :selected))))
    (if selection
	(progn
	  (s-value (MOVE-GROW-FEEDBACK-OBJ) :field-string
		   (name-for-schema selection))
	  (s-value (MOVE-GROW-FEEDBACK-OBJ) :value button-label)
	  (dialog-enqueue :feedback-obj selection *MOVE-GROW-INTER-QUEUE*))
	(progn
	  (s-value (MOVE-GROW-FEEDBACK-OBJ) :field-string nil)
	  (s-value (MOVE-GROW-FEEDBACK-OBJ) :value nil)))))

(defun MOVE-GROW-NIL-FEEDBACK-OBJ-FN (button button-label)
  (declare (special move-grow-inter-menu))
  (declare (ignore button))
  (dialog-enqueue :feedback-obj NIL *MOVE-GROW-INTER-QUEUE*)
  (s-value (MOVE-GROW-FEEDBACK-OBJ) :field-string nil)
  (s-value (MOVE-GROW-FEEDBACK-OBJ) :value button-label))

(defun MOVE-GROW-FORMULA-FEEDBACK-OBJ-FN (button button-label)
  (declare (special move-grow-inter-menu))
  (c32 (g-value button :window :inter) :feedback-obj
       '*MOVE-GROW-INTER-QUEUE*)
  (s-value (MOVE-GROW-FEEDBACK-OBJ) :field-string nil)
  (s-value (MOVE-GROW-FEEDBACK-OBJ) :value button-label))

(defun move-grow-attach-point-fn (inter button)
  (declare (ignore inter))
  (let ((attach-point (g-value button :attach-point)))
    (if (eq attach-point :formula)
	(c32 (g-value button :window :inter) :attach-point
	     '*move-grow-inter-queue*)
        (dialog-enqueue :attach-point 
		      attach-point
		      *MOVE-GROW-INTER-QUEUE*))))

(defun MOVE-GROW-FINAL-FUNCTION-FN (labeled-box string)
  (declare (ignore labeled-box))
  (dialog-enqueue :final-function
		  (if (string= string "") nil (read-from-string string))
		  *MOVE-GROW-INTER-QUEUE*))
