# TreeCtrlDnD.tcl ---
# 
#       An attempt to add dnd code to treectrl in a simple way.
#       
#   Usage:
#       set idx [lsearch [bindtags $T] TreeCtrl]
#       bindtags $T [linsert [bindtags $T] $idx TreeCtrlDnD]
#  
#       $T notify install <Drag-begin>
#       $T notify install <Drag-end>
#       $T notify install <Drag-receive>
#       $T notify install <Drag-enter>
#       $T notify install <Drag-leave>
#       
#       List of lists: {column style element ...} specifying elements
#       added to the drag sources and targets when dragging selected items.
#       
#       ::TreeCtrl::DnDSetDragSources $T listOfLists
#       ::TreeCtrl::DnDSetDropTargets $T listOfLists
#       
#   This file is distributed under BSD style license.
#
#   Copyright (c) 2007-2008  Mats Bengtsson

package require treectrl

package provide TreeCtrlDnD 0.1

# Command-click should provide a discontinuous selection on OSX
switch -- [tk windowingsystem] {
    "aqua" { set modifier Command }
    default { set modifier Control }
}
bind TreeCtrlDnD <$modifier-ButtonPress-1> {
    set TreeCtrl::Priv(selectMode) toggle
    ::TreeCtrl::DnDButton1 %W %x %y
    break
}
bind TreeCtrlDnD <Shift-ButtonPress-1> {
    set TreeCtrl::Priv(selectMode) add
    ::TreeCtrl::DnDButton1 %W %x %y
    break
}
bind TreeCtrlDnD <ButtonPress-1> {
    set TreeCtrl::Priv(selectMode) set
    ::TreeCtrl::DnDButton1 %W %x %y
    break
}
bind TreeCtrlDnD <Button1-Motion> {
    ::TreeCtrl::DnDMotion1 %W %x %y
    break
}
bind TreeCtrlDnD <ButtonRelease-1> {
    ::TreeCtrl::DnDRelease1 %W %x %y
    break
}
bind TreeCtrlDnD <Destroy> {
    ::TreeCtrl::DnDFree %W
}
bind TreeCtrlDnD <Button1-Leave> {
    TreeCtrl::DnDLeave %W %x %y
}


# ::TreeCtrl::DnDSetDragSources --
# 
#       List of lists: {column style element ...} specifying elements
#       added to the drag image when dragging selected items

proc ::TreeCtrl::DnDSetDragSources {T listOfLists} {
    variable dnd

    foreach list $listOfLists {
	set column [lindex $list 0]
	set style [lindex $list 1]
	set elements [lrange $list 2 end]
	if {[$T column id $column] eq ""} {
	    error "column \"$column\" doesn't exist"
	}
	if {[lsearch -exact [$T style names] $style] == -1} {
	    error "style \"$style\" doesn't exist"
	}
	foreach element $elements {
	    if {[lsearch -exact [$T element names] $element] == -1} {
		error "element \"$element\" doesn't exist"
	    }
	}
    }
    set dnd(dragimage,$T) $listOfLists
    return
}

proc ::TreeCtrl::DnDIsDragSource {T item} {
    variable dnd
    
    if {![$T item enabled $item]} {
	return 0
    }
    if {![info exists dnd(dragimage,$T)]} {
	puts stderr "Need to call ::TreeCtrl::DnDSetDragSources"
	return 0
    }
    foreach list $dnd(dragimage,$T) {
	set C [lindex $list 0]
	set S [lindex $list 1]
	if {[$T item style set $item $C] ne $S} continue
	return 1
    }
    return 0
}

# ::TreeCtrl::DnDSetDropTargets --
# 
#       List of lists: {column style element ...} specifying elements
#       the user can drop items on.

proc ::TreeCtrl::DnDSetDropTargets {T listOfLists} {
    variable dnd
    
    foreach list $listOfLists {
	set column [lindex $list 0]
	set style [lindex $list 1]
	set elements [lrange $list 2 end]
	if {[$T column id $column] eq ""} {
	    error "column \"$column\" doesn't exist"
	}
	if {[lsearch -exact [$T style names] $style] == -1} {
	    error "style \"$style\" doesn't exist"
	}
	foreach element $elements {
	    if {[lsearch -exact [$T element names] $element] == -1} {
		error "element \"$element\" doesn't exist"
	    }
	}
    }
    set dnd(dropTargets,$T) $listOfLists
}

