163 lines
5.2 KiB

;;;; Dialog box creation utility
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; 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.
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;; Author: Erick Gallesio []
;;;; Creation date: 4-Aug-1993 11:05
;;;; Last file update: 3-Sep-1999 19:50 (eg)
(provide "dialog")
(select-module Tk)
(define stk::button-pressed #f)
;; STk:make-dialog
;; This procedure displays a dialog box following the spcifications given in
;; arguments. Arguments are given as keywords.
;; window (.dialog) Window name to use for dialog top-level.
;; title ("Dialog") Title to display in dialog's decorative frame.
;; text ("") Message to display in dialog.
;; bitmap ("") Bitmap to display in dialog (empty string means none).
;; default (-1) Index of button that is to display the default ring
;; (-1 means none).
;; grab (#f) Indicates if make-dialog must wait that a button be
;; pressed before returning. Use 'global to heve a global
;; grab.
;; buttons ('()) A list of couples indicating the button text and its
;; associated action (a closure)
;; If grabbing is set, this procedure returns the button pressed index.
(define (STk:make-dialog . arguments)
(let ((w (get-keyword :window arguments '.dialog))
(title (get-keyword :title arguments "Dialog"))
(text (get-keyword :text arguments ""))
(bitmap (get-keyword :bitmap arguments #f))
(image (get-keyword :image arguments #f))
(default (get-keyword :default arguments -1))
(grabbing (get-keyword :grab arguments #f))
(buttons (get-keyword :buttons arguments '()))
(old-focus (Tk:focus)))
(catch (Tk:destroy w))
(set! stk::button-pressed #f)
;; 1. Create the top-level window and divide it into top and bottom parts.
(define (format #f "" w))
(define (format #f "" w))
(define w.msg (format #f "" w))
(define w.bmp (format #f "" w))
(Tk:toplevel w :class "Dialog")
(Tk:wm 'title w title)
(Tk:wm 'iconname w "Dialog")
(Tk:pack [Tk:frame :relief "raised" :bd 1] :expand #t :fill "both")
(Tk:pack [Tk:frame :relief "raised" :bd 1] :fill "x")
;; 2. Fill the top part with bitmap and message (use the option
;; database for -wraplength so that it can be overridden by
;; the caller).
(option 'add "*Dialog.msg.wrapLength" "3i" "widgetDefault")
(Tk:pack [message w.msg :justify "left" :text text :aspect 1000
:font '(Times 18)]
:side "right"
:expand #t
:padx 10
:pady 10
:fill "both")
(if image
(Tk:pack [Tk:label w.bmp :image image]
:side "left"
:padx 10
:pady 10)
(if bitmap
(Tk:pack [Tk:label w.bmp :bitmap bitmap :fg "red"]
:side "left"
:padx 10
:pady 10)))
;; 3. Create a row of buttons at the bottom of the dialog.
(do ([i 0 (+ i 1)] [but buttons (cdr but)])
([null? but] '())
(let ((name (format #f "~A.but-~A" w i)))
(Tk:button name :text (caar but)
:command (lambda ()
(if old-focus (Tk:focus old-focus))
(set! stk::button-pressed i)
(Tk:destroy w)
(apply (cadar but) '())))
(if (equal? i default)
(Tk:focus name))
(Tk:pack name :side "left" :expand #t :padx 20 :pady 8 :ipadx 2 :ipady 2)))
;; 4. Center window
(STk:center-window w)
;; 5. Wait until a button is pressed if grab is set
(when grabbing
(let* ((old-grab (Tk:grab 'current *root*))
(grab-status (if old-grab
(grab 'status old-grab)
(if (eqv? grabbing 'global)
(Tk:grab :global '.dialog)
(Tk:grab 'set w))
;; Add a binding that sets the result to -1 if the window is detroyed
(bind w "<Destroy>" (lambda ()
(unless stk::button-pressed
(set! stk::button-pressed -1))))
(Tk:tkwait 'variable 'stk::button-pressed)
(if old-grab
(if (equal? grab-status "global")
(Tk:grab :global old-grab)
(Tk:grab old-grab))))
(define (STk:center-window w)
;; Withdraw the window, then update all the geometry information
;; so we know how big it wants to be, then center the window in the
;; display and de-iconify it.
(wm 'withdraw w)
(update 'idletasks)
(let ((x (- (/ [winfo 'screenwidth w] 2)
(/ [winfo 'reqwidth w] 2)
(winfo 'vrootx [eval [winfo 'parent w]])))
(y (- (/ [winfo 'screenheight w] 2)
(/ [winfo 'reqheight w] 2)
(winfo 'vrooty [eval [winfo 'parent w]]))))
(wm 'geom w (format #f "+~A+~A" (inexact->exact (floor x))
(inexact->exact (floor y))))
(wm 'deiconify w)))
;;;;; Compatibility
(define stk::make-dialog STk:make-dialog)