#!/usr/bin/wish -f

#       Sample tree mega-widget.Can be used to display hierachies. The clients
#       who use this package need to specify parent and tail procedures for any
#       element of the tree hierarchy. All the nodes that get stored inside the
#       tree are complete path names separated by '/'. The toplevel node is
#       always /
#

package provide tree 1.0

namespace eval tree {
   variable tree


   #  
   # default font setup
   # 

   switch $tcl_platform(platform) {
      unix {
    set tree(font) \
        -adobe-helvetica-medium-r-normal-*-11-80-100-100-p-56-iso8859-1
      }
      windows {
    set tree(font) \
        -adobe-helvetica-medium-r-normal-*-14-100-100-100-p-76-iso8859-1
      }
   }
   
   #
   # Bitmaps used to show which parts of the tree can be opened/closed
   #

   set maskdata "#define solid_width 9\n#define solid_height 9"
   append maskdata {
      static unsigned char solid_bits[] = {
    0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01,
    0xff, 0x01, 0xff, 0x01, 0xff, 0x01
      };
   }
   set data "#define open_width 9\n#define open_height 9"
   append data {
      static unsigned char open_bits[] = {
    0xff, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x7d, 0x01, 0x01, 0x01,
    0x01, 0x01, 0x01, 0x01, 0xff, 0x01
      };
   }

   set tree(openbm) [image create bitmap openbm -data $data \
          -maskdata $maskdata \
          -foreground black -background white]

   set data "#define closed_width 9\n#define closed_height 9"
   append data {
      static unsigned char closed_bits[] = {
    0xff, 0x01, 0x01, 0x01, 0x11, 0x01, 0x11, 0x01, 0x7d, 0x01, 0x11, 0x01,
    0x11, 0x01, 0x01, 0x01, 0xff, 0x01
      };
   }
   set tree(closedbm) [image create bitmap closedbm -data $data \
            -maskdata $maskdata \
            -foreground black -background white]


    namespace export create additem delitem config setselection getselection 
    namespace export openbranch closebranch labelat
}

# tree::create -- 
#
#   Create a new tree widget. Canvas is used to emulate a tree
#   widget. Initialized all the tree specific data structures. $args become
#   the configuration arguments to the canvas widget from which the tree is
#   constructed.  #

# Arguments:
#    -paren   proc
#
#      sets the parent procedure provided by the application. tree
#      widget will use this procedure to determine the parent of an
#      element. This procedure will be called with the node as an 
#      argument  
#
#   -tail    proc  [Given a complete path this proc will give the end-element
#                        name]
#
# Results:   A tree widget with the path $w is created.
#

proc tree::create {w args} {
   variable tree
   set newArgs {}
   
   for {set i 0} {$i < [llength $args]} {incr i} {
      set arg [lindex $args $i]
      switch -glob -- $arg {
    -paren* {set tree($w:parenproc) [lindex $args [expr $i +1]]; incr i}
    -tail* {set tree($w:tailproc) [lindex $args [expr $i +1]]; incr i}
    default {lappend newArgs $arg}
    }
      }

   if ![info exists tree($w:parenproc)] {
      set tree($w:parenproc) parent
   }

   if ![info exists tree($w:tailproc)] {
      set tree($w:tailproc) tail
   }

  eval canvas $w -bg white $newArgs
  bind $w <Destroy> "tree::delitem $w /"
  tree::DfltConfig $w /
  tree::BuildWhenIdle $w
  set tree($w:selection) {}
  set tree($w:selidx) {}
}

# tree::DfltConfig  --
#   
#   Internal fuction used to initial the attributes associated with an item/node. Usually called when an item is added into the tree
#
#  Arguments:
#   wid   tree widget
#   node  complete path of the new node
#
#  Results:
#   Initializes the attributes associated with a node.


proc tree::DfltConfig {wid node} {
  variable tree
  set tree($wid:$node:children) {}
  set tree($wid:$node:open) 0
  set tree($wid:$node:icon) {}
  set tree($wid:$node:tags) {}

}

# tree::config --
#   
#   Fuction to set tree widget configuration options. 
#
#  Arguments:
#   args  any valid configuration option a canvas widget takes
#   
#  Results:
#   Configures the underlying canvas widget with the options
#

