# use_tree.tcl
# 
# Copyright (c) 1994 R"udiger Franke
# All Rights Reserved.
# 
# Redistribution and use in any form, with or without modification, 
# is permitted, provided that the following conditions are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in other form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. All advertising materials mentioning features or use of this software
#    must display the following acknowledgement:
#       This product includes software developed by R"udiger Franke.
# 4. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

#
# constructor for "use_tree"
#
proc use_tree {w  args} {
  upvar #0 $w this

  # user initializations

  # manage a tree with unique node names
  # store for every node a list of children -- this(children,$node)
  # store for every node it's parent -- this(parent,$node)
  # data initializations

  set this(use_tree) $w
  
  # widget creations

  canvas $this(use_tree)  \
    -scrollregion "0 0 0 0"
  
  useCreateComponent use_tree $w $args

  # user additions

  # initialize "superroot"
  set this(children,) {}
  
  # init delayed redrawing
  set this(redraw_req) 0
  
  # init layout
  set this(pdist) 30
  set this(sdist) 5
  set this(margin) 20

  return $w
}

#
# method "_delayedRedraw"
#
proc use_tree::_delayedRedraw {w } {
  upvar #0 $w this

  set this(redraw_req) 0
  
  use_tree::_noderedraw_vert $w \
    {} [expr {$this(margin) - $this(pdist)}] $this(margin)
  
  set bbox [$w.use_tree bbox all]
  if {$bbox != {}} {
    scan $bbox "%d %d %d %d" x1 y1 x2 y2 
    incr x2 $this(margin)
    incr y2 $this(margin)
    $w.use_tree configure -scrollregion "$x1 $y1 $x2 $y2"
  }
}

#
# method "_noderedraw_vert"
#
proc use_tree::_noderedraw_vert {w node x y} {
  upvar #0 $w this

  # args x, y: upper left corner for drawing
  # returns y: lower left corner from node and children
  
  # determine position and extension of this node
  
  if {$node != {}} {
    set bbox [$w.use_tree bbox $node]
    set width [expr {[lindex $bbox 2] - [lindex $bbox 0]}]
    set height [expr {[lindex $bbox 3] - [lindex $bbox 1]}]
  } else {
    set bbox {0 0 0 0}
    set width 0
    set height 0
  }
  
  # draw a row with all children
  
  set cx [expr {$x + $width + $this(pdist)}]
  set cy $y
  foreach child $this(children,$node) {
    set cy [use_tree::_noderedraw_vert $w $child $cx $cy]
    incr cy $this(sdist)
  }
  set cy [expr {$cy - $this(sdist)}]
  set mincy [expr {$y + $height}]
  if {$cy < $mincy} {
    set cy $mincy
  }
  
  # draw this node
  # position lines to all children
  
  if {$node != {}} {
    set ym [expr {($y + $cy) / 2}]
    set this(ypos,$node) $ym
    set this(xpos,$node) $x
    $w.use_tree move $node  [expr {$x - [lindex $bbox 0]}]  [expr {$ym - [lindex $bbox 1] - $height / 2}]
  
    set xr [expr {$x + $width}]
    foreach child $this(children,$node) {
      $w.use_tree coords $this(line,$child)  $xr $ym $this(xpos,$child) $this(ypos,$child)
    }
  }
  
  return $cy
}

#
# method "children"
#
proc use_tree::children {w node} {
  upvar #0 $w this

  return $this(children,$node)
}

#
# method "nodeadd"
#
proc use_tree::nodeadd {w parent node {lineargs {}}} {
  upvar #0 $w this

  if [info exists this(parent,$node)] {
    error "node $node already exists"
  }
  
  # register new node for it's parent
  
  lappend this(children,$parent) $node
  
  # init nodes data
  
  set this(parent,$node) $parent
  set this(children,$node) {}
  set this(line,$node) [eval "$w.use_tree create line 0 0 0 0 $lineargs"]
  set this(rmscript,$node) {}
  set this(xpos,$node) 0
  set this(ypos,$node) 0
  
  use_tree::redraw $w
}

