''[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 ballon, expanding the CSV files with employee ID or position
* add a person icon instead of the folder default icon
package require BWidget
namespace eval LemonTree {variable uniqueID 0}
if 0 {The Tree widget allows a -data item for each node, which I use for a dict-like
list that contains the node's type and "real name"
(as opposed to the "display name" - for instance, a dir node would display only its [file tail],
but the real name is the full path). This routine adds a node to the LemonTree: }
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)
}
}
if 0 {For speed, a Tree isn't drawn fully expanded at the beginning.
Instead, nodes are opened on demand, when the user clicks on the [+] icon.
I use the -drawcross "allways" mode (shudder - should be fixed to "always",
but then older code might break) to indicate that the node hasn't been opened before
- after the first opening, the mode is set to "auto", meaning to draw a cross
only if the node has children. }
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
}
}
if 0 {So far for the generic LemonTree - the rest is already customization for specific item types.
The kids($type) call above looks like an array element
- in fact it's a way of dispatching the generic operation of providing the list of children of an entity of given type, which of course depends on the type. For instance, the children of a directory are its subdirectories, and then its files (with special-casing for Windows, so that drive letters are the children of "/"): }
proc LemonTree::kids(html) {w node} {
set name [dict'get [$w itemcget $node -data] name]
list html [getReporters $name]
}
if 0 {A Tree looks prettier if nodes have icons, so I'm using some of those that BWidget comes with:}
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]
}
if 0 {This thing is more useful if you can get more information about an item by clicking on it
- for a file, its size and date; for a variable, its value; for a proc, its full specification,
etc. As a small first shot, I selected a "balloon" for that purpose. }
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
}
if 0 {From Tcl 8.5, one would use a real dict, but it's easy to make a replacement
that works roughly the same in 8.4 (it returns "" for non- existing keys instead
of throwing an error), and might be slower, but I won't notice on dicts with two elements ;-}
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 . {exec wish $argv0 &; exit}
bind . {console show}
<>Enter Category Here