proc tree::config {wid args} {
variable tree
    set newArgs {}
    for {set i 0} {$i < [llength $args]} {incr i} {
      set arg [lindex $args $i]
      switch -glob -- $arg {
    -paren* {set tree($w:parenproc) [lindex $args [expr $i +1]]; incr i}
    -tail* {set tree($w:tailproc) [lindex $args [expr $i +1]]; incr i}
    default {lappend newArgs $arg}
    }
      }
  eval $wid config $newArgs
}

#  tree::additem --
#
# Called to add a new node to the tree.
#
#  Arguments:
#       wid   tree widget
#       node  complete path name of the node (path is separated by /)
#       args  can be -image val, -tags {taglist} to identify the item
#
#  Results:
#       Adds the new item and configures the new item
#

proc tree::additem {wid node args} {
  variable tree
   set parent [$tree($wid:parenproc) $node]
   set n [eval $tree($wid:tailproc) $node]
  if {![info exists tree($wid:$parent:open)]} {
    error "parent item \"$parent\" is missing"
  }
  set i [lsearch -exact $tree($wid:$parent:children) $n]
  if {$i>=0} {
      return
  }
  lappend tree($wid:$parent:children) $n
  set tree($wid:$parent:children) [lsort $tree($wid:$parent:children)]
  tree::DfltConfig $wid $node
  foreach {op arg} $args {
    switch -exact -- $op {
      -image {set tree($wid:$node:icon) $arg}
      -tags {set tree($wid:$node:tags) $arg}
    }
  }
  tree::BuildWhenIdle $wid
}

#  tree::delitem  --
#   
#   Deletes the specified item from the widget
#
#  Arguments:
#   wid   tree widget
#   node  complete path of the node
#
#  Results:
#   If the node exists, it will be deleted.
#

proc tree::delitem {wid node} {
  variable tree
  if {![info exists tree($wid:$node:open)]} return
  if {[string compare $node /]==0} {
    # delete the whole widget
    catch {destroy $wid}
    foreach t [array names tree $wid:*] {
      unset tree($t)
    }
  }
  foreach c $tree($wid:$node:children) {
    catch {tree::delitem $wid $node/$c}
  }
  unset tree($wid:$node:open)
  unset tree($wid:$node:children)
  unset tree($wid:$node:icon)
  set parent [$tree($wid:parenproc) $node]
   set n [eval $tree($wid:tailproc) $node]
  set i [lsearch -exact $tree($wid:$parent:children) $n]
  if {$i>=0} {
    set tree($wid:$parent:children) [lreplace $tree($wid:$parent:children) $i $i]
  }
  tree::BuildWhenIdle $wid
}

# The user has control over which node in the item can be assigned as a selection.
# setselection and getselection routines are used to accomplish the job.
# The selection object is drawn with a highlighted background.

# tree::setselection  --
#   
#   Makes the given node as the currently selected node.
#
#  Arguments:
#   wid - tree widget
#   node - complete path of the one of nodes
#
#  Results:
#   The given node will be selected
#

proc tree::setselection {wid node} {
  variable tree
  set tree($wid:selection) $node
  tree::DrawSelection $wid
}

#  tree::getselection  --
#   
#   Get the currently selected tree node
#
#  Arguments:
#   wid - tree widget
#   
#  Results:
#   If a node is currently selected it will be returned otherwise NULL
#

proc tree::getselection wid {
  variable tree
  return $tree($wid:selection)
}

#  tree::Build --
#   
#   Internal function to rebuild the tree
#
#  Arguments:
#   wid -  tree widgets
#   
#  Results:
#
#     This routine has no complex logic in it. Deletes all the current items
#    on the canvas associated with the tree and re-builds the tree.  #
#
#       

proc tree::Build wid {
  variable tree
  $wid delete all
  catch {unset tree($wid:buildpending)}
  set tree($wid:y) 30
  tree::BuildNode $wid / 10
  $wid config -scrollregion [$wid bbox all]
  tree::DrawSelection $wid
}

#  tree::BuildNode --
#   
#   Function called by tree::build to incrementally build each node
#
#  Arguments:
#   wid - tree widget
#       node - complete path of the node
#   in - the starting x-cordinate
#
#  Results:
#   The node gets drawn
#