proc ::TreeCtrl::DnDIsDropTarget {T x y} {
    variable dnd
    
    if {![info exists dnd(dropTargets,$T)]} {
	return 0
    }
    set id [$T identify $x $y]
    if {[lindex $id 0] ne "item" || [llength $id] != 6} {
	return 0
    }
    lassign $id where item arg1 arg2 arg3 arg4
    if {![$T item enabled $item]} {
	return 0
    }
    foreach list $dnd(dropTargets,$T) {
	set C [lindex $list 0]
	set S [lindex $list 1]
	set eList [lrange $list 2 end]
	if {[$T column compare $arg2 != $C]} continue
	if {[$T item style set $item $C] ne $S} continue
	if {[lsearch -exact $eList $arg4] == -1} continue
	return 1
    }
    return 0
}

proc ::TreeCtrl::DnDButton1 {T x y} {
    variable Priv
    variable dnd
    
    focus $T
    set id [$T identify $x $y]
    set dnd(buttonMode) ""

    # Click outside any item
    if {$id eq ""} {
	$T selection clear

    # Click in header
    } elseif {[lindex $id 0] eq "header"} {
	ButtonPress1 $T $x $y

    # Click in item
    } else {
	lassign $id where item arg1 arg2 arg3 arg4
	switch $arg1 {
	    button {
		$T item toggle $item
	    }
	    line {
		$T item toggle $arg2
	    }
	    column {
		set dnd(drag,motion) 0
		set dnd(drag,click,x) $x
		set dnd(drag,click,y) $y
		set dnd(drag,x) [$T canvasx $x]
		set dnd(drag,y) [$T canvasy $y]
		set dnd(drop) ""
		set dnd(lastDrop) ""
		set dnd(dragged) [list]

		if {$Priv(selectMode) eq "add"} {
		    BeginExtend $T $item
		} elseif {$Priv(selectMode) eq "toggle"} {
		    BeginToggle $T $item
		} elseif {![$T selection includes $item]} {
		    BeginSelect $T $item
		}
		$T activate $item

		if {[$T selection includes $item]} {
		    set dnd(buttonMode) drag
		}
	    }
	}
    }
    return
}

proc ::TreeCtrl::DnDMotion1 {T x y} {
    variable Priv
    variable dnd

    if {![info exists dnd(buttonMode)]} return

    switch $dnd(buttonMode) {
	"drag" {
	    set Priv(autoscan,command,$T) {::TreeCtrl::DnDMotion %T %x %y}
	    AutoScanCheck $T $x $y
	    DnDMotion $T $x $y
	}
	default {
	    TreeCtrl::Motion1 $T $x $y
	}
    }
    return
}

# TreeCtrl::DnDMotion --
# 
#       We must be very careful to handle changes that happen during the
#       drag process since items may have been deleted.

