;;; -*- 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 contains code for attaching constraints to objects
;;; in the graphical editor. The code handles the actions associated
;;; with the constraint menu

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


;;; ============================================================
;;; propagate formulas and their offsets to all instances of
;;; a schema
;;; ============================================================

(defun propagate-formula (schema slot formula objover-slot objover
				 offset-slot offset
				 &optional scale-slot scale-factor)
  (dovalues (instance schema :is-a-inv :local t)
     (propagate-formula instance slot formula objover-slot objover
			offset-slot offset scale-slot scale-factor)
     ;; save values for undo
     (undo-save instance slot)
     (undo-save instance objover-slot)
     (undo-save instance offset-slot)
     (s-value instance slot (formula formula))
     (s-value instance objover-slot (formula objover))
     (s-value instance offset-slot offset)
     (when scale-slot
       (undo-save instance scale-slot)
       (s-value instance scale-slot scale-factor))))

(defun propagate-offset (schema slot formula offset-slot offset)
  (dovalues (instance schema :is-a-inv :local t)
     (propagate-offset instance slot formula offset-slot offset)
     (when (is-a-p (get-value instance slot) formula)
	   (undo-save instance offset-slot)
	   (s-value instance offset-slot offset))))

;;; ============================================================
;;; determine if the two objects have a common ancestor in the
;;; aggregate hierarchy. A simple way of doing this is to go
;;; to the tops of each of their aggregate hierarchies and 
;;; comparing the respective roots. Although a marking strategy
;;; could save us from going all the way to the top of the
;;; hierarchies, we would have to retract all the marks at
;;; the end, which would complicate the function. Also the
;;; hierarchies are likely to be shallow so marking probably
;;; would not save any time
;;; ============================================================


(defun get-root (obj)
  (let ((parent (or (g-value obj :parent)
		    (g-value obj :operates-on))))
    (if (is-a-p obj inter:interactor)
	(if parent
	    (get-root parent)
	    obj)
        (if (eq (g-value obj :parent)
		(g-value obj :window :editor-agg))
	    (return-from get-root obj)
	    (get-root parent)))))

(defun common-ancestor-p (obj1 obj2)
  (let ((parent1 (get-root obj1))
	(parent2 (get-root obj2)))
    (eq parent1 parent2)))

;;; ============================================================
;;; destroy a constraint and any associated support
;;; slots, such as link and offset slots
;;; ============================================================

(defun lapidary-destroy-constraint (schema slot link offset &optional (scale))
  ;; save values for undo. Note: KR does not actually destroy the constraint,
  ;; it merely removes the constraint from the slot, so it is sufficient to
  ;; save the constraint
  (undo-save schema slot)
  (undo-save schema link)
  (undo-save schema offset)
  (when scale
	(undo-save schema scale))
  (destroy-constraint schema slot)
  (destroy-slot schema link)
  (destroy-slot schema offset)
  (destroy-slot schema scale))

