# canvas_object_dropper.tcl --
#
# Part of: Useless Widgets Package
# Contents: test script for object dropping
# Date: Wed Jan 19, 2005
#
# Abstract
#
# Drops objects on a canvas widget.
#
# 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_object_dropper_drop_cursor hand2
#page
## ------------------------------------------------------------
## Main.
## ------------------------------------------------------------
proc main {} {
global exit_trigger
wm title . "Canvas Objects Dropper"
wm geometry . +200+100
frame .f
canvas [set c .f.c] -width 300 -height 300 -background white
grid $c -sticky news -padx 5
uwp_object_dropper_bind $c
frame .radio
foreach { name } { oval rectangle none } {
grid [radiobutton .radio.$name -text [string totitle $name] \
-variable object -value $name -anchor w\
-command [list droppable_${name}_register $c]] -sticky news
}
.radio.none select
grid .f .radio -sticky news
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
}
#page
## ------------------------------------------------------------
## UWP infrastructure procedures.
## ------------------------------------------------------------
set uwp_counter 0
proc uwp_data_set { widget key value } {
global uwp_data
set uwp_data($widget:$key) $value
}
proc uwp_data_unset_by_pattern { widget args } {
global uwp_data
foreach key $args { array unset uwp_data $widget:$key* }
}
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
}
proc uwp_unique { } {
global uwp_counter
format "uwp__%d" [incr uwp_counter]
}
#page
## ------------------------------------------------------------
## Generic droppable object procedures.
## ------------------------------------------------------------
proc droppable_object_remove_from_canvas { token } {
upvar \#0 $token object
$object(CANVAS_WIDGET) delete $object(DELETE_TAG)
}
proc droppable_object_forget { token } {
uplevel \#0 [list unset $token]
}
proc droppable_none_register { canvas_widget } {
uwp_object_dropper_forget_object $canvas_widget
}
#page
## ------------------------------------------------------------
## Droppable oval procedures.
## ------------------------------------------------------------
proc droppable_oval_register { canvas_widget } {
upvar \#0 [set token [uwp_unique]] object
set object(CANVAS_WIDGET) $canvas_widget
set object(DRAW_SCRIPT) [list droppable_oval_draw_on_canvas $token]
set object(DELETE_SCRIPT) [list droppable_oval_remove_from_canvas $token]
set object(DROP_SCRIPT) [list droppable_oval_drop_on_canvas $token]
set object(FORGET_SCRIPT) [list droppable_oval_forget $token]
set object(DELETE_TAG) [uwp_unique]
uwp_object_dropper_register_object $canvas_widget $token
}
proc droppable_oval_draw_on_canvas { token spotX spotY } {
upvar \#0 $token object
set id [oval_draw $object(CANVAS_WIDGET) $spotX $spotY]
$object(CANVAS_WIDGET) itemconfigure $id -tags $object(DELETE_TAG)
}
proc droppable_oval_drop_on_canvas { token spotX spotY } {
upvar \#0 $token object
oval_draw $object(CANVAS_WIDGET) $spotX $spotY
}
alias droppable_oval_remove_from_canvas droppable_object_remove_from_canvas
alias droppable_oval_forget droppable_object_forget
proc oval_draw { canvas_widget upper_left_X upper_left_Y } {
$canvas_widget create oval $upper_left_X $upper_left_Y \
[expr {$upper_left_X+40}] [expr {$upper_left_Y+40}]
}
#page
## ------------------------------------------------------------
## Droppable rectangle procedures.
## ------------------------------------------------------------
proc droppable_rectangle_register { canvas_widget } {
upvar \#0 [set token [uwp_unique]] object
set object(CANVAS_WIDGET) $canvas_widget
set object(DRAW_SCRIPT) [list droppable_rectangle_draw_on_canvas $token]
set object(DELETE_SCRIPT) [list droppable_rectangle_remove_from_canvas $token]
set object(DROP_SCRIPT) [list droppable_rectangle_drop_on_canvas $token]
set object(FORGET_SCRIPT) [list droppable_rectangle_forget $token]
set object(DELETE_TAG) [uwp_unique]
uwp_object_dropper_register_object $canvas_widget $token
}
proc droppable_rectangle_draw_on_canvas { token spotX spotY } {
upvar \#0 $token object
set id [rectangle_draw $object(CANVAS_WIDGET) $spotX $spotY]
$object(CANVAS_WIDGET) itemconfigure $id -tags $object(DELETE_TAG)
}
proc droppable_rectangle_drop_on_canvas { token spotX spotY } {
upvar \#0 $token object
rectangle_draw $object(CANVAS_WIDGET) $spotX $spotY
}
alias droppable_rectangle_remove_from_canvas droppable_object_remove_from_canvas
alias droppable_rectangle_forget droppable_object_forget
proc rectangle_draw { canvas_widget upper_left_X upper_left_Y } {
$canvas_widget create rectangle $upper_left_X $upper_left_Y \
[expr {$upper_left_X+100}] [expr {$upper_left_Y+40}]
}
#page
## ------------------------------------------------------------
## Object dropper tag bindings.
## ------------------------------------------------------------
bind ObjectDropper <ButtonRelease-1> { uwp_object_dropper_event_release %W %x %y }
bind ObjectDropper <Enter> { uwp_object_dropper_event_enter %W }
bind ObjectDropper <Leave> { uwp_object_dropper_event_leave %W }
bind ObjectDropper <Motion> { uwp_object_dropper_event_motion %W %x %y }
proc uwp_object_dropper_bind { widget } {
uwp_p_append_tag ObjectDropper $widget
uwp_object_dropper_forget_object $widget
}
proc uwp_object_dropper_unbind { widget } {
uwp_p_remove_tag ObjectDropper $widget
uwp_data_unset_by_pattern $widget UWPObjectDropper
}
#page
## ------------------------------------------------------------
## Object dropper object registration/unregistration procedures.
## ------------------------------------------------------------
proc uwp_object_dropper_register_object { widget token } {
uwp_data_set $widget UWPObjectDropperObjectToken $token
}
proc uwp_object_dropper_forget_object { widget } {
uwp_data_set $widget UWPObjectDropperObjectToken {}
}
proc uwp_object_dropper_an_object_is_registered { widget } {
string length [uwp_data_get $widget UWPObjectDropperObjectToken]
}
#page
## ------------------------------------------------------------
## Object dropper event handling procedures.
## ------------------------------------------------------------
proc uwp_object_dropper_event_enter { widget } {
if { [uwp_object_dropper_an_object_is_registered $widget] } {
uwp_p_object_dropper_save_current_cursor $widget
uwp_p_object_dropper_set_drop_cursor $widget
}
}
proc uwp_object_dropper_event_leave { widget } {
if { [uwp_object_dropper_an_object_is_registered $widget] } {
uwp_p_object_dropper_restore_current_cursor $widget
uwp_p_object_dropper_delete_object $widget
}
}
proc uwp_object_dropper_event_motion { widget clickX clickY } {
if { [uwp_object_dropper_an_object_is_registered $widget] } {
uwp_p_object_dropper_delete_object $widget
uwp_p_object_dropper_draw_object $widget \
[$widget canvasx $clickX] [$widget canvasy $clickY]
}
}
proc uwp_object_dropper_event_release { widget clickX clickY } {
if { [uwp_object_dropper_an_object_is_registered $widget] } {
uwp_p_object_dropper_drop_object $widget \
[$widget canvasx $clickX] [$widget canvasy $clickY]
uwp_p_object_dropper_restore_current_cursor $widget
after 100 [list uwp_p_object_dropper_after_dropping $widget]
}
}
proc uwp_p_object_dropper_after_dropping { widget } {
if { [winfo exists $widget] } { uwp_p_object_dropper_set_drop_cursor $widget }
}
#page
## ------------------------------------------------------------
## Object dropper pointer procedures.
## ------------------------------------------------------------
proc uwp_p_object_dropper_save_current_cursor { widget } {
uwp_data_set $widget UWPObjectDropperCursor [. cget -cursor]
}
proc uwp_p_object_dropper_restore_current_cursor { widget } {
. configure -cursor [uwp_data_get $widget UWPObjectDropperCursor]
}
proc uwp_p_object_dropper_set_drop_cursor { widget } {
. configure -cursor [option get $widget uwp_object_dropper_drop_cursor {}]
}
#page
## ------------------------------------------------------------
## Object dropper object interface procedures.
## ------------------------------------------------------------
proc uwp_p_object_dropper_access_object { canvas_widget } {
set token [uwp_data_get $canvas_widget UWPObjectDropperObjectToken]
uplevel [subst { upvar \#0 $token object; set token $token }]
}
proc uwp_p_object_dropper_invoke_object_script { script args } {
uplevel \#0 $script $args
}
proc uwp_p_object_dropper_draw_object { canvas_widget canvasX canvasY } {
uwp_p_object_dropper_access_object $canvas_widget
uwp_p_object_dropper_invoke_object_script $object(DRAW_SCRIPT) $canvasX $canvasY
}
proc uwp_p_object_dropper_delete_object { canvas_widget } {
uwp_p_object_dropper_access_object $canvas_widget
uwp_p_object_dropper_invoke_object_script $object(DELETE_SCRIPT)
}
proc uwp_p_object_dropper_drop_object { canvas_widget canvasX canvasY } {
uwp_p_object_dropper_access_object $canvas_widget
uwp_p_object_dropper_invoke_object_script $object(DROP_SCRIPT) $canvasX $canvasY
}
#page
## ------------------------------------------------------------
## Let's go.
## ------------------------------------------------------------
main
### end of file
# Local Variables:
# mode: tcl
# End: