# tktreemap.tcl 
# Author:      Gerard Sookahet
# Date:        17 July 2004 
# Version:     0.2
# Description: Directory treemap
# References: B. Shneiderman, Tree visualization with treemaps: 
#             a 2-d space-filling approach.
#             http://www.cs.umd.edu/local-cgi-bin/hcil/rr.pl?number=91-03
#             See also http://www.cs.umd.edu/hcil/treemap-history/index.shtml

package require Tk

bind all <Escape> {exit}

# Hexadecimal color codes table with 766 items
set lcolor "
#000000 #000033 #000080 #00008B #00009C #0000CD #0000EE #0000FF #003300 #006400
#00688B #007FFF #008000 #008080 #00868B #008B00 #008B45 #008B8B #0099CC #009ACD
#00AF33 #00B2EE #00BFFF #00C5CD #00C78C #00C957 #00CD00 #00CD66 #00CDCD #00CED1
#00E5EE #00EE00 #00EE76 #00EEEE #00F5FF #00FA9A #00FF00 #00FF33 #00FF66 #00FF7F
#00FFAA #00FFCC #00FFFF #00FFFF #030303 #03A89E #050505 #05B8CC #080808 #0A0A0A
#0AC92B #0D0D0D #0F0F0F #0FDDAF #104E8B #120A8F #121212 #141414 #171717 #1874CD
#191970 #1A1A1A #1C1C1C #1C86EE #1E90FF #1F1F1F #20B2AA #212121 #215E21 #218868
#228B22 #23238E #236B8E #238E68 #242424 #262626 #27408B #28AE7B #292421 #292929
#2B2B2B #2C5D3F #2E0854 #2E2E2E #2E473B #2E8B57 #2F2F4F #2F4F2F #2F4F4F #2F4F4F
#303030 #308014 #3232CC #3232CD #3299CC #32CC32 #32CC99 #32CD32 #32CD99 #330000
#3300FF #333333 #3333FF #33A1C9 #33FF33 #363636 #36648B #380474 #383838 #385E0F
#388E8E #38B0DE #3A5FCD #3B3B3B #3B5E2B #3CB371 #3D3D3D #3D59AB #3D9140 #404040
#40E0D0 #4169E1 #424242 #42426F #426F42 #436EEE #43CD80 #454545 #458B00 #458B74
#4682B4 #473C8B #474747 #483D8B #4876FF #48D1CC #4A4A4A #4A708B #4A766E #4B0082
#4D4D4D #4D4DFF #4EEE94 #4F2F4F #4F4F2F #4F4F4F #4F94CD #50A6C2 #525252 #527F76
#528B8B #53868B #548B54 #54FF9F #551011 #551033 #551A8B #555555 #556B2F #567E3A
#575757 #595959 #5959AB #5C246E #5C3317 #5C4033 #5C5C5C #5CACEE #5D478B #5E2605
#5E2612 #5E5E5E #5F9EA0 #5F9F9F #607B8B #616161 #61B329 #636363 #63B8FF #6495ED
#660000 #6600FF #666666 #6666FF #668014 #668B8B #66CD00 #66CDAA #66FF66 #68228B
#68838B #691F01 #6959CD #696969 #696969 #698B22 #698B69 #6A5ACD #6B238E #6B4226
#6B6B6B #6B8E23 #6C7B8B #6CA6CD #6E6E6E #6E7B8B #6E8B3D #6EFF70 #6F4242 #707070
#708090 #708090 #7093DB #70DB93 #70DBDB #7171C6 #71C671 #733D1A #734A12 #737373
#757575 #76EE00 #76EEC6 #777733 #778899 #778899 #787878 #79CDCD #7A378B #7A67EE
#7A7A7A #7A8B8B #7AC5CD #7B3F00 #7B68EE #7CCD7C #7CFC00 #7D26CD #7D7D7D #7D9EC0
#7EC0EE #7F00FF #7F7F7F #7FFF00 #7FFFD4 #800000 #800080 #802A2A #808000 #808069
#808080 #808080 #808A87 #828282 #836FFF #838B83 #838B8B #8470FF #855E42 #856363
#858585 #871F78 #872657 #87421F #878787 #87CEEB #87CEFA #87CEFF #8968CD #8A2BE2
#8A3324 #8A360F #8A8A8A #8B0000 #8B008B #8B0A50 #8B1A1A #8B1C62 #8B2252 #8B2323
#8B2500 #8B3626 #8B3A3A #8B3A62 #8B3E2F #8B4500 #8B4513 #8B4726 #8B475D #8B4789
#8B4C39 #8B5742 #8B5A00 #8B5A2B #8B5F65 #8B636C #8B6508 #8B668B #8B6914 #8B6969
#8B7355 #8B7500 #8B7765 #8B795E #8B7B8B #8B7D6B #8B7D7B #8B7E66 #8B814C #8B8378
#8B8386 #8B864E #8B8682 #8B8878 #8B8970 #8B8989 #8B8B00 #8B8B7A #8B8B83 #8C1717
#8C7853 #8C8C8C #8DB6CD #8DEEEE #8E2323 #8E236B #8E388E #8E6B23 #8E8E38 #8EE5EE
#8F5E99 #8F8F8F #8F8FBC #8FBC8F #8FD8D8 #90EE90 #91219E #912CEE #919191 #9370DB
#93DB70 #9400D3 #949494 #964514 #969696 #96C8A2 #96CDCD #97694F #97FFFF #98F5FF
#98FB98 #990099 #9932CC #9932CD #993300 #999999 #99CC32 #9A32CD #9AC0CD #9ACD32
#9AFF9A #9B30FF #9BC4E2 #9BCD9B #9C661F #9C9C9C #9E9E9E #9F5F9F #9F79EE #9F9F5F
#9FB6CD #A020F0 #A0522D #A1A1A1 #A2B5CD #A2CD5A #A39480 #A3A3A3 #A4D3EE #A52A2A
#A62A2A #A67D3D #A68064 #A6A6A6 #A8A8A8 #A9A9A9 #A9A9A9 #A9ACB6 #AA00FF #AA6600
#AAAAAA #AAAAFF #AADD00 #AB82FF #ABABAB #ADADAD #ADD8E6 #ADEAEA #ADFF2F #AEEEEE
#AF4035 #AFEEEE #B0171F #B03060 #B0B0B0 #B0C4DE #B0E0E6 #B0E2FF #B13E0F #B22222
#B23AEE #B2DFEE #B3B3B3 #B3EE3A #B452CD #B4CDCD #B4EEB4 #B5A642 #B5B5B5 #B6316C
#B7C3D0 #B87333 #B8860B #B8B8B8 #B9D3EE #BA55D3 #BABABA #BBFFFF #BC8F8F #BCD2EE
#BCEE68 #BDB76B #BDBDBD #BDFCC9 #BEBEBE #BF3EFF #BFBFBF #BFEFFF #C0C0C0 #C0D9D9
#C0FF3E #C1CDC1 #C1CDCD #C1FFC1 #C2C2C2 #C4C4C4 #C5C1AA #C67171 #C6C3B5 #C6E2FF
#C71585 #C73F17 #C76114 #C77826 #C7C7C7 #C82536 #C9C9C9 #CAE1FF #CAFF70 #CBCAB6
#CC00FF #CC1100 #CC3232 #CC3299 #CC7722 #CC7F32 #CC99CC #CCCC00 #CCCCCC #CCCCFF
#CCFFCC #CD0000 #CD00CD #CD1076 #CD2626 #CD2990 #CD3278 #CD3333 #CD3700 #CD4F39
#CD5555 #CD5B45 #CD5C5C #CD6090 #CD6600 #CD661D #CD6839 #CD6889 #CD69C9 #CD7054
#CD7F32 #CD8162 #CD8500 #CD853F #CD8C95 #CD919E #CD950C #CD96CD #CD9B1D #CD9B9B
#CDAA7D #CDAD00 #CDAF95 #CDB38B #CDB5CD #CDB79E #CDB7B5 #CDBA96 #CDBE70 #CDC0B0
#CDC1C5 #CDC5BF #CDC673 #CDC8B1 #CDC9A5 #CDC9C9 #CDCD00 #CDCDB4 #CDCDC1 #CDCDCD
#CFB53B #CFCFCF #CFD784 #D02090 #D0D2C4 #D15FEE #D19275 #D1D1D1 #D1EEEE #D2691E
#D2B48C #D3D3D3 #D3D3D3 #D41A1F #D43D1A #D4D4D4 #D6D6D6 #D8BFD8 #D8D8BF #D98719
#D9D919 #D9D9D9 #D9D9F3 #DA70D6 #DAA520 #DAF4F0 #DB2645 #DB2929 #DB7093 #DB70DB
#DB9370 #DBDB70 #DBDBDB #DBE6E0 #DBFEF8 #DC143C #DCDCDC #DDA0DD #DEB887 #DEDEDE
#DFFFA5 #E066FF #E0E0E0 #E0EEE0 #E0EEEE #E0FFFF #E2DDB5 #E31230 #E3170D #E32636
#E32E30 #E33638 #E3701A #E38217 #E3A869 #E3CF57 #E3E3E3 #E47833 #E5E5E5 #E6B426
#E6E6FA #E6E8FA #E8E8E8 #E8F1D4 #E9967A #E9C2A6 #EAADEA #EAEAAE #EBC79E #EBEBEB
#ED9121 #EDC393 #EDEDED #EE0000 #EE00EE #EE1289 #EE2C2C #EE30A7 #EE3A8C #EE3B3B
#EE4000 #EE5C42 #EE6363 #EE6A50 #EE6AA7 #EE7600 #EE7621 #EE7942 #EE799F #EE7AE9
#EE8262 #EE82EE #EE8833 #EE9572 #EE9A00 #EE9A49 #EEA2AD #EEA9B8 #EEAD0E #EEAEEE
#EEB422 #EEB4B4 #EEC591 #EEC900 #EECBAD #EECFA1 #EED2EE #EED5B7 #EED5D2 #EED6AF
#EED8AE #EEDC82 #EEDD82 #EEDFCC #EEE0E5 #EEE5DE #EEE685 #EEE8AA #EEE8CD #EEE9BF
#EEE9E9 #EEEE00 #EEEED1 #EEEEE0 #F08080 #F0A804 #F0E68C #F0F0F0 #F0F8FF #F0FFF0
#F0FFFF #F2F2F2 #F4A460 #F5DEB3 #F5F5DC #F5F5F5 #F5FFFA #F7F7F7 #F8F8FF #FA8072
#FAEBD7 #FAF0E6 #FAFAD2 #FAFAFA #FBEC5D #FCE6C9 #FCFCFC #FCFFF0 #FDF5E6 #FDF8FF
#FEE5AC #FEE8D6 #FEF0DB #FEF1B5 #FF0000 #FF0033 #FF0066 #FF007F #FF00AA #FF00CC
#FF00FF #FF00FF #FF030D #FF1493 #FF1CAE #FF2400 #FF3030 #FF3300 #FF3333 #FF34B3
#FF3D0D #FF3E96 #FF4040 #FF4500 #FF5721 #FF6103 #FF6347 #FF6600 #FF6666 #FF69B4
#FF6A6A #FF6EB4 #FF6EC7 #FF7256 #FF7722 #FF7D40 #FF7F00 #FF7F24 #FF7F50 #FF8000
#FF8000 #FF8247 #FF82AB #FF83FA #FF8600 #FF8C00 #FF8C69 #FF9912 #FF9955 #FFA07A
#FFA500 #FFA54F #FFA812 #FFA824 #FFAA00 #FFADB9 #FFAEB9 #FFB00F #FFB5C5 #FFB6C1
#FFB90F #FFBBFF #FFC0CB #FFC125 #FFC1C1 #FFCC11 #FFCC99 #FFCCCC #FFD39B #FFD700
#FFDAB9 #FFDEAD #FFE1FF #FFE303 #FFE4B5 #FFE4C4 #FFE4E1 #FFE7BA #FFEBCD #FFEC8B
#FFEFD5 #FFEFDB #FFF0F5 #FFF5EE #FFF68F #FFF8DC #FFFACD #FFFAF0 #FFFAFA #FFFF00
#FFFFAA #FFFFCC #FFFFE0 #FFFFF0 #FFFFFE #FFFFFF"

