124 lines
3.9 KiB
Plaintext
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")
|
|
|#
|