First version of new where axis
[dyninst.git] / paradyn / tcl / whereAxis.tcl
1 # whereAxis.tcl
2 # Ariel Tamches
3
4 #
5 # $Log: whereAxis.tcl,v $
6 # Revision 1.1  1995/07/17 05:00:34  tamches
7 # First version of new where axis
8 #
9 #
10
11 proc resize1Scrollbar {sbname newTotal newVisible} {
12    # This is a nice n' generic routine  --ari
13    # However, it is (currently) only called from C++ code.  If this
14    # situation doesn't change, then we might want to just
15    # zap this and turn it into C++ code...
16
17    # 'newTotal' and 'newVisible' are tentative values;
18    # We use them to calculate 'newFirst' and 'newLast'.
19    # We make an effort to keep 'newFirst' as close as possible to 'oldFirst'.
20
21    set oldConfig [$sbname get]
22    set oldFirst  [lindex $oldConfig 0]
23    set oldLast   [lindex $oldConfig 1]
24 #   puts stderr "oldFirst=$oldFirst; oldLast=$oldLast"
25
26    if {$newVisible < $newTotal} {
27       # The usual case: not everything fits
28       set fracVisible [expr 1.0 * $newVisible / $newTotal]
29 #      puts stderr "newVisible=$newVisible; newTotal=$newTotal; fracVisible=$fracVisible"
30
31       set newFirst $oldFirst
32       set newLast [expr $newFirst + $fracVisible]
33
34 #      puts stderr "tentative newFirst=$newFirst; newLast=$newLast"
35      
36       if {$newLast > 1.0} {
37          set theOverflow [expr $newLast - 1.0]
38 #         puts stderr "resize1Scrollbar: would overflow by fraction of $theOverflow; moving newFirst back"
39          set newFirst [expr $oldFirst - $theOverflow]
40          set newLast  [expr $newFirst + $fracVisible]
41       } else {
42 #         puts stderr "resize1Scrollbar: yea, we were able to keep newFirst unchanged at $newFirst"
43       }
44    } else {
45       # the unusual case: everything fits (visible >= total)
46       set newFirst 0.0
47       set newLast  1.0
48    }
49
50    if {$newFirst < 0} {
51       # This is an assertion failure
52       puts stderr "resize1Scrollbar warning: newFirst is $newFirst"
53    }
54    if {$newLast > 1} {
55       # This is an assertion failure
56       puts stderr "resize1Scrollbar warning: newLast is $newLast"
57    }
58   
59    $sbname set $newFirst $newLast
60 }
61
62 # ##################################################################
63
64 proc whereAxisCatchDeleteWindow {} {
65    # change the delete into an iconify
66    wm iconify .whereAxis
67 }
68
69 # ##################################################################
70
71 proc whereAxisInitialize {} {
72    toplevel .whereAxis -class "WhereAxis"
73    option add *whereAxis*Background grey
74    wm protocol .whereAxis WM_DELETE_WINDOW whereAxisCatchDeleteWindow
75    
76    frame .whereAxis.top
77    pack  .whereAxis.top -side top -fill x -expand false -anchor n
78       # area for menubar
79    
80    frame .whereAxis.top.mbar -borderwidth 2 -relief raised
81    pack  .whereAxis.top.mbar -side top -fill both -expand false
82    
83    menubutton .whereAxis.top.mbar.file -text File -menu .whereAxis.top.mbar.file.m
84    menu .whereAxis.top.mbar.file.m -selectcolor cornflowerblue
85    .whereAxis.top.mbar.file.m add command -label "Iconify" -command "wm iconify .whereAxis"
86    
87    menubutton .whereAxis.top.mbar.nav -text Navigate -menu .whereAxis.top.mbar.nav.m
88    menu .whereAxis.top.mbar.nav.m -selectcolor cornflowerblue
89    
90    menubutton .whereAxis.top.mbar.abs -text Abstraction -menu .whereAxis.top.mbar.abs.m
91    menu .whereAxis.top.mbar.abs.m -selectcolor cornflowerblue
92    
93    pack .whereAxis.top.mbar.file .whereAxis.top.mbar.nav .whereAxis.top.mbar.abs -side left -padx 4
94    tk_menuBar .whereAxis.top.mbar .whereAxis.top.mbar.file .whereAxis.top.mbar.nav .whereAxis.top.mbar.abs
95    
96    # -----------------------------------------------------------
97    
98    frame .whereAxis.nontop
99    pack  .whereAxis.nontop -side bottom -fill both -expand true
100    
101    # -----------------------------------------------------------
102    
103    frame .whereAxis.nontop.main -width 3i -height 2.5i
104    pack  .whereAxis.nontop.main -side top -fill both -expand true
105    
106    scrollbar .whereAxis.nontop.main.leftsb -orient vertical -width 16 -background gray \
107         -activebackground gray \
108         -command "newVertScrollPosition"
109    
110    pack .whereAxis.nontop.main.leftsb -side left -fill y -expand false
111    
112    scrollbar .whereAxis.nontop.main.bottsb -orient horizontal -width 16 \
113         -activebackground gray \
114         -command "newHorizScrollPosition"
115    
116    pack .whereAxis.nontop.main.bottsb -side bottom -fill x -expand false
117    
118    #canvas .whereAxis.nontop.main.all -relief flat -width 3i -height 2i \
119    #    -yscrollcommand myYScrollCommand \
120    #    -xscrollcommand myXScrollCommand \
121    #    -scrollincrement 1
122    frame .whereAxis.nontop.main.all -relief flat -width 3i -height 2i
123    pack .whereAxis.nontop.main.all -side left -fill both -expand true
124    
125    # -----------------------------------------------------------
126    
127    label .whereAxis.nontop.tip1 -relief sunken -text "Click to select; double-click to expand/un-expand" -font "*-Helvetica-*-r-*-12-*"
128    pack  .whereAxis.nontop.tip1 -side top -fill both -expand false
129       # fill both (instead of just x) seems needed to prevent from shrinking
130       # when window made shorter
131    
132    label .whereAxis.nontop.tip2 -relief sunken -text "Shift-double-click to expand/un-expand ALL subtrees of a node" -font "*-Helvetica-*-r-*-12-*"
133    pack  .whereAxis.nontop.tip2 -side top -fill both -expand false
134       # fill both (instead of just x) seems needed to prevent from shrinking
135       # when window made shorter
136    
137    # -----------------------------------------------------------
138    
139    frame .whereAxis.nontop.find
140    pack  .whereAxis.nontop.find -side top -fill both -expand false
141    
142    label .whereAxis.nontop.find.label -relief sunken -font "*-Helvetica-*-r-*-12-*" -text "Search:"
143    pack  .whereAxis.nontop.find.label -side left -fill y -expand false
144    
145    entry .whereAxis.nontop.find.entry -relief sunken -font "*-Helvetica-*-r-*-12-*"
146    pack  .whereAxis.nontop.find.entry -side left -fill x -expand true
147    
148    bind  .whereAxis.nontop.find.entry <Return> {findHook [.whereAxis.nontop.find.entry get]}
149    
150    # -----------------------------------------------------------
151    
152    # install resize, expose, and button event hooks for .whereAxis.nontop.main.all
153    bind .whereAxis.nontop.main.all <Configure> {configureHook %w %h}
154    bind .whereAxis.nontop.main.all <Expose>    {exposeHook %c}
155    bind .whereAxis.nontop.main.all <Button-1>  {singleClickHook %x %y}
156    bind .whereAxis.nontop.main.all <Double-Button-1> {doubleClickHook %x %y}
157    bind .whereAxis.nontop.main.all <Shift-Double-Button-1> {shiftDoubleClickHook %x %y}
158    
159    set currMenuAbstraction 1
160 }
161
162 #whereAxisInitialize