stk/Lib/balloon.stk

124 lines
3.9 KiB
Plaintext

;;;;
;;;; 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")
|#