proc ColorTable { n } {
    global lcolor
 return [lindex $lcolor [expr {$n%766}]]
}

# Initial call for the treemap
proc InitTreemap { w tree } {
 $w.c delete all
 set x1 0
 set y1 0
 set x2 [$w.c cget -width]
 set y2 [$w.c cget -height]
 $w.f2.lt configure -text "Total: [lindex $tree 2] bytes"
 DrawTreemap $w $x1 $y1 $x2 $y2 0 0 $tree
}
 
# Draw recursively the treemap
proc DrawTreemap { w x1 y1 x2 y2 axis level tree } {
    global status
 foreach {root_name root_list root_size} $tree {}
 if {$x2 > 0 && $y2 > 0} then {
   set rect [DrawRect $w $x1 $y1 $x2 $y2 [ColorTable $root_size]]
   $w.c bind $rect <Double-1> "SubDir {$root_name}"
   $w.c bind $rect <Enter> "set status {$root_name  $root_size bytes  (level $level)}"
   $w.c bind $rect <Leave> {set status ""}
 }
 set x $x1
 set y $y1 
 foreach sublist $root_list {
        set child_size [lindex $sublist 2]
        if {$root_size == 0} then {
          set ratio 100.0
        } else {
          set ratio [expr {double($child_size)/double($root_size)}]
        }
        if $axis then {
          set xd $x2
          set yd [expr {$y2*$ratio}]
        } else {
          set yd $y2
          set xd [expr {$x2*$ratio}]
        }
        DrawTreemap $w $x $y $xd $yd [expr {1-$axis}] [expr {$level+1}] $sublist
        if $axis then {set y [expr {$y+$yd}]} else {set x [expr {$x+$xd}]}
 }
}

# Draw rectangle in canvas
proc DrawRect { w x y xd yd color } {
 return [$w.c create rectangle \
             $x $y [expr {$x+$xd}] [expr {$y+$yd}] -width 2 -fill $color]
}

proc InitDirTree { d } {
 if {$d != ""} then {
   set sublist [DirTree $d]
   set size 0
   foreach j $sublist {
          set size [expr {$size + [lindex $j 2]}]
   }
   return [list $d $sublist $size]
 } else {
   tk_messageBox -title "Choose a directory" \
     -icon error \
     -parent . \
     -type ok \
     -message "Please, choose a directory before running"
   return
 }
}

# Recursive tree directory. A kind of Unix 'du' command
# The tree is stored in a nested list
proc DirTree { d } {
 catch {unset tree}
 catch {unset ldir}

 set tree {}
 set ldir {}
 set ftype {f d {f hidden} {d hidden}}
 cd $d

 foreach i $ftype {lappend ldir [glob -nocomplain -type  $i *]}
 set ldir [join $ldir]
 foreach i $ldir {
        set fpath [file normalize $i]
        if [file isdirectory $i] { 
          set sublist [DirTree $fpath] 
          set size 0
          foreach j $sublist {set size [expr {$size + [lindex $j 2]}]}
          set dirlist [list $fpath $sublist $size]
          cd ..
        } elseif [file isfile $i] {
          set dirlist [list $fpath {} [file size $fpath]]
        } else {
          set dirlist [list $fpath {} 0]
        }
        lappend tree $dirlist
 }
 return $tree
}

