
(in-package "INSPECT")

(defvar *default-inspecter-font* "fixed")

(defvar *default-inspecter-documentation-font* "fixed")

(defvar *inspecter-initial-width*
  825)
(defvar *inspecter-initial-height*
  725)

(defvar *foreground-color* "black")
(defvar *background-color* "white")
(defvar *border-color* "black")

(defvar *direction-of-panes* :vertical)
(defvar *number-of-panes* 3)

(defclass inspecter (item)
  ((host :initarg :host :initform (default-host))
   (screen)
   (all-font-names)
   (border-color-name :initform "" :accessor inspecter-border-color-name)
   (border-color :initform *border-color*
		 :accessor inspecter-border-color)
   (border-pixel :initform nil :accessor inspecter-border-pixel)
   (foreground-color-name :initform "" :accessor inspecter-foreground-color-name)
   (foreground-color :initform *foreground-color*
		     :accessor inspecter-foreground-color)
   (foreground-pixel :initform nil :accessor inspecter-foreground-pixel)
   (background-color-name :initform "" :accessor inspecter-background-color-name)
   (background-color :initform *background-color*
		     :accessor inspecter-background-color)
   (background-pixel :initform nil :accessor inspecter-background-pixel)
   (cursor-font)
   (cursor :initform nil :reader inspecter-cursor) ; center-ptr-cursor (22) is best
   (vscroll-cursor :initform nil
		   :reader inspecter-vscroll-cursor) ; sb-v-double-arrow-cursor (116)
   (font-name :initform *default-inspecter-font* 
	      :accessor inspecter-font-name)
   (font :initform nil :accessor inspecter-font)
   (draw-gc :initform nil :accessor inspecter-draw-gc)
   (inverse-draw-gc :initform nil :accessor inspecter-inverse-draw-gc)
   (documentation-font-name :initform *default-inspecter-documentation-font*
			    :accessor inspecter-documentation-font-name)
   (documentation-font :initform nil :accessor inspecter-documentation-font)
   (documentation-draw-gc :initform nil :accessor inspecter-documentation-draw-gc)
   (documentation-inverse-draw-gc :initform nil 
				  :accessor inspecter-documentation-inverse-draw-gc)
   (cursor)

   (current-mouse-window :initform nil)
   (menu-item :reader inspecter-menu-item)
   (visible-panes-item :reader inspecter-visible-panes-item)
   (documentation-item :reader inspecter-documentation-item)
   (mouse-documentation-item)
   (extra-mouse-documentation-item)
   (input-text-item :initform nil :reader inspecter-input-text-item)
   (selected-item :initform nil :accessor inspecter-selected-item)
   (focus-p :initform nil :reader inspecter-focus-p))
  (:default-initargs :border-width 1))

(defmethod shared-initialize :after ((self inspecter) slot-names &key)
  (declare (ignore slot-names))
  (with-slots (inspecter)
    self
    (setq inspecter self)))

