;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT; Patch-File: T; -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Window
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/utilities/mouse-documentation.lisp
;;; File Creation Date: 5/19/90 09:48:11
;;; Last Modification Time: 12/09/92 09:21:46
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 01/31/1991 (Matthias) added: show-mouse-documentation (string) method
;;;                              with-mouse-documentation 
;;;                                  (docu-string <body>) macro
;;;                              for displaying explicit docu strings
;;;                       changed: remove-mouse-documentation-window
;;; 
;;; 9/07/90  Hubertus  - added test to prevent display operations on a
;;;                      destroyed mouse-documentation-window.
;;; 12/16/1991 (Matthias) - added test in update-mouse-documentation-window
;;;                         and trigger for resize of toplevel
;;;_____________________________________________________________________________

(in-package :xit)

;_____________________________________________________________________________
;
;                   Mouse Documentation Window
;_____________________________________________________________________________

(defcontact mouse-documentation-window (text-dispel)
   ((name :initform :mouse-documentation)
    (inside-border :initform 5)
    (display-position :initform :upper-left)
    (adjust-size? :initform nil)))

(define-resources
  (* mouse-documentation-window background) "black"
  (* mouse-documentation-window foreground) "white"
  (* mouse-documentation-window border-width) 0
  (* mouse-documentation-window font) '(:family :helvetica :face :bold :size 14))

(defun make-mouse-documentation-window (&optional (parent *toplevel*))
  (declare (special *toplevel* *mouse-documentation-window*))
  (with-slots ((parent-x x) (parent-y y)
	       (parent-width width) (parent-height height)) parent
     (setq *mouse-documentation-window*
       (make-window `mouse-documentation-window
		    :parent parent
		    :width parent-width
		    :state :managed))
     (with-slots (height) *mouse-documentation-window*
       (move-window *mouse-documentation-window* 0 (- parent-height height))
       (totop-window *mouse-documentation-window*))))

;;; Overwrite dummy methods (02/01/1991 (Matthias))

(defmethod show-documentation ((self mouse-documentation-window) documentation)
  (unless (destroyed-p self)
    (setf (text self) documentation)))

(defmethod hide-documentation ((self mouse-documentation-window))
  (unless (destroyed-p self)
    (setf (text self) "")))

(defmethod changing-documentation ((self mouse-documentation-window)
				   documentation continuation)
  (with-slots (display) self
    (let ((saved-mouse-documentation (text self)))
      (unwind-protect
	  (progn
	    (show-documentation self documentation)
	    (display-force-output display)
	    (funcall continuation))
	(show-documentation self saved-mouse-documentation)
	(display-force-output display)))))

;;; Update mouse documentation window when toplevel is resized
;;
(defmethod resize :after ((self toplevel-window) width height border-width)
  (declare (ignore width height border-width))
  (update-mouse-documentation-window))

(defun update-mouse-documentation-window ()
  (declare (special *mouse-documentation-window*))
  (when *mouse-documentation-window*
    (with-slots (parent height) *mouse-documentation-window*
     (with-slots ((parent-width width) (parent-height height)) parent
	(newsize-window *mouse-documentation-window*
			0 (- parent-height height) parent-width height)))))


(defun remove-mouse-documentation-window ()
  (declare (special *mouse-documentation-window*))
  (when *mouse-documentation-window*
    (destroy *mouse-documentation-window*)
    (setq *mouse-documentation-window* nil)))
  	       
;_____________________________________________________________________________
;
;              mouse documentation for interaction windows
;_____________________________________________________________________________
(defun remove-mouse-documentation-for (window)
  (when (typep window 'interaction-window)
    (setf (mouse-documentation window) nil))
  (when (typep window 'composite)
    (dolist (child (composite-children window))
      (remove-mouse-documentation-for child))))

(defun mouse-documentation-if-needed-for (window)
  (when (typep window 'interaction-window)
    (setf (compute-mouse-documentation? window) :if-needed))
  (when (typep window 'composite)
    (dolist (child (composite-children window))
      (mouse-documentation-if-needed-for child))))

(defun make-default-mouse-documentation-window (&optional (parent *toplevel*))
  (declare (special *toplevel*))
  (make-mouse-documentation-window parent)
  (mouse-documentation-if-needed-for parent))


;_____________________________________________________________________________
;
;                         dependencies
;_____________________________________________________________________________

(defun remove-mouse-documentation-window-close-hook (display)
  (remove-mouse-documentation-window))

(add-close-display-hook 'remove-mouse-documentation-window-close-hook)

;_____________________________________________________________________________
;
;                      instance creation
;_____________________________________________________________________________


(if (and (boundp '*display*) *display*
	 (boundp '*toplevel*) *toplevel*)
    (make-mouse-documentation-window)
  (add-open-toplevel-hook 'make-mouse-documentation-window))



