#!/usr/local/bin/wish -f
## -*- Mode: TCL -*-

## ^^^^^^
## CHANGE #! entry at top of this file to point to your
## copy of Tcl/Tk, i.e. wish.

## Drew J. Asson, SST
## Started: 16 Nov 94
## Last updated: 5 April 1995
##
## Provide graphical view of [incr Tcl] classes and their components
##
## Release 1.0
##    - fixed up Generate_PS routine to print out everything viewable
##      on screen
## Release 0.95
##    - made independent (I think) from TclX by changing use of lassign
##      to a new routine called var_assign, which does the same thing.
##
## =========================================
##    Drew J. Asson, Sr. S/W Engr -- SST
##    Space Telescope Science Institute
##    (410) 338-4474, Fax: (410) 338-1592
## =========================================
##        STScI: asson@stsci.edu
##     Newton: DrewJAsson (@eworld.com)
## http://chacmool.stsci.edu:8001/asson.html
## =========================================

## ----------------------------------------------------------------
## Included below is the foxTypedOpts.tcl script 
## ----------------------------------------------------------------
##
# typedopts -- parse command line options in TCL
#
# USAGE:
#   typedopts <arg-list> <opt-list> <opt-ret> <arg-ret> <rest>
#     [ <options> ]
#
# OPTIONS:
#   -noinit
#     Don't initialize <opt-ret> and <arg-ret>
#
# typedopts is a command line option parser.  It reads <arg-list> and
# finds all the options that are described in <opt-list>.  If no errors
# are found, then typedopts will <rest> to the command line arguments
# that weren't parsed, set <opt-ret> and <arg-ret> as described below,
# and return 1.  <opt-ret> and <arg-ret> will be set to arrays, indexed
# by the names of the options in <opt-list>.  <opt-ret> will contain
# boolean values indicating which options were found in <arg-list>, and
# <arg-ret> will contain the arguments to the options found.
#
# <opt-list> is a TCL list that describes all of the options that the
# program accepts.  It consists of type-name pairs: { <type> <name>
# <type> <name> ... }.  <type> describes what type of argument the
# option may take; the types are described below.  Some of the types
# require additional parameters; for these types, <type> must be a TCL
# list with the type name followed by the parameters.
#
# <name> is the name of the option; if the program accepts more than
# one option of type <type>, then <name> may be a TCL list of all the
# options of that type.  The option may be abbreviated on the command
# line, as long as the abbreviation uniquely identifies one option.
#
# The types for <type> are listed here.  The type name in <type> may be
# a unique abbreviation of the type name listed.
#
#     boolean
#       A simple flag; no argument is accepted for the option.
#
#     string
#       A string -- no type checking is done.
#
#     float
#       A floating point number.  All of the TCL floating point formats
#       should be accepted for this.
#
#     integer
#       An integer.
#
#     number
#       A floating point number or an integer.
#
#     one-of <value>...
#       One of a specific set of values.  The values may be abbreviated
#       when used on the command line.
#
#     list-of <type>
#       A list of values of type <type>.  The list ends when one of the
#       following is found:  A valid command line option, the string
#       "--", or the end of <arg-list>.
#
#     multiple <type>
#       This option takes one argument of type <type>, but may appear
#       more than once on the command line.  If an option is not
#       specified as being of type multiple... then it may appear only
#       once.
#
# If an option is of type list-of... or multiple..., then the value
# found for that option in <arg-ret> will be a TCL list of all the
# values found for the option, in the order that they appeared on the
# command line.
#
# If typedopts finds an option that is not described in <opt-list>, or
# if it finds an option argument of the wrong type, it will set
# <arg-ret>(_ERROR_) to an error message, set <rest> to the rest of the
# options and arguments, and return 0.
#
# If the -noinit option is given to typedopts, then the <opt-ret> and
# <arg-ret> will _not_ be initialized.  This allows the program to call
# typedopts several times with different <arg-list>s without losing the
# information from previous calls.
#
# if typedopts can't parse its options for any reason, it will print an
# error message to stderr and return a -1 without modifying any other
# variables.
#
# EXAMPLE:
#
# The command line parser for a simple text formatter is given below.
# The formatter accepts the options -top, -bottom, -left, -right, and
# -paragraph to set the margins, -header to set the header string,
# -pagenum to set the page number, and -position to position the page
# number in the footer (the position can be left, right, or center).
# It first parses arguments from the environment variable TFORMAT, then
# from the command line.  The command line can have options and
# filenames intermixed; the options affect all files found after the
# option.
#
# proc parseOpts { } {
#
# # global variables needed:  env = environ variables array,
# #                           argv == command line args
#   global env argv
#
# # The options list: (they have to be declared multiple, because we
# # aren't re-initializing the option arrays each time.
#   set optlist {
#     { multiple integer } { left right top bottom paragraph pagenum }
#     { multiple string } header
#     { multiple one-of left right center } position
#   }
#
# # check if we have a $TFORMAT environment variable to parse
#   if { [ lsearch -exact [ array names $env ] "TFORMAT" ] > -1 } then {
#
# # initialize the options arrays found() and values() with the values
# # from TFORMAT
#     set list $env(TFORMAT)
#     while { ! [ typedopts $list $opts found values list ] } {
#
# # error returned from typedopts:  print the error message and
# # continue parsing
#       puts stderr "Parsing \$TFORMAT: $values(_ERROR_)"
#     }
#
# # check if there are any arguments left; if so, give a warning.
#   if { [ llength $list ] } then {
#     puts stderr "Warning:  \$TFORMAT has non-option arguments!"
#   }
#
#   } else {
#
# # initialize options arrays found() and values() from an empty list
#     typedopts { } $opts found values
#   }
#
# # start parsing the command line.  As long as its not empty, we first
# # pass pass it through the option parser, then call the formatter on
# # the files.
#   while { [ llength $argv ] } {
#     while { ! [ typedopts $argv $opts found values argv -noinit ] } {
#       puts stderr "$values(_ERROR_)"
#     }
#     format [ lindex $argv 0 ]
#     set argv [ lrange $argv 1 end ]
#   }
# }
#
# REVISION HISTORY
#
# 1.1.1.1
#   asson
#     1994/09/07 12:15:41
#
# foxTypedOpts.tcl,v
# Revision 1.1.1.1  1994/09/07  12:15:41  asson
# Imported sources
#
# Revision 1.1  1994/07/29  17:34:20  asson
# 0.9b
#
#   Revision 1.0  1994/02/19  22:04:23  darkfox
#   Initial revision
#