#
# method "nodedelete"
#
proc use_tree::nodedelete {w node} {
  upvar #0 $w this

  # delete all children
  
  foreach child $this(children,$node) {
    use_tree::nodedelete $w $child
  }
  
  # evaluate nodes rmscript
  
  if {$this(rmscript,$node) != {}} {
    catch {uplevel #0 $this(rmscript,$node)}
  }
  
  # unregister node for it's parent
  
  set parent $this(parent,$node)
  set i [lsearch $this(children,$parent) $node]
  set this(children,$parent) [lreplace $this(children,$parent) $i $i]
  
  # delete nodes data and canvas items
  
  $w.use_tree delete $node $this(line,$node)
  
  unset this(parent,$node)
  unset this(children,$node)
  unset this(line,$node)
  unset this(rmscript,$node)
  unset this(xpos,$node)
  unset this(ypos,$node)
  
  use_tree::redraw $w
}

#
# method "nodedown"
#
proc use_tree::nodedown {w node} {
  upvar #0 $w this

  # put node at the bottom of it's siblings
  
  set parent $this(parent,$node)
  set i [lsearch $this(children,$parent) $node]
  set this(children,$parent) [lreplace $this(children,$parent) $i $i]
  set this(children,$parent) [linsert $this(children,$parent) 0 $node]
  
  use_tree::redraw $w
}

#
# method "nodemove"
#
proc use_tree::nodemove {w node amount} {
  upvar #0 $w this

  # move node within it's siblings for amount positions
  
  set parent $this(parent,$node)
  set i [lsearch $this(children,$parent) $node]
  set this(children,$parent) [lreplace $this(children,$parent) $i $i]
  incr i $amount
  
  set nsibl [llength $this(children,$parent)]
  if {$i < 0} {
    set i $nsibl
  } elseif {$i > $nsibl} {
    set i 0
  }
    
  set this(children,$parent) [linsert $this(children,$parent) $i $node]
  
  use_tree::redraw $w
}

#
# method "noderename"
#
proc use_tree::noderename {w node newname} {
  upvar #0 $w this

  # change parents list of children
  
  set parent $this(parent,$node)
  set i [lsearch $this(children,$parent) $node]
  set this(children,$parent) [lreplace $this(children,$parent) $i $i $newname]
  
  # change parent of own children
  
  foreach child $this(children,$node) {
    set this(parent,$child) $newname
  }
  
  # change tagging
  
  $w.use_tree addtag $newname withtag $node
  $w.use_tree dtag $node
  
  # change nodes data
  
  set this(parent,$newname) $this(parent,$node)
  set this(children,$newname) $this(children,$node)
  set this(line,$newname) $this(line,$node)
  set this(rmscript,$newname) $this(rmscript,$node)
  set this(xpos,$newname) $this(xpos,$node)
  set this(ypos,$newname) $this(ypos,$node)
  
  unset this(parent,$node)
  unset this(children,$node)
  unset this(line,$node)
  unset this(rmscript,$node)
  unset this(xpos,$node)
  unset this(ypos,$node)
  
}

#
# method "nodermscript"
#
proc use_tree::nodermscript {w node args} {
  upvar #0 $w this

  if {[llength $args] == 0} {
    return $this(rmscript,$node)
  } else {
    set this(rmscript,$node) [lindex $args 0]
  }
}

#
# method "nodeup"
#
proc use_tree::nodeup {w node} {
  upvar #0 $w this

  # put node at the top of it's siblings
  
  set parent $this(parent,$node)
  set i [lsearch $this(children,$parent) $node]
  set this(children,$parent) [lreplace $this(children,$parent) $i $i]
  lappend this(children,$parent) $node
  
  use_tree::redraw $w
}

#
# method "parent"
#
proc use_tree::parent {w node} {
  upvar #0 $w this

  return $this(parent,$node)
}

#
# method "parentdistance"
#
proc use_tree::parentdistance {w args} {
  upvar #0 $w this

  if {[llength $args] == 0} {
    return $this(pdist)
  } else {
    set this(pdist) [lindex $args 0]
  }
}

#
# method "redraw"
#
proc use_tree::redraw {w } {
  upvar #0 $w this

  # delayed redrawing
  
  if {$this(redraw_req) == 0} {
    after 1 "$w _delayedRedraw"
    set this(redraw_req) 1
  }
}

#
# method "siblingdistance"
#
proc use_tree::siblingdistance {w args} {
  upvar #0 $w this

  if {[llength $args] == 0} {
    return $this(sdist)
  } else {
    set this(sdist) [lindex $args 0]
  }
}

