# snitdnd: implements simple mechanism for drag-and-drop within Tk
 # applications. 
 # (c) 2009 WordTech Communications LLC. License: standard Tcl
 # (c) 2012 Dr. Detlef Groth, University of Potsdam. License: standard Tcl
 # for license see http://www.tcl.tk/software/tcltk/license.html
 ##############################################################################


 # based on simplednd from the Tcl-Wiki by WordTexCommunications LLC  
 # advantages:
 # * no collision if several registered drag events have to share the same variable
 # * improved demo
 # * -trackcmd option can be supplied to monitor the actual object on the target site.
 # this is demonstraded by hilighting the dragtargets in the dom
 # just do a:
 # % package require snitdnd
 # % snitdnddemo::demo
 # to see the demo example
 source c:/home/dgroth/project/starkit-dev/bi-starkit.kit
 package require snit
 snit::type snitdnd {
    option -trackcmd {}
    option -dragcmd {}
    option -dropcmd {}
    option -target {}
    option -source {}
    option -dragtextvar ""
    typevariable dragicon
    typevariable dragtext
    typevariable dragimage
    variable targetdirection
    constructor {args} {
        $self configurelist $args    
        $self dragRegister $options(-source) $options(-target) \
              $options(-dragcmd) $options(-dropcmd) $options(-trackcmd)
        trace add variable $options(-dragtextvar) write [mymethod setDragText]
    }
    method setDragText {varname key op} {
        upvar $varname var
        set dragtext $var
    }
    method makeDragIcon {txt img} {
        #create the icon
        if {![info exists dragicon]} {
            set dragicon [toplevel .dnd]
            set dragtext $txt
            set dragimage $img
            wm overrideredirect $dragicon true
            label $dragicon.view  -image $dragimage -text $dragtext -compound left
            pack $dragicon.view
            #now hide the icon
            wm withdraw $dragicon
        }
    }

    # register widget to respond to drag events: widget to register, its
    # target widget, callback to associate with this drag event, text for the
    # drag label, and image for the drag label 
    
    method dragRegister {w target dragcmd dropcmd trackcmd}  {
        puts "cmd: $options(-trackcmd)"
        $self makeDragIcon {} {}

        puts "$w registered as dragsite with $target as the drop target"

        #binding for when drag motion begins
        bind $w <B1-Motion> [mymethod dragMove %W %X %Y $dragcmd $target]

        #binding for when drop event occurs
        bind $w <ButtonRelease-1> [mymethod dragStop %W %X %Y $target $dropcmd]


    }

    # drag motion with following args: source widget, cursor x position,
    # cursor y position, drag command, target widget 
    
    method dragMove {w x y dragcmd target} {
        #the dragcmd properly configures the drag icon
        eval $dragcmd

        #configure drag icon with customized text and image
        $dragicon.view configure -text $dragtext  -image $dragimage

        #dragicon appears
        wm deiconify $dragicon
        catch {raise $dragicon}

        #this places the drag icon below the cursor
        set x [expr {$x - ([winfo reqwidth $dragicon] / 2) }]
        set y [expr {$y - [winfo reqheight $dragicon] + 25 }]

        wm geometry $dragicon +$x+$y

        $self trackCursor $w $x $y $target 

    }


    # track the cursor, change if it is over the drop target; args are source
    # widget (w), x pos (x), y pos (y), target widget (target) 
    method trackCursor {w x y target} {
        #get the coordinates of the drop target
        set targetx [winfo rootx $target]
        set targety [winfo rooty $target]
        set targetwidth [expr [winfo width $target] + $targetx]
        set targetheight [expr [winfo height $target] + $targety]
        if {$options(-trackcmd) ne ""} {
            $options(-trackcmd) $w $x $y $target
        }
        #change the icon if over the drop target
        if {($x > $targetx) && ($x < $targetwidth) && ($y > $targety) && ($y < $targetheight)} {
            $w configure -cursor based_arrow_up
        } else {
            $w configure -cursor dot
        }   
    }


    # dragstop/drop event with following args: source widget, cursor x
    # position, cursor y position, target widget, dropcommand: if over drop
    # target, execute dropcommand; otherwise simply return 
    method dragStop {w x y target dropcmd} {
        
        #hide dragicon on drop event
        wm withdraw $dragicon 

        #change cursor back to arrow
        $w configure -cursor arrow

        #execute callback or simply return
        if {[winfo containing $x $y] != $target} {
            puts "target $w not reached"
        } else {
            focus -force $target
            eval $dropcmd            
        }
    }
 }

 namespace eval snitdnddemo {
    #demo package
    proc demo {} {
        variable dragicon
        variable dragtext
        variable dragimage
        #create image for demo
        image create photo dnd_demo -data {R0lGODlhEAAQALMAAAAAAMbGxv//////////////////////////////////\
                                          /////////////////////yH5BAEAAAEALAAAAAAQABAAAAQwMMhJ6wQ4YyuB\
                                          +OBmeeDnAWNpZhWpmu0bxrKAUu57X7VNy7tOLxjIqYiapIjDbDYjADs=}
        image_rotate dnd_demo 90
        listbox .l -selectmode single -activestyle none
        listbox .b -selectmode single -activestyle none
        listbox .s -selectmode single -activestyle none
        foreach item {do re mi} {
            .l insert end $item
            .s insert end $item
        }

        foreach item {fa so la} {
            .b insert end $item
            .s insert end $item
        }
        
        pack .l -side left
        pack .b -side left
        pack .s -side left
        

        #register drag sources, drag targets, and callbacks
        snitdnd snd1 -source .l -target .b -dragcmd [namespace current]::drag_l \
              -dropcmd [namespace current]::drop_l -trackcmd [namespace current]::track \
              -dragtextvar [namespace current]::dragtext

        snitdnd snd2 -source .b -target .l -dragcmd [namespace current]::drag_b \
              -dropcmd [namespace current]::drop_b -trackcmd [namespace current]::track \
              -dragtextvar [namespace current]::dragtext
        snitdnd snd3 -source .s -target .s -dragcmd [namespace current]::drag_s \
              -dropcmd [namespace current]::drop_s -trackcmd [namespace current]::track \
              -dragtextvar [namespace current]::dragtext

    }
    proc drag_l {} {

        variable dragtext
        variable dragimage

        set item [lindex [.l get [.l curselection]]]
        set dragtext $item
        set dragimage navup22 ;#dnd_demo

    }
    proc drag_s {} {

        variable dragtext
        variable dragimage

        set item [lindex [.s get [.s curselection]]]
        set dragtext $item
        set dragimage navup22 ;#dnd_demo

    }
    proc drop_s {} {

        variable dragtext
        variable dragimage
        variable lastIdx
        .s insert $lastIdx(.s) $dragtext
        .s delete [.s curselection]
    }

    proc track {w x y target} {
        variable lastIdx

        set idx [$target nearest [expr $y - [winfo rooty $target]]]
        puts "y=[expr [winfo rooty $target] + $y]"
        #puts [.tf.tbl rowcget $idx -text]
        if {[info exists lastIdx($target)]} {
            $target itemconfigure $lastIdx($target) -foreground black
            $target itemconfigure $lastIdx($target) -background white
        }
        $target itemconfigure $idx -foreground blue
        $target itemconfigure $idx -background "light blue"
        set lastIdx($target) $idx

    }
    #dropcommand for demo l widget: callback to execute on drop
    proc drop_l {} {

        variable dragtext
        variable dragimage
        variable lastIdx

        .b insert $lastIdx(.b) $dragtext
        
        .l delete [.l curselection]
    }

    #dragcommand for demo b widget: configures dragicon
    proc drag_b {} {

        variable dragtext
        variable dragimage

        set item [lindex [.b get [.b curselection]]]
        set dragtext $item
        set dragimage dnd_demo

    }
    #dropcommand for demo b widget: callback to execute on drop
    proc drop_b {} {

        variable dragtext
        variable dragimage
        variable lastIdx

        .l insert $lastIdx(.l) $dragtext
        
        .b delete [.b curselection]
    }



 }
 package provide snitdnd 0.1

<<categories>>Drag and Drop, GUI