;;;;
;;;; b a l l o o n . s t k 					-- balloon help 
;;;;
;;;; Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 11-Dec-1998 18:00
;;;; Last file update:  3-Sep-1999 19:48 (eg)

(select-module Tk)
(export add-balloon-help activate-balloons deactivate-balloons find-balloon-help)


;;;;
;;;; Resources (FIXME: background does not work. why? Tk bug?)
;;;;

(option 'add "*HelpBalloon*Label*Background"	"#ffffb0"	"widgetDefault")
(option 'add "*HelpBalloon*Label*Foreground"	"black"		"widgetDefault")    
(option 'add "*HelpBalloon*Label*BorderWidth"	1		"widgetDefault")
(option 'add "*HelpBalloon*Font"		'(Courier -12)	"widgetDefault")
(option 'add "*HelpBalloon*Relief"		"solid"		"widgetDefault")
(option 'add "*HelpBalloon*HighlightThickness"	0		"widgetDefault")


;;;;
;;;; Globals 
;;;;
(define *balloon-handler* #f)
(define *balloon-top*     #f)
(define *balloon-label*   #f)


(define (initialize-balloon)
  (set! *balloon-top*   (toplevel ".__balloon__" :class "HelpBalloon"))
  (set! *balloon-label* (label (& *balloon-top* ".l") :padx 3 :pady 2))
  (pack *balloon-label* :expand #f :fill "both")
  (activate-balloons)
  ; make widget transient
  (wm 'withdraw *balloon-top*)
  (wm 'over     *balloon-top* #t))

(define (activate-balloons)
  (bind "Balloon" "<Enter>" (lambda (|W|) (display-balloon-help |W|)))
  (bind "Balloon" "<Leave>" (lambda (|W|) (delete-balloon-help |W|))))

(define (deactivate-balloons)
  (bind "Balloon" "<Enter>" "")
  (bind "Balloon" "<Leave>" ""))

(define (add-balloon-help w txt delay bg)
  (unless *balloon-top* 
    (initialize-balloon))

  ;; store parameters in widget and make it a "Balloon" widget
  (set-widget-property! w :balloon-txt   txt)
  (set-widget-property! w :balloon-delay delay)
  (set-widget-property! w :balloon-bg    bg)
  (bindtags w (cons "Balloon" (remove "Balloon" (bindtags w)))))


(define (find-balloon-help)
  (unless *balloon-label* 
    (initialize-balloon))
  *balloon-label*)


(define (display-balloon-help w)
  (after 'cancel *balloon-handler*)

  (let ((delay (get-widget-property w :balloon-delay -1))
	(txt   (get-widget-property w :balloon-txt   ""))
	(bg    (get-widget-property w :balloon-bg    "")))
    (when (>= delay 0)
      (set! *balloon-handler*
	    (after delay
		   (lambda ()
		     (when (winfo 'exists w)
		       (let* ((height (winfo 'height w))
			      (pos-y  (winfo 'rooty  w)))
			 (*balloon-label* 'conf :text txt :bg bg)
			 ;; place the balloon just outside the widget
			 (wm 'geometry *balloon-top* 
			     (format #f "+~A+~A" 
				     (winfo 'pointerx w) (+ pos-y height 2)))
			 ;; required for windows, otherwise it appears at top left
			 (update)
			 ;; Deiconify
			 (wm 'deiconify *balloon-top*)
			 (raise *balloon-top*)
			 (eventually-delete-ballon-help w)))))))))

(define (eventually-delete-ballon-help w)
  ;; Delete the ballon if the window to which the balloon is assocaited does not
  ;; Exist anymore.
  (if (winfo 'exists w)
      (set! *balloon-handler*
	    (after 800 (lambda () (eventually-delete-ballon-help w))))
      (delete-balloon-help w)))


(define (delete-balloon-help w)
  (wm 'withdraw *balloon-top*)
  (after 'cancel  *balloon-handler*))

(provide "balloon")

#|
  (button '.b1 :text "foo")
  (button '.b2 :text "bar")
  (pack .b1 .b2)
  (add-balloon-help .b1 "On several\nlines\n..." 10 "yellow")
  (add-balloon-help .b2 "This is help" 1000 "red")
|#