Version 13 of LemonTree Org Chart

Updated 2012-12-07 00:30:12 by Jorge

JM 9 Oct 2012 - someone asked me to create a kind of org chart from a list of employees, which includes (among other employee's relevant information), the employee's manager name. There is of course some off the shelve solutions using google docs or visio, but I am always on the mood to give Tcl a try.
this script (not fully tested btw) uses LemonTree again, given the flexibility it offers. I removed the code I did not need so please refer to LemonTree if you want to review the beauty of this code from RS
the script parses a file (hardcoded name, sorry) called "orgchart.csv" which contents are like this:

 General,
 Colonel A,General
 Colonel B,General
 Captain A,Colonel B
 Captain B,Colonel B
 Captain C,Colonel B
 Sergeant A,Captain A
 Sergeant B,Captain A
 Private A,Sergeant B
 Private B,Sergeant B


the objective is to create something similar to http://en.wikipedia.org/wiki/Organizational_chart , but with a dynamic twist.
lemonTreeOrgChart

as an exercise for the reader:

  • put some info on the balloon, expanding the CSV file with employee ID or position
  • add a person icon instead of the folder default icon
 package require BWidget
 namespace eval LemonTree {variable uniqueID 0}

 proc LemonTree::add {w parent type name {text ""}} {
    variable uniqueID; variable icon
    set text $name
    if {$parent != "root"} {
      if {$text eq ""} {set text "$val3,$val2,[string range $val1 0 20]"}
    }
    set id n[incr uniqueID]
    set data [list type $type name $name]
    #tk_messageBox -message "$type,$name"
    set fill [expr {[string match (* $text]? "blue": "black"}]
    set drawcross [expr {[info proc ::LemonTree::kids($type)] eq ""?
         "never": "allways"}]
    $w insert end $parent $id -text $text -data $data -drawcross $drawcross -fill $fill
    if [info exists icon($type)] {
             $w itemconfigure $id -image $icon($type)
    }
 }
 
 proc LemonTree::open {w node} {
    if {[$w itemcget $node -drawcross] eq "allways"} {
        set data [$w itemcget $node -data]
        set type [dict'get $data type]
        foreach {ktype kids} [kids($type) $w $node] {
            foreach kid $kids {add $w $node $ktype $kid}
        }
        $w itemconfigure $node -drawcross auto
    }
 }

 proc LemonTree::kids(html) {w node} {
    set name [dict'get [$w itemcget $node -data] name]
    list html [getReporters $name]
 }


set path $BWIDGET::LIBRARY/images

 foreach {type name} {dir folder file file array copy html folder} {
    set LemonTree::icon($type) [image create photo -file $path/$name.gif]
 }

 proc LemonTree::Info {w node} {
    set type [dict'get [$w itemcget $node -data] type]
    if {[info proc ::LemonTree::info($type)] ne ""} {
        balloon $w [info($type) $w $node]
    }
 }

#-- type-specific info providers:

 proc LemonTree::info(html) {w node} {
    return "TBD"
 }

#-- A simple ballon, modified from Bag of Tk algorithms:  
 proc balloon {w text} {
    set top .balloon
    catch {destroy $top}
    toplevel $top -bd 1
    pack [message $top.txt -aspect 10000 -bg lightyellow \
        -borderwidth 0 -text $text -font {Helvetica 9}]
    wm overrideredirect $top 1
    wm geometry $top +[winfo pointerx $w]+[winfo pointery $w]
    bind  $top <1> [list destroy $top]
    raise $top
 }

 proc dict'get {dict key} {
    foreach {k value} $dict {if {$k eq $key} {return $value}}
 }

#
#
#
 proc getReporters {who} {
  set fp [open orgchart.csv r]
  while {[gets $fp line] >= 0} {
     foreach {empl jefe} [split $line ,] {
       if {$jefe == $who} {
        lappend reporters $empl
       }
     }
  }
  close $fp
  if {[info exists reporters]} {
    if {[llength $reporters] > 1} {
      return $reporters
    }
  }
 }

 proc main {quien} {
  LemonTree::add .t root html $quien $quien
  return
 }

# -------------------------------------------
 label .lbl -text "From:"
 entry .txt -width 60
 button .btnGet -text "Start" -command {main [.txt get]}
 button .btnSalir -text Exit -command {
 catch {t destroy}
 exit
 }
 grid .lbl .txt
 grid .btnGet -row 1 -column 1
 grid .btnSalir -row 1 -column 2

#-- Now to demonstrate and test the whole thing: 
 Tree .t -background white -opencmd {LemonTree::open .t} \
 -width 60 -height 30 -yscrollcommand {.y set}
 .t bindText  <1> {LemonTree::Info .t}
 .t bindImage <1> {LemonTree::Info .t}
 
 scrollbar .y -command {.t yview}
 grid .t -row 2 -column 0 -columnspan 3 
 grid .y -row 2 -column 3 -sticky ns
 .txt insert end "General"
#-- Little development helpers:
 bind . <Escape> {exec wish $argv0 &; exit}
 bind . <F1> {console show}