home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / button.stk next >
Encoding:
Text File  |  1996-07-02  |  5.1 KB  |  138 lines
  1. ;;;;
  2. ;;;; Buttons, Check button and radio buttons bindings and procs
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;; This software is a derivative work of other copyrighted softwares; the
  15. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  16. ;;;;
  17. ;;;;
  18. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  19. ;;;;    Creation date: 17-May-1993 12:35
  20. ;;;; Last file update:  2-Jul-1996 12:24
  21. ;;;;
  22.  
  23.  
  24. ;; This file is loaded for the first button, radio or check
  25. ;; button. Avoid to load it several times
  26. (unless (or (tk-command? Tk:button) 
  27.         (tk-command? Tk:checkbutton) 
  28.         (tk-command? Tk:radiobutton))
  29.   (let ()
  30.  
  31. ;; The procedure below is invoked when the mouse pointer enters a
  32. ;; button widget.  It records the button we're in and changes the
  33. ;; state of the button to active unless the button is disabled.
  34.  
  35. (define (Tk:button-enter |W|)
  36.   (unless (equal? (tk-get |W| :state) "disabled")
  37.      (tk-set! |W| :state "active")
  38.      (if (equal? tk::button-window |W|)
  39.      (tk-set! |W| :state "active"
  40.               :relief "sunken")))
  41.   (set! tk::window |W|))
  42.  
  43. ;; The procedure below is invoked when the mouse pointer leaves a
  44. ;; button widget. It changes the state of the button back to
  45. ;; inactive. If we're leaving the button window with a mouse button
  46. ;; pressed (tk::button-window == |W|), restore the relief of the
  47. ;; button too.
  48.  
  49. (define (Tk:button-leave |W|)
  50.   (unless (equal? (tk-get |W| :state) "disabled")
  51.      (tk-set! |W| :state "normal"))
  52.   (if (equal? tk::button-window |W|)
  53.       (tk-set! |W| :relief tk::relief))
  54.   (set! tk::window #f))
  55.  
  56.  
  57. ;; The procedure below is invoked when the mouse button is pressed in
  58. ;; a button widget. It records the fact that the mouse is in the
  59. ;; button, saves the button's relief so it can be restored later, and
  60. ;; changes the relief to sunken.
  61.  
  62. (define (Tk:button-down |W|)
  63.   (set! tk::relief       (tk-get |W| :relief))
  64.   (set! tk::button-window |W|)
  65.   (unless (equal? (tk-get |W| :state) "disabled")
  66.      (set! tk::button-window |W|)
  67.      (tk-set! |W| :relief "sunken")))
  68.  
  69. ;; The procedure below is invoked when the mouse button is released
  70. ;; in a button widget.  It restores the button's relief and invokes
  71. ;; the command as long as the mouse hasn't left the button.
  72.  
  73. (define (Tk:button-up |W|)
  74.   (when (equal? tk::button-window |W|)
  75.      (set! tk::button-window "")
  76.      (tk-set! |W| :relief tk::relief)
  77.      (when (and (equal? |W| tk::window)
  78.         (not (equal? (tk-get |W| :state) "disabled")))
  79.        (|W| 'invoke))))
  80.  
  81. ;; The procedure below is called when a button is invoked through
  82. ;; the keyboard.  It simulate a press of the button via the mouse.
  83. (define (Tk:button-invoke |W|)
  84.   (unless (equal? (tk-get |W| :state) "disabled")
  85.      (let ((old-relief (tk-get |W| :relief))
  86.        (old-state  (tk-get |W| :state)))
  87.        (tk-set! |W| :state "active"
  88.             :relief "sunken")
  89.        (update 'idletasks)
  90.        (after 100)
  91.        (tk-set! |W| :state  old-state 
  92.           :relief old-relief)
  93.        (|W| 'invoke))))
  94.  
  95. ;; The procedure below is invoked when the mouse button is pressed in
  96. ;; a checkbutton or radiobutton widget, or when the widget is invoked
  97. ;; through the keyboard.  It invokes the widget if it isn't disabled.
  98.  
  99. (define (Tk:R&C-button-invoke |W|)
  100.   (unless (equal? (tk-get |W| :state) "disabled")
  101.     (|W| 'invoke)))
  102.  
  103. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  104. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  105.  
  106. ;; Class bindings for various flavors of button widgets. tk::window
  107. ;; keeps track of the button containing the mouse, and tk::relief
  108. ;; saves the original relief of the button so it can be restored when
  109. ;; the mouse button is released.
  110.  
  111.  
  112. (bind "Button" "<FocusIn>"         "")
  113. (bind "Button" "<Enter>"        Tk:button-enter)
  114. (bind "Button" "<Leave>"        Tk:button-leave)
  115. (bind "Button" "<1>"            Tk:button-down)
  116. (bind "Button" "<ButtonRelease-1>"     Tk:button-up)
  117. (bind "Button" "<space>"        Tk:button-invoke)
  118.  
  119. (bind "Checkbutton" "<FocusIn>"     "")
  120. (bind "Checkbutton" "<Enter>"         Tk:button-enter)
  121. (bind "Checkbutton" "<Leave>"         Tk:button-leave)
  122. (bind "Checkbutton" "<1>"         Tk:R&C-button-invoke)
  123. (bind "Checkbutton" "<space>"         Tk:R&C-button-invoke)
  124. (bind "Checkbutton" "<Return>"         (lambda (|W|)
  125.                       (unless *tk-strict-motif*
  126.                         (Tk:R&C-button-invoke |W|))))
  127.  
  128. (bind "Radiobutton" "<FocusIn>"     "")
  129. (bind "Radiobutton" "<Enter>"         Tk:button-enter)
  130. (bind "Radiobutton" "<Leave>"         Tk:button-leave)
  131. (bind "Radiobutton" "<1>"         Tk:R&C-button-invoke)
  132. (bind "Radiobutton" "<space>"         Tk:R&C-button-invoke)
  133. (bind "Radiobutton" "<Return>"         (lambda (|W|)
  134.                       (unless *tk-strict-motif*
  135.                         (Tk:R&C-button-invoke |W|))))
  136. ))
  137.  
  138.