proc typedopts { args } {

    proc abbr { s1 s2 } {
	if { [ set len [ string length $s1 ]] } then {
	    if { ! [ string compare $s1 [ string range $s2 0 [ expr $len - 1 ]]] } then {
		return 1
	    }
	}
	return 0
    }

    proc findabbr { list val } {
	set list [ lsort $list ]
	if { [ set pos [ lsearch -exact $list $val ]] > -1 } then {
	    return [ lindex $list $pos ]
	}
	if { [ set pos [ lsearch -glob $list "$val*" ]] > -1 } then {
	    if { [ abbr $val [ set realval [ lindex $list $pos ]]] } then {
		if { ! [ abbr $val [ lindex $list [ incr pos ]]] } then {
		    return $realval
		}
	    }
	}
	return ""
    }
    
    proc shift { listname } {
	upvar $listname list
	set ret [ lindex $list 0 ]
	set list [ lrange $list 1 end ]
	return $ret
    }
    
    proc extract { list args } {
	foreach arg $args {
	    upvar $arg var
	    set var [ shift list ]
	}
	return $list
    }
    
    proc parseFormats { fmts var } {
	foreach fmt $fmts {
	    if { [ regexp $fmt $var ] } then {
		return 1
	    }
	}
	return 0
    }
    
    proc parseOptionType { type listname retname } {
	upvar $listname args
	upvar $retname var
	
	set ifmt {
	    "^\[+-\]?0x\[0-9a-fA-F\]+\$"
	    "^\[+-\]?0\[0-7\]+\$"
	    "^\[+-\]?\[0-9\]+\$"
	}
	
	set ffmt {
	    "^\[+-\]?\.\[0-9\]+(\[Ee\]\[+-\]?\[0-9\]*)?\$"
	    "^\[+-\]?\[0-9\]+\.\[0-9\]*(\[Ee\]\[+-\]?\[0-9\]*)?\$"
	    "^\[+-\]?\[0-9\]+\[Ee\]\[+-\]?\[0-9\]*\$"
	}
	
	set nfmt [ concat $ifmt $ffmt ]
	
	set otype $type
	switch -exact [ shift type ] {
	    b {
		set var ""
		return 1
	    }
	    i {
		if { [ llength $args ] } then {
		    set val [ shift args ]
		    if { [ parseFormats $ifmt $val ] } then {
			set var $val
			return 1
		    }
		}
		set var "requires an integer argument."
		return 0
	    }
	    f {
		if { [ llength $args ] } then {
		    set val [ shift args ]
		    if { [ parseFormats $ffmt $val ] } then {
			set var $val
			return 1
		    }
		}
		set var "requires a floating-point argument."
		return 0
	    }
	    n {
		if { [ llength $args ] } then {
		    set val [ shift args ]
		    if { [ parseFormats $nfmt $val ] } then {
			set var $val
			return 1
		    }
		}
		set var "requires a numeric argument."
		return 0
	    }
	    s {
		if { [ llength $args ] } then {
		    set var [ shift args ]
		    return 1
		}
		set var "requires a string argument."
		return 0
	    }
	    o {
		if { [ llength $args ] } then {
		    if { [ string length [ set val [ findabbr $type [ shift args ]]]] } then {
			set var $val
			return 1
		    }
		}
		set var "requires a string argument."
		return 0
	    }
	    m {
		return [ parseOptionType $type args var ]
	    }
	    l {
		set val ""
		while { [ llength $args ] && ! [ string match "-*" $args ] } {
		    if { ! [ parseOptionType $type args ret ] } then {
			set var $ret
			return 0
		    }
		    lappend val $ret
		}
		set var $val
		return 1
	    }
	    default {
		puts stderr "Eek!  Option type <$otype> not supported yet!"
		set var "isn't a supported type."
		return 0
	    }
	}
    }
    
    proc parseOption { optlist } {
	set type [ shift optlist ]
	
	switch -exact [ findabbr { "booleans" "integers" "numbers" "floats" "strings" "one-of" "list-of" "multiple" } $type ] {
	    "booleans" -
	    "integers" -
	    "numbers" -
	    "floats" -
	    "strings" {
		if { [ llength $optlist ] } then {
		    puts stderr "typedopts:  Type $type doesn't take arguments"
		    return ""
		}
		return [ string index $type 0 ]
	    }
	    "one-of" {
		if { ! [ llength $optlist ] } then {
		    puts stderr "typedopts:  No arguments given to type $type"
		    return ""
		}
		return [ concat [ string index $type 0 ] $optlist ]
	    }
	    "list-of" -
	    "multiple" {
		if { ! [ llength $optlist ] } then {
		    puts stderr "typedopts:  No arguments given to type $type"
		    return ""
		}
		if { ! [ string length [ set subtype [ parseOption $optlist ]]] } then {
		    return ""
		}
		return [ concat [ string index $type 0 ] $subtype ]
	    }
	    default {
		puts stderr "typedopts:  Unknown option type $type"
		return ""
	    }
	}
    }
    
    set doinit 1
    
    if { [ llength $args ] < 5 } then {
	puts stderr "typedopts: bad number of arguments."
	return -1
    }
    
    set args [ extract $args arglist optlist optret argret restret ]
    
    while { [ llength $args ] } {
	set opt [ shift args ]
	switch -exact [ findabbr { -noinitialize } $opt ] {
	    -noinitialize {
		set doinit 0
	    }
	    default {
		puts stderr "typedopts: bad option \"$opt\": should be -noinitialize or --"
		return -1
	    }
	}
    }
    
    upvar $optret _opts
    upvar $argret _args
    upvar $restret _rest
    
    set allopts ""
    
    set type ""
    
    foreach word $optlist {
	set word [ string trim $word ]
	if { [ string length $type ] } then {
	    foreach arg $word {
		if { [ lsearch -exact $arg $allopts ] > -1 } then {
		    puts stderr "typedopts: option -$arg multiply declared."
		    return -1
		}
		lappend allopts $arg
		set opttype($arg) $type
	    }
	    set type ""
	} else {
	    if { ! [ string length [ set type [ parseOption $word ]]] } then {
		return -1
	    }
	}
    }
    
    if { $doinit } then {
	foreach opt $allopts {
	    set _opts($opt) 0
	    set _args($opt) ""
	}
    }
    
    set _args(_ERROR_) ""
    
    set retval 1
    
    while { [ llength $arglist ] } {
	switch -glob -- $arglist {
	    -- {
		shift arglist
		break
	    }
	    -* {
	    }
	    * {
		break
	    }
	}
	set opt [ string range [ shift arglist ] 1 end ]
	if { [ string length [ set fnd [ findabbr $allopts $opt ]]] } then {
	    set type $opttype($fnd)
	    if { [ parseOptionType $opttype($fnd) arglist arg ] } then {
		if { $_opts($fnd) && ! [ string match "m*" $type ] } then {
		    set _args(_ERROR_) "Found multiple occurrences of option -$fnd"
		    set retval 0
		    break
		}
		set _opts($fnd) 1
		set _args($fnd) $arg
	    } else {
		set _args(_ERROR_) "Option -$fnd $arg"
		set retval 0
		break
	    }
	} else {
	    set _args(_ERROR_) "Unknown option: -$opt"
	    set retval 0
	    break
	}
    }
    
    set _rest $arglist
    
    return $retval
}

