;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; CHANGE LOG
;;;
;;; 08/24/92 amickish - Added proclaim

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

(proclaim '(special *df-copy* *df-xor* *df-and* *df-or* *df-other*
	    *df-nor* *df-clear* *df-set* *df-no-op* *df-copy-inverted*
	    *df-invert* *df-equiv* *df-nand* *df-and-inverted*
	    *df-and-reverse* *df-or-inverted* *df-or-reverse*))

;; define some feedback objects
(create-instance '*left-feedback* button-feedback) 
(create-instance '*top-feedback* button-feedback)
(create-instance '*width-feedback* button-feedback)
(create-instance '*height-feedback* button-feedback)
(create-instance '*box-feedback1* button-feedback)
(create-instance '*box-feedback2* button-feedback)
(create-instance '*line-feedback1* button-feedback)
(create-instance '*line-feedback2* button-feedback)
(create-instance '*draw-fct-feedback1* button-feedback)
(create-instance '*draw-fct-feedback2* button-feedback)

(defvar *unconstrain-left* nil)
(defvar *unconstrain-top* nil)
(defvar *unconstrain-width* nil)
(defvar *unconstrain-height* nil)
(defvar *unconstrain-line* nil)

#|
(defun set-feedback ()
  (let* ((selection-type (g-value *selection-info* :selection-type))
	 (p-selection (car (g-value *selection-info* :p-selected)))
	 (s-selection (if (eq selection-type 'one-one)
			  (car (g-value *selection-info* :s-selected))
			  nil)))
       
       ;; determine which constraint icons should be highlighted 
    (if (or (eq selection-type 'one-zero) 
	    (eq selection-type 'one-one))
	;; constraint icons should be highlighted only if there is one
	;; primary selection and zero or one secondary selections
       (cond ((is-a-line-p p-selection)
	      (let ((pt1-formula (get-value p-selection :x1))
		    (pt2-formula (get-value p-selection :x2)))
		(if (and (formula-p pt1-formula)
			 (or (eq selection-type 'one-zero)
			     (depends-on-p p-selection :x1 
					   s-selection :x1-over)))
		    (progn
		      (s-value *line-feedback1* :obj-over
			       (g-value pt1-formula :line-menu-item))
		      (s-value *box-feedback1* :obj-over
			       (g-value pt1-formula :box-menu-item)))
		    (progn
		      (s-value *line-feedback1* :obj-over *unconstrain-line*)
		      (s-value *box-feedback1* :obj-over nil)))
		(if (and (formula-p pt2-formula)
			 (or (eq selection-type 'one-zero)
			     (depends-on-p p-selection :x2 
					   s-selection :x2-over)))
		    (progn
		      (s-value *line-feedback2* :obj-over
			       (g-value pt2-formula :line-menu-item))
		      (s-value *box-feedback2* :obj-over
			       (g-value pt2-formula :box-menu-item)))
		    (progn
		      (s-value *line-feedback2* :obj-over *unconstrain-line*)
		      (s-value *box-feedback2* :obj-over nil)))
		(remove-box-constraint-feedback)))

	     ;; if the primary selection is a box object, the secondary 
	     ;; selection is a line, and the left and top slots of the box
	     ;; object depend on the line, highlight the appropriate
	     ;; constraint icons in the line constraint menu
	     ((and (eq selection-type 'one-one)
		   (is-a-line-p s-selection))
	      (let ((formula (get-value p-selection :left)))
		(if (and (formula-p formula)
			 (or (eq selection-type 'one-zero)
			     (depends-on-p p-selection :left 
					   s-selection :left-over)))
		    (progn
		      (s-value *line-feedback1* :obj-over
			       (g-value formula :line-menu-item))
		      (s-value *box-feedback1* :obj-over
			       (g-value formula :box-menu-item))
		      (s-value *line-feedback2* :obj-over nil)
		      (s-value *box-feedback2* :obj-over nil))
		    (progn
		      (remove-line-constraint-feedback)
		      (s-value *line-feedback1* :obj-over *unconstrain-line*)))))
	     (t
	      (do ((slots '(:left :top :width :height) (cdr slots))
		   (unconstrain-icons (list *unconstrain-left* *unconstrain-top*
					    *unconstrain-width* *unconstrain-height*)
				      (cdr unconstrain-icons))
		   (feedback-objs (list *left-feedback* *top-feedback*
					*width-feedback* *height-feedback*)
				  (cdr feedback-objs))
		   (links (list :left-over :top-over :width-over :height-over)
			  (cdr links)))
		  ((null slots))
		(let* ((slot (car slots))
		       (value (get-value p-selection slot))
		       (feedback-obj (car feedback-objs)))
		  (s-value feedback-obj :obj-over
			   (if (formula-p value)
			       (case selection-type
				 (one-zero
				  ;; if there is only one primary selection,
				  ;; return the menu item that shows which 
				  ;; formula constraints the slot
				  (g-value value :menu-item))
				 (one-one
				  ;; if there is one primary and one secondary 
				  ;; selection, determine if the primary selection 
				  ;; depends on the secondary selection and if it 
				  ;; does, highlight
				  ;; the appropriate constraint icon
				  (if (depends-on-p p-selection slot 
						    s-selection (car links))
				      (g-value value :menu-item)
				      (car unconstrain-icons))))
			       (car unconstrain-icons)))))
	      (remove-line-constraint-feedback))))))
|#
(defun set-feedback ())

(defun dependency-any-slot-p (schema obj slot)
  (let ((formula (get-value schema slot)))
    (when (formula-p formula)
      (doslots (this-slot obj)
	       (when (member formula (kr::get-dependents obj this-slot))
		     (return-from dependency-any-slot-p t))))
    nil))

(defun depends-on-p (p-selection slot s-selection link)

  ;; determine if the formula depends on the secondary selection
  (if (is-a-p (get-value p-selection slot) *custom-constraint*)
      ;; if this is a custom formula, determine whether the
      ;; slot in the primary selection depends on any of the
      ;; slots in the secondary selection
      (dependency-any-slot-p p-selection s-selection slot)
      
      ;; if this is a lapidary formula, determine whether the
      ;; slot in the primary selection depends on the same slot
      ;; in the secondary selection
      (eq (g-value p-selection link) s-selection)))

(defun remove-box-constraint-feedback ()
  (dolist (feedback-obj (list *left-feedback* *top-feedback*
			      *width-feedback* *height-feedback*))
    (s-value feedback-obj :obj-over nil)))

(defun remove-line-constraint-feedback ()
  (dolist (feedback-obj (list *line-feedback1* *line-feedback2*
			      *box-feedback1* *box-feedback2*))
    (s-value feedback-obj :obj-over nil)))

(defun set-draw-fct-feedback ()
  (let ((selected (g-value *selection-info* :selected)))
    (when (and selected (not (cdr selected)))
      (s-value *draw-fct-feedback1* :obj-over
	       (case (g-value (car selected) :draw-function)
		 (:copy *df-copy*)
		 (:xor *df-xor*)
		 (:and *df-and*)
		 (:or *df-or*)
		 (t *df-other*)))
      (if (eq (g-value *draw-fct-feedback1* :obj-over) *df-other*)
	  (s-value *draw-fct-feedback2* :obj-over
		   (case (g-value (car selected) :draw-function)
		     (:nor *df-nor*)
		     (:clear *df-clear*)
		     (:set *df-set*)
		     (:no-op *df-no-op*)
		     (:copy-inverted *df-copy-inverted*)
		     (:invert *df-invert*)
		     (:equiv *df-equiv*)
		     (:nand *df-nand*)
		     (:and-inverted *df-and-inverted*)
		     (:and-reverse *df-and-reverse*)
		     (:or-inverted *df-or-inverted*)
		     (:or-reverse *df-or-reverse*)))
	  (s-value *draw-fct-feedback2* :obj-over nil)))))
