# 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:

----
[[[Category GUI]]]