home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / button_bind.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  4.2 KB  |  168 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # generic procedures for managing button sweeping
  8.  
  9. # setup the bindings for a button
  10. #  tag:        The window or tag to bind to this button
  11. #  button    The button number to bind to
  12. #  prefix    The function prefix for the binding procedures
  13. #    <prefix>_down:  The button went down
  14. #    <prefix>_start_sweep    We started a sweep
  15. #    <prefix>_sweep            We are sweeping
  16. #     <prefix>_end_sweep        We ended the sweep (button up)
  17. #     <prefix>_up            button up - no sweep
  18. #    each proc gets "%W %X %Y" by default
  19. #  gravity    The amount of sweeping needed to cause a "sweep"
  20. #  args        The arguments passed to the button functions
  21. #
  22. #  Calling sequences:
  23. #     down -> up
  24. #    down -> start_sweep -> [sweep] -> end_sweep
  25.  
  26. proc button_setup {win tag prefix {button 1} {gravity 3} {params {%W %X %Y}}} {
  27.  
  28.     # set the bindings
  29.  
  30.     bind $tag <Button-$button> "
  31.             set Down $button
  32.             set Lost 0
  33.             set Root_x \[winfo rootx $win\]
  34.             set Root_y \[winfo rooty $win\]
  35.             set Shift \[expr %s&1\]
  36.             set Alt \[expr (%s&64) > 0\]
  37.             set Control \[expr (%s&4) > 0\]
  38.             set New_hit $button
  39.             set X0 %X; set Y0 %Y
  40.             ${prefix}_down $params
  41.             update idletasks
  42.             break
  43.         "
  44.     bind $tag <B${button}-Motion> "
  45.             if {\$Lost == 1} {
  46.                 do_lost $tag $button %W %X %Y
  47.                 set Lost 0
  48.                 }
  49.             button_drag $prefix %X %Y $gravity $params
  50.             update idletasks
  51.             break
  52.         "
  53.     bind $tag <ButtonRelease-${button}> "
  54.             set Down 0
  55.             if {\$Lost} break
  56.             set Lost 1
  57.             # grab release \[grab current %W\]
  58.             if {\$New_hit} {
  59.                 ${prefix}_up $params
  60.             } else {
  61.                 ${prefix}_end_sweep $params
  62.             }
  63.             update idletasks
  64.             break;
  65.         "
  66. # testing
  67. # bind all <1> {puts "v(%W)"}
  68. # bind all <B1-Motion> {puts .(%W)}
  69. # bind all <ButtonRelease-1> {puts ^(%W)}
  70. }
  71.  
  72. # Sometimes a button-down gets lost!.  If we see a button-motion,
  73. # simulate the button down.  We also need to manage the grab ourselves,
  74. # as X won't do it for us if the Button press is lost.
  75. # Since grabs are flakey too, use <bind all> instead
  76. # (It would probably be OK to ignore everything until the nect button push)
  77.  
  78. proc do_lost {tag button win x y} {
  79.     global Shift _Message
  80.  
  81.     # simulate a button down
  82.  
  83.     set prefix [expr {$Shift ? "Shift-" : ""} ]
  84.     set _Message "Slow down, I'm having a hard time catching up!"
  85.     grab $win
  86.     set expr [bind_subst [bind $tag <$prefix$button>] "W $win" "X $x" "Y $y"]
  87.     set code [catch {uplevel #0 $expr} result]
  88.     if {$code == 1} {
  89.         return -code error $result
  90.     }
  91. }
  92.  
  93. # whimpy version of do_lost
  94.  
  95. proc do_lost {tag button win x y} {
  96.     #puts "lost button for $tag"
  97.     return -code break
  98. }
  99.  
  100. # substitute bindings by hand (no error checking)
  101. # expr: expression to substitute
  102. # args: list of name value pairs
  103.  
  104. proc bind_subst {expr args} {
  105.     set weird !~!    ;# a string unlikely to appear
  106.     regsub -all  %%  $expr $weird expr    ;# handle %%'s
  107.     foreach sub $args {
  108.         regsub -all %[lindex $sub 0] $expr [lindex $sub 1] expr
  109.     }
  110.     regsub -all $weird $expr % expr    ;# put %'s back
  111.     return $expr
  112. }
  113.  
  114. # undo the button bindings (for "run" mode) [obsolete]
  115.  
  116. proc button_undo {tag {button 1}} {
  117.     bind $tag <Button-$button> {}
  118.     bind $tag <B${button}-Motion> {}
  119.     bind $tag <ButtonRelease-${button}> {}
  120. }
  121.  
  122. # handle sweeping gets called during button motion
  123.  
  124. proc button_drag {prefix x y gravity args} {
  125.     global New_hit X Y
  126.     if {$New_hit} {
  127.         if {[button_gravity $x $y $gravity]} {
  128.             return
  129.         }
  130.         set New_hit 0
  131.         eval "${prefix}_start_sweep $args"
  132.     } else {
  133.         eval "${prefix}_sweep $args"
  134.     }
  135. }
  136.  
  137. # return true if gravity is still on
  138. # X0 and Y0 (globals) containing the gravitational center
  139.  
  140. proc button_gravity {x y gravity} {
  141.     global X0 Y0
  142.     return [expr abs($x-$X0) + abs($y-$Y0) < $gravity]
  143. }
  144.  
  145. # Dummy procedures for testing
  146.  
  147. proc dummy_down {win x y} {
  148.     puts "Button down for $win at $x,$y"
  149. }
  150.  
  151. proc dummy_start_sweep {win x y} {
  152.     puts "Button start sweep for $win at $x,$y"
  153. }
  154.  
  155. proc dummy_sweep {win x y} {
  156.     global X0 Y0
  157.     puts "Button sweep for $win at $x,$y (down at $X0 $Y0)"
  158. }
  159.  
  160. proc dummy_end_sweep {win x y} {
  161.     global X0 Y0
  162.     puts "Button end sweep for $win at $x,$y (down at $X0 $Y0)"
  163. }
  164.  
  165. proc dummy_up {win x y} {
  166.     puts "Button up for $win at $x,$y"
  167. }
  168.