stk/Lib/button.stk

244 lines
9.3 KiB
Plaintext
Raw Normal View History

1996-09-27 06:29:02 -04:00
;;;;
;;;; Buttons, Check button and radio buttons bindings and procs
;;;;
1999-02-02 06:13:40 -05:00
;;;; Copyright <20> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
1996-09-27 06:29:02 -04:00
;;;;
1999-09-05 07:16:41 -04:00
;;;; 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.
1996-09-27 06:29:02 -04:00
;;;;
;;;; 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
1999-09-05 07:16:41 -04:00
;;;; Last file update: 3-Sep-1999 19:49 (eg)
1996-09-27 06:29:02 -04:00
;;;;
1998-04-10 06:59:06 -04:00
(select-module Tk)
1996-09-27 06:29:02 -04:00
;; 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))
1999-02-02 06:13:40 -05:00
1998-04-10 06:59:06 -04:00
;==============================================================================
;
; 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
;
;==============================================================================
1996-09-27 06:29:02 -04:00
;; 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)))
1998-04-10 06:59:06 -04:00
(tk-set! |W| :state "active" :relief "sunken")
1996-09-27 06:29:02 -04:00
(update 'idletasks)
(after 100)
1998-04-10 06:59:06 -04:00
(tk-set! |W| :state old-state :relief old-relief)
1996-09-27 06:29:02 -04:00
(|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.
1998-04-10 06:59:06 -04:00
(define (Tk:R&C-invoke |W| . cmd)
1996-09-27 06:29:02 -04:00
(unless (equal? (tk-get |W| :state) "disabled")
1998-04-10 06:59:06 -04:00
(|W| (if (null? cmd) 'invoke (car cmd)))))
1996-09-27 06:29:02 -04:00
1999-02-02 06:13:40 -05:00
(define (Tk:R&C-invoke1 |W|)
(Tk:R&C-invoke |W|))
1996-09-27 06:29:02 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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.
1998-04-10 06:59:06 -04:00
;;; 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
1996-09-27 06:29:02 -04:00
(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)
1999-02-02 06:13:40 -05:00
(bind "Button" "<Return>" Tk:button-invoke)
1996-09-27 06:29:02 -04:00
1998-04-10 06:59:06 -04:00
(bind "Checkbutton" "<FocusIn>" "")
(bind "Checkbutton" "<Leave>" Tk:button-leave)
1999-02-02 06:13:40 -05:00
(bind "Checkbutton" "<space>" Tk:R&C-invoke1)
(bind "Checkbutton" "<Return>" Tk:R&C-invoke1)
1996-09-27 06:29:02 -04:00
(bind "Radiobutton" "<FocusIn>" "")
(bind "Radiobutton" "<Leave>" Tk:button-leave)
1999-02-02 06:13:40 -05:00
(bind "Radiobutton" "<space>" Tk:R&C-invoke1)
(bind "Radiobutton" "<Return>" Tk:R&C-invoke1)
1996-09-27 06:29:02 -04:00
1999-02-02 06:13:40 -05:00
)