# Scan a subdirectory 
proc SubDir { f } {
    global dirname
    global odirname
 set dir [file dirname $f]
 if {$dir eq $dirname} {return}
 lappend odirname $dirname
 set dirname $dir
 InitTreemap .tm [InitDirTree $dirname]
}

# Go back to the previous directory
proc UpDir {} {
    global dirname
    global odirname
 if {[llength $odirname] == 0} {return} 
 set dirname [lindex $odirname end]
 InitTreemap .tm [InitDirTree $dirname]
 set odirname [lrange $odirname 0 end-1]
}

proc BrowseDir { d } {
    set dir [tk_chooseDirectory -initialdir $d \
                                -title "Choose directory"]
    if {$dir != ""} {return $dir}
}

# Inline base 64 encoded images
proc Images { s } {

 switch $s {

    button_dir {
          return {R0lGODlhEwALAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8AB0
                  0dlv1f/iAgDJVj1ZqgBFfX+5/4JCf/+3/5mHAf//gAB4M3//qiQ1Zp6s7gAA
                  cgAqAAAqVQAqqgAq/wBVAABVVQBVqgBV/wB/AAB/VQB/qgB//wCqAACqVQCq
                  qgCq/wDVAADVVQDVqgDV/yoAACoAVSoAqioA/yoqACoqVSoqqioq/ypVACpV
                  VSpVqipV/yp/ACp/VSp/qip//yqqACqqVSqqqiqq/yrVACrVVSrVqirV/yr/
                  ACr/VSr/qir//1UAAFUAVVUAqlUA/1UqAFUqVVUqqgAAVVUq/1VVAFVVVVVV
                  qlVV/1V/AFV/VVV/qlV//1WqAFWqVVWqqlWq/1XVAFXVVVXVqlXV/1X/AFX/
                  VVX/qlX//38AAH8AVX8Aqn8A/38qAH8qVX8qqn8q/39VAH9VVX9Vqn9V/39/
                  AH9/VX9/qn9//3+qAH+qVX+qqn+q/3/VAH/VVX/Vqn/V/3//AH//VX///6oA
                  AKoAVaoAqqoA/6oqAKoqVaoqqgD/Vaoq/6pVAKpVVapVqqpV/6p/AKp/VQAA
                  qqp/qqp//6qqAKqqVaqqqqqq/6rVAKrVVarVqqrV/6r/AKr/Var/qqr//9UA
                  ANUAVdUAqtUA/9UqANUqVdUqqtUq/9VVANVVVdVVqtVV/9V/ANV/VdV/qtV/
                  /9WqANWqVdWqqtWq/9XVANXVVdXVqtXV/9X/ANX/VdX/qtX///8AVf8Aqv8q
                  AP8qVf8qqv8q//9VAP9VVf9Vqv9V//9/AP9/Vf9/qv9///+qAP+qVf+qqgD/
                  qv+q///VAP/VVf/Vqv/V////Vf//qnNzc6mpqa3Y5gCi/wBhmX/i/2eBivL/
                  /ywAAFYAAIcAAMAAAAAsACwsAFYsAIcsAMAsAP8sAABWACxWAFZWAIdWAMBW
                  AP9WAACHACyHAFaHAIeHAMCHAP+HAADAACzAAFbAAP/78KCgpICAgP8AAAD/
                  AP//AAAA//8A/wD//////ywAAAAAEwALAAAIQgD/CRxIsOBAAP8OKFzIsOEB
                  fAgdSlwIMeFEiRUvYoyoEEDHjwc8KsyosSHJkhQ5ohyJEJ/LlzBjugRAs6bN
                  mzcDAgA7}
    }

    button_up { 
          return {R0lGODlhEwALAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8AB0
                  0dlv1f/iAgDJVj1ZqgBFfX+5/4JCf/+3/5mHAf//gAB4M3//qiQ1Zp6s7gAA
                  cgAqAAAqVQAqqgAq/wBVAABVVQBVqgBV/wB/AAB/VQB/qgB//wCqAACqVQCq
                  qgCq/wDVAADVVQDVqgDV/yoAACoAVSoAqioA/yoqACoqVSoqqioq/ypVACpV
                  VSpVqipV/yp/ACp/VSp/qip//yqqACqqVSqqqiqq/yrVACrVVSrVqirV/yr/
                  ACr/VSr/qir//1UAAFUAVVUAqlUA/1UqAFUqVVUqqgAAVVUq/1VVAFVVVVVV
                  qlVV/1V/AFV/VVV/qlV//1WqAFWqVVWqqlWq/1XVAFXVVVXVqlXV/1X/AFX/
                  VVX/qlX//38AAH8AVX8Aqn8A/38qAH8qVX8qqn8q/39VAH9VVX9Vqn9V/39/
                  AH9/VX9/qn9//3+qAH+qVX+qqn+q/3/VAH/VVX/Vqn/V/3//AH//VX///6oA
                  AKoAVaoAqqoA/6oqAKoqVaoqqgD/Vaoq/6pVAKpVVapVqqpV/6p/AKp/VQAA
                  qqp/qqp//6qqAKqqVaqqqqqq/6rVAKrVVarVqqrV/6r/AKr/Var/qqr//9UA
                  ANUAVdUAqtUA/9UqANUqVdUqqtUq/9VVANVVVdVVqtVV/9V/ANV/VdV/qtV/
                  /9WqANWqVdWqqtWq/9XVANXVVdXVqtXV/9X/ANX/VdX/qtX///8AVf8Aqv8q
                  AP8qVf8qqv8q//9VAP9VVf9Vqv9V//9/AP9/Vf9/qv9///+qAP+qVf+qqgD/
                  qv+q///VAP/VVf/Vqv/V////Vf//qnNzc6mpqa3Y5gCi/wBhmX/i/2eBivL/
                  /ywAAFYAAIcAAMAAAAAsACwsAFYsAIcsAMAsAP8sAABWACxWAFZWAIdWAMBW
                  AP9WAACHACyHAFaHAIeHAMCHAP+HAADAACzAAFbAAP/78KCgpICAgP8AAAD/
                  AP//AAAA//8A/wD//////ywAAAAAEwALAAAIRQD/CRxIsOBAAP8OKFzIsOEB
                  fAgdKgQgEWJChwAyOrSIMaNGhhwZehwJMuLCkSgXhjyAsqXClRI3IsRHs6bN
                  mzRb6tQZEAA7}
    }
 }
}

