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

#|
ChangeLog:
  13 Oct 93 R J Williams - Look for inherited slots in DOSLOTS calls
  14 Sep 93 Andrew Mickish - Removed :x-substr case from opal::legal-type-p
  28 May 93 Dario Giuse - replace kr internals with calls to g-formula-value.
  23 Mar 93 Brad Myers - added new debug functions break-on-slot-set and
	  notify-on-slot-set and clear-slot-set, call-func-on-slot-set
  20 Jan 93 Mickish Cleared input buffer before IDENT's real event-case;
                    Added schema-p checks in IDENTIFY.
  18 Jan 93 Brad Myers - fixed Look-inter and added :next option
                       - changed output of std-proto to add package name
  10 Dec 92 Mickish *drawable-to-window-mapping* ---> *garnet-windows*
  21 Apr 92 Pervin Using new function opal:main-event-loop-process-running-p
  14 Apr 92 Pervin Got multi-process stuff to work on HP.

   6 Apr 92  DZG  Fixed explain-slot for release 2.0 of KR.

  27 Mar 92 Pervin    In ident, kill and re-launch the main-event-loop-process.
		      In std-proto, check that schema-name is symbol.

  27 Mar 92 amickish  Removed format statements from tests for conditionals in
                      flash because they rendered the code body unreachable;
                      Added ~A in format string of explain-nil.

  25 Mar 92 amickish  Get-Values--->G-Value;  Get-Local-Values--->G-Local-Value

  30 Oct 89  RBD  added direct-clx versions of flash and ident

  18 Oct 89  RBD  changed fix-up-aggregate and just-remove-component to
                  test for null objects,
                  fixed ident to return leaf elements (bug fix),
                  test for null objects in :start-where in look-inter,
                  declared flash-object.
  11 Dec 89  ECP  uncommented create-flash-object

  25 Jan 90  RBD  fixed code to use get-local-values to avoid "inheriting"
                  components,
                  print prompt to user when ident is started
                  improved test for bad objects in fix-up-window

  29 Jan 90  RBD  test for window in FLASH

  12 Mar 90  RBD  modified IDENT to return list of useful values,
                  fixed std-parent to take NIL, renamed to std-proto.

  14 Mar 90  RBD  fixed IDENT to not return when user types shift or ctrl.

  16 Apr 90  ECP  Got rid of defvars of previously defined objects
		  like opal:aggregate.
		  Took defun of fix-up-aggregate and fix-up-window
		  out of let statement.

  31 May 90  RBD  fixed explain-slot by properly accessing :kr-depends-on slot.
                  look now prints interactors of aggregadgets and aggrelists

  27 Jun 90  RBD  look-inter now prints all active interactors that operate
                  in a window if the first argument is a window

  12 Jul 90  RBD  minor change in output from IDENT

  31 Jul 90  RBD  look-inter now looks at :final-feed-avail, -inuse, and -obj slots
  
  12 Mar 91  ECP  Gave flash an optional argument: the number of blinks

  11 Dec 91  Amickish  Converted to new KR:  Added 'car' to :is-a references,
                       changed kr::name-accessor to kr::schema-name
|#

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

(export '(explain-short explain-slot explain-nil
	  fix-up-window flash ident invert 
	  is-a-tree kids look look-inter 
	  uninvert what where windows break-on-slot-set
	  notify-on-slot-set clear-slot-set call-func-on-slot-set))



(defvar flash-object)
(defvar blink-gc nil)


;;; blink-rectangle -- used by flash
;;;
(defun blink-rectangle (number-of-blinks win agg left top width height)
  (declare (ignore agg))
  (let ((window (g-value win :drawable)))
    (cond ((null window)
	   (format t "No :drawable for ~A~%" win)
	   (return-from blink-rectangle)))
#| 
    ;;; this is the opal-based blinking code
    ;; if flash-object does not exist yet, then create it
    (create-flash-object)
    
    (s-value flash-object :left left)
    (s-value flash-object :top top)
    (s-value flash-object :width width)
    (s-value flash-object :height height)
    (dotimes (n number-of-blinks)
      (add-component agg  flash-object)
      (update win)
      (sleep 0.1)
      (remove-component agg flash-object)
      (update win))
|#

    ;;; this is xlib-based blinking code
    (initialize-blinking-context win)
    (dotimes (n number-of-blinks)
      (xlib:draw-rectangle window blink-gc left top width height t)
      (xlib:display-force-output (xlib:window-display window))
      (sleep 0.1))
    (xlib:free-gcontext blink-gc)
    (setf blink-gc nil) ))