proc ::TreeCtrl::DnDMotion {T x y} {
    variable Priv
    variable dnd
    
    if {$dnd(buttonMode) ne "drag"} {
	return
    }
    
    if {!$dnd(drag,motion)} {
	
	# Detect initial mouse movement
	if {(abs($x - $dnd(drag,click,x)) <= 4) &&
	(abs($y - $dnd(drag,click,y)) <= 4)} return
	
	set Priv(selection) [$T selection get]
	set dnd(dragged) [list]
	foreach item $Priv(selection) {
	    if {[DnDIsDragSource $T $item]} {
		lappend dnd(dragged) $item
	    }
	}
	if {![llength $dnd(dragged)]} {
	    return
	}
	set dnd(drop) ""
	$T dragimage clear
	
	# For each dragged item, add some elements to the dragimage
	foreach I $dnd(dragged) {
	    foreach list $dnd(dragimage,$T) {
		set C [lindex $list 0]
		set S [lindex $list 1]
		if {[$T item style set $I $C] eq $S} {
		    eval $T dragimage add $I $C [lrange $list 2 end]
		}
	    }
	}
	set dnd(lastDrop) ""
	set dnd(drag,motion) 1
	TryEvent $T Drag begin {}
	
    } else {
	
	# Dragged items may have been deleted during dragging.
	# Also the 'drop' item may have been deleted.	
	if {![DnDCheckExistence $T]} {
	    unset dnd(buttonMode)
	    return
	}
    }
    
    # Find the item under the cursor
    set cursor X_cursor
    set drop ""
    set id [$T identify $x $y]
    
    if {[DnDIsDropTarget $T $x $y]} {
	set item [lindex $id 1]
	
	# If the item is not in the pre-drag selection
	# (i.e. not being dragged) see if we can drop on it
	if {[lsearch -exact $dnd(dragged) $item] == -1} {
	    set drop $item
	    
	    # We can drop if dragged item isn't an ancestor
	    foreach item2 $dnd(dragged) {
		if {[$T item isancestor $item2 $item]} {
		    set drop ""
		    break
		}
	    }
	    if {$drop ne ""} {
		scan [$T item bbox $drop] "%d %d %d %d" x1 y1 x2 y2
		if {$y < $y1 + 3} {
		    set cursor top_side
		    set dnd(drop,pos) prevsibling
		} elseif {$y >= $y2 - 3} {
		    set cursor bottom_side
		    set dnd(drop,pos) nextsibling
		} else {
		    set cursor ""
		    set dnd(drop,pos) lastchild
		}
	    }
	}
    }
    
    # Enter/Leave events if any.
    if {$dnd(lastDrop) != $drop} {
	if {$dnd(lastDrop) ne ""} {
	    TryEvent $T Drag leave [list I $dnd(lastDrop) l $dnd(dragged)]
	}
	if {$drop ne ""} {
	    TryEvent $T Drag enter [list I $drop l $dnd(dragged)]
	}
    }
    set dnd(lastDrop) $drop
    
    if {[$T cget -cursor] ne $cursor} {
	$T configure -cursor $cursor
    }
    
    # Select the item under the cursor (if any) and deselect
    # the previous drop-item (if any)
    $T selection modify $drop $dnd(drop)
    set dnd(drop) $drop
    
    # Show the dragimage in its new position
    set x [expr {[$T canvasx $x] - $dnd(drag,x)}]
    set y [expr {[$T canvasy $y] - $dnd(drag,y)}]
    $T dragimage offset $x $y
    $T dragimage configure -visible yes
    
    return
}

proc ::TreeCtrl::DnDRelease1 {T x y} {
    variable Priv
    variable dnd
    
    if {![info exists dnd(buttonMode)]} return
        
    switch $dnd(buttonMode) {
	"drag" {
	    if {![DnDCheckExistence $T]} {
		unset dnd(buttonMode)
		return
	    }
	    AutoScanCancel $T
	    $T dragimage configure -visible no
	    $T configure -cursor ""
	    if {[DnDItemExists $T $dnd(drop)]} {
		$T selection modify {} $dnd(drop)
		TryEvent $T Drag receive [list I $dnd(drop) l $dnd(dragged)]
	    }
	    TryEvent $T Drag end {}
	    unset dnd(buttonMode)
	}
	default {
	    Release1 $T $x $y
	}
    }
    return
}

proc ::TreeCtrl::DnDLeave {T x y} {
    variable dnd
    
    if {![info exists dnd(buttonMode)]} return
	
    switch $dnd(buttonMode) {
	"drag" {
	    $T dragimage configure -visible no
	    $T configure -cursor ""
	    if {[DnDItemExists $T $dnd(drop)]} {
		$T selection modify {} $dnd(drop)
	    }
	    TryEvent $T Drag end {}
	    set dnd(buttonMode) ""
	}
    }
}

# TreeCtrl::DnDCheckExistence --
# 
#       Dragged items may have been deleted during dragging.
#       Also the 'drop' item may have been deleted.
#       Check both drop targets and dragged that still exist.

proc ::TreeCtrl::DnDCheckExistence {T} {
    variable Priv
    variable dnd
    
    set dragged [list]
    foreach item $dnd(dragged) {
	if {[$T item id $item] ne ""} {
	    lappend dragged $item
	}
    }
    set dnd(dragged) $dragged
    if {![llength $dragged]} {
	$T dragimage configure -visible no
	$T configure -cursor ""
    }
    
    if {![DnDItemExists $T $dnd(drop)]} {
	set dnd(drop) ""
    }
    if {![DnDItemExists $T $dnd(lastDrop)]} {
	set dnd(lastDrop) ""
    }	
    return [llength $dragged]
}

proc ::TreeCtrl::DnDItemExists {T item} {
    return [expr {($item ne "") && ([$T item id $item] ne "")}]
}

proc ::TreeCtrl::DnDFree {T} {
    variable dnd
    array unset dnd *,$T
}

