# 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:escargo 18 Jan 2005 - I used wish-reaper to download this to my Windows XP Pro system. No ants marched.DKF: IIRC, Tk on Win has a few deficiencies in the dash handling... :^(MM See Canvas dash lines. HJG and Dash lines on Windows
Getting started
Home • Recent changes • Help • Create new page • Search • Add comments
• Edit