# canvas_grab_scrolling.tcl --
 # 
 # Part of: Useless Widgets Package
 # Contents: test script for the grab scrolling
 # Date: Sun Jan 16, 2005
 # 
 # Abstract
 # 
 #        Scrolls a canvas by dragging the mouse. This version makes use
 #        of the "scan" widget subcommand, instead of the "scroll" one.
 # 
 # Copyright (c) 2005 Marco Maggi
 # 
 # The author  hereby grant permission to use,  copy, modify, distribute,
 # and  license this  software  and its  documentation  for any  purpose,
 # 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.  Modifications to this software may be copyrighted by
 # their authors and need not  follow the licensing terms described here,
 # provided that the new terms are clearly indicated on the first page of
 # each file where they apply.
 # 
 # IN NO  EVENT SHALL THE AUTHOR  OR DISTRIBUTORS BE LIABLE  TO ANY PARTY
 # FOR  DIRECT, INDIRECT, SPECIAL,  INCIDENTAL, OR  CONSEQUENTIAL DAMAGES
 # ARISING OUT  OF THE  USE OF THIS  SOFTWARE, ITS DOCUMENTATION,  OR ANY
 # DERIVATIVES  THEREOF, EVEN  IF THE  AUTHOR  HAVE BEEN  ADVISED OF  THE
 # POSSIBILITY OF SUCH DAMAGE.
 # 
 # THE  AUTHOR  AND DISTRIBUTORS  SPECIFICALLY  DISCLAIM ANY  WARRANTIES,
 # INCLUDING,   BUT   NOT  LIMITED   TO,   THE   IMPLIED  WARRANTIES   OF
 # MERCHANTABILITY,    FITNESS   FOR    A    PARTICULAR   PURPOSE,    AND
 # NON-INFRINGEMENT.  THIS  SOFTWARE IS PROVIDED  ON AN "AS  IS" BASIS,
 # AND  THE  AUTHOR  AND  DISTRIBUTORS  HAVE  NO  OBLIGATION  TO  PROVIDE
 # MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 # 
 #
 
 #page
 ## ------------------------------------------------------------
 ## Setup.
 ## ------------------------------------------------------------
 
 package require Tcl 8.4
 package require Tk  8.4
 
 #page
 ## ------------------------------------------------------------
 ## Widget options.
 ## ------------------------------------------------------------
 
 option add *borderWidth                                        1
 
 option add *Canvas.uwp_grab_scroller_grab_cursor        fleur
 option add *Canvas.uwp_grab_scroller_ungrab_cursor        hand2
 
 # Possible values: quick_scroll, sticky_mouse, an integer
 # selecting the "gain" directly (see the canvas man page,
 # "scan dragto" subcommand).
 option add *a.uwp_grab_scroller_gain                        quick_scroll
 option add *b.uwp_grab_scroller_gain                        sticky_mouse
 
 #page
 ## ------------------------------------------------------------
 ## Main.
 ## ------------------------------------------------------------
 
 proc main {} {
     global        exit_trigger
 
     wm title . "Canvas Grab Scrolling"
     wm geometry . +200+100
 
     grid [frame .f] -sticky news
     canvas [set a .f.a] -width 300 -height 300 -background white
     canvas [set b .f.b] -width 300 -height 300 -background white
     grid $a $b -sticky news -padx 5
     
     put_rectangles $a
     put_rectangles $b
 
     uwp_grab_scroller_bind $a
     uwp_grab_scroller_bind $b
     
     grid [button .quit -text Exit -command main_exit]
     focus .quit
     bind .quit <Return> main_exit
     bind . <Escape> main_exit
     
     interp alias {} main_exit {} set exit_trigger 1
     vwait exit_trigger
     exit
 }
 proc put_rectangles { c } {
     set max [expr {2*[$c cget -width]}]
     for {set i 0} {$i < 15} {incr i} {
         $c create rectangle \
             [set x [expr {10*$i*2}]] $x [set y [expr {$max-$x}]] $y
     }
     $c create line 0 0 $max $max
     $c create line 0 $max $max 0
     $c configure -scrollregion [list 0 0 $max $max]
 }
 #page
 proc uwp_data_set { widget key value } {
     global        uwp_data
     set uwp_data($widget:$key) $value
 }
 proc uwp_data_get { widget key } {
     global        uwp_data
     return $uwp_data($widget:$key)
 }
 proc uwp_p_append_tag { tag widget } {
     bindtags $widget [linsert [bindtags $widget] end $tag]
 }
 proc uwp_p_remove_tag { tag widget } {
     set idx [lsearch [set ell [bindtags $widget]] $tag]
     bindtags $widget [lreplace $ell $idx $idx]
 }
 proc alias { alias args } {
     eval { interp alias {} $alias {} } $args
 }
 #page
 bind GrabScroller <ButtonPress-1>        { uwp_grab_scroller_event_press %W %x %y }
 bind GrabScroller <ButtonRelease-1>        { uwp_grab_scroller_event_release %W }
 bind GrabScroller <Enter>                { uwp_grab_scroller_event_enter %W }
 bind GrabScroller <Leave>                { uwp_grab_scroller_event_leave %W }
 bind GrabScrollerScroll <Motion>        { uwp_grab_scroller_event_motion %W %x %y }
 alias uwp_grab_scroller_bind                uwp_p_append_tag GrabScroller
 alias uwp_grab_scroller_unbind                uwp_p_remove_tag GrabScroller
 alias uwp_p_grab_scroller_bind_motion        uwp_p_append_tag GrabScrollerScroll
 alias uwp_p_grab_scroller_unbind_motion        uwp_p_remove_tag GrabScrollerScroll
 #page
 proc uwp_grab_scroller_event_press { widget x y } {
     uwp_p_grab_scroller_bind_motion $widget
     uwp_p_grab_scroller_set_grab_cursor $widget
     $widget scan mark $x $y
 }
 proc uwp_grab_scroller_event_release { widget } {
     uwp_p_grab_scroller_unbind_motion $widget    
     uwp_p_grab_scroller_set_ungrab_cursor $widget
 }
 proc uwp_grab_scroller_event_enter { widget } {
     uwp_p_grab_scroller_save_current_cursor $widget
     uwp_p_grab_scroller_set_ungrab_cursor $widget
 }
 proc uwp_grab_scroller_event_leave { widget } {
     uwp_p_grab_scroller_restore_current_cursor $widget
 }
 proc uwp_grab_scroller_event_motion { widget x y } {
     switch -exact -- [set gain [option get $widget uwp_grab_scroller_gain {}]] {
         sticky_mouse        { set gain 1 }
         quick_scroll        { set gain [expr {[winfo width $widget]/8}] }
         default                { if { [string length $gain] == 0 } { set gain 10 } }
     }
     $widget scan dragto $x $y $gain
 }
 proc uwp_p_grab_scroller_save_current_cursor { widget } {
     uwp_data_set $widget oldCursor [. cget -cursor]
 }
 proc uwp_p_grab_scroller_restore_current_cursor { widget } {
     . configure -cursor [uwp_data_get $widget oldCursor]
 }
 proc uwp_p_grab_scroller_set_grab_cursor { widget } {
     . configure -cursor [option get $widget uwp_grab_scroller_grab_cursor {}]
 }
 proc uwp_p_grab_scroller_set_ungrab_cursor { widget } {
     . configure -cursor [option get $widget uwp_grab_scroller_ungrab_cursor {}]
 }
 #page
 ## ------------------------------------------------------------
 ## Let's go.
 ## ------------------------------------------------------------
 
 main
 
 ### end of file
 # Local Variables:
 # mode: tcl
 # End:

  canvas .c
  bind .c <2> [bind Text <2>]
  bind .c <B2-Motion> [bind Text <B2-Motion>]

  bind .c <ButtonPress-1> {%W scan mark %x %y}
  bind .c <B1-Motion> {%W scan dragto %x %y 1}