(defmethod show-object-in-inspecter ((inspecter inspecter) object 
				   &key object-view object-view-class)
  (with-slots (visible-panes-item state)
    inspecter
    (setq  *** **   ** *   * object)
    (map-window inspecter)
    (show-object-in-inspecter visible-panes-item object
			      ':object-view object-view
			      ':object-view-class object-view-class)))

(defmethod inspecter-direction-of-panes ((inspecter inspecter))
  (with-slots (visible-panes-item)
    inspecter
    (item-direction-of-children visible-panes-item)))

(defmethod inspecter-number-of-panes ((inspecter inspecter))
  (with-slots (visible-panes-item)
    inspecter
    (length (item-list visible-panes-item))))

(defclass operation-item (text-item)
  ((operation :initarg :operation :reader item-operation))
  (:default-initargs :border-width nil))

(defmethod item-documentation ((item operation-item))
  (item-text item))

(defun operation-documentation (operation)
  (let ((function (if (symbolp operation)
		      (symbol-function operation)
		      operation)))
    (or (and (pcl::generic-function-p function)
	     (pcl::documentation function))
	(and (symbolp operation)
	     (nsubstitute #\space #\-
			  (string-capitalize (symbol-name operation))))
	(format nil "~S" operation))))

(defmethod compute-item-text ((item operation-item))
  (with-slots (operation)
    item
    (operation-documentation operation)))

;returns:
;; ((((button-code . button-state) operation-gf) ...)
;;  mouse-documentation-string)
(defmethod operation-entry (item item-or-nil)
  (declare (ignore item item-or-nil))
  '(() ""))

(defmethod operation-entry ((item operation-item) item-or-nil)
  (declare (ignore item-or-nil))
  (let ((operation (item-operation item))
	(text (item-text item)))
    `((((1 . 0) ,operation))
      ,(format nil "L: ~A" text))))

(defgeneric show-panes (item)
  (:generic-function-class operation)
  (:documentation "Inspecter and Pane Operations"))

(defmethod show-panes ((item item))
  (let ((inspecter (item-inspecter item)))
    (show-object-in-inspecter inspecter inspecter)))

(defgeneric revert-inspecter (item)
  (:generic-function-class operation)
  (:documentation "Recompute Panes"))

(defmethod revert-inspecter ((item item))
  (let ((inspecter (item-inspecter item)))
    (revert-item inspecter)
    (display-item inspecter)))

(defgeneric show-interesting-objects (item)
  (:generic-function-class operation)
  (:documentation "Interesting Objects"))

(defvar *interesting-object-list* nil)

(defmethod show-interesting-objects ((item item))
  (let ((inspecter (item-inspecter item)))
    (show-object-in-inspecter inspecter *interesting-object-list*)))

(defun add-interesting-object (object)
  (unless (member object *interesting-object-list*)
    (setq *interesting-object-list*
	  (append *interesting-object-list*
		  (list object)))))

#+pcl (add-interesting-object 'pcl::*find-class*)
#+pcl (add-interesting-object 'pcl::*eql-specializer-methods*)
#+pcl (add-interesting-object 'pcl::*pv-key-to-pv-table-table*)

(defclass filler-operation-item (text-item)
  ()
  (:default-initargs :border-width nil
                     :size-within-parent :ask))

(defmethod item-operation ((item filler-operation-item))
  nil)

(defmethod item-desired-size ((item filler-operation-item) direction)
  (case direction
    (:horizontal
     ':even)
    (:vertical
     (call-next-method))))

(defclass inspecter-menu (item)
  ()
  (:default-initargs :documentation "Menu of operations on the inspecter"
                     :direction-of-children :horizontal
		     :size-within-parent :ask))

(defvar *inspecter-menu-operations*
  '(exit-inspecter show-panes inspect-read show-interesting-objects))

(defmethod initialize-instance :after ((item inspecter-menu) &key)
  (with-slots (item-list)
    item
    (setq item-list (nconc (mapcar #'(lambda (op)
				       (make-instance 'operation-item
						      ':parent item
						      ':operation op))
				   *inspecter-menu-operations*)
			   (list (make-instance 'filler-operation-item
						':parent item))))))

(defclass documentation-font-mixin (text-item)
  ())

(defmethod item-font ((item documentation-font-mixin))
  (inspecter-documentation-font (item-inspecter item)))

(defmethod item-draw-gc ((item documentation-font-mixin))
  (inspecter-documentation-draw-gc (item-inspecter item)))

(defmethod item-inverse-draw-gc ((item documentation-font-mixin))
  (inspecter-documentation-inverse-draw-gc (item-inspecter item)))
				  
(defclass documentation-window (documentation-font-mixin text-item)
  ()
  (:default-initargs :documentation "Information about the item under the mouse"
                     :border-width nil))		     

(defclass mouse-documentation-window (documentation-window)
  ()
  (:default-initargs
        :documentation "Information about what the mouse buttons will do now"))

(defmethod initialize-instance :after ((self inspecter) &key
				       (default-screen-depth 1)
				       object-view object-view-class
				       object)
  (with-slots (host xlib:display screen parent font-name documentation-font-name
	       cursor-font foreground-color background-color border-color
	       menu-item visible-panes-item documentation-item
	       mouse-documentation-item extra-mouse-documentation-item
	       item-list x y width height border-width direction-of-children)
    self
    (let ((success-p nil))
      (unwind-protect
	   (progn
	     (setq xlib:display (xlib:open-display host))
	     (setf (getf (xlib:display-plist xlib:display) 'inspecter) self)
	     (setq screen (or (and default-screen-depth
				   (find default-screen-depth 
					 (xlib:display-roots xlib:display)
					 :key #'xlib:screen-root-depth))
			      (xlib:display-default-screen xlib:display)))
	     (setq parent (xlib:screen-root screen))
	     (setq font-name 
		   (or (first (xlib:list-font-names xlib:display font-name))
		       "fixed"))
	     (setq documentation-font-name 
		   (or (first (xlib:list-font-names
			       xlib:display documentation-font-name))
		       "fixed"))
	     (setq cursor-font (xlib:open-font xlib:display "cursor"))
	     (setq x 100 y 100)
	     (setq width *inspecter-initial-width* height *inspecter-initial-height*)
	     (create-window self)
	     (set-colors self foreground-color background-color border-color t)
	     (setq direction-of-children :vertical)
	     (setq menu-item 
		   (make-instance 'inspecter-menu ':parent self))
	     (setq visible-panes-item 
		   (make-instance 'inspecter-visible-panes ':parent self
				  ':direction-of-children *direction-of-panes*
				  ':number-of-panes *number-of-panes*))
	     (setq documentation-item
		   (make-instance 'documentation-window ':parent self))
	     (setq mouse-documentation-item 
		   (make-instance 'mouse-documentation-window ':parent self))
	     (setq extra-mouse-documentation-item 
		   (make-instance 'mouse-documentation-window ':parent self))
	     (setq item-list (list menu-item
				   visible-panes-item
				   mouse-documentation-item
				   extra-mouse-documentation-item
				   documentation-item))
	     (map-window self)
	     (xlib:set-wm-properties self :name "Inspect" :icon-name "Inspect")
	     (xlib:with-state (self)
	       (setq x (xlib:drawable-x self) y (xlib:drawable-y self)
		     width (xlib:drawable-width self)
		     height (xlib:drawable-height self)))
	     (adjust-sizes-and-positions-of-children self)
	     (map-window-and-all-subwindows self)
	     (when (or object-view-class object)
	       (show-object-in-inspecter self object 
				       ':object-view object-view
				       ':object-view-class object-view-class))
	     (xlib:display-finish-output xlib:display)
	     (setq success-p t))
	(unless (or success-p (null xlib:display))
	  (xlib:close-display xlib:display))))))

(defvar *inspecter* nil)
(defvar *in-inspecter-p* nil)
(defvar *exit-process-events* nil)
(defvar *kill-inspecter-on-exit-p* nil)

(defgeneric exit-inspecter (item)
  (:generic-function-class operation)
  (:documentation "Exit Inspecter"))

(defmethod exit-inspecter ((item item))
  (with-slots (xlib:display)
    item
    (unmap-window *inspecter*)
    (setq *exit-process-events* t)))

(#-pcl progn #+pcl pcl::expanding-make-instance-top-level
(defun new-inspect (&optional object &key object-view object-view-class)
  (if (or *in-inspecter-p* (not (or *inspecter* (default-host))))
      (funcall (or #+pcl (pcl::original-definition 'inspect) #'inspect)
	       object)
      (progn
	(restore-inspecter-parameters)
	(let ((*print-length* 5)
	      (*print-level* 2)
	      (*print-circle* nil)
	      (*print-pretty* nil)
	      ;;(*print-structure* nil)
	      (*print-array* nil)
	      (*in-inspecter-p* t))
	  (if *inspecter*
	      (show-object-in-inspecter *inspecter* object
					':object-view object-view
					':object-view-class object-view-class)
	      (setq *inspecter*
		    (make-instance 'inspecter 
				   ':object object
				   ':object-view object-view
				   ':object-view-class object-view-class)))
	  (unwind-protect
	       (progn
		 (process-events *inspecter*)
		 (prog1 * (setq * **   *** **)))
	    (when *kill-inspecter-on-exit-p*
	      (kill-inspecter *inspecter*)))))))
)

#+pcl
(pcl::redefine-function 'inspect 'new-inspect)

(defun kill-inspecter (&optional (inspecter *inspecter*))
  (xlib:close-display (xlib:window-display inspecter))
  (when (and *inspecter* (eq inspecter *inspecter*))
    (setq *inspecter* nil))
  nil)

(defvar *current-mouse-window* nil)

(defmethod process-events ((self inspecter))
  (with-slots (current-mouse-window)
    self
    (let ((*exit-process-events* nil)
	  (*current-mouse-window* current-mouse-window))
      (loop (process-events-internal self :timeout 0)
	    (when *exit-process-events* (return nil))
	    (unless (eq *current-mouse-window* current-mouse-window)
	      (change-mouse-window self *current-mouse-window*))
	    (process-events-internal self :exit-p t)
	    (when *exit-process-events* (return nil))))))

(defmethod process-events-internal ((self inspecter) &key timeout exit-p)
  (with-slots (xlib:display selected-item input-text-item focus-p)
    self
    (xlib:event-case (xlib:display :timeout timeout :discard-p t)
      (:button-press 
       (event-window code state x y)
       (if (scroll-window-p event-window)
	   (progn
	     (do-scroll event-window code x y)
	     (xlib:display-force-output xlib:display))
	   (let* ((entry (operation-entry event-window selected-item))
		  (e-key (cons code state))
		  (op-gf (second (assoc e-key (first entry) :test #'equal))))
	     (when op-gf
	       (when (symbolp op-gf) (setq op-gf (pcl::gdefinition op-gf)))
	       (case (if (pcl::generic-function-p op-gf)
			 (pcl::arg-info-number-required (pcl::gf-arg-info op-gf))
			 0)
		 (0 (funcall op-gf))
		 (1 (funcall op-gf event-window))
		 (2 (funcall op-gf event-window selected-item))
		 (t (error "bad operation ~s" op-gf)))
	       (xlib:display-force-output xlib:display))))
       (or *exit-process-events* exit-p))
      (:key-press
       (code state)
       (when input-text-item
	 (process-key-press input-text-item code state))
       (or *exit-process-events* exit-p))
      (:exposure
       (window count)
       (when (zerop count)
	 (refresh-window window)       
	 (xlib:display-force-output xlib:display))
       (or *exit-process-events* exit-p))
      (:configure-notify
       (window x y width height)
       (when (eq window self)
	 (with-slots ((self-x x) (self-y y) (self-width width) (self-height height))
	   self
	   (setq self-x x self-y y self-width width self-height height)
	   (display-item window)
	   (xlib:display-force-output xlib:display)))
       (or *exit-process-events* exit-p))
      (:enter-notify 
       (event-window kind)
       (unless (or (eq kind :virtual) (eq kind :nonlinear-virtual))
	 (setq *current-mouse-window* event-window))
       (or *exit-process-events* exit-p))
      (:leave-notify
       (event-window)
       (when (eq event-window *current-mouse-window*)
	 (setq *current-mouse-window* nil))
       (or *exit-process-events* exit-p))
      (:focus-in
       ()
       (unless focus-p
	 (setq focus-p t)
	 (when input-text-item
	   (draw-text-cursor input-text-item))))
      (:focus-out
       ()
       (when focus-p
	 (setq focus-p nil)
	 (when input-text-item
	   (draw-text-cursor input-text-item))))
      (t
       ()
       (or *exit-process-events* exit-p)))))

(defmethod item-event-mask ((item inspecter))
  *inspecter-event-mask*)

(defmethod change-mouse-window ((self inspecter) new)
  (with-slots (selected-item documentation-item current-mouse-window
	       mouse-documentation-item extra-mouse-documentation-item)
    self
    (unless (eq new current-mouse-window)
      (when (and current-mouse-window
		 (not (equal (item-text mouse-documentation-item) "")))
	(unhighlight-window current-mouse-window))
      (setq current-mouse-window new)
      (multiple-value-bind (documentation 
			    mouse-documentation extra-mouse-documentation)
	  (if (null new)
	      (values "" "" "")
	      (if (scroll-window-p new)
		  (values (item-documentation new)
			  (mouse-documentation new)
			  "")
		  (let* ((entry (operation-entry new selected-item)))
		    (values (item-documentation new)
			    (or (second entry) "")
			    (or (third entry) "")))))
	(setf (item-text mouse-documentation-item) mouse-documentation)
	(setf (item-text extra-mouse-documentation-item) extra-mouse-documentation)
	(setf (item-text documentation-item) documentation)
	(refresh-window mouse-documentation-item)
	(refresh-window extra-mouse-documentation-item)
	(refresh-window documentation-item)
	(unless (equal "" mouse-documentation)
	  (highlight-window new))))))

(defgeneric set-colors (item &optional fore-color back-color b-color no-redisplay-p)
  (:generic-function-class operation)
  (:documentation "Set the inspecter's colors"))

(defmethod set-colors ((item item) &optional fore-color back-color b-color
		       no-redisplay-p)
  (with-slots (inspecter)
    item
    (set-colors inspecter fore-color back-color b-color no-redisplay-p)))

(defun read-rgb-file (table pathname)
  (with-open-file (in pathname :direction :input)
    (loop (let* ((r (* (or (read in nil) (return nil)) #.(/ 1.0s0 #xff)))
		 (g (* (read in) #.(/ 1.0s0 #xff)))
		 (b (* (read in) #.(/ 1.0s0 #xff)))
		 (lcolor (list r g b))
		 (cname (progn (peek-char t in) (read-line in)))
		 (names (gethash lcolor table)))
	    (unless (member cname names ':test #'equal)
	      (push cname (gethash lcolor table)))
	    (setf (gethash cname table) lcolor)))))

(defvar *color-table*)
(defvar *color-names-p* nil)
(defvar *all-color-names* nil)  

(defun make-color-table ()
  (setq *color-table* (make-hash-table ':test #'equal))
  (let* ((dsys (find-package "DSYS"))
	 (file-dir (if dsys
		       (funcall (intern "SYSTEM-DEFAULT-SOURCE-PATHNAME" dsys)
				(funcall (intern "FIND-SYSTEM" dsys)
					 'inspecter))
		       (pathname #+cmu "inspect:" #-cmu ""))))			   
    (read-rgb-file *color-table* 
		   (make-pathname :name "rgb"
				  :type "txt"
				  :defaults file-dir)))
  (setq *color-names-p* nil)
  (all-color-names)
  *color-table*)

(defun all-color-names ()
  (unless *color-names-p*
    (setq *all-color-names* nil)
    (let ((new-entries nil))
      (maphash #'(lambda (key value)
		   (when (consp key)
		     (let ((name (or (dolist (n value)
				       (when (dotimes (i (1- (length n)) t)
					       (let ((char (aref n (1+ i))))
						 (when (or (eql char #\space)
							   (upper-case-p char)
							   (digit-char-p char))
						   (return nil))))
					 (return n)))
				     (dolist (n value)
				       (when (find #\space n)
					 (return n)))
				     (car value))))
		       (when name
			 (let* ((new-name nil)
				(last-was-space-p t)
				(last-was-digit-p nil))
			   (dotimes (i (length name))
			     (let ((char (aref name i)))
			       (when (and (null last-was-space-p)
					  (or (upper-case-p char)
					      (and (digit-char-p char)
						   (not last-was-digit-p))))
				 (push #\space new-name))
			       (push (if last-was-space-p (char-upcase char) char)
				     new-name)
			       (setq last-was-space-p (eql char #\space))
			       (setq last-was-digit-p (digit-char-p char))))
			   (setq name (coerce (nreverse new-name) 'string)))
			 (let ((color (gethash name *color-table*)))
			   (if (null color)
			       (push (cons name key) new-entries)
			       (unless (equalp key color)
				 (setq name (format nil "~A (alternate)" name))
				 (push (cons name key) new-entries))))
			 (push name *all-color-names*)))))
	       *color-table*)
      (dolist (entry new-entries)
	(setf (gethash (car entry) *color-table*) (cdr entry))))
    (setq *all-color-names* (sort *all-color-names* #'string<))	  
    (setq *color-names-p* t))
  *all-color-names*)

(unless (boundp '*color-table*)
  (make-color-table))

(defun lookup-color (map color-name)
  (declare (ignore map))
  (apply #'xlib::make-color-internal
	 (gethash color-name *color-table* '(0.0 0.0 0.0))))

(defmacro set-color-variables (map var color color-name)
  `(cond ((null ,var)
	  (setq ,color (lookup-color ,map ,color-name)))
	 ((stringp ,var)
	  (setq ,color-name ,var)
	  (setq ,color (lookup-color ,map ,var)))
	 (t
	  (setq ,color-name "")
	  (setq ,color ,var))))

(defmethod set-colors ((item inspecter) &optional fore-color back-color b-color
		       no-redisplay-p)
  (with-slots (foreground-color-name foreground-color foreground-pixel
               background-color-name background-color background-pixel
	       border-color-name border-color border-pixel
	       cursor-font cursor vscroll-cursor font-name documentation-font-name)
    item
    (let ((colormap (first (xlib:installed-colormaps item))))
      (set-color-variables colormap fore-color foreground-color foreground-color-name)
      (set-color-variables colormap back-color background-color background-color-name)
      (set-color-variables colormap b-color border-color border-color-name)
      (setq foreground-pixel (xlib:alloc-color colormap foreground-color))
      (setq background-pixel (xlib:alloc-color colormap background-color))
      (setq border-pixel (xlib:alloc-color colormap border-color))
      (setq cursor (xlib:create-glyph-cursor 
		    :source-font cursor-font
		    ;; see clue/clue/cursors.lisp for a list
		    :source-char 22	; 22 is the best one, I think
		    :mask-font   cursor-font
		    :mask-char   (1+ 22)
		    :foreground  foreground-color
		    :background  background-color))
      (setq vscroll-cursor (xlib:create-glyph-cursor 
			    :source-font cursor-font
			    ;; see clue/clue/cursors.lisp for a list
			    :source-char 116
			    :mask-font   cursor-font
			    :mask-char   (1+ 116)
			    :foreground  foreground-color
			    :background  background-color))
      (set-inspecter-font item font-name t)
      (set-inspecter-documentation-font item documentation-font-name t)
      (revert-properties-of-window item)
      (unless no-redisplay-p
	(display-item item)))))

(defmethod inspecter-all-font-names ((item inspecter))
  (with-slots (xlib:display all-font-names)
    item
    (if (slot-boundp item 'all-font-names)
	all-font-names
	(setq all-font-names (sort (xlib:list-font-names xlib:display "*")
				   #'string<)))))

(defmacro set-inspecter-font-internal (item new-font-name no-redisplay-p
					  font-name font draw-gc inverse-draw-gc)
  `(with-slots (xlib:display inspecter)
     ,item
     (let* ((old-font-name (,font-name inspecter))
	    (old-font (,font inspecter))
	    (old-gc (,draw-gc inspecter))
	    (old-inverse-gc (,inverse-draw-gc inspecter))
	    (new-font (xlib:open-font xlib:display ,new-font-name))
	    (new-gc (get-gc inspecter :font new-font))
	    (new-inverse-gc (get-gc inspecter :font new-font :inverse-p t))
	    (*asapoc-throw-on-error-p* t))
       (if (catch 'asapoc-error
	     (setf (,font-name inspecter) ,new-font-name)
	     (setf (,font inspecter) new-font)
	     (setf (,draw-gc inspecter) new-gc)
	     (setf (,inverse-draw-gc inspecter) new-inverse-gc)
	     (unless ,no-redisplay-p
	       (display-item inspecter))
	     t)
	   (progn
	     (when old-font (xlib:close-font old-font))
	     (when old-gc (xlib:free-gcontext old-gc))
	     (when old-inverse-gc (xlib:free-gcontext old-inverse-gc)))
	   (progn
	     (setf (,font-name inspecter) old-font-name)
	     (setf (,font inspecter) old-font)
	     (setf (,draw-gc inspecter) old-gc)
	     (setf (,inverse-draw-gc inspecter) old-inverse-gc)
	     (setf (item-text (inspecter-documentation-item inspecter))
		   "This font is too big")
	     (display-item inspecter)
	     (xlib:close-font new-font)
	     (xlib:free-gcontext new-gc)
	     (xlib:free-gcontext new-inverse-gc))))))

(defmethod set-inspecter-font ((item item) font-name
			     &optional no-redisplay-p)
  (set-inspecter-font-internal 
   item font-name no-redisplay-p
   inspecter-font-name inspecter-font inspecter-draw-gc inspecter-inverse-draw-gc))

(defmethod set-inspecter-documentation-font ((item item) font-name
					   &optional no-redisplay-p)
  (set-inspecter-font-internal 
   item font-name no-redisplay-p
   inspecter-documentation-font-name inspecter-documentation-font
   inspecter-documentation-draw-gc inspecter-documentation-inverse-draw-gc))

(defmethod get-gc ((self inspecter)
		   &key (function boole-1) foreground background inverse-p 
		   (font nil font-p) (line-width 1))
  (with-slots (xlib:display foreground-pixel background-pixel
			    drawable font-name parent)
    self
    (let ((white background-pixel) 
	  (black foreground-pixel))
      (unless foreground (setq foreground (if inverse-p white black)))
      (unless background (setq background (if inverse-p black white))))
    (when (or font (null font-p))
      (unless font (setq font font-name))
      (unless (typep font 'xlib:font)
	(setq font (xlib:open-font xlib:display font))))
    (xlib:create-gcontext :drawable parent
			  :function function
			  :foreground foreground
			  :background background
			  :font font
			  :line-width line-width)))

(defun getenv (name)
  (setq name (string name))
  #+(or kcl lucid excl)
  (#+kcl si:getenv
   #+lucid lcl:environment-variable
   #+excl system:getenv
     (string name))
  #+cmu (cdr (assoc (intern name :keyword) ext:*environment-list*))
  #-(or kcl lucid excl cmu)
  nil)

(defun default-host ()
  #-(or kcl lucid excl cmu) nil
  #+(or kcl lucid excl cmu)
  (let* ((spec (getenv :display))
	 (c (and spec (position #\: spec))))
    (and c (subseq spec 0 c))))    

(defvar text-displaced-by-gc-message nil)
(defvar gc-message "Collecting...")

(defun before-gc-hook ()
  (if (and *inspecter*
	     (eq 'mapped (window-state *inspecter*)))
      (let ((doc (inspecter-documentation-item *inspecter*)))
	(setq text-displaced-by-gc-message (item-text doc))
	(setf (item-text doc) gc-message)
	(refresh-window doc)
	(xlib:display-force-output (xlib:window-display *inspecter*)))
      (setq text-displaced-by-gc-message nil)))

(defun after-gc-hook ()
  (when (and *inspecter*
	     (eq 'mapped (window-state *inspecter*)))
    (let ((doc (inspecter-documentation-item *inspecter*)))
      (setf (item-text doc) text-displaced-by-gc-message)
      (setq text-displaced-by-gc-message nil)
      (refresh-window doc)
      (xlib:display-force-output (xlib:window-display *inspecter*)))))

#+cmu
(progn
(pushnew 'before-gc-hook ext:*before-gc-hooks*)
(pushnew 'after-gc-hook ext:*after-gc-hooks*)
)
