(in-package "C32" :use '("LISP" "KR" "KR-DEBUG"))

(defvar lapidary-p t)

;; add slots to list of slots that c32 should show for lapidary interactors
(s-value lapidary:directional-move-grow-interactor :slots-to-show
	 (append (g-value lapidary:directional-move-grow-interactor 
			  :slots-to-show)
		 '(:grow-box-parms :move-box-parms)))
	 
(defun generate-link-name (obj)
  (let ((counter 0)
	link)
    (setf link (read-from-string
		(concatenate 'simple-string ":link-" 
			     (princ-to-string counter))))
    (loop
     (when (not (has-slot-p obj link))
	   (return))
     (incf counter)
     (setf link (read-from-string
		 (concatenate 'simple-string ":link-" 
			      (princ-to-string counter)))))
    link))


(defun Get-Reference-For (to-obj to-slot from-obj from-slot)
  (declare (ignore from-slot))
  (declare (special *all-windows*))

  (let (link ref win)

    ;; find the window which contains the current formula. This might
    ;; be more easily accomplished by passing in the gadget, but then 
    ;; I'd have to modify even more of C32 than I already have
    (setf win (dolist (w *all-windows*)
		      (when (and (schema-p w)
				 (g-value w :visible)
				 (eq (g-local-value w :c32-obj) from-obj)
				 (eq (g-local-value w :c32-slot) from-slot))
			    (return w))))

    ;; see if the from-obj and to-obj are the same and avoid the messy
    ;; generating of links if they are
    (cond ((eq to-obj from-obj)
	   (setf ref (if (or (null to-slot) (eq to-slot T)) 
			 ;; if a reference to the object itself, return SELF
			 "(gv :SELF)" 
		         ;; else use to-slot of object	     
		         (prin1-to-string `(gvl ,to-slot)))))
	  (t
	    ;; see if a link for this object already exists
	    (dolist (slot (g-value from-obj :links))
		    (when (eq to-obj (g-value from-obj slot))
			  (setf link slot)
			  (return)))

	    ;; also check the links generated for this formula.
	    ;; the links are in a list of the form ((link obj) ... (link obj))
	    (when (null link)
		  (setf link (member to-obj (g-value win :links) :key #'cdr))
		  (when link (setf link (caar link))))

	    ;; if a link couldn't be found, generate a new link. Start 
	    ;; generating link names and see if they're already in use. 
	    ;; Start with :link-0 and work up. Since there are unlikely 
	    ;; to be too many link names, this is not that wasteful.
	    (when (null link)
		  (setf link (generate-link-name from-obj))
		  ;; temporarily install the link so that the formula
		  ;; can be tested--it will be removed or given the
		  ;; appropriate path later
		  (s-value from-obj link to-obj)
		  (push (cons link to-obj) (g-value win :links)))

	    ;; create the reference that will be returned
	    (if (or (null to-slot) (eq to-slot T)) ; reference to the object itself
		(setf ref (prin1-to-string `(gvl ,link)))
	        (setf ref (prin1-to-string `(gvl ,link ,to-slot))))))

    ref))

;;; install links that will be used in a formula. if the object referenced
;;; by the link and the link belong to a common aggregadget, create a formula 
;;; that traverses the aggregate hierarchy to get the to-obj; otherwise use 
;;; a direct reference
(defun install-links (win from-obj)
  (let (link to-obj)
    (dolist (link-obj (g-value win :links))
	    (setf link (car link-obj))
	    (setf to-obj (cdr link-obj))
	    (if (lapidary::common-ancestor-p from-obj to-obj)
		(s-value from-obj link 
			 (eval `(o-formula (gvl ,@(lapidary::make-path from-obj to-obj)))))
	        (s-value from-obj link to-obj))
	    ;; remember that link is a link
	    (pushnew link (g-value from-obj :links)))
    ;; reset the window's links slot to nil
    (s-value win :links nil)))

;;; get rid of the temporarily installed links and reset the links list
;;; to nil
(defun remove-temporary-links (obj win)
  (dolist (link-obj (g-value win :links))
	  (destroy-slot obj (car link-obj)))
  (s-value win :links nil))

(defun Do-Form-Cancel (gadget item)
  (declare (Ignore item))
  (let ((win (g-value gadget :window)))
    (setq *Current-Formula-Win* NIL)
    ;; get rid of the links that were temporarily installed so that
    ;; the formula could be safely evaluated
    (remove-temporary-links (g-value win :c32-obj) win)
    (s-value win :visible NIL)
    (push win Formula-Wins-Available)
    ;; if this formula was requested by some property sheet, make c32 
    ;; invisible
    (when (g-value win :disappear-p)
	  ;; restore these slots to default settings
	  (s-value win :disappear-p nil)
	  (s-value win :queue nil)

	  (c32-ok-function)
	  )))


(defun Do-Form-Ok (gadget item)
  (declare (Ignore item))
  (let* ((win (g-value gadget :window))
	 (obj (g-value win :c32-obj))
	 (slot (g-value win :c32-slot))
	 (item (g-value win :c32-item))
	 (valstr (opal:get-string (g-value win :edit-string)))
	 (*current-formula-obj* obj)
	 (*current-formula-slot* slot)
	 result)
    (setq *Current-Formula-Win* NIL)
    (multiple-value-bind (val ok-p)
	(Convert-Str-To-Formula valstr)
      (case ok-p
	((t)
	 ;; place the formula on an interactor queue if a queue is provided
	 (if (g-value win :queue)
	     (progn
	       (setf result (g-value win :links))
	       (push val result)
	       (funcall (g-value win :install-fct) slot result 
			(g-value win :queue))
	       ;; get rid of the links that were temporarily installed so that
	       ;; the formula could be safely evaluated
	       (remove-temporary-links (g-value win :obj) win))
	     ;; else, install the formula
	     (progn
	       ;; install links
	       (install-links win obj)
	       (s-value obj slot val)))	; formula
	 ;; if formula added or removed, won't necessarily notice
	 (kr:recompute-formula item :formula-p))
	(:val
	 (destroy-constraint obj slot) ; regular value
	 (s-value obj slot val))
	(:empty
	 (destroy-constraint obj slot)) ; empty value, use old value
	((NIL)
	 (return-from Do-Form-Ok))) ; error already reported
      (s-value win :visible NIL)
      (push win Formula-Wins-Available)

    ;; if this formula was requested by some property sheet, make c32 
    ;; invisible
    (when (g-value win :disappear-p)
	  ;; restore these slots to default settings
	  (s-value win :disappear-p nil)
	  (s-value win :queue t)

	  (c32-ok-function))
)))

	 
;; Lapidary tries to copy links as well as the formula; however, Lapidary
;; cannot assure that the links will be copied correctly. For example,
;; if a link has the formula (gvl :parent :frame), Lapidary will copy the
;; formula but it will only work if the object that the formula is copied
;; to has the appropriate structure

(defun Start-Copy-Formula (from-c32item to-c32item)
  (let* ((from-obj (g-value from-c32item :obj))
	 (from-slot (g-value from-c32item :slot))
	 (to-obj (g-value to-c32item :obj))
	 (to-slot (g-value to-c32item :slot))
	 (links (g-value from-obj :links))
	 (from-form (get-value from-obj from-slot))
	 (depends-on (kr::i-depend-on from-obj from-slot))
	 slot)
    (multiple-value-bind (expr formula-p)
	(Get-Formula-Expr from-form)
      (if formula-p
	(progn
	  (multiple-value-bind (obj-list slot-list)
	      (recursive-list-find-refs expr NIL NIL)
	    (declare (ignore obj-list))
	    (multiple-value-bind (from-slots to-slots)
		(Map-Slots from-slot to-slot slot-list)
	      (Pop-Up-Confirm-Copy-Formula from-obj from-slot to-obj to-slot
				       from-slots to-slots
				       expr to-c32item)))

	  ;; copy any slots that are in from-obj but not in to-obj to
	  ;; to-obj
	  (dolist (obj-slot depends-on)
		  (setf slot (cdr obj-slot))
		  (when (and (eq (car obj-slot) from-obj)
			     (not (has-slot-p to-obj slot)))
			
			;; copy the value of slot into to-obj
			(if (formula-p (get-value from-obj slot))
			    (s-value to-obj slot
				     (copy-formula (get-value from-obj slot)))
			    (s-value to-obj slot (g-value from-obj slot)))
			    
			;; if this slot is a link slot, push the link onto
			;; to-obj's link list
			(when (or (member slot links)
				  (member slot
					 '(:left-over :top-over :width-over
					   :height-over :x1-over :y1-over
					   :x2-over :y2-over)))
			      (push slot (g-value to-obj :links))))))

	;; else just copy the value
	(progn
	  (destroy-constraint to-obj to-slot) ; in case used to be a formula
	  (s-value to-obj to-slot expr)
	  ;; * if formula added or removed, won't necessarily notice
	  (kr:recompute-formula to-c32item :formula-p))))))

(create-instance 'direct-ref-query-gadget garnet-gadgets:query-gadget
		 (:modal-p t)
		 (:button-names '("YES" "NO")))

(defun check-for-direct-ref (expr)
  (cond ((listp expr)
	 (dolist (element expr)
		 (when (string-equal (check-for-direct-ref element) "YES")
		       (return-from check-for-direct-ref t)))
	 nil)
	(t (if (and (boundp expr) 
		    (is-a-p (symbol-value expr) opal:view-object))
	       (garnet-gadgets:display-query-and-wait direct-ref-query-gadget
		     (format nil "The formula contains a direct reference to 
~S.
Lapidary may not be able to generalize this
formula properly if the direct reference
should be a parameter. If the direct reference
should be a parameter, please edit the
formula and use either 'Insert Ref From Spread...'
or 'Insert Ref from Mouse' to insert the reference.
Do you want to edit the formula?" expr))

	     ;; else the expr is not a view-object, so return nil
	       nil))))

    
;;; Returns a pair of values: new-val OK-P.  If OK, then new-val is
;;; valid, otherwise it failed to be read.
;;; If <check-formula-p>, make sure the expression can be evaluated (as part
;;; of a formula).
;;; If <read-value-too> is true, the first entry may be followed by a
;;; space and then a value.  This can be used, for example, to read a slot
;;; name and value in one operation
;;;
(defun Careful-Read-From-String (new-str check-formula-p read-value-too)
  (let ((checked-p nil)
	final-value formula-value no-error had-value second-value)
    (ignore-error-give-message
     (let ((*package* *c32-package*))
       (read-from-string new-str))
     (multiple-value-setq (final-value no-error)
       (cond ((not (numberp errorp))	; invalid
	      (values new-str NIL))
	     ((and (symbolp val) (boundp val)) ; if a symbol, eval it
	      (values (eval val) T))
	     ((and val (listp val) check-formula-p)
	      ;; check and make sure there are no direct references. Only
	      ;; continue if check-for-direct-ref returns nil
	      (if (null (check-for-direct-ref val))
		  ;; Check to make sure this will work as a formula.
		  (let ((value val)
			(new-formula (formula val))) ; make formula here.
		    (ignore-error-give-message
		     ;; Try out the formula without actually installing it.
		     (let ((kr::*schema-self* *current-formula-obj*)
			   (kr::*schema-slot* *current-formula-slot*)
			   (kr::*current-formula* new-formula)
			   (kr::*warning-on-null-link* T))
		       (setf formula-value (catch 'kr::no-link
					     (eval value)))
		       (setf checked-p T))
		     (setf val val)	; suppress error message
		     (if (or (null errorp) (numberp errorp))
			 (progn
			   (setf checked-p T)
			   (values new-formula T))
		       (values value NIL))))
		  ;; else there were direct references that the user
		  ;; wants to edit
		  (values val nil)))
	     (t
	      (values val T))))
     (when (and no-error read-value-too (> (length new-str) errorp))
       (setf new-str (subseq new-str errorp))
       (setf had-value T)
       (setf second-value (read-from-string new-str)))
     (if no-error
       (unless (opal::legal-type-p *current-formula-obj* *current-formula-slot*
				   (if checked-p formula-value final-value))
	 (setf no-error NIL)))
     (if had-value
       (values final-value no-error second-value)
       (values final-value no-error)))))
	   

(defun c32-ok-function ()

  ;; allow no windows to be selected by the obj-find interactor
  (s-value (g-value c32::ask-object :obj-find) :window nil)

  (setf lapidary-p nil)

  (dolist (win *All-windows*)
    (if (schema-p win)
      (s-value win :visible nil)))
  (dolist (panel (copy-list (g-value *Current-Panel-Set* :aggrel :components)))
	  (remove-panel panel)))


(defun QuitFunc (gadget sel)
  (declare (ignore gadget sel))
  (declare (special lapidary-p))
  (if lapidary-p
      (c32-ok-function)
      (progn
	(do-stop)
	#-cmu (inter:exit-main-event-loop)))
  )