proc tree::BuildNode {wid node in} {
  variable tree
  if {$node=="/"} {
    set vx {}
  } else {
    set vx $node
  }
  set start [expr $tree($wid:y)-10]
  foreach c $tree($wid:$node:children) {
    set y $tree($wid:y)
    incr tree($wid:y) 17
    $wid create line $in $y [expr $in+10] $y -fill gray50  
    set icon $tree($wid:$vx/$c:icon)
    set taglist x
    foreach tag $tree($wid:$vx/$c:tags) {
      lappend taglist $tag
    }
    set x [expr $in+12]
    if {[string length $icon]>0} {
      set k [$wid create image $x $y -image $icon -anchor w -tags $taglist]
      incr x 20
      set tree($wid:tag:$k) $vx/$c
    }
    set j [$wid create text $x $y -text $c -font $tree(font) \
                                -anchor w -tags $taglist]
    set tree($wid:tag:$j) $vx/$c
    set tree($wid:$vx/$c:tag) $j
    if {[string length $tree($wid:$vx/$c:children)]} {
      if {$tree($wid:$vx/$c:open)} {
         set j [$wid create image $in $y -image $tree(openbm)]
         $wid bind $j <1> "set tree::tree($wid:$vx/$c:open) 0; tree::Build $wid"
         tree::BuildLayer $wid $vx/$c [expr $in+18]
      } else {
         set j [$wid create image $in $y -image $tree(closedbm)]
         $wid bind $j <1> "set tree::tree($wid:$vx/$c:open) 1; tree::Build $wid"
      }
    }
  }
  set j [$wid create line $in $start $in [expr $y+1] -fill gray50 ]
  $wid lower $j
}

# Now, after the tree gets displayed, if the user chooses to open any of the
# branches by clicking the '+' image next to a node then the following
# openbranch routine will arrange to redraw the tree by displaying the node's children.

#  tree::openbranch --
#
# A callback that gets called to open a node to show its children
#
#  Arguments:
#       wid - tree widget
#       node - the node whose children should be shown
#
#  Results:
#      The children of the node will be drawn
#

proc tree::openbranch {wid node} {
  variable tree
  if {[info exists tree($wid:$node:open)] && $tree($wid:$node:open)==0
      && [info exists tree($wid:$node:children)] 
      && [string length $tree($wid:$node:children)]>0} {
    set tree($wid:$node:open) 1
    tree::Build $wid
  }
}

# Similarly, when the user clicks on the '-' image next to a node, the
# closebranch routine will arrange the tree to be redrawn by closing
# the branch and undisplaying the children.

# tree::closebranch   --
#
# The opposite of open branch, see above
#
#  Arguments:
#
#
#  Results:
#

proc tree::closebranch {wid node} {
  variable tree
  if {[info exists tree($wid:$node:open)] && $tree($wid:$node:open)==1} {
    set tree($wid:$node:open) 0
    tree::Build $wid
  }
}

# The DrawSelection routine will highlight the currently selected node.

#  tree::DrawSelection --
#
# Highlights the current selection
#
#  Arguments:
#      wid - tree widget
#
#  Results:
#      The current selection will be high-lighted with skyblue
#

proc tree::DrawSelection wid {
  variable tree
  if {[string length $tree($wid:selidx)]} {
    $wid delete $tree($wid:selidx)
  }
  set node $tree($wid:selection)
  if {[string length $node]==0} return
  if {![info exists tree($wid:$node:tag)]} return
  set bbox [$wid bbox $tree($wid:$node:tag)]
  if {[llength $bbox]==4} {
    set i [eval $wid create rectangle $bbox -fill skyblue -outline {{}}]
    set tree($wid:selidx) $i
    $wid lower $i
  } else {
    set tree($wid:selidx) {}
  }
}

#  tree::BuildWhenIdle --
#	
#	Function to reduce the number redraws of the tree. When a redraw is not
#	immediately warranted this function gets called
#
#  Arguments:
#	wid  - tree wiget
#	
#  Results:
#	Set the tree widget to be redrawn in future.
#

proc tree::BuildWhenIdle wid {
  variable tree
  if {![info exists tree($wid:buildpending)]} {
    set tree($wid:buildpending) 1
    after idle "tree::Build $wid"
  }
}

#  tree::labelat --
#	
#	Returns the tree node closest to  x,y co-ordinates
#
#  Arguments:
#	wid      tree widget
#	x,y      co-ordinates
#
#  Results:
#	The node closest to x,y will be returned.


proc tree::labelat {wid x y} {
  set x [$wid canvasx $x]
  set y [$wid canvasy $y]
  variable tree
  foreach m [$wid find overlapping $x $y $x $y] {
    if {[info exists tree($wid:tag:$m)]} {
      return $tree($wid:tag:$m)
    }
  }
  return ""
}