;;; ============================================================
;;; prompt the user for a custom constraint and install it in 
;;; the desired slot. print out the names of the primary and
;;; secondary selections to assist the user
;;; ============================================================
#|
(defun make-custom-constraint (slot &key (type nil))

  (let ((p-selections (g-value *selection-info* :p-selected))
	(s-selections (g-value *selection-info* :s-selected))
	link-name)

  ;; the custom constraint must refer to objects indirectly via links.
  ;; thus print out the names of the secondary selections
  ;; and instruct the designer to enter linknames that will refer to
  ;; thse objects. Lapidary will automatically construct a pathname
  ;; from schema to these objects and store the pathname in the link

  (format t "~% ~% To reference the object which contains the new constraint")
  (format t "~% you must use the expression (gvl :slotname).")
  (format t "~% ~% The names of the secondary selections are ~S" s-selections)
  (format t "~% ~% The constraint must reference these objects indirectly")
  (format t "~% through links (gvl :linkname :slotname). For each of the")
  (format t "~% following objects, please enter the keyword name of the link that")
  (format t "~% should point to the object. A keyword has a colon, ':',")
  (format t "~% followed by a name (e.g., :foo). Lapidary will automatically")
  (format t "~% construct an expression that ensures that this link will")
  (format t "~% always point to the object. You may enter nil (press return)")
  (format t "~% if the constraint will not reference this object. ~%")

  (dolist (obj s-selections)
    (garnet-debug:flash obj)
    (garnet-debug:invert obj)
    (format t "~% The link for ~S should be named (e.g., :foo): " obj)
    (force-output)
    (setf link-name (read-line))
    (when (not (string= link-name ""))
      (setf link-name (read-from-string link-name))
      (when (not (keywordp link-name))
	    (loop
	     (format t "~% Name must be a keyword. Please ~
				    enter a keyword name: ")
	     (force-output)
	     (setf link-name (read-line))
	     (when (not (string= link-name ""))
		   (setf link-name (read-from-string link-name)))
	     (when (keywordp link-name)
		   (return))))
      (dolist (schema p-selections)
	(when (or (not type) (is-a-p schema type))
	      (undo-save schema link-name)
	      (if (common-ancestor-p schema obj)
		  (s-value schema link-name 
			   (eval `(o-formula (gvl ,@(make-path schema obj)))))
		  (s-value schema link-name obj))))))

  (garnet-debug:uninvert)

  ;; now get the formula itself
  (format t "~% ~% please enter the formula [e.g., (+ (gvl :width) 10)] ~% ")
  (let ((form (read)))
    (dolist (schema p-selections)
      (when (or (not type) (is-a-p schema type))
	;; create a custom constraint by creating an instance of
	;; a custom prototype and then changing the formula to
	;; the custom formula. the :lambda slot has to be
	;; set with an actual value or else change-formula will fail
	(let ((formula (formula *custom-constraint*))
	      (old-value (get-value schema slot))
	      (new-value most-positive-fixnum))
	  ;; if the old-value is a formula, save a copy of the formula.
	  ;; if this is not done, the formula will be destroyed when 
	  ;; the new formula is stored in the slot
	  (when (formula-p old-value)
		(setf old-value (copy-formula old-value)))

	  ;; be prepared to undo this formula if something goes wrong
;	  (undo-save schema slot)
	  (unwind-protect
	      (progn
		(kr::copy-to-all-instances schema slot formula)
		(change-formula schema slot form)
		;; force the formula to be evaluated to see if it will fail
		(setf new-value (g-value schema slot)))
	    ;; if new-value is equal to most-positive-fixnum, something
	    ;; went wrong, we need to back out; otherwise we should
	    ;; propagate the formula to all instances
	    (when (eq new-value most-positive-fixnum)
		  (progn
		    (destroy-constraint schema slot)
		    (s-value schema slot old-value)
		    (format t "~% The bad constraint was destroyed and the old value restored.")
		    (format t "~% To continue, type (inter:main-event-loop)~%"))))))))))
|#

;;; ======================================
;;; attach a constraint to a slot
;;; of a primarily selected object
;;; ======================================

(defun attach-constraint (menu slot link-slot offset-slot constraint
			       &optional (scale-slot))
  (let ((p-selected-item (car (g-value *selection-info* :p-selected)))
	(s-selected-item (car (g-value *selection-info* :s-selected))))

;    (reset-undo)

    ;; certain slots should not be altered. if this slot is
    ;; one of them, tell the user and do not proceed
    (when (member slot (g-value p-selected-item :do-not-alter-slots))
	  (lapidary-error
	   (format nil "cannot change ~S's ~S slot" 
		   p-selected-item slot))
	  (return-from attach-constraint))

    ;; store the value of the offset field in the offset slot,
    ;; the value of the secondary selection in the link slot,
    ;; and the value of the scale field (if there is one) in the
    ;; scale slot. these slots must be set
    ;; before the formula is installed in slot, since KR will 
    ;; immediately evaluate the formula and thus these fields must
    ;; already be set
    (undo-save p-selected-item offset-slot)
    (s-value p-selected-item offset-slot
	     (g-value menu offset-slot))
    (when scale-slot
	  (undo-save p-selected-item scale-slot)
	  (s-value p-selected-item scale-slot
		   (g-value menu scale-slot)))

    (when (not (eq (g-value p-selected-item link-slot) s-selected-item))
	  (undo-save p-selected-item link-slot)
	  (cond ((eq p-selected-item s-selected-item)
		 ;; this case must be handled differently since make-path
		 ;; would generate nil and (gvl ) would be returned.
		 ;; The (gv :self) will be substituted into the slot's 
		 ;; formula when the object is saved, so the superfluous
		 ;; link access will not slow down the object when it
		 ;; runs in an application
		 (s-value p-selected-item link-slot (o-formula (gv :self))))

		;; if there is a common ancestor, construct a formula that
		;; walks through the aggregate hierarchy to find the secondary
		;; selection
		((common-ancestor-p p-selected-item s-selected-item)
		 (s-value p-selected-item link-slot
		       (eval `(o-formula (gvl ,@(make-path p-selected-item
						   s-selected-item))))))

		;; if no common ancestor, simply store the secondary
		;; selection in the link slot
		(t (s-value p-selected-item link-slot s-selected-item))))

    (when (not (is-a-p (get-value p-selected-item slot) constraint))
	  (undo-save p-selected-item slot)
	  (kr::copy-to-all-instances p-selected-item slot 
				     (eval `(o-formula ,constraint))))))
#|
    ;; propagate the formula to all slots that inherit this slot's
    ;; value
    (kr::copy-to-all-instances p-selected-item slot 
			       (get-value p-selected-item slot))))

    (propagate-formula p-selected-item slot 
		       (get-value p-selected-item slot)
		       link-slot
		       (get-value p-selected-item link-slot)
		       offset-slot
		       (g-value p-selected-item offset-slot)
		       scale-slot
		       (g-value p-selected-item scale-slot))))
|#
;;; ======================================
;;; remove a constraint from a slot and
;;; destroy all slots used to support that
;;; constraint
;;; ======================================

(defun remove-constraint (inter obj-over)
  (declare (special *selection-info* *box-constraint-menu*))
;  (reset-undo)
;; if there was a constraint button selected, deselect it
  (when (g-value inter :deselect)
	(deselect-constraint-button (g-value inter :deselect)))
  (let ((slot (g-value inter :slot))
	(link-slot (g-value inter :link-slot))
	(offset-slot (g-value inter :offset-slot))
	(scale-slot (g-value inter :scale-slot)))
    (s-value *box-constraint-menu* (g-value inter :constraint-slot) obj-over)
    (dolist (obj (g-value *selection-info* :selected))
	    (lapidary-destroy-constraint obj slot link-slot 
					 offset-slot scale-slot))))

;;; ======================================
;;; create a custom constraint
;;; ======================================

(defun create-custom-constraint (inter obj-over)
  (declare (special *box-constraint-menu* *selection-info*))
;  (reset-undo)
;; if there was a constraint button selected, deselect it
  (when (g-value inter :deselect)
	(deselect-constraint-button (g-value inter :deselect)))
  (when (g-value *selection-info* :p-selected)
	(c32 (car (g-value *selection-info* :p-selected))
	     (g-value inter :slot))
	(s-value *box-constraint-menu* 
		 (g-value inter :constraint-slot) 
		 obj-over)))