proc About {} {
 set w .about
 catch {destroy $w}
 toplevel $w
 wm title $w "About TkTreemap"
 message $w.msg -justify center -aspect 250 -relief sunken -bg blue -fg white \
        -text "TkTreemap: a directory treemap\n\nGerard Sookahet\n\nAugust 2004"
 button $w.bquit -text " OK " -command {destroy .about}
 eval pack [winfo children $w]
}

proc Main { cx cy } {
    global dirname
    global odirname
    global status
 set w .tm
 catch {destroy $w}
 toplevel $w
 wm withdraw .
 wm title $w "TkTreemap"
 wm geometry $w +100+10

 image create photo button_dir -data [Images button_dir]
 image create photo button_up  -data [Images button_up]
 set status " "
 set dirname [pwd]
 set odirname {}

 pack [canvas $w.c -width $cx -height $cy -bg white]

 set f1 [frame $w.f1 -relief sunken -borderwidth 2]
 pack $f1 -fill x
 label $f1.ld -text "Directory "
 entry $f1.e1 -width 64 -textvariable dirname
 button $f1.bbrowse -image button_dir -relief flat \
       -command {
                 set odirname {}
                 set dir [BrowseDir $dirname]
                 if {$dir != ""} then {set dirname $dir}
                }
 button $f1.bup -image button_up -relief flat -command {UpDir}
 label $f1.l1 -text "    "
 button $f1.br -text Run -width 6 -bg blue -fg white \
       -command {InitTreemap .tm [InitDirTree $dirname]}
 button $f1.ba -text About -width 6 -bg blue -fg white -command {About}
 button $f1.bq -text Quit -width 5 -bg blue -fg white -command exit
 eval pack [winfo children $f1] -side left
 set f2 [frame $w.f2 -borderwidth 2]
 pack $f2 -fill x
 label $f2.lt -width 26 -relief sunken -text " "
 label $f2.ls -width 89 -relief sunken -textvariable status
 eval pack [winfo children $f2] -side left

 bind $f1.bbrowse <Enter> "set status {Choose directory}"
 bind $f1.bbrowse <Leave> {set status ""}
 bind $f1.bup <Enter> "set status {Previous directory}"
 bind $f1.bup <Leave> {set status ""}
}

# Canvas size
Main 700 480