244 lines
9.3 KiB
Plaintext
244 lines
9.3 KiB
Plaintext
;;;;
|
|
;;;; Buttons, Check button and radio buttons bindings and procs
|
|
;;;;
|
|
;;;; Copyright © 1993-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.
|
|
;;;;
|
|
;;;; 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 [eg@unice.fr]
|
|
;;;; Creation date: 17-May-1993 12:35
|
|
;;;; Last file update: 3-Sep-1999 19:49 (eg)
|
|
;;;;
|
|
|
|
(select-module Tk)
|
|
|
|
;; This file is loaded for the first button, radio or check
|
|
;; button. Avoid to load it several times
|
|
(unless (or (tk-command? Tk:button)
|
|
(tk-command? Tk:checkbutton)
|
|
(tk-command? Tk:radiobutton))
|
|
|
|
;==============================================================================
|
|
;
|
|
; UNIX stuff
|
|
;
|
|
;==============================================================================
|
|
(when (eqv? (os-kind) 'Unix)
|
|
|
|
;; The procedure below is invoked when the mouse pointer enters a
|
|
;; button widget. It records the button we're in and changes the
|
|
;; state of the button to active unless the button is disabled.
|
|
(define (Tk:button-enter |W|)
|
|
(unless (equal? (tk-get |W| :state) "disabled")
|
|
(tk-set! |W| :state "active")
|
|
(if (equal? tk::button-window |W|)
|
|
(tk-set! |W| :state "active" :relief "sunken")))
|
|
(set! tk::window |W|))
|
|
|
|
;; The procedure below is invoked when the mouse pointer leaves a
|
|
;; button widget. It changes the state of the button back to
|
|
;; inactive. If we're leaving the button window with a mouse button
|
|
;; pressed (tk::button-window == |W|), restore the relief of the
|
|
;; button too.
|
|
(define (Tk:button-leave |W|)
|
|
(unless (equal? (tk-get |W| :state) "disabled")
|
|
(tk-set! |W| :state "normal"))
|
|
(if (equal? tk::button-window |W|)
|
|
(tk-set! |W| :relief tk::relief))
|
|
(set! tk::window #f))
|
|
|
|
;; The procedure below is invoked when the mouse button is pressed in
|
|
;; a button widget. It records the fact that the mouse is in the
|
|
;; button, saves the button's relief so it can be restored later, and
|
|
;; changes the relief to sunken.
|
|
(define (Tk:button-down |W|)
|
|
(set! tk::relief (tk-get |W| :relief))
|
|
(unless (equal? (tk-get |W| :state) "disabled")
|
|
(set! tk::button-window |W|)
|
|
(tk-set! |W| :relief "sunken")))
|
|
|
|
;; The procedure below is invoked when the mouse button is released
|
|
;; in a button widget. It restores the button's relief and invokes
|
|
;; the command as long as the mouse hasn't left the button.
|
|
(define (Tk:button-up |W|)
|
|
(when (equal? tk::button-window |W|)
|
|
(set! tk::button-window "")
|
|
(tk-set! |W| :relief tk::relief)
|
|
(when (and (equal? |W| tk::window)
|
|
(not (equal? (tk-get |W| :state) "disabled")))
|
|
(|W| 'invoke)))))
|
|
|
|
;==============================================================================
|
|
;
|
|
; WINDOWS stuff
|
|
;
|
|
;==============================================================================
|
|
(when (eqv? (os-kind) 'Windows)
|
|
|
|
;; The procedure below is invoked when the mouse pointer enters a
|
|
;; button widget. It records the button we're in and changes the
|
|
;; state of the button to active unless the button is disabled.
|
|
(define (Tk:button-enter |W|)
|
|
(unless (equal? (tk-get |W| :state) "disabled")
|
|
(if (equal? tk::button-window |W|)
|
|
(tk-set! |W| :state "active" :relief "sunken")))
|
|
(set! tk::window |W|))
|
|
|
|
;; The procedure below is invoked when the mouse pointer leaves a
|
|
;; button widget. It changes the state of the button back to
|
|
;; inactive. If we're leaving the button window with a mouse button
|
|
;; pressed (tk::button-window == |W|), restore the relief of the
|
|
;; button too.
|
|
(define (Tk:button-leave |W|)
|
|
(unless (equal? (tk-get |W| :state) "disabled")
|
|
(tk-set! |W| :state "normal"))
|
|
(if (equal? tk::button-window |W|)
|
|
(tk-set! |W| :relief tk::relief))
|
|
(set! tk::window #f))
|
|
|
|
;; The procedure below is invoked when the mouse button is pressed in
|
|
;; a button widget. It records the fact that the mouse is in the
|
|
;; button, saves the button's relief so it can be restored later, and
|
|
;; changes the relief to sunken.
|
|
(define (Tk:button-down |W|)
|
|
(set! tk::relief (tk-get |W| :relief))
|
|
(unless (equal? (tk-get |W| :state) "disabled")
|
|
(set! tk::button-window |W|)
|
|
(tk-set! |W| :relief "sunken" :state "active")))
|
|
|
|
;; The procedure below is invoked when the mouse button is released
|
|
;; in a button widget. It restores the button's relief and invokes
|
|
;; the command as long as the mouse hasn't left the button.
|
|
(define (Tk:button-up |W|)
|
|
(when (equal? tk::button-window |W|)
|
|
(set! tk::button-window "")
|
|
(when (and (equal? |W| tk::window)
|
|
(not (equal? (tk-get |W| :state) "disabled")))
|
|
(tk-set! |W| :relief tk::relief :state "normal")
|
|
(|W| 'invoke))))
|
|
|
|
;; The procedure below is invoked when the mouse pointer enters a
|
|
;; checkbutton or radiobutton widget. It records the button we're in
|
|
;; and changes the state of the button to active unless the button is
|
|
;; disabled.
|
|
(define (Tk:R&C-enter |W|)
|
|
(unless (equal? (tk-get |W| :state) "disabled")
|
|
(if (equal? tk::button-window |W|)
|
|
(tk-set! |W| :state "active")))
|
|
(set! tk::window |W|))
|
|
|
|
;; The procedure below is invoked when the mouse button is pressed in
|
|
;; a button widget. It records the fact that the mouse is in the button,
|
|
;; saves the button's relief so it can be restored later, and changes
|
|
;; the relief to sunken.
|
|
(define (Tk:R&C-down |W|)
|
|
(set! tk::relief (tk-get |W| :relief))
|
|
(unless (equal? (tk-get |W| :state) "disabled")
|
|
(set! tk::button-window |W|)
|
|
(tk-set! |W| :state "active"))))
|
|
|
|
|
|
;==============================================================================
|
|
;
|
|
; Common stuff
|
|
;
|
|
;==============================================================================
|
|
|
|
;; The procedure below is called when a button is invoked through
|
|
;; the keyboard. It simulate a press of the button via the mouse.
|
|
(define (Tk:button-invoke |W|)
|
|
(unless (equal? (tk-get |W| :state) "disabled")
|
|
(let ((old-relief (tk-get |W| :relief))
|
|
(old-state (tk-get |W| :state)))
|
|
(tk-set! |W| :state "active" :relief "sunken")
|
|
(update 'idletasks)
|
|
(after 100)
|
|
(tk-set! |W| :state old-state :relief old-relief)
|
|
(|W| 'invoke))))
|
|
|
|
;; The procedure below is invoked when the mouse button is pressed in
|
|
;; a checkbutton or radiobutton widget, or when the widget is invoked
|
|
;; through the keyboard. It invokes the widget if it isn't disabled.
|
|
|
|
(define (Tk:R&C-invoke |W| . cmd)
|
|
(unless (equal? (tk-get |W| :state) "disabled")
|
|
(|W| (if (null? cmd) 'invoke (car cmd)))))
|
|
|
|
(define (Tk:R&C-invoke1 |W|)
|
|
(Tk:R&C-invoke |W|))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Class bindings for various flavors of button widgets. tk::window
|
|
;; keeps track of the button containing the mouse, and tk::relief
|
|
;; saves the original relief of the button so it can be restored when
|
|
;; the mouse button is released.
|
|
|
|
|
|
;;; UNIX bindings
|
|
(when (eqv? (os-kind) 'Unix)
|
|
(bind "Checkbutton" "<Return>" (lambda (|W|)
|
|
(unless *tk-strict-motif*
|
|
(Tk:R&C-invoke |W|))))
|
|
(bind "Checkbutton" "<1>" (lambda (|W|)
|
|
(Tk:R&C-invoke |W|)))
|
|
(bind "Checkbutton" "<Enter>" Tk:button-enter)
|
|
|
|
(bind "Radiobutton" "<Return>" (lambda (|W|)
|
|
(unless *tk-strict-motif*
|
|
(Tk:R&C-invoke |W|))))
|
|
(bind "Radiobutton" "<1>" (lambda (|W|)
|
|
(Tk:R&C-invoke |W|)))
|
|
(bind "Radiobutton" "<Enter>" Tk:button-enter))
|
|
|
|
|
|
;;; WINDOWS bindings
|
|
(when (eqv? (os-kind) 'Windows)
|
|
(bind "Checkbutton" "<equal>" (lambda (|W|)
|
|
(Tk:R&C-invoke |W| 'select)))
|
|
(bind "Checkbutton" "<plus>" (lambda (|W|)
|
|
(Tk:R&C-invoke |W| 'select)))
|
|
(bind "Checkbutton" "<minus>" (lambda (|W|)
|
|
(Tk:R&C-invoke |W| 'deselect)))
|
|
|
|
(bind "Checkbutton" "<1>" Tk:R&C-down)
|
|
(bind "Checkbutton" "<ButtonRelease-1>" Tk:button-up)
|
|
(bind "Checkbutton" "<Enter>" Tk:R&C-enter)
|
|
|
|
(bind "Radiobutton" "<1>" Tk:R&C-down)
|
|
(bind "Radiobutton" "<ButtonRelease-1>" Tk:Button-up)
|
|
(bind "Radiobutton" "<Enter>" Tk:R&C-enter))
|
|
|
|
;;; Common bindings
|
|
(bind "Button" "<FocusIn>" "")
|
|
(bind "Button" "<Enter>" Tk:button-enter)
|
|
(bind "Button" "<Leave>" Tk:button-leave)
|
|
(bind "Button" "<1>" Tk:button-down)
|
|
(bind "Button" "<ButtonRelease-1>" Tk:button-up)
|
|
(bind "Button" "<space>" Tk:button-invoke)
|
|
(bind "Button" "<Return>" Tk:button-invoke)
|
|
|
|
(bind "Checkbutton" "<FocusIn>" "")
|
|
(bind "Checkbutton" "<Leave>" Tk:button-leave)
|
|
(bind "Checkbutton" "<space>" Tk:R&C-invoke1)
|
|
(bind "Checkbutton" "<Return>" Tk:R&C-invoke1)
|
|
|
|
(bind "Radiobutton" "<FocusIn>" "")
|
|
(bind "Radiobutton" "<Leave>" Tk:button-leave)
|
|
(bind "Radiobutton" "<space>" Tk:R&C-invoke1)
|
|
(bind "Radiobutton" "<Return>" Tk:R&C-invoke1)
|
|
|
|
)
|