Tree nodes in motion

if 0 {Richard Suchenwirth 2003-11-19 - Here is how to move nodes on a BWidget Tree widget - basically three procs to be bound to <1>, <B1-Motion> and <ButtonRelease-1> events.

When you click on a node's text, a movable copy of the text is added on the canvas (which underlies the Tree implementation), and follows the mouse motion. When you release the mouse button on another node, the "moving" node is indeed moved to be the first child of that node (if possible - one can't reparent into a descendant of itself). }

 package require BWidget

 proc tree'mark {w x y label} {
    set text [[winfo parent $w] itemcget $label -text]
    $w create text $x $y -text $text -tag marked
    set ::g(x) $x
    set ::g(y) $y
 }

 proc tree'motion {w x y label} {
    $w move marked [expr $x-$::g(x)] [expr $y-$::g(y)]
    set ::g(x) $x
    set ::g(y) $y
 }
 proc tree'release {w x y label} {
    $w delete marked
    if [regexp n:(.+) [$w gettags [$w find closest $x $y]] -> target] {
        if {$label ne $target} {
            set tree [winfo parent $w]
            catch {
                $tree move $target $label 0
                $tree opentree $target
            }
        }
    }
 }

#----- testing demo:

 pack [Tree .t]

 .t insert 0 root node1 -text hello
 .t insert 0 root node2 -text world
 .t insert 0 root node3  -text again
 .t insert 0 node2 node4 -text fourth

 .t bindText <1>               {+ tree'mark %W %x %y}
 .t bindText <B1-Motion>       {tree'motion %W %x %y}
 .t bindText <ButtonRelease-1> {tree'release %W %x %y}

MPJ Nice. The only problem I saw was that you can not move a node to the top level.

CJB I created new procs for this.

#Allows only children of non-root nodes to move.
proc tree'release'child {w x y label} {
    $w delete marked
    if [regexp n:(.+) [$w gettags [$w find closest $x $y]] -> target] {
        if {$label ne $target} {
            set tree [winfo parent $w]
            if {[::Tree::parent $tree $label] ne "root"} {
            catch {
                $tree move $target $label 0
                $tree opentree $target
            }
            }
        }
    }
 }

 #Allows nodes to move back to the root.
 proc tree'release'root {w x y label} {
    $w delete marked
    set tree [winfo parent $w]
    if [regexp n:(.+) [$w gettags [$w find closest $x $y]] -> target] {
        if {$label ne $target} {
            catch {
                $tree move $target $label 0
                $tree opentree $target
            }
        }
    } else {
        $tree move root $label 0
    }
 }

 #Allows nodes to move between children of root.
 #Each child of the root contains only leaves.
 #Children of the root cannot move.
 proc tree'release'leaf {w x y label} {
    $w delete marked
    if [regexp n:(.+) [$w gettags [$w find closest $x $y]] -> target] {
        if {$label ne $target} {
            set tree [winfo parent $w]
            if {[::Tree::parent $tree $label] ne "root" && [::Tree::parent $tree $target] eq "root"} {
            catch {
                $tree move $target $label 0
                $tree opentree $target
            }
            }
        }
    }
 }

Arts and crafts of Tcl-Tk programming

Category Example