# canvas_marching_ants.tcl --
 # 
 # Part of: Useless Widgets Package
 # Contents: test script for the marching ants selection
 # Date: Mon Jan 17, 2005
 # 
 # Abstract
 # 
 #        Selects items with the marching ants.
 # 
 # Copyright (c) 2005 Marco Maggi
 #
 # Most of [uwp_p_marching_ants_start_auto_scan] comes from the TK source
 # version 8.4, file "listbox.tcl".
 #
 # Copyright (c) 1994 The Regents of the University of California.
 # Copyright (c) 1994-1995 Sun Microsystems, Inc.
 # Copyright (c) 1998 by Scriptics Corporation.
 # 
 # 
 # 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.select_move_cursor                fleur
 option add *Canvas.select_point_cursor                hand1
 
 option add *Canvas.marching_ant_pattern                {10 4}
 option add *Canvas.marching_ant_step                4
 option add *Canvas.marching_ant_select_color        green
 option add *Canvas.marching_ant_marching_color        red
 option add *Canvas.marching_ant_delay                300
 
 
 #page
 ## ------------------------------------------------------------
 ## Main.
 ## ------------------------------------------------------------
 
 proc main {} {
     global        exit_trigger
 
     wm title . "Canvas Marching Ants Selection"
     wm geometry . +200+100
 
     frame .f
     canvas [set c .f.c] -width 300 -height 300 -background white \
         -xscrollcommand {.f.hb set} -yscrollcommand {.f.vb set}
     scrollbar .f.vb -orient vertical -command {.f.c yview}
     scrollbar .f.hb -orient horizontal -command {.f.c xview}
     grid .f.c -sticky news -row 0 -column 0
     grid .f.vb -sticky ns -row 0 -column 1
     grid .f.hb -sticky ew -row 1 -column 0
 
     listbox .l -background bisque
     
     grid .f .l -sticky news
     
     $c configure -scrollregion [list 0 0 400 400]
     $c create rectangle 20 20 60 60 -tags Rectangle
     $c create text 350 290 -text {This is some text} -tags Text
     $c create oval 50 50 80 80 -tags {"Little Circle"}
     $c create oval 50 50 120 120 -tags {"Medium Circle"}
     $c create oval 50 50 200 200 -tags {"Big Circle"}
     
     uwp_marching_ants_bind $c update_selection_list
 
     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 update_selection_list { widget selected_items_identifiers_list } {
     set selected_items_first_tags {}
     foreach item $selected_items_identifiers_list {
         lappend selected_items_first_tags [lindex [$widget gettags $item] 0]
     }
     .l delete 0 end
     eval {.l insert end} $selected_items_first_tags
 }
 #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 MarchingAnts <ButtonPress-1>        { uwp_marching_ants_event_press %W %x %y }
 bind MarchingAnts <ButtonRelease-1>        { uwp_marching_ants_event_release %W %x %y }
 bind MarchingAnts <ButtonRelease-3>        { uwp_marching_ants_event_release3 %W }
 bind MarchingAnts <Enter>                { uwp_marching_ants_event_enter %W }
 bind MarchingAnts <Leave>                { uwp_marching_ants_event_leave %W }
 bind MarchingAnts <B1-Leave>                { uwp_marching_ants_event_pressed_and_leave %W }
 bind MarchingAntsSelect <Motion>        { uwp_marching_ants_event_motion %W %x %y }
 alias uwp_marching_ants_unbind                uwp_p_remove_tag MarchingAnts
 alias uwp_marching_ants_bind_motion        uwp_p_append_tag MarchingAntsSelect
 alias uwp_marching_ants_unbind_motion        uwp_p_remove_tag MarchingAntsSelect
 
 proc uwp_marching_ants_bind { widget {command {}} } {
     uwp_p_append_tag MarchingAnts $widget
     uwp_data_set $widget MarchingAntsSelectCommand $command
 }
 #page
 proc uwp_marching_ants_event_press { widget x y } {
     uwp_p_marching_ants_delete_and_deselect_all $widget
     uwp_p_marching_ants_set_select_cursor $widget
     uwp_p_marching_ants_save_current_pointer_position $widget $x $y
     uwp_marching_ants_bind_motion $widget
     uwp_p_marching_ants_draw_selection_rectangle $widget $x $y
 }
 proc uwp_marching_ants_event_release { widget x y } {
     uwp_marching_ants_unbind_motion $widget    
     uwp_p_marching_ants_set_point_cursor $widget
     uwp_p_marching_ants_delete_selection_rectangle $widget
     uwp_p_marching_ants_draw_marching_ants $widget $x $y
     uwp_p_marching_ants_select_items $widget
     uwp_p_marching_ants_stop_auto_scan $widget
 }
 proc uwp_marching_ants_event_release3 { widget } {
     uwp_p_marching_ants_delete_and_deselect_all $widget
 }
 proc uwp_marching_ants_event_enter { widget } {
     uwp_p_marching_ants_save_current_cursor $widget
     uwp_p_marching_ants_set_point_cursor $widget
     uwp_p_marching_ants_stop_auto_scan $widget
 }
 proc uwp_marching_ants_event_leave { widget } {
     uwp_p_marching_ants_restore_current_cursor $widget
 }
 proc uwp_marching_ants_event_motion { widget x y } {
     uwp_p_marching_ants_update_selection_rectangle_coords $widget $x $y
 }
 proc uwp_marching_ants_event_pressed_and_leave { widget args } {
     uwp_p_marching_ants_start_auto_scan $widget
 }
 #page
 proc uwp_p_marching_ants_save_current_pointer_position { widget spotX spotY } {
     uwp_data_set $widget spot \
         [list [$widget canvasx $spotX] [$widget canvasy $spotY]]
 }
 proc uwp_p_marching_ants_save_current_cursor { widget } {
     uwp_data_set $widget oldCursor [. cget -cursor]
 }
 proc uwp_p_marching_ants_restore_current_cursor { widget } {
     . configure -cursor [uwp_data_get $widget oldCursor]
 }
 proc uwp_p_marching_ants_set_point_cursor { widget } {
     . configure -cursor [option get $widget select_point_cursor {}]
 }
 proc uwp_p_marching_ants_set_select_cursor { widget } {
     . configure -cursor [option get $widget select_move_cursor {}]
 }
 #page
 proc uwp_p_marching_ants_draw_selection_rectangle { widget x y } {
     foreach {spotX spotY} [uwp_data_get $widget spot] {}
     $widget create rectangle \
         $spotX $spotY [$widget canvasx $x] [$widget canvasy $y] \
         -tags SelectionRectangle \
         -outline [option get $widget marching_ant_select_color {}] \
         -dash [option get $widget marching_ant_pattern {}]
 }
 proc uwp_p_marching_ants_delete_selection_rectangle { widget } {
     $widget delete SelectionRectangle
 }
 proc uwp_p_marching_ants_update_selection_rectangle_coords { widget x y } {
     foreach {spotX spotY} [uwp_data_get $widget spot] {}
     $widget coords SelectionRectangle \
         $spotX $spotY [$widget canvasx $x] [$widget canvasy $y]
 }
 #page
 proc uwp_p_marching_ants_draw_marching_ants { widget x y } {
     foreach {spotX spotY} [uwp_data_get $widget spot] {}
     $widget create rectangle \
         $spotX $spotY [$widget canvasx $x] [$widget canvasy $y] \
         -tags MarchingAnts \
         -dash [option get $widget marching_ant_pattern {}] \
         -outline [option get $widget marching_ant_marching_color {}]
     uwp_p_marching_ants_schedule_step $widget
 }
 proc uwp_p_marching_ants_delete_marching_ants { widget } {
     uwp_p_marching_ants_unschedule_step $widget
     $widget delete MarchingAnts
 }
 proc uwp_p_marching_ants_schedule_step { widget {step 0} } {
     uwp_data_set $widget MarchingAntsMarchAfterId \
         [after [option get $widget marching_ant_delay {}] \
              [list uwp_p_marching_ants_step $widget \
                   [incr step [option get $widget marching_ant_step {}]]]]
 }
 proc uwp_p_marching_ants_unschedule_step { widget } {
     catch {after cancel [uwp_data_get $widget MarchingAntsMarchAfterId]}
 }
 proc uwp_p_marching_ants_step { widget step } {
     if { [winfo exists $widget]} {
         $widget itemconfigure MarchingAnts -dashoffset $step
         uwp_p_marching_ants_schedule_step $widget $step
     }
 }
 proc uwp_p_marching_ants_delete_and_deselect_all { widget } {
     uwp_p_marching_ants_delete_selection_rectangle $widget
     uwp_p_marching_ants_delete_marching_ants $widget
     uwp_p_marching_ants_deselect_items $widget
 }
 #page
 proc uwp_p_marching_ants_select_items { widget } {
     eval {$widget addtag MarchingAntSelection enclosed} [$widget coords MarchingAnts]
     utp_p_marching_ants_invoke_selection_command $widget \
         [$widget find withtag MarchingAntSelection]
 }
 proc uwp_p_marching_ants_deselect_items { widget } {
     $widget dtag MarchingAntSelection MarchingAntSelection
     utp_p_marching_ants_invoke_selection_command $widget {}
 }
 proc utp_p_marching_ants_invoke_selection_command { widget selected_items_tags } {
     set command [uwp_data_get $widget MarchingAntsSelectCommand]
     if { [string length $command] } {
         uplevel \#0 $command [list $widget $selected_items_tags]
     }
 }
 #page
 # Most of this comes from the TK source version 8.4, file "listbox.tcl".
 proc uwp_p_marching_ants_start_auto_scan { widget } {
     if { [winfo exists $widget] } {
         set x [expr [winfo pointerx $widget]-[winfo rootx $widget]]
         set y [expr [winfo pointery $widget]-[winfo rooty $widget]]
         if {$y >= [winfo height $widget]} {
             $widget yview scroll 1 units
         } elseif {$y < 0} {
             $widget yview scroll -1 units
         } elseif {$x >= [winfo width $widget]} {
             $widget xview scroll 1 units
         } elseif {$x < 0} {
             $widget xview scroll -1 units
         } else {
             return
         }
         uwp_data_set $widget MarchingAntsAutoScanAfterId \
             [after 50 [list uwp_marching_ants_event_pressed_and_leave $widget]]
     }
 }
 proc uwp_p_marching_ants_stop_auto_scan { widget } {
     catch {after cancel [uwp_data_get $widget MarchingAntsAutoScanAfterId]}
 }
 #page
 ## ------------------------------------------------------------
 ## Let's go.
 ## ------------------------------------------------------------
 
 main
 
 ### end of file
 # Local Variables:
 # mode: tcl
 # End: