Posted to tcl by gps at Sat Apr 25 19:47:51 GMT 2009view raw
- package require Tk
- set dir [file dirname [info script]]
- load [file join $dir objstructure.so]
- set ::mode view
- pack [label .l -textvariable ::mode] -fill x -expand 1
- pack [text .t -bg black -font {Vera 18}] -fill both -expand 1
- bind .t <Escape> [list up]
- proc up {} {
- global root path
- set path [lrange $path 0 end-1]
- render $root $path
- }
- proc node {pnode name} {
- global root
- set n [objstructure]
- if {"" ne $pnode} {
- set clist [$pnode children]
- lappend clist $n
- $pnode children $clist
- }
- $n ::add-keys \
- parent $pnode \
- name $name \
- data "" \
- children [list]
- return $n
- }
- proc follow name {
- global root path
- lappend path $name
- render $root $path
- }
- proc render-recurse {node path} {
- puts "$node $path"
- set p [lindex $path 0]
- if {![llength $path]} {
- set n 1
- foreach child [$node children] {
- puts FOUND:[$child name]
- set tag link$n
- .t insert end [$child name] $tag
- .t insert end \n
- .t tag configure $tag -foreground white -background blue
- .t tag bind $tag <ButtonPress-1> [list follow [$child name]]
- incr n
- }
- } else {
- foreach child [$node children] {
- if {$p eq [$child name]} {
- render-recurse $child [lrange $path 1 end]
- }
- }
- }
- }
- proc render {root path} {
- .t delete 1.0 end
- render-recurse $root [lrange $path 1 end]
- }
- proc main {argv} {
- set root [node {} root]
- set design [node $root design]
- set notes [node $root notes]
- set code [node $root code]
- set modules [node $code modules]
- set libc [node $modules libc]
- set main [node $modules main]
- set include [node $main include]
- set procs [node $main procedures]
- set ::root $root
- set ::path [list $root]
- render $root $::path
- }
- main $::argv