;;; -*- 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:
  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))



(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
			 (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 (kr::a-formula-depends-on value))
			 (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 (kr::on-schema kr::*last-formula*))
	   (setf slot (kr::on-slot kr::*last-formula*))
	   (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: "
	    (kr::get-lambda kr::*last-formula*)
	    " 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)
    (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)
      (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 ()
  (maphash #'(lambda (x-window opal-window)
	       (declare (ignore x-window))
	       (return-from get-an-opal-window opal-window))
	   opal::*drawable-to-window-mapping*)
  nil)


;;; 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))
	   (xlib:event-case
	    (display-info :discard-p t :force-output-p t)
	    (button-press
	     (event-window x y state code event-key)
	     (setf window (gethash event-window
				   opal::*drawable-to-window-mapping*))
	     (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 (gethash event-window
				   opal::*drawable-to-window-mapping*))
	     (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))
    (setf agg (g-value window :aggregate))
    (cond (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))))



;;; INTER-PRINT-TEST -- used by look-inter to decide what to print out
;;;
;;; print each interactor that is :active, has a :window, and (if window
;;;  is not null) has window or T in the :window slot.
;;;
(defun inter-print-test (inter window)
  (let ((windows (g-value inter :window)))
    (and (g-value inter :active) 
	 windows
	 (or (null window)
	     (eq windows t)
	     (eq window windows)
	     (and (listp windows) (member window windows))))))



;;; 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)))
    (:x-substr
	(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 detail)
  "Print a description of an opal object:
  inter is the interactor to describe (all interactors if omitted), and
    detail of
      0 just prints active interactors (default) or
      1 shows where they start
  OR inter may be a graphical object, in which case
    look-inter searches for interactors that might
    affect the object.
  Either or both args may be omitted."

  ;; start with argument checking
  (cond ((and (null detail) (numberp inter))
	 (setf detail inter)
	 (setf inter nil)))
  (cond ((and (not (null inter))
	      (not (is-a-p inter inter:interactor))
	      (not (is-a-p inter window)))
	 ;; if called with non-interactor & non-window, search for interactors
	 ;; that might change the object, ignore detail argument
	 (search-for-inter inter)
	 (return-from look-inter))
	((not (member detail '(0 1 nil)))
	 (format t "bad argument: ~S, (look-inter :help) for help~%"
		 detail)
	 (return-from look-inter)))
  ;; handle the case of a specific inter first
  (cond ((and inter (not (is-a-p inter window)))
	 (format t "~S's :ACTIVE is " inter)
	 (print-a-slot inter :active)
	 (format t ", :WINDOW is ")
	 (print-a-slot inter :window)
	 (format t "~%")
	 (dolist (level inter:priority-level-list)
	   (cond ((member inter (g-value level :interactors))
		  (format t "~S is on the ~S level~%" inter level))))
	 (print-inter-details inter))
	;; either NIL (print all) or a window (print interactors for the window)
	(t
	 (let ((*print-pretty* nil))
	   (if inter
	     (format t "Interactors whose :WINDOW contains ~S are~%" inter)
	     (format t "Interactors that are :ACTIVE and have a :WINDOW are:~%"))
	   (dolist (level inter:priority-level-list)
	     (format t "Level ~s: " level)
	     (dolist (each (g-value level :interactors))
	       (cond ((inter-print-test each inter)
		      (format t "~s " each))))
	     (format t "~%"))
	   (cond ((null detail) (return-from look-inter)))
	   (cond ((> detail 0)
		  (dolist (level inter:priority-level-list)
		    (dolist (each (g-value level :interactors))
		      (cond ((inter-print-test each inter)
			     (print-inter-details each)))))))))))

	
;;; 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 " (~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)
  (let (where)
    (dolist (level inter:priority-level-list)
      (dolist (inter (g-local-value level :interactors))
	(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, and final-feedback-obj
	(cond ((eq obj (g-local-value inter :final-feedback-obj))
	       (format t "~S's :final-feedback-obj is ~S~%" inter obj)))
	(cond ((member obj (get-local-value inter :final-feed-inuse))
	       (format t "~S's :final-feed-inuse contains ~S~%" inter obj)))
	(cond ((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 opal or interactor parent
;;;
(defun std-proto (object)
  (let (result 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))))
		  (setf result (kr::schema-name ancestor))))))
    result))



;;; 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 ()
  (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))



