removed refs to PdBitmapDir; we now call makeLogo (pdLogo.C)
[dyninst.git] / paradyn / tcl / shg.tcl
1 # shg.tcl
2 # Ariel Tamches
3
4 #
5 # $Log: shg.tcl,v $
6 # Revision 1.3  1995/11/29 00:21:56  tamches
7 # removed refs to PdBitmapDir; we now call makeLogo (pdLogo.C)
8 #
9 # Revision 1.2  1995/11/20 04:06:02  tamches
10 # fixed activeBackground/activeForeground colors that were making for ugly
11 # menu highlighting.
12 #
13 # Revision 1.1  1995/10/17 22:25:14  tamches
14 # First version of new search history graph
15 #
16 #
17
18 proc resize1Scrollbar {sbname newTotal newVisible} {
19    # This is a nice n' generic routine  --ari
20    # However, it is (currently) only called from C++ code.  If this
21    # situation doesn't change, then we might want to just
22    # zap this and turn it into C++ code...
23
24    # 'newTotal' and 'newVisible' are tentative values;
25    # We use them to calculate 'newFirst' and 'newLast'.
26    # We make an effort to keep 'newFirst' as close as possible to 'oldFirst'.
27
28    set oldConfig [$sbname get]
29    set oldFirst  [lindex $oldConfig 0]
30    set oldLast   [lindex $oldConfig 1]
31    #   puts stderr "oldFirst=$oldFirst; oldLast=$oldLast"
32
33    if {$newVisible < $newTotal} {
34       # The usual case: not everything fits
35       set fracVisible [expr 1.0 * $newVisible / $newTotal]
36 #      puts stderr "newVisible=$newVisible; newTotal=$newTotal; fracVisible=$fracVisible"
37
38       set newFirst $oldFirst
39       set newLast [expr $newFirst + $fracVisible]
40
41 #      puts stderr "tentative newFirst=$newFirst; newLast=$newLast"
42
43       if {$newLast > 1.0} {
44          set theOverflow [expr $newLast - 1.0]
45 #         puts stderr "resize1Scrollbar: would overflow by fraction of $theOverflow; moving newFirst back"
46          set newFirst [expr $oldFirst - $theOverflow]
47          set newLast  [expr $newFirst + $fracVisible]
48       } else {
49 #         puts stderr "resize1Scrollbar: yea, we were able to keep newFirst unchanged at $newFirst"
50       }
51    } else {
52       # the unusual case: everything fits (visible >= total)
53       set newFirst 0.0
54       set newLast  1.0
55    }
56
57    if {$newFirst < 0} {
58       # This is an assertion failure
59       puts stderr "resize1Scrollbar warning: newFirst is $newFirst"
60    }
61    if {$newLast > 1} {
62       # This is an assertion failure
63       puts stderr "resize1Scrollbar warning: newLast is $newLast"
64    }
65
66    $sbname set $newFirst $newLast
67 }
68
69 proc shgInitialize {} {
70    global shgHack
71    
72    if {[winfo exists .shg]} {
73 #      puts stderr "(shg window already exists; not creating)"
74       wm deiconify .shg
75       raise .shg
76       return
77    }
78
79    toplevel .shg -class "Shg"
80    option add *shg*Background grey
81    option add *shg*activeBackground LightGrey
82    option add *shg*activeForeground black
83    wm protocol .shg WM_DELETE_WINDOW {wm iconify .shg}
84
85    # area for title, menubar, logo
86    frame .shg.titlearea
87    pack  .shg.titlearea -side top -fill x -expand false -anchor n
88
89    frame .shg.titlearea.right
90    pack  .shg.titlearea.right -side right -fill y -expand false
91
92    makeLogo .shg.titlearea.right.logo paradynLogo raised 2 mediumseagreen
93    pack  .shg.titlearea.right.logo -side top
94
95    frame .shg.titlearea.left
96    pack  .shg.titlearea.left -side left -fill both -expand true
97
98    label .shg.titlearea.left.title -text "The Performance Consultant" \
99            -foreground white -anchor c \
100            -font *-New*Century*Schoolbook-Bold-R-*-14-* \
101            -relief raised \
102            -background mediumseagreen
103    pack  .shg.titlearea.left.title -side top -fill both -expand true
104
105    # area for menubar:
106    frame .shg.titlearea.left.menu
107    pack  .shg.titlearea.left.menu -side top -fill x -expand false -anchor n
108
109    frame .shg.titlearea.left.menu.mbar -borderwidth 2 -relief raised
110    pack  .shg.titlearea.left.menu.mbar -side top -fill both -expand false
111
112    menubutton .shg.titlearea.left.menu.mbar.file -text File -menu .shg.titlearea.left.menu.mbar.file.m
113    menu .shg.titlearea.left.menu.mbar.file.m -selectcolor cornflowerblue
114    .shg.titlearea.left.menu.mbar.file.m add command -label "Iconify" -command "wm iconify .shg"
115
116    menubutton .shg.titlearea.left.menu.mbar.phase -text Searches -menu .shg.titlearea.left.menu.mbar.phase.m
117    menu .shg.titlearea.left.menu.mbar.phase.m -selectcolor cornflowerblue
118
119    pack .shg.titlearea.left.menu.mbar.file .shg.titlearea.left.menu.mbar.phase -side left -padx 4
120
121    # -----------------------------------------------------------
122
123    frame .shg.nontop
124    pack  .shg.nontop -side bottom -fill both -expand true
125
126    # -----------------------------------------------------------
127
128    frame .shg.nontop.currphasearea
129    pack  .shg.nontop.currphasearea -side top -fill x -expand false
130
131    label .shg.nontop.currphasearea.label1 -text "Current Phase: " \
132            -font "*-Helvetica-*-r-*-12-*" -anchor e
133    pack  .shg.nontop.currphasearea.label1 -side left -fill both -expand true
134
135    label .shg.nontop.currphasearea.label2 -text "" \
136            -font "*-Helvetica-*-r-*-12-*" -anchor w
137    pack  .shg.nontop.currphasearea.label2 -side left -fill both -expand true
138
139    # -----------------------------------------------------------
140
141    frame .shg.nontop.textarea
142    pack  .shg.nontop.textarea -side top -fill x -expand false
143
144    text .shg.nontop.textarea.text -borderwidth 2 -width 40 -height 5 -relief sunken \
145            -font "*-Helvetica-*-r-*-12-*" \
146            -yscrollcommand ".shg.nontop.textarea.sb set"
147    pack .shg.nontop.textarea.text -side left -fill both -expand true
148
149    scrollbar .shg.nontop.textarea.sb -relief sunken \
150            -command ".shg.nontop.textarea.text yview"
151    pack .shg.nontop.textarea.sb -side right -fill y -expand false
152
153    # -----------------------------------------------------------
154
155    frame .shg.nontop.main -width 4i -height 3.5i
156    pack  .shg.nontop.main -side top -fill both -expand true
157
158    scrollbar .shg.nontop.main.leftsb -orient vertical -width 16 \
159            -background gray \
160            -activebackground gray \
161            -command "shgNewVertScrollPosition"
162
163    pack .shg.nontop.main.leftsb -side left -fill y -expand false
164
165    scrollbar .shg.nontop.main.bottsb -orient horizontal -width 16 \
166         -activebackground gray \
167         -command "shgNewHorizScrollPosition"
168
169    pack .shg.nontop.main.bottsb -side bottom -fill x -expand false
170
171    frame .shg.nontop.main.all -relief flat -width 3i -height 2i
172    pack .shg.nontop.main.all -side left -fill both -expand true
173
174    # -----------------------------------------------------------
175
176    frame .shg.nontop.labelarea
177    pack  .shg.nontop.labelarea -side top -fill x -expand false
178
179 #   label .shg.nontop.labelarea.current -relief sunken -height 1 \
180 #          -font "*-Helvetica-*-r-*-12-*"
181 #   pack  .shg.nontop.labelarea.current -side left -fill both -expand false
182
183    text .shg.nontop.labelarea.current -relief sunken -height 1 \
184            -font "*-Helvetica-*-r-*-12-*" \
185            -wrap none
186    pack .shg.nontop.labelarea.current -side left -fill both -expand true
187
188    # -----------------------------------------------------------
189
190    frame .shg.nontop.buttonarea
191    pack  .shg.nontop.buttonarea -side top -fill x -expand false
192
193    frame .shg.nontop.buttonarea.left
194    pack  .shg.nontop.buttonarea.left -side left -fill y -expand true
195
196    button .shg.nontop.buttonarea.left.search -text "Search" -anchor c \
197            -command {.shg.nontop.buttonarea.left.search config -state normal; \
198                      .shg.nontop.buttonarea.middle.pause config -state normal; \
199                      shgSearchCommand}
200    pack   .shg.nontop.buttonarea.left.search -side left -ipadx 10 -fill y -expand false
201
202    frame .shg.nontop.buttonarea.middle
203    pack  .shg.nontop.buttonarea.middle -side left -fill y -expand true
204
205    button .shg.nontop.buttonarea.middle.pause -text "Pause" -state disabled -anchor c \
206            -command {.shg.nontop.buttonarea.left.search config -state normal; \
207                      .shg.nontop.buttonarea.middle.pause config -state disabled; \
208                      shgPauseCommand}
209    pack   .shg.nontop.buttonarea.middle.pause -side left -fill y -expand false
210
211 #   frame .shg.nontop.buttonarea.right
212 #   pack  .shg.nontop.buttonarea.right -side left -fill y -expand true
213 #
214 #   button .shg.nontop.buttonarea.right.resume -text "Resume" -state disabled -anchor c \
215 #          -command {.shg.nontop.buttonarea.left.search config -state normal; \
216 #                    .shg.nontop.buttonarea.middle.pause config -state normal; \
217 #                    .shg.nontop.buttonarea.right.resume config -state disabled; \
218 #                    shgResumeCommand}
219 #   pack   .shg.nontop.buttonarea.right.resume -side right -fill y -expand false
220
221    # -----------------------------------------------------------
222
223    label .shg.nontop.tip0 -relief groove \
224            -text "Uninstrumented" -anchor c \
225            -font "*-Helvetica-*-r-*-12-*" \
226            -background "#e9fbb57aa3c9"
227               # yuck --ari
228 #          -background Gray
229    pack   .shg.nontop.tip0 -side top -fill both -expand false
230
231    label .shg.nontop.tip1 -relief groove \
232            -text "Instrumented; no decision yet" -anchor c \
233            -font "*-Helvetica-*-r-*-12-*" \
234            -background "#ffffbba5bba5"
235                 # yuck --ari
236 #          -background Tan
237    pack   .shg.nontop.tip1 -side top -fill both -expand false
238
239    label .shg.nontop.tip2 -relief groove \
240            -text "Instrumented; believed true" -anchor c \
241            -font "*-Helvetica-*-r-*-12-*" \
242            -background "#acbff48ff6c8"
243                 # yuck --ari
244 #-text "True (tentatively)"
245
246 #          -background LightBlue
247    pack   .shg.nontop.tip2 -side top -fill both -expand false
248
249    label .shg.nontop.tip3 -relief groove \
250            -text "Uninstrumented; believed false" -anchor c \
251            -font "*-Helvetica-*-r-*-12-*" \
252            -background "#cc85d5c2777d" 
253                 # yuck --ari
254 #          -background pink
255 #False (instrumentation removed)
256
257    pack   .shg.nontop.tip3 -side top -fill both -expand false
258
259    label .shg.nontop.tip4 -relief sunken \
260            -text "Hold down Alt and move the mouse to scroll freely" -anchor c \
261            -font "*-Helvetica-*-r-*-12-*"
262    pack  .shg.nontop.tip4 -side top -fill both -expand false
263
264    # -----------------------------------------------------------
265
266    bind .shg.nontop.main.all <Configure> {shgConfigureHook}
267    bind .shg.nontop.main.all <Expose>    {shgExposeHook %c}
268    bind .shg.nontop.main.all <Button-1>  {shgSingleClickHook %x %y}
269    bind .shg.nontop.main.all <Button-2>  {shgSingleClickHook %x %y}
270    bind .shg.nontop.main.all <Double-Button-1> {shgDoubleClickHook %x %y}
271 #   bind .shg.nontop.main.all <Shift-Double-Button-1> {shgShiftDoubleClickHook %x %y}
272 #   bind .shg.nontop.main.all <Control-Double-Button-1> {shgCtrlDoubleClickHook %x %y}
273    bind .shg.nontop.main.all <Alt-Motion> {shgAltPressHook %x %y}
274    bind .shg.nontop.main.all <Motion> {shgAltReleaseHook %x %y}
275
276    if {$shgHack} {
277 #      puts stderr "shgHack"
278       paradyn shg start global
279    }
280 }