;;; create-flash-object -- create xor object unless it exists already
;;;
(defun create-flash-object ()
  (let (agg win)
    (cond ((or (null (boundp 'flash-object))
	       (null (schema-p flash-object)))
	   (create-instance 'flash-object opal:rectangle
			    (:draw-function :xor)
			    (:name "debug-opal's flash object")
			    (:filling-style opal:black-fill))))

    ;; if flash-object is already in use, remove it from parent
    (setf agg (g-value flash-object :parent))
    (setf win (g-value flash-object :window))
    (cond (agg
	   (remove-component agg flash-object)))
    (cond (win
	   (update win)))))



;;; EXPLAIN-SHORT -- tell what a slot depends upon
;;;
(defun explain-short (object slot) (explain-slot object slot 0 nil 2))

;; use this to avoid circularities and printing shared dependencies
(defvar explain-visited)



;;; EXPLAIN-SLOT -- tell why a slot has a value
;;;
(defun explain-slot (object slot &optional (indent 0) (use-inverse-method nil) 
			    (n-levels 0))
  (setf explain-visited nil)  ;start with an empty list
  (explain-2 object slot indent use-inverse-method n-levels)
  (setf explain-visited nil)  ;free storage for gc
  )


;;; explain-2 -- look for dependents, avoid circularities
;;;
(defun explain-2 (object slot indent use-inverse-method n-levels)
  (let ((pair (cons object slot)))
    (cond ((member pair explain-visited :test #'equal)
	   (indent-by indent)
	   (format t "~S's ~S -- already printed~%"
		   object slot)
	   (return-from explain-2 nil))
	  (t
	   (push pair explain-visited))))
  (let ((value (get-value object slot))
	depends-on)
    (indent-by indent)
    (cond ((formula-p value)
	   (let ((*print-pretty* nil))
	     (format t "~S's ~S is " object slot)
	     (print-a-slot object slot)
	     (format t ",~%")
	     (cond ((not (kr::cache-is-valid value))
		    (indent-by indent)
		    (format t 
 "(warning: this formula is invalid, so dependencies may be incorrect)~%"))))
	   (setf indent (+ indent 1))
	   (cond ((/= indent n-levels)   ;; stop recursion when ident = n-levels
		  (indent-by (1- indent))
		  (format t "which depends upon:~%")
		  (cond (use-inverse-method  ;; don't trust :depends-on
			 (dolist (win opal::*garnet-windows*)
			   (let ((agg (g-value win :aggregate)))
			     (if agg
				 (find-depended agg value indent))))
			 #|
			 (maphash
			  #'(lambda (x-window opal-window)
			      (declare (ignore x-window))
			      (let ((agg (g-value opal-window :aggregate)))
				(cond (agg
				       (find-depended agg value indent)))))
				  opal::*drawable-to-window-mapping*)
                         |#
			 )
			((setf depends-on (g-formula-value value :DEPENDS-ON))
			 (find-dependencies depends-on value indent n-levels))
			(t ;; couldn't find :kr-depends-on
			 (indent-by indent)
			 (format t "No dependencies recorded.~%"))))
		 (t ;; stop recursion but indicate something missing
		  (indent-by indent)
		  (format t "...~%"))))
	  (t  ;; not a formula, just print the value
	   (format t "~S's ~S is " object slot)
	   (print-a-slot object slot)
	   (format t "~%"))))
    NIL)



;;; EXPLAIN-NIL -- why did the update fail?
;;;
(defun explain-nil ()
  (let (schema
	slot)
    (cond ((formula-p kr::*last-formula*)
	   (setf schema (g-formula-value kr::*last-formula* :SCHEMA))
	   (setf slot (g-formula-value kr::*last-formula* :SLOT))
	   (format
	    t "~A~%~A~A~A~%~A~%~A~%~A~A~A~S~A~A.~%~A~A~A~A~%     ~A~%"
	    "Assuming that you just trapped into the debugger and you"
	    "   got a message like 'Wrong type argument, "
	    (kr::cached-value kr::*last-formula*) ", ...',"
	    "   OR you got a message 'bad formula: ...' then"
	    "   maybe a call to GV in a formula failed.  If so, the formula"
	    "   was " kr::*last-formula* " which is in the "
	    slot " slot of " schema
	    "   Formula " kr::*last-formula* " is: "
	    (g-formula-value kr::*last-formula* :LAMBDA)
	    " The dependencies (one of which is probably a null link) are:")
	   (if (schema-p schema)
	     (explain-slot schema slot 0 t)
	     (format t " formula's :schema-slot is ~S !~%" schema))
	   (setf kr::*last-formula* nil))
	  (t
	   (format t "No errors in formula evaluation detected~%")))))


;;; find-depended -- search window for back-links
;;;
(defun find-depended (aggregate formula indent)
  (doslots (slot aggregate T)
    (let ((depended-slots (kr::get-dependents aggregate slot)))
      (if (member formula depended-slots)
	(explain-2 aggregate slot indent t 0))))
  (dolist (child (g-local-value aggregate :components))
    (find-depended child formula indent)))


;;; find-dependencies -- search objects for back-links
;;;
(defun find-dependencies (obj-list formula indent level)
  (kr::do-one-or-list (obj obj-list)
    (doslots (slot obj T)
      (let ((dependents (kr::get-dependents obj slot)))
	(if (if (listp dependents)
	      (member formula dependents)
	      (eq formula dependents))
	  (explain-2 obj slot indent nil level))))))


(defvar there-is-a-problem NIL)

;;; fix-up-aggregate -- recursive function to implement fix-up-window
;;;
(defun fix-up-aggregate (agg)
  (let ((comps (g-local-value agg :components)))
    (dolist (comp comps)
      (cond ((null comp)
	     (format t "~S has NIL for a component.~%" agg)
	     (cond ((y-or-n-p "Do you want me to try to remove it? ")
		    (just-remove-component agg comp))
		   (t
		    (setf there-is-a-problem t))))
	    ((is-a-p comp opal:aggregate)
	     (fix-up-aggregate comp))
	    ((test-display-slots comp))
	    (t
	     (format t "~S has bad slots.~%" comp)
	     (cond ((y-or-n-p "Do you want me to try to remove it? ")
		    (just-remove-component agg comp))
		   (t
		    (setf there-is-a-problem t))))))))


		       
;;; FIX-UP-WINDOW -- help user fix a window that won't update
;;;
(defun fix-up-window (win)
  (let ((agg (g-value win :aggregate))
	(invalid-objects
	 (opal::win-update-info-invalid-objects
	  (g-value win :win-update-info))) 
	bad-objects)
    (setf there-is-a-problem nil)

    ;; check for null invalid objects
    (dolist (object invalid-objects)
      (cond ((and (null (get-local-value object :update-info))
		  (progn
		    (format t "~A has no :update-info. " object)
		    (y-or-n-p "Remove from invalid-objects? ")))
	     (pushnew object bad-objects))))
    (cond (bad-objects
	   (dolist (object bad-objects)
	     (setf invalid-objects (delete object invalid-objects)))
	   (setf (opal::win-update-info-invalid-objects 
		  (g-value win :win-update-info)) 
		 invalid-objects)))

    ;; check aggregate tree
    (cond ((null agg));; null agg is ok
	  ((is-a-p agg opal:aggregate)
	   (fix-up-aggregate agg))
	  (t;; :aggregate is not an aggregate!
	   (format t "The window's aggregate ~S is not an opal:aggregate~%"
		   agg)
	   (cond ((y-or-n-p "Do you want me to remove it? ")
		  (s-value win :aggregate nil)))))
    (cond ((null there-is-a-problem)
	   (opal:update win t)))))



;;; FLASH -- blink where an object is located
;;;
(defun flash (obj &optional (num-blinks 10))
  (let ((win (g-value obj :window))
	(left (g-value obj :left))
	(top (g-value obj :top))
	(width (g-value obj :width))
	(height (g-value obj :height))
	(minsize 10)
	agg  winwidth winheight
	aggleft aggtop aggwidth aggheight
	invisible-agg)
    
    (cond (win
	   (setf agg (g-value win :aggregate))
	   (setf winwidth (g-value win :width))
	   (setf winheight(g-value win :height))))
    (cond (agg
	   (setf aggleft (g-value agg :left))
	   (setf aggtop (g-value agg :top))
	   (setf aggwidth (g-value agg :width))
	   (setf aggheight (g-value agg :height))))
    (cond ((null win)
	   (format t "~S does not have a window~%" obj))
	  ((null agg)
	   (format t "The window of ~S does not have an aggregate~%" obj))
	  ((not (and left top width height))
	   (format t "~S does not have a left, top, width, and height:~%" obj)
	   (where obj))
	  ((and (not (eq win obj));; this is not a window
		(or
		 (< (+ top height) 0);; above the window
		 (< (+ left width) 0);; left of the window
		 (> top winheight);; below the window
		 (> left winwidth)));; right of the window
	   (format t "~S is outside of it's window:~%" obj)
	   (where obj))
	  ((null (g-value win :visible))
	   (format t "~S's window ~S's :visible slot is NIL~%" obj win))
	  ((null (g-value obj :visible))
	   (format t "~S's :visible slot is NIL~%" obj))
	  ((setf invisible-agg (search-invisible-agg agg))
	   (format t "Aggregate ~S's :visible slot is NIL~%" invisible-agg))
	  ((not (and aggleft aggtop aggwidth aggheight))
	   (format t
		   "~S's aggregate does not have a left, top, width, and height:~%"
		   obj)
	   (where agg))
	  ((and (not (eq obj win));; not flashing the window
		(or
		 (< top aggtop)
		 (< left aggleft)
		 (> (+ top height) (+ aggtop aggheight))
		 (> (+ left width) (+ aggleft aggwidth))))
	   (format t "~S is at least partially outside of its aggregate ~S~%"
		   obj agg)
	   (where obj)
	   (where agg))
	  (t
	   (cond ((eq obj win)
		  (setf left 0)
		  (setf top 0))) 
	   (cond ((or (< width minsize) (< height minsize))
		  (format 
		   t "Enlarging feedback to ~D by ~D because ~S is small:~%" 
		   (max width minsize) (max height minsize)
		   obj)
		  (where obj)))
	   (cond ((null (g-value obj :visible))
		  (format t "~S is not currently visible." obj)))
	   (blink-rectangle num-blinks win agg left top
			    (max width minsize) (max height minsize))))))


;;; get-an-opal-window -- find any opal window and return it
;;;
(defun get-an-opal-window ()
  (car opal::*garnet-windows*)
  #|
  (maphash #'(lambda (x-window opal-window)
	       (declare (ignore x-window))
	       (return-from get-an-opal-window opal-window))
	   opal::*drawable-to-window-mapping*)
  |#
  )


;;; has-component-p -- see if aggregate has a component
;;;
(defun has-component-p (agg obj)
  (let ((comps (g-local-value agg :components)))
    (dolist (comp comps)
      (cond ((eq obj comp) (return t))))))


;;; has-leaf-p -- see if aggregate tree has a component
;;;
(defun has-leaf-p (agg obj)
  (let (comps)
    (setf comps (g-local-value agg :components))
    (dolist (comp comps)
      (cond ((eq obj comp) (return t))
	    ((and (is-a-p comp opal:aggregate)
		  (has-leaf-p comp obj))
	     (return t))))))



;;; IDENT -- identify an object by pointing
;;;
(defvar ident)  ;; ident gets the value you point to

#|
;;; this ident is based on interactors, and is superseded by the clx
;;; implementation below
(defun ident ()
  (cond ((or (not (boundp 'identify-interactor))
	     (not (schema-p identify-interactor)))
	 (create-identify-interactor)))
  ;; make sure the interactor is not still running -- this may
  ;;  not be necessary but it won't hurt
  (cond ((g-value identify-interactor :active)
	 (inter:change-active identify-interactor nil)))
  ;; start the interactor
  (inter:change-active identify-interactor t)
  (format t "Click or Type on any object or window...~%"))
|#

;;; create-identify-interactor -- create interactor for IDENT function
;;;
(defun create-identify-interactor ()
  (format t "making identify-interactor~%")
  (create-instance 
      'identify-interactor
      inter:button-interactor
    (:window t)
    (:active nil)
    (:continuous nil)
    (:waiting-priority inter:high-priority-level)
    (:start-where
     (o-formula (list :leaf-element-of-or-none
		      (gvl :current-window :aggregate))))
    (:feedback-obj nil)
    (:self-deactivate t)
    (:start-event '(:any-mousedown :any-mouseup :any-keyboard))
    (:stop-action 'identify-stop-action)))


;;; Identify-stop-action -- called by interactor to tell user about object
;;;
(defun identify-stop-action (interactor obj)
  (declare (ignore interactor))
  (let ((x (inter:event-x inter:*Current-Event*))
	(y (inter:event-y inter:*Current-Event*))
	(win (inter:event-window inter:*Current-Event*))
	(ch (inter:event-char inter:*Current-Event*))
        (indent 0) last-obj)
    (format t "in Window ~A, ~S at x=~D, y=~D:~%" win ch x y)
    (setf ident obj)
    (cond ((eq ident :none)
	   (setf ident win)))
    (setf obj ident)
    (format t "~S~%" obj)
    (do ()
	((null obj))
      (cond ((> indent 0)
	     (indent-by indent)
	     (format t "in ")))
      (what obj)
      (setf last-obj obj)
      (setf obj (g-value obj :parent))
      (setf indent (1+ indent)))
    (indent-by indent)
    (format t "in ")
    (what (g-value last-obj :window))
    ;; (inter:change-active interactor nil) -- :self-deactivate does this
    ))



(defun ident (&optional (verbose t))
  "Wait for user to point to a garnet object and returns (obj window x y code). 
  Use (ident nil) to suppress normal printout"
  (let ((a-window (get-an-opal-window))
        suspend-process
	opal-display display-info obj window loc-x loc-y garnet-code)
    (cond (a-window
	   (if verbose
	     (format t "Click or Type on any object or window...~%"))
           (when (opal:main-event-loop-process-running-p)
	     (setf suspend-process T)
	     (opal:kill-main-event-loop-process))
	   (setf opal-display (the opal::DISPLAY-INFO
				   (g-value a-window :display-info)))
	   (setf display-info (opal::display-info-display
			       opal-display))
	   ;; first, throw away any pending events
	   (xlib:event-case (opal::*default-x-display* :discard-p t :timeout 1)
			    (:destroy-notify () NIL)  ; get rid of warnings
			    (otherwise () t))
	   (xlib:event-case
	    (display-info :discard-p t :force-output-p t)
	    (button-press
	     (event-window x y state code event-key)
	     (setf window (getf (xlib:drawable-plist event-window) :garnet))
	     (setf loc-x x)
	     (setf loc-y y)
	     (setf garnet-code (interactors::translate-mouse-character
				code state event-key))
	     (setf obj (identify window x y garnet-code verbose))
	     t)
	    (key-press
	     (event-window x y state code)
	     (setf window (getf (xlib:drawable-plist event-window) :garnet))
	     (setf loc-x x)
	     (setf loc-y y)
	     (setf garnet-code (interactors::translate-character
				(opal::display-info-display
				 (the opal::DISPLAY-INFO
				      (g-value window :display-info)))
				code state))
	     (cond (garnet-code
		    (setf obj (identify window x y garnet-code verbose))
		    t);; exit the event loop
		   (t nil);; must have been shift key, etc.  Loop for more.
		   )))
	   (when suspend-process
	     (opal:launch-main-event-loop-process))
	   ))
    (list obj window loc-x loc-y garnet-code)))



;;; identify -- find where an event is and print event code and x,y
;;;
(defun identify (window x y code verbose)
  (let (elem agg (indent 0) ident)
    (if verbose
      (format t "in Window ~A, ~S at x=~D, y=~D:~%" window code x y))
    (if (schema-p window) (setf agg (g-value window :aggregate)))
    (cond ((schema-p agg)
	   (setf elem
		 (if (opal:point-in-gob agg x y)
		   (kr-send agg :point-to-leaf agg x y)
		   nil))
	   (setf ident elem)
	   (cond ((and verbose elem)
		  (do ()
		      ((null elem))
		    (cond ((> indent 0)
			   (indent-by indent)
			   (format t "in ")))
		    (what elem)
		    (setf elem (g-value elem :parent))
		    (setf indent (1+ indent)))
		  (indent-by indent)
		  (format t "in ")
		  (what window)))))
    ident))


;;; indent-by -- indentation function used for printing trees
;;;
(defun indent-by (indent)
  (dotimes (i indent) (format t "   "))
  (* indent 3))


;;; initialize-blinking-context -- set up a g-context for direct use of xlib
;;;
(defun initialize-blinking-context (win)
  (let ((display-info (g-value win :display-info))
	(window (g-value win :drawable))
	screen)
    (cond ((null display-info)
	   (format t "~A has no :display-info~%" win)
	   (return-from initialize-blinking-context))
	  ((null window)
	   (format t "~A has no :drawable~%" window)
	   (return-from initialize-blinking-context)))
    (setf screen (opal:display-info-screen display-info))
    (setq blink-gc 
	  (xlib:create-gcontext
	   :drawable window :background (xlib:screen-white-pixel screen)
	   :foreground (xlib:screen-black-pixel screen)
	   :function boole-c2 :fill-style :solid))))


;;; INVERT -- invert a selected object using xor
;;;
(defun invert (obj)
  (let ((win (g-value obj :window))
	(left (g-value obj :left))
	(top (g-value obj :top))
	(width (g-value obj :width))
	(height (g-value obj :height))
	agg)
    (create-flash-object)

    (setf agg (g-value win :aggregate))
    (cond ((and agg left top width height)
	   (s-value flash-object :left left)
	   (s-value flash-object :top top)
	   (s-value flash-object :width width)
	   (s-value flash-object :height height)
	   (add-component agg flash-object)
	   (update win)))))



;;; IS-A-TREE -- print the is-a links recursively
;;;
(defun is-a-tree (obj &optional (indent 0))
  (let (isa)
    (indent-by indent)
    (format t "~S" obj)
    (setf isa (car (g-value obj :is-a)))
    (cond (isa
	   (format t " is-a~%")
	   (is-a-tree isa (1+ indent)))
	  (t
	   (format t "~%")))))



;;; just-remove-component -- remove component without graphical fixup
;;;
(defun just-remove-component (agg obj)
  (s-value agg :components
	   (delete obj (g-local-value agg :components) :from-end t :count
		   1))
  (if (and obj (schema-p obj))
      (s-value obj :parent nil))
  (mark-as-changed agg :components))



;;; KIDS -- tell the opal type of an object and children
;;;
(defun kids (object &key (indent 0))
  (look object 1 :indent indent))



;;; This is a type-checking facility, called any time an object's slot has
;;; changed its value.  It's only invoked if *opal-debug* is non-NIL.
;;; All boolean slots (:visible :fast-redraw-p :open-p :actual-heightp)
;;; cannot be type-checked, since any non-NIL value is True.
(defun opal::legal-type-p (object slot value)
  (if
   (case slot
    ((:top :left :x1 :x2 :y1 :y2 :head-x :head-y :from-x :from-y)
	(typep value 'integer))
    ((:width :height :radius :draw-radius :length :diameter)
	(and (typep value 'integer) (>= value 0)))
    (:line-style
	(or (null value)
	    (and (schema-p value)
	         (is-a-p value opal:line-style))))
    (:filling-style
	(or (null value)
	    (and (schema-p value)
	         (is-a-p value opal:filling-style))))
    (:draw-function
	(assoc value opal::*function-alist*))
    ((:angle1 :angle2)
	(numberp value))
    (:point-list
	(and (listp value)
	     (zerop (mod (length value) 2))		;; of even length?
	     (not (dolist (coord value)
		    (unless (typep coord 'integer) (return T))))))
    ((:string :title :icon-title)
	(or (null value) (stringp value)))
    (:font
	(and (schema-p value)
	     (or (is-a-p value opal:font)
		 (is-a-p value opal:font-from-file))))
    (:xfont
	(xlib:font-p value))
    (:text-extents
	(listp value))
    (:cursor-index
	(or (null value)
	    (and (typep value 'integer) (>= value 0))))
    (:justification
	(member value '(:left :center :right)))
    (:cut-strings
	(and (listp value)
	     (not (dolist (cut-string-member value)
		    (unless (opal::cut-string-p cut-string-member) (return T))))))
    (:image			;; bitmap
	(xlib::image-p value))
    (:aggregate
	(or (null value)
	    (is-a-p value opal:aggregate)))
    (:parent			;; window's can only have window's!
	(or (null value)
	    (and (schema-p value)
		 (if (is-a-p object opal::window)
		     (is-a-p value opal::window)
		     T))))
    (:cursor
	(and (listp value)
	     (is-a-p (car value) opal:bitmap)
	     (is-a-p (cdr value) opal:bitmap)))
    (:display
	(stringp value))
    (otherwise
	T)
   )
  T
  (format t "*** Warning:  Object ~A, Slot ~A, Value ~A is illegal!~%"
	object slot value))
)



;;; LOOK -- describes opal objects, level specifies how much detail
;;;
(defun look (object &optional (detail 2) &key (indent 0))
  "Describe a graphical object, detail is one of:
  0 outputs one line, same as (what schema)
  1 also shows children, same as (kids schema)
  2 prints all children (default)
  3 also prints fields of schema
  4 also prints fields of children
  5 prints all fields of whole tree"
  (let (class children parent name next-detail proto)
    (indent-by indent)
    (setf name (g-value object :known-as))
    (cond (name
	   (format t "~A: " name)))
    (setf parent (car (g-value object :is-a)))
    (format t "~A is-a ~A" object parent)
    (setf class (std-proto parent))
    (cond (class
	   (format t " (~A)" class)))
    (format t "~%")
    (cond ((> detail 2)
	   (ps object :indent indent :control :default)
	   (indent-by indent)
	   (cond ((is-a-p object opal::window)
		  (format t "Aggregate is:~%"))
		 ((g-local-value object :components)
		  (format t " Components are:~%"))
		 (t
		  (format t "~%")))))
    (cond ((> detail 0)
	   (setf next-detail detail)	; detail parameter for recursive step
	   (cond ((is-a-p object opal::window)
		  (setf children (g-value object :aggregate))
		  (cond ((null children)
			 (indent-by indent)
			 (format t "   No aggregate!~%"))))
		 (t
		  (setf children (get-local-value object :components))
		  (cond ((or (= detail 1) (= detail 3) (= detail 4))
			 (setf next-detail (- detail 1)))))) ; suppress children's
					; fields
	   (dolist (c children) (look c next-detail :indent (+ indent 1)))
	   (setf children (g-local-value object :behaviors))
	   (cond (children
		  (indent-by indent)
		  (format t " Interactors are:~%")
		  (incf indent)
		  (dolist (i children)
		    (indent-by indent)
		    (setf name (g-value i :known-as))
		    (cond (name
			   (format t "~A: " name)))
		    (setf parent (car (g-value i :is-a)))
		    (format t "~A is-a ~A" i parent)
		    (setf class (std-proto i))
		    (cond (class
			   (format t " (~A)" class)))
		    (format t "~%")
		    (cond ((> detail 2)
			   (ps i :indent indent :control :default))))
		  (decf indent)))
	   (setf proto (get-local-value object :item-prototype-object))
	   (cond (proto
		  (indent-by indent)
		  (format t " Item Prototype is:~%")
		  (look proto next-detail :indent (+ indent 1)))) ))))



;;; LOOK-INTER -- print out the interactors
;;;
(defun look-inter (&optional inter)
  "Looks for interactors relevant to the parameters.
  inter can be:
    * an interactor to describe.
    * NIL to list all active interactors
    * a window, to list all active interactors on that window
    * an interactor priority-level, to list all active inters on that level
    * an opal object, to try to find all interactors that affect that object
    * :next to wait and describe the next interactor to be executed."

  ;; start with argument checking
  (fresh-line)
  (cond ((eq inter :next)
	 (format T "Will invoke look-inter on next interactor that runs.~%")
	 (setq inter:*debug-next-inter* 'look-inter)
	 (values))
	((null inter)
	 (format t "Interactors that are :ACTIVE and have a :WINDOW are:~%")
	 (inter:print-inter-levels))
	((is-a-p inter inter:interactor-window)
	 (format t "Interactors active over :WINDOW ~S are:~%" inter)
	 (inter:print-inter-levels :window inter))
	((is-a-p inter inter:priority-level)
	 (format t "Interactors active in priority level ~S are:~%" inter)
	 (inter:print-inter-levels :level inter))
	((is-a-p inter inter:interactor)
	 (format t "~S's :ACTIVE is " inter)
	 (print-a-slot inter :active)
	 (format t ", :WINDOW is ")
	 (print-a-slot inter :window)
	 (format t "~%   current priority-level ~s~%"
		 (g-value inter :current-priority-level))
	 (print-inter-details inter))
	((is-a-p inter opal:view-object)
	;; if called with non-interactor & non-window, search for interactors
	 ;; that might change the object, ignore detail argument
	 (search-for-inter inter))
	(T ; bad value
	 (format t "Bad value for inter parameter.  Options for inter are:
    * an interactor to describe.
    * NIL to describe all active interactors
    * a window, to describe all interactors on that window
    * an opal object, to try to find all interactors that affect that object
    * the special keyword :next to wait and describe the next interactor to
      be executed.
  detail can be
      0 just prints active interactors (default) or
      1 shows where they start
  Either or both args may be omitted.~%"))))


;;; print-inter-details -- print class, start-event and start-where
;;;
(defun print-inter-details (inter)
  (let (class where ev)
    (format t "~s" inter)
    (setf class (std-proto inter))
    (cond (class (format t " (which is a ~A)~%" class)))
    (setf ev (g-value inter :start-event))
    (setf where (g-value inter :start-where))
    (format t "   starts when ~S ~S~%" ev where)))
  

;;; print-a-slot -- prints value (and cache if value is formula)
;;;
(defun print-a-slot (obj slot)
  (let ((value (get-value obj slot))
	actual-cached-value cached-value-to-print validity)
    (cond ((formula-p value)
	   (setf actual-cached-value (g-cached-value obj slot))
	   (setf cached-value-to-print actual-cached-value)
	   (cond ((member slot '(:XFONT :TEXT-EXTENTS))
		  (setf cached-value-to-print "...")))
	   (setf validity (kr::cache-is-valid value))
	   (format t "~S (~S . ~A #~A)" value cached-value-to-print 
		   validity (kr::cache-mark value))
	   
	   )
	  (t
	   (format t "~S" value)))))

;;; search-for-inter -- find interactor that might change object
;;;
(defun search-for-inter (obj)
  (inter:Do-All-Interactors
      #'(lambda (inter)
	  (when (and (g-value inter :active)
		     (g-value inter :window))
	  (let (where)
	    ;; first check :start-where's
	    (setf where (g-local-value inter :start-where))
	    (cond ((eq t where)
		   (format t "~S has a :start-where of T~%" inter))
		  ((null where));; won't match
		  ((listp where)
		   (let ((control (first where))
			 (agg (second where))
			 slot lst)
		     (case control
		       ((:element-of :element-of-or-none)
			(cond ((null agg))
			      ((not (schema-p agg)))
			      ((has-component-p agg obj)
			       (format
				t "~S's :start-where is ~S,~% and ~S contains ~S~%"
				inter where agg obj))))
		       ((:list-element-of :list-element-of-or-none)
			(setf slot (third where))
			(cond 
			  ((and agg (schema-p agg))
			   (setf lst (g-value agg slot))
			   (cond
			     ((listp lst)
			      (dolist (i lst)
				(cond ((eq i obj)
				       (format
					t "~S's :start-where is ~S,~%   ~S's ~S is ~S,~%"
					inter where agg slot lst)))))))))
		       ((:list-leaf-element-of
			 :list-check-leaf-but-return-element
			 :list-leaf-element-of-or-none
			 :list-check-leaf-but-return-element-or-none
			 :check-leaf-but-return-element
			 :check-leaf-but-return-element-or-none
			 )
			(setf slot (third where))
			(cond
			  ((and agg (schema-p agg))
			   (setf lst (g-value agg slot))
			   (cond
			     ((listp lst)
			      (dolist (i lst)
				(cond ((has-leaf-p i obj)
				       (format t
					       "~S's :start-where is ~S,~%   ~S's ~S is ~S, and~%   ~S contains ~S"
					       inter where agg slot lst i obj)))))))))
		       ((:leaf-element-of
			 :leaf-element-of-or-none)
			(cond ((and agg (schema-p agg) (has-leaf-p agg obj))
			       (format
				t "~S's :start-where is ~S,~% and ~S contains ~S~%"
				inter where agg obj))))
		       ((:in-box :in :in-but-not-on)
			(cond ((eq agg obj)
			       (format t "~S's :start-where is ~S~%"
				       inter where))))
		       (t (format t "~S has a bad :start-where : ~S~%" inter where)))))
		  (t (format t "~S has a bad :start-where : ~S~%"
			     inter where)))

	    ;; end of :start-where search, now look at :feedback-obj...
	    (cond ((eq obj (g-local-value inter :feedback-obj))
		   (format t "~S's :feedback-obj is ~S~%" inter obj)))

	    ;; look at final-feed-avail, final-feed-inuse, final-feedback-obj
	    (cond ((eq obj (g-local-value inter :final-feedback-obj))
	       (format t "~S's :final-feedback-obj is ~S~%" inter obj))
	      ((member obj (get-local-value inter :final-feed-inuse))
	       (format t "~S's :final-feed-inuse contains ~S~%" inter obj))
	      ((member obj (get-local-value inter :final-feed-avail))
	       (format t "~S's :final-feed-avail contains ~S~%" inter obj)))

	    ;; check :obj-to-change as well...
	    (cond ((eq obj (g-local-value inter :obj-to-change))
		   (format t "~S's :obj-to-change is ~S~%" inter obj))))))))
	
;;; search-invisible-agg -- look up parent tree for :visible nil
;;;
(defun search-invisible-agg (agg)
  (let (parent)
    (cond ((null (g-value agg :visible)) agg)
	  ((setf parent (g-value agg :parent))
	   (search-invisible-agg parent))
	  (t nil))))

#|
;; currently we do not determine standard names by lookup.

;;; *standard-names* -- names of opal objects
;;;
(defparameter *standard-names*
   (list
    (cons opal:black-fill             'opal:black-fill)
    (cons opal:white-fill             'opal:white-fill)
    (cons opal:gray-fill              'opal:gray-fill)
    (cons opal:light-gray-fill        'opal:light-gray-fill) 
    (cons opal:dark-gray-fill         'opal:dark-gray-fill)
    (cons opal:thin-line              'opal:thin-line)
    (cons opal:dotted-line            'opal:dotted-line)
    (cons opal:dashed-line            'opal:dashed-line)
    (cons opal:line-1                 'opal:line-1)
    (cons opal:line-2                 'opal:line-2)
    (cons opal:line-4                 'opal:line-4)
    (cons opal:line-8                 'opal:line-8)
    (cons opal:aggregate              'opal:aggregate)
    (cons opal:default-filling-style  'opal:default-filling-style)
    (cons opal:default-line-style     'opal:default-line-style)
    (cons opal:rectangle              'opal:rectangle)
    (cons opal:line                   'opal:line)
    (cons opal:roundtangle            'opal:roundtangle)
    (cons opal:circle                 'opal:circle)
    (cons opal:text                   'opal:text)
    (cons opal::window                'opal::window)

    (cons inter:angle-interactor      'inter:angle-interactor)
    (cons inter:interactor            'inter:interactor)
    (cons inter:move-grow-interactor  'inter:move-grow-interactor)
    (cons inter:text-interactor       'inter:text-interactor)
    (cons inter:menu-interactor       'inter:menu-interactor)
    (cons inter:two-point-interactor  'inter:two-point-interactor)
    (cons inter:button-interactor     'inter:button-interactor)
    (cons inter:interactor-window     'inter:interactor-window)
)
  "what name to ouput for standard schema")
|#

#|
;;; std-proto -- go up :is-a links to find opal or interactor parent
;;;
(defun std-proto (object)
  (let (result)
    (do ((ancestor object (car (g-value ancestor :is-a))))
	((or (null ancestor)
	     (setf result (assoc ancestor *standard-names*)))))
    (cond (result (cdr result))
	   (t nil))))
|#

;;; std-proto -- go up :is-a links to find non-KR-DEBUG package
;;;
(defun std-proto (object)
  (let (start)
    (if object (setf start (car (g-value object :is-a))))
    (do ((ancestor start (car (g-value ancestor :is-a))))
	((or (null ancestor)
             (not (symbolp (kr::schema-name ancestor)))
	     (and (not (eq (find-package "KR-DEBUG")
			   (symbol-package (kr::schema-name ancestor))))
		  (return-from std-proto (format NIL "~s" ancestor))))))
    NIL))



;;; test-display-slots -- type-check the update slots of an object
;;;
(defun test-display-slots (obj)
  (dolist (slot (g-value obj :update-slots))
    (cond ((opal::legal-type-p obj slot (g-value obj slot)))
	  (t  ;; bad type
	   (return-from test-display-slots nil))))
  t)


;;; UNIVERT -- remove inverted region
;;;
(defun uninvert () 
  ;; create-flash-object will remove flash-object and redisplay
  (create-flash-object))


;;; what -- tell the opal type of an object
;;;
(defun what (object &key (indent 0))
  (look object 0 :indent indent))


;;; where -- tell where an opal object is
;;;
(defun where (object)
  (format t "~S :TOP ~S :LEFT ~S :WIDTH ~S :HEIGHT ~S"
	  object
	  (g-value object :top)
	  (g-value object :left)
	  (g-value object :width)
	  (g-value object :height))
  (cond ((is-a-p object opal::window)
	 (format t "~%"))
	(t
	 (format t " :WINDOW ~S~%" (g-value object :window)))))

;;; WINDOWS -- tell me where windows are
;;;
(defun windows ()
  opal::*garnet-windows*
  #|
  (let (result)
    (maphash #'(lambda (x-window opal-window)
		 (declare (ignore x-window))
		 (where opal-window)
		 (push opal-window result))
	     opal::*drawable-to-window-mapping*)
    result)
  |#
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Stuff to break or notify when slots are set
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(proclaim '(special kr::*slot-setter-debug*))
(defparameter *object-slot-val-fnc-list* NIL)

;;; returns T if matches
(defun Matches? (schema slot new-value ctrl)
  (let ((o (first ctrl)))
    (if (or (eq o :*any*) (eq o schema))
	(let ((s (second ctrl)))
	  (if (or (eq s :*any*) (eq s slot))
	      (let ((v (third ctrl)))
		(if (or (eq v :*any*) (eq v new-value))
		    T
		    NIL))
	      NIL))
	NIL)))

;;; Called on every slot set, reason will be one of :S-VALUE,
;;; :FORMULA-EVALUATION, :INHERITANCE-PROPAGATION, :DESTROY-SLOT
(defun Debug-Check-Object-Slot-Val-Set (schema slot new-value reason)
  (let (fnc extra)
    (dolist (ctrl *object-slot-val-fnc-list*)
      (when (matches? schema slot new-value ctrl)
	(setq fnc (fourth ctrl))
	(setq extra (fifth ctrl))
	(return)))
    (when fnc
      (funcall fnc schema slot new-value reason extra))))

(defun Do-Break (schema slot new-value reason extra)
  (declare (ignore extra))
  (fresh-line)
  (break (format NIL "Because ~s slot ~s set with ~s due to ~a"
		 schema slot new-value reason)))

(defun Do-Notify (schema slot new-value reason extra)
  (declare (ignore extra))
  (fresh-line)
  (format T "#### ~s slot ~s set with ~s due to ~a~%"
	  schema slot new-value reason))

(defun Print-Current-Status ()
  (if *object-slot-val-fnc-list*
      (dolist (ctrl *object-slot-val-fnc-list*)
	(format T "~a when object ~s slot ~s is set with ~s~%"
		(if (eq (fourth ctrl) #'Do-Break) "Breaking" "Notifying")
		(first ctrl) (second ctrl)(third ctrl)))
      (format T "No breaks or notifies are active~%"))
  (values))
      
(defun call-func-on-slot-set (object slot value fnc extra-val)
 "Call the function when the slot of object is assigned value.  If
 value is :*any*, then call function when slot is set with any value.
 If slot and value are :*any*, then call function whenever any slot
 of object is set.  If object is :*any*, then call function when any
 object is set.  If object is NIL, then clears all breaks and notifies.
 The function is called as (lambda (obj slot val reason extra-val) and
 extra-val can be anything useful to the function. Reason will be one
 of :S-VALUE, :FORMULA-EVALUATION, :INHERITANCE-PROPAGATION, :DESTROY-SLOT"
  (cond ((null object)
	 (setq *object-slot-val-fnc-list* NIL)
	 (setq kr::*slot-setter-debug* NIL))
	((and (eq object :*any*) (eq slot :*any*) (eq value :*any*))
	 (Print-Current-Status))
	(T
	 (push (list object slot value fnc extra-val)
	       *object-slot-val-fnc-list*)
	 (setq kr::*slot-setter-debug* #'Debug-Check-Object-Slot-Val-Set)
	 T)))

(defun break-on-slot-set (&key (object :*any*) (slot :*any*) (value :*any*))
  "Break when the slot of object is assigned value.  If value is missing, then
 break when slot is set with any value.  If slot and value are missing, then 
 break whenever any slot of object is set.  If object is missing, then
 break when any object is set.
 If object is NIL, then clears all breaks and notifies.
 If all parameters are missing, show current status."
  (call-func-on-slot-set object slot value #'Do-Break NIL))

(defun notify-on-slot-set (&key (object :*any*) (slot :*any*) (value :*any*))
  "Print a message when the slot of object is assigned value.  If value is
 missing, then print msg when slot is set with any value.  If slot and value
 are missing, then print msg whenever any slot of object is set.  If
 object is missing, then break when any object is set.
 If object is NIL, then clears all breaks and notifies.
 If all parameters are missing, show current status."
  (call-func-on-slot-set object slot value #'do-notify NIL))

(defun clear-slot-set (&key (object :*any*) (slot :*any*) (value :*any*))
 "Clear the break or notify for object, slot and value.  If nothing
  specified or object is NIL, then clear all breaks and notifies."
  (if (or (null object)
	  (and (eq object :*any*) (eq slot :*any*) (eq value :*any*)))
      (setq *object-slot-val-fnc-list* NIL)
      ;; else remove the specific one
      (setq *object-slot-val-fnc-list*
	    (delete-if #'(lambda (element)
			   (and (eq (first element) object)
				(eq (second element) slot)
				(eq (third element) value)))
		       *object-slot-val-fnc-list*)))
  (when (null *object-slot-val-fnc-list*)
    (setq kr::*slot-setter-debug* NIL)))


      