## ----------------------------------------------------------------
## End of the foxTypedOpts.tcl script 
## ----------------------------------------------------------------

########################################################
### BEGIN class-browser code
########################################################

## num_min and var_assign are used to replicate the lassign function
## of Extended Tcl (tclX).

proc num_min { x y } { if { $x <= $y } { return $x } else { return $y } }

proc var_assign { entries args } {

    set args_len [llength $args]
    set entries_len [llength $entries]

    set new_len [num_min $args_len $entries_len]

    for {set x 0} {$x<$new_len} {set x [expr $x + 1]} {
        uplevel 1 set [lindex $args $x] [lindex $entries $x]
    }
    if {$args_len < $entries_len} {
        return [lrange $entries $args_len end]
    } elseif {$entries_len < $args_len} {
        foreach entry [lrange $args $new_len end] {
            uplevel 1 set $entry \"\" ; ## "
        }
    }
}

proc debug { x } {
    global DEBUG

    if { $DEBUG } { puts $x }
}

proc Pushnew { listname val {debug 0}} {
    upvar $listname arr

    if {[info exists arr]} {
	if { $arr==""} {
	    set arr $val
	} elseif {[lsearch $arr $val] == -1} {
	    append arr " $val"
	}
    } else {
	set arr $val
    }
}

proc Calculate_Root_Classes {} {
    global root

    set root_list ""
    
    foreach entry [array names root] {
	if {$root($entry)} {
	    Pushnew root_list $entry
	}
    }
    return [lsort -ascii $root_list]
}

proc Get_All_Class_Info { item } {
    global classes methods constructors destructors public protected common

    if {[info exists methods($item)]} {
	set meths [lsort $methods($item)]
	regsub -all " " $meths "\n  " meths
	set meths [format "\n\nMethods:\n  %s"  $meths]
    } else { set meths "" }
    
    if {[info exists public($item) ]} {
	set publics [lsort $public($item)]
	regsub -all " " $publics "\n  " publics
	set publics [format "\n\nPublic:\n  %s"  $publics]
    } else { set publics "" }

    if {[info exists protected($item)]} {
	set protecteds [lsort $protected($item)]
	regsub -all " " $protecteds "\n  " protecteds
	set protecteds [format "\n\nProtected:\n  %s"  $protecteds]
    } else { set protecteds "" }
    
    if {[info exists common($item)]} {
	set commons [lsort $common($item)]
	regsub -all " " $commons "\n  " commons
	set commons [format "\n\nCommons:\n  %s"  $commons]
    } else { set commons "" }
    
    if {[info exists constructors($item)]} {
	set constructor "yes"
    } else { 
	set constructor "no" 
    }
    
    if {[info exists destructors($item)]} {
	set destructor "yes"
    } else { 
	set destructor "no" 
    }
    
    set out [format "$item\nConstructor: $constructor\n Destructor: \
	    $destructor$publics$protecteds$commons$meths"]
    return $out
}

proc Draw_Item { x y str item } {
    global min_box_x max_box_x min_box_y max_box_y

    .top.can create text $x $y -text $str -tags "$item class" -width 150 \
	    -font -adobe-times-medium-r-normal--*-120-* -anchor nw

    ## put box around text.
    var_assign [.top.can bbox "$item"] x1 y1 x2 y2
    set x1 [expr $x1 - 10]
    set y1 [expr $y1 -10]
    set x2 [expr $x2 +10]
    set y2 [expr $y2 + 10]
    debug " *** placing rectangle at ($x1,$y1) to ($x2,$y2)"
    .top.can create rectangle $x1 $y1 $x2 $y2 -tags "box_$item"
    var_assign [.top.can bbox $item] x1 y1 x2 y2
    if { $x1 < $min_box_x } { set min_box_x $x1 }
    if { $y1 < $min_box_y } { set min_box_y $y1 }
    if { $x2 > $max_box_x } { set max_box_x $x2 }
    if { $y2 > $max_box_y } { set max_box_y $y2 }
    return [list $x1 $x2 $y1 [expr $y2+40]]
}

proc Is_Leaf { node } {
    global classes

    if {$classes($node) == ""} { return 1 } else { return 0 }
}

proc Draw_Classes { root x base_y } {
    global drawn full_info classes

    debug " * Draw classes invoked for $root"
    debug " ** IN: y is $base_y"
    set y $base_y
    
    debug " ** root is $root"

    foreach entry [lsort -ascii $classes($root)] {
	if { ![info exists drawn($entry)]} {
	    debug " *** entering $entry FROM $root"
	    set y [Draw_Classes $entry [expr $x + 150+10+40] $y]
	    debug " *** returning to $root"
	}
    }

    debug " ** Drawing $root"
    if { $full_info } {set out [Get_All_Class_Info $root]} else {set out $root}
    if { [Is_Leaf $root]} {
	debug " **** LEAF ($x $y)"
	var_assign [Draw_Item $x $y $out $root] x1 x2 y1 y2
    } else {
	debug " **** NON-LEAF ( $x , [expr ($y+$base_y)/2] ) "
	var_assign [Draw_Item $x [expr ($y+$base_y)/2] $out $root] x1 x2 y1 y2
	if { $y > $y2 } { set y2 $y }
    }

    set drawn($root) 1

    debug " *** returning $y2"
    return $y2
}

proc Draw_Links {} {
    global classes

    puts " * Drawing links"
    foreach class [array names classes] {
	var_assign [.top.can bbox "box_$class"] x1 y1 class_x y2
	if { $x1 == "" } {continue}
	set class_y [expr ($y1+$y2)/2]
	foreach child $classes($class) {
	    var_assign [.top.can bbox "box_$child"] child_x y1 x2 y2
	    if {$child_x == ""} {continue}
	    set child_y [expr ($y1+$y2)/2]
	    .top.can create line $class_x $class_y $child_x $child_y -arrow last \
		    -tags "link: ${class} to ${child}"
	}
    }
}

proc Use_All_Nodes { all { new_root ""} } {
    global all_nodes new_base_root

    if { $all } {
	set all_nodes 1
	set new_base_root ""
    } else {
	set all_nodes 0
	set new_base_root $new_root
    }
}

proc Focus_On {} {
    global current_root

    if { $current_root != ""} {
	Use_All_Nodes 0 $current_root
	Redraw
    }
}

proc Return_To_All_Classes {} {
    global current_root

    set current_root ""
    Use_All_Nodes 1
    Redraw
}

proc Redraw {} {
    global all_roots max_box_x max_box_y min_box_x min_box_y drawn
    global current_root new_base_root all_nodes
    global Big_Val Little_Val

    catch {.top.can delete all}
    catch { unset drawn }
    set min_box_x $Big_Val
    set min_box_y $Big_Val
    set max_box_x $Little_Val
    set max_box_y $Little_Val
    set x 40
    set y 40
    if { $all_nodes } {
	foreach entry $all_roots {
	    set y [Draw_Classes $entry $x $y]
	}
    } else {
	set y [Draw_Classes $new_base_root $x $y]
    }

    bind .top.can <ButtonPress-1> {Focus_On}

    .top.can bind class <Any-Enter> {
	global current_root classes

	set tmp [.top.can itemconfigure current -tags]
	foreach entry $tmp {
	    foreach sub_entry $entry {
		if { [info exists classes($sub_entry)]} {
		    set current_root $sub_entry
		    break
		}
		if {$current_root != ""} {break}
	    }
	}
    }

    .top.can bind class <Any-Leave> {
	global current_root

	set current_root ""
    }

    .top.can configure -scrollregion \
	    [list [expr $min_box_x - 30] [expr $min_box_y - 30] \
	    [expr $max_box_x + 30] [expr $max_box_y + 30]]
    .top.can xview $min_box_x
    .top.can yview $min_box_y
    Draw_Links
}

proc Generate_PS {} {
    global DEBUG

    var_assign [.top.can bbox all] x1 prev_y doc_x_size doc_y_size
    debug "  **** $x1, $prev_y, $doc_x_size, $doc_y_size"
    set dpi [winfo pixels . 1i]
    debug "  **** DPI is $dpi"
    set calc_doc_y_size [expr $doc_y_size / $dpi]
    set calc_doc_x_size [expr $doc_x_size / $dpi]

    set fd [open "Class-Browser.ps" w]
    set pg_num 1

    set height 10 ; set width 7.5
    set start_y 0 ; set end_y [expr $start_y + $height]

    while {1} {
	set start_x 0
	set end_x [expr $start_x + $width]

	while {1} {
	    set objs [.top.can find overlapping \
		    "${start_x}i" "${start_y}i" "${end_x}i" "${end_y}i"]
	    if [llength $objs] {
		puts stdout "  Saving page $pg_num"
		if { $DEBUG } {
		    foreach entry $objs {
			puts "    ** Object [.top.can gettags $entry]"
		    }
		}
		incr pg_num
		puts $fd [.top.can postscript -x "${start_x}i" -y "${start_y}i" \
			-height 10i -width 7.5i \
			-pageheight "${height}i" -pagewidth "${width}i"]
	    }
	    set start_x $end_x
	    set end_x [expr $start_x + $width]
	    if { $start_x > $calc_doc_x_size } { break }
	}

	set start_y $end_y
	set end_y [expr $start_y + $height]
	if { $start_y > $calc_doc_y_size } {break}
    }
    close $fd
    puts "  Finished generating PS file."
}

proc Read_File { filename } {
    global classes methods constructors destructors public protected common
    global root
    
    puts stdout " * Reading $filename"
    flush stdout
    set re(ws) "\[ \t\n\r\f\]"
    set re(word) "(\[A-Za-z0-9\_\]+)"

    if {![file exists $filename]} {
	puts " ** File $filename does not exist."
	return 0
    }

    if [catch { set fd [open $filename r] } msg] {
	puts " ** Unable to open $filename"
	return 0
    }
    
    while { [gets $fd line] >= 0} {
	if { [regexp "^$re(ws)*#" $line]} {continue}
	if {[regexp "^$re(ws)*itcl_class$re(ws)*$re(word)" $line match name]} {
	    if { ![info exists classes($name)]} {
		set classes($name) ""
	    }
	    set root($name) 1
	} elseif {[regexp "^$re(ws)*inherit$re(ws)*(.*)" $line match inh_list]} {
	    set root($name) 0
	    foreach entry $inh_list { 
		Pushnew classes($entry) $name
		if { ![info exists root($entry)] } {
		    set root($entry) 1
		}
	    }
	} elseif {[regexp "^$re(ws)*method$re(ws)*$re(word)" $line match method]} {
	    Pushnew methods($name) $method
	} elseif {[regexp "^$re(ws)*constructor" $line]} { 
	    set constructors($name) 1
	} elseif {[regexp "^$re(ws)*destructor" $line]} {
	    set destructors($name) 1
	} elseif {[regexp "^$re(ws)*public$re(ws)*$re(word)" $line match var]} {
	    Pushnew public($name) $var
	} elseif {[regexp "^$re(ws)*protected$re(ws)*$re(word)" $line match var]} {
	    Pushnew protected($name) $var
	} elseif {[regexp "^$re(ws)*common$re(ws)*$re(word)" $line match var]} {
	    Pushnew common($name) $var
	}
    }
}

set help_string "
The class browser is used to view \[incr Tcl\] class definitions\
including their internals (methods, variables, constructors, etc.).\
The graph is drawn by selecting as root nodes all the classes that do\
not inherit from anyone else.

There are two views available, 'Full Display' and 'Show only class names'.\
The full display is used to see all the information in the class.  The other\
method is to show only the class names.  It sometimes helps to navigate with\
just the class names, but to use the Full Display option once you've found\
the area you wish to look at.

Since the tree generated can be quite crowded, you can reselect the base node\
by just clicking on a node, in either Full Display or Show only class names mode.\
This redraws the graph using that node as the base.  You can return to viewing\
all the nodes by hitting the 'Show all nodes' button.

The 'Generate_PS' button generates a PostScript file of the entire display.
"

proc Help {} {
    global help_string

    toplevel .help
    wm title .help "Class Browser Help"
    
    message .help.help -text $help_string -width 500 -borderwidth 5
    button .help.quit -text "Dismiss" -command "destroy .help"
    pack .help.help -in .help -side top
    pack .help.quit -in .help -side top -fill x
}

set usage "Usage is \n\
	class-browser \[-debug\] \[-only-classes\] \[-full-info\] <files>\n\n\
	only-classes brings up only the class names in the files\n\
	full-info brings up all information found about that class\n\
	debug puts debugging information to stdout.\n"

proc Die_Win_Info { msg } {
    message .msg -text $msg -width 500
    button .quit -text "Quit" -command "destroy ."
    pack .msg -in . -side top
    pack .quit -in . -side top -fill x
    update
    tkwait window .
    exit 1
}

proc Init_Window {} {
    wm title . "Class Browser 1.0"
    frame .top

    ## create canvas and scroll bars
    canvas .top.can -borderwidth 2 -background gray \
	    -xscrollcommand {.top.scrollx set} \
	    -yscrollcommand {.top.scrolly set} \
	    -scrollincrement 20 \
	    -width 800 -height 600 \
	    -scrollregion {-10 -10 9000 9000}
    
    scrollbar .top.scrollx -orient horiz -relief sunken -command ".top.can xview"
    scrollbar .top.scrolly -relief sunken -command ".top.can yview"
    pack append .top .top.scrollx {bottom fillx} .top.scrolly {right filly} \
	    .top.can {expand fillx filly}
    
    ## set up buttons
    frame .bot -borderwidth 10
    button .bot.quit -text "Quit" -command "destroy ."
    button .bot.full -text "Full display" -command "Use_Full_Info 1 ; Redraw"
    button .bot.short -text "Show only class names" -command "Use_Full_Info 0 ; Redraw"
    button .bot.all -text "Show all nodes" -command Return_To_All_Classes
    button .bot.print -text "Generate PS file" -command Generate_PS
    button .bot.help -text "Help" -command Help
    pack append .bot \
	    .bot.full { left expand fillx} \
	    .bot.short { left expand fillx} \
	    .bot.all { left expand fillx} \
	    .bot.print {left expand fillx} \
	    .bot.help {left expand fillx} \
	    .bot.quit {left expand fillx}
    pack append . .top {top} .bot {top expand fillx}
}

proc Use_Full_Info { flag } {
    global full_info

    if { $flag } {set full_info 1} else {set full_info 0}
}

proc Top_Level {} {
    global argv all_roots DEBUG classes usage
    
    if {$argv==""} { Die_Win_Info $usage}

    set optlist { boolean debug boolean only-classes boolean full-info }

    typedopts $argv $optlist opts args rest

    if {$opts(debug)} {set DEBUG 1}
    if {$opts(only-classes)} { Use_Full_Info 0 }
    if {$opts(full-info)} {Use_Full_Info 1}
    
    ## iterate through file names
    foreach entry $rest { Read_File $entry }

    if { ![info exists classes] } {
	Die_Win_Info "No \[incr Tcl\] information found."
    }

    ## set up window
    Init_Window

    ## Find base nodes for class trees
    set all_roots [Calculate_Root_Classes]

    ## Draw it
    Redraw
}

set tcl_precision 17
set Big_Val 10000000
set Little_Val -10000000
Use_Full_Info 1
set DEBUG 0
Use_All_Nodes 1
set current_root ""
Top_Level
