Posted to tcl by gps at Sat Apr 25 19:47:51 GMT 2009view raw

  1. package require Tk
  2.  
  3. set dir [file dirname [info script]]
  4. load [file join $dir objstructure.so]
  5.  
  6. set ::mode view
  7.  
  8. pack [label .l -textvariable ::mode] -fill x -expand 1
  9. pack [text .t -bg black -font {Vera 18}] -fill both -expand 1
  10. bind .t <Escape> [list up]
  11.  
  12. proc up {} {
  13. global root path
  14.  
  15. set path [lrange $path 0 end-1]
  16. render $root $path
  17. }
  18.  
  19. proc node {pnode name} {
  20. global root
  21.  
  22. set n [objstructure]
  23.  
  24. if {"" ne $pnode} {
  25. set clist [$pnode children]
  26. lappend clist $n
  27. $pnode children $clist
  28. }
  29.  
  30. $n ::add-keys \
  31. parent $pnode \
  32. name $name \
  33. data "" \
  34. children [list]
  35.  
  36. return $n
  37. }
  38.  
  39. proc follow name {
  40. global root path
  41.  
  42. lappend path $name
  43. render $root $path
  44. }
  45.  
  46. proc render-recurse {node path} {
  47. puts "$node $path"
  48.  
  49. set p [lindex $path 0]
  50.  
  51. if {![llength $path]} {
  52. set n 1
  53. foreach child [$node children] {
  54. puts FOUND:[$child name]
  55.  
  56. set tag link$n
  57. .t insert end [$child name] $tag
  58. .t insert end \n
  59. .t tag configure $tag -foreground white -background blue
  60. .t tag bind $tag <ButtonPress-1> [list follow [$child name]]
  61. incr n
  62. }
  63. } else {
  64. foreach child [$node children] {
  65. if {$p eq [$child name]} {
  66. render-recurse $child [lrange $path 1 end]
  67. }
  68. }
  69. }
  70. }
  71.  
  72. proc render {root path} {
  73. .t delete 1.0 end
  74. render-recurse $root [lrange $path 1 end]
  75. }
  76.  
  77. proc main {argv} {
  78. set root [node {} root]
  79. set design [node $root design]
  80. set notes [node $root notes]
  81. set code [node $root code]
  82.  
  83. set modules [node $code modules]
  84. set libc [node $modules libc]
  85.  
  86. set main [node $modules main]
  87. set include [node $main include]
  88. set procs [node $main procedures]
  89.  
  90. set ::root $root
  91. set ::path [list $root]
  92.  
  93. render $root $::path
  94. }
  95.  
  96. main $::argv
  97.