# canvas_cyclic_selection.tcl --
#
# Part of: Useless Widgets Package
# Contents: test script for the cyclic object selection
# Date: Wed Jan 19, 2005
#
# Abstract
#
# Shows how to select a group of objects, and then each sub-object
# cyclically, by point-and-click on an object. This is useful when
# composite objects are placed on a canvas and we want to be able
# to configure them as a whole, as well as to configure a component
# alone.
#
# It should work well for "planar" drawings, like electrical
# circuits and flow charts. If there are many objects stacked one
# over the other: the selection by point-and-click may become
# unfriendly to the user; in this case another way to select
# the objects should be used in replacement of [$canvas find closest].
#
# 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_cyclic_selection_cursor hand2
#page
## ------------------------------------------------------------
## Main.
## ------------------------------------------------------------
proc main {} {
global exit_trigger groups
wm title . "Canvas Cyclic Selection"
wm geometry . +10+10
# Draw two canvas widgets with a listbox associated to each to
# display the list of currently selected objects.
grid [frame .f] -sticky news
foreach master {.f.left .f.right} {
frame $master -relief sunken
grid [label $master.l -text $master] -sticky news
canvas $master.c -width 300 -height 300 -background white
listbox $master.lb -background bisque
grid $master.c $master.lb -sticky news -padx 5
pack $master -side left -expand yes -fill both
}
foreach { canvasA listboxA canvasB listboxB } \
{ .f.left.c .f.left.lb .f.right.c .f.right.lb } {}
# Draw the exit button.
grid [button .quit -text Exit -command main_exit]
focus .quit
bind .quit <Return> main_exit
bind . <Escape> main_exit
# An object is unselectable if it is not registered as part of a
# group. Unselectable objects ARE useful, examples: a background
# grid of lines; a coordinates system of reference.
$canvasA create text 100 200 -text "This text is an\nunselectable object."
$canvasB create text 100 200 -text "This text is an\nunselectable object."
# Setup canvaes bindings.
set tokenA "unique_global_varname"
set tokenB "another_global_varname"
setup $tokenA $canvasA CanvasA_Activation $listboxA
setup $tokenB $canvasB CanvasB_Activation $listboxB
alias main_exit set exit_trigger 1
vwait exit_trigger
# Cleanup groups and context instances (this is just to show how to
# do it, it is not really required at the end of the script).
cleanup $tokenA $canvasA CanvasA_Activation
cleanup $tokenB $canvasB CanvasB_Activation
exit
}
proc setup { token canvas activation_tag listbox } {
global groups
uwp_cyclic_selection_bind $canvas
uwp_cyclic_selection_activate_token $token
uwp_append_tag $activation_tag $canvas
bind $activation_tag <Enter> \
[list activate_canvas_selection $token $canvas $listbox]
# Groups must have empty intersection.
uwp_cyclic_selection_register_groups \
[lappend groupOne \
[$canvas create oval 250 50 200 100 -tags LittleOval] \
[$canvas create oval 230 80 160 200 -tags MediumOval] \
[$canvas create oval 200 100 280 240 -tags BigOval]] \
[lappend groupTwo \
[$canvas create rectangle 40 40 100 100 -tags LittleRectangle] \
[$canvas create rectangle 60 60 140 140 -tags MediumRectangle] \
[$canvas create rectangle 100 100 240 240 -tags BigRectangle]]
lappend groups($canvas) $groupOne $groupTwo
}
proc cleanup { token canvas activation_tag } {
global groups
uwp_cyclic_selection_unbind $canvas
uwp_remove_tag $activation_tag $canvas
uwp_cyclic_selection_activate_token $token
eval { uwp_cyclic_selection_forget_groups } $groups($canvas)
uplevel \#0 [list unset $token]
}
#page
## ------------------------------------------------------------
## UWP infrastructure procedures.
## ------------------------------------------------------------
proc alias { alias args } { eval { interp alias {} $alias {} } $args }
proc uwp_append_tag { tag widget } {
bindtags $widget [linsert [bindtags $widget] end $tag]
}
proc uwp_remove_tag { tag widget } {
set idx [lsearch [set ell [bindtags $widget]] $tag]
bindtags $widget [lreplace $ell $idx $idx]
}
proc uwp_application_set_mouse_cursor_of_parent { widget } {
$widget configure -cursor [[winfo parent $widget] cget -cursor]
}
#page
## ------------------------------------------------------------
## User defined object interface procedures.
## ------------------------------------------------------------
proc activate_canvas_selection { token_name canvas_widget listbox_widget } {
uwp_cyclic_selection_activate_token $token_name
alias uwp_cyclic_selection_draw_selected_object \
object_draw_selected $canvas_widget
alias uwp_cyclic_selection_draw_deselected_object \
object_draw_deselected $canvas_widget
alias uwp_cyclic_selection_notify_selection \
object_notify_selection $canvas_widget $listbox_widget
}
proc object_draw_selected { canvas_widget object_identifier } {
$canvas_widget itemconfigure $object_identifier -outline red
}
proc object_draw_deselected { canvas_widget object_identifier } {
$canvas_widget itemconfigure $object_identifier -outline black
}
proc object_notify_selection { canvas_widget listbox_widget selection_list } {
$listbox_widget delete 0 end
foreach object_identifier $selection_list {
$listbox_widget insert end \
[lindex [$canvas_widget gettags $object_identifier] 0]
}
}
#page
## ------------------------------------------------------------
## Cyclic selection tag bindings.
## ------------------------------------------------------------
bind UWPCyclicSelection <ButtonRelease-1> { uwp_cyclic_selection_event_release %W %x %y }
bind UWPCyclicSelection <ButtonRelease-3> { uwp_cyclic_selection_event_release3 %W }
proc uwp_cyclic_selection_bind { widget } {
uwp_append_tag UWPCyclicSelection $widget
$widget configure -cursor [option get $widget uwp_cyclic_selection_cursor Cursor]
}
alias uwp_cyclic_selection_unbind uwp_remove_tag UWPCyclicSelection
#page
## ------------------------------------------------------------
## Cyclic selection event handling procedures.
## ------------------------------------------------------------
proc uwp_cyclic_selection_event_release { canvas_widget x y } {
set id [$canvas_widget find closest \
[$canvas_widget canvasx $x] [$canvas_widget canvasy $y]]
# We check the string because it can be empty if no object is on the
# canvas.
if { [string length $id] } {
uwp_cyclic_selection_select_from_identifier $canvas_widget $id
}
}
proc uwp_cyclic_selection_event_release3 { canvas_widget } {
uwp_cyclic_selection_deselect_all $canvas_widget
}
#page
## ------------------------------------------------------------
## Cyclic selection objects groups handlind procedures.
## ------------------------------------------------------------
# The lists of identifiers are never modified, so it is efficient to
# use them directly as values in arrays.
proc uwp_cyclic_selection_activate_token { unique_name_in_global_namespace } {
uplevel \#0 \
[list upvar \#0 $unique_name_in_global_namespace uwp_cyclic_selection_token]
upvar \#0 uwp_cyclic_selection_token data
if { ! [info exists data(selected_object_index)] } {
set data(selected_object_index) all
}
if { ! [info exists data(selected_group)] } { set data(selected_group) {} }
}
proc uwp_cyclic_selection_register_groups { args } {
upvar \#0 uwp_cyclic_selection_token data
foreach object_identifiers_list $args \
{ foreach identifier $object_identifiers_list \
{ set data(id:$identifier) $object_identifiers_list } }
}
proc uwp_cyclic_selection_forget_groups { args } {
upvar \#0 uwp_cyclic_selection_token data
foreach object_identifiers_list $args \
{ foreach identifier $object_identifiers_list { unset data(id:$identifier) } }
}
#page
## ------------------------------------------------------------
## Cyclic selection procedures.
## ------------------------------------------------------------
proc uwp_cyclic_selection_deselect_all { canvas_widget } {
upvar \#0 uwp_cyclic_selection_token data
uwp_cyclic_selection_notify_selection {}
uwp_cyclic_selection_deselect $canvas_widget
set data(selected_group) {}
set data(selected_object_index) all
}
proc uwp_cyclic_selection_select_from_identifier { canvas_widget object_identifier } {
upvar \#0 uwp_cyclic_selection_token data
uwp_cyclic_selection_deselect $canvas_widget
if { ! [info exists data(id:$object_identifier)] } {
uwp_cyclic_selection_deselect_all $canvas_widget
} else {
if { [lsearch $data(selected_group) $object_identifier] >= 0 } {
uwp_cyclic_selection_advance_current_selection
} else {
set data(selected_group) $data(id:$object_identifier)
set data(selected_object_index) all
}
uwp_cyclic_selection_select $canvas_widget
if { $data(selected_object_index) eq "all" } {
uwp_cyclic_selection_notify_selection $data(selected_group)
} else {
uwp_cyclic_selection_notify_selection \
[lindex $data(selected_group) $data(selected_object_index)]
}
}
}
proc uwp_cyclic_selection_advance_current_selection {} {
upvar \#0 uwp_cyclic_selection_token data
if { $data(selected_object_index) eq "all" } {
set data(selected_object_index) 0
} elseif { [incr data(selected_object_index)] == [llength $data(selected_group)] } {
set data(selected_object_index) all
return $data(selected_group)
}
lindex $data(selected_group) $data(selected_object_index)
}
#page
## ------------------------------------------------------------
## Cyclic selection hangling procedures.
## ------------------------------------------------------------
# This is invoked to draw the selected object/group in with the
# "selected" appearance.
alias uwp_cyclic_selection_select \
uwp_cyclic_selection_handling uwp_cyclic_selection_draw_selected_object
# This is invoked to draw the selected object/group in with the
# "deselected" appearance.
alias uwp_cyclic_selection_deselect \
uwp_cyclic_selection_handling uwp_cyclic_selection_draw_deselected_object
proc uwp_cyclic_selection_handling { draw_command canvas_widget } {
upvar \#0 uwp_cyclic_selection_token data
if { $data(selected_object_index) eq "all" } {
foreach object_identifier $data(selected_group) \
{ $draw_command $object_identifier }
} else {
$draw_command [lindex $data(selected_group) $data(selected_object_index)]
}
}
#page
## ------------------------------------------------------------
## Let's go.
## ------------------------------------------------------------
main
### end of file
# Local Variables:
# mode: tcl
# End: