removed shgHack
[dyninst.git] / paradyn / tcl / shg.tcl
1 # shg.tcl
2 # Ariel Tamches
3
4 #
5 # $Log: shg.tcl,v $
6 # Revision 1.9  1996/02/07 19:16:30  tamches
7 # removed shgHack
8 #
9 # Revision 1.8  1996/02/02 18:57:22  tamches
10 # added key & tips areas
11 # cleaner search/resume button code
12 # no more "paradyn shg start global" in window startup
13 #
14 # Revision 1.7  1996/01/23 07:14:30  tamches
15 # now 7 eval states, divided among 4 eval states & an active flag
16 #
17 # Revision 1.6  1996/01/11 23:43:49  tamches
18 # there are now 6 node styles instead of 4
19 #
20 # Revision 1.5  1996/01/11 00:53:59  tamches
21 # removed resize1ScrollBar (now in generic.tcl)
22 # removed iconify menu
23 #
24 # Revision 1.4  1996/01/09 01:09:00  tamches
25 # the label area at the bottom of the shg window can now be 1 or
26 # 4 lines in height, depending on the status of the devel mode tc
27 #
28 # Revision 1.3  1995/11/29 00:21:56  tamches
29 # removed refs to PdBitmapDir; we now call makeLogo (pdLogo.C)
30 #
31 # Revision 1.2  1995/11/20 04:06:02  tamches
32 # fixed activeBackground/activeForeground colors that were making for ugly
33 # menu highlighting.
34 #
35 # Revision 1.1  1995/10/17 22:25:14  tamches
36 # First version of new search history graph
37 #
38 #
39
40 proc shgChangeCurrLabelHeight {numlines} {
41    if {[winfo exists .shg.nontop.labelarea.current]} {
42       .shg.nontop.labelarea.current config -height $numlines
43       pack .shg.nontop.labelarea.current -side left -fill both -expand true
44    }
45 }
46
47 proc redrawKeyAndTipsAreas {drawkeychange drawtipschange} {
48    set keyArea .shg.nontop.keyarea
49    set tipArea .shg.nontop.tiparea
50
51    set keyIsUp [winfo exists $keyArea.left]
52    set tipsAreUp [winfo exists $tipArea.tip0]
53
54    # erase em both
55    shgEraseTips
56    shgEraseKey
57
58    set drawKey false
59    if {$drawkeychange=="on"} {
60       set drawKey true
61    }
62    if {$drawkeychange=="nc" && $keyIsUp} {
63       set drawKey true
64    }
65  
66    set drawTips false
67    if {$drawtipschange=="on"} {
68       set drawTips true
69    }
70    if {$drawtipschange=="nc" && $tipsAreUp} {
71       set drawTips true
72    }
73    
74    # and redraw, as appropriate
75    if {$drawKey} {
76       shgDrawKey
77    }
78    if {$drawTips} {
79       shgDrawTips
80    }
81 }
82
83 proc shgDrawKeyBase {} {
84    set keyArea .shg.nontop.keyarea
85    frame $keyArea
86    pack  $keyArea -side top -fill both
87 }
88
89 proc shgDrawKey {} {
90    set leftLabels ".shg.nontop.keyarea.left"
91    set rightLabels ".shg.nontop.keyarea.right"
92
93    frame $leftLabels 
94    pack  $leftLabels -side left -fill both -expand true
95
96    frame $rightLabels 
97    pack  $rightLabels -side right -fill both -expand true
98
99    label $leftLabels.tip0 -relief groove \
100            -text "Never Evaluated" -anchor c \
101            -font "*-Helvetica-*-r-*-12-*" \
102            -background grey
103    pack   $leftLabels.tip0 -side top -fill x -expand false
104
105    label $leftLabels.tip1 -relief groove \
106            -text "Unknown" -anchor c \
107            -font "*-Helvetica-*-r-*-12-*" \
108            -background #60c0a0
109            # a nice green...
110    pack   $leftLabels.tip1 -side top -fill x -expand false
111 #          -background "#e9fbb57aa3c9"
112
113    label $leftLabels.tip2 -relief groove \
114            -text "True" -anchor c \
115            -font "*-Helvetica-*-r-*-12-*" \
116            -background cornflowerblue
117 #          -background "#acbff48ff6c8"
118                 # yuck --ari
119    pack   $leftLabels.tip2 -side top -fill x -expand false
120
121    label $leftLabels.tip3 -relief groove \
122            -text "False" -anchor c \
123            -font "*-Helvetica-*-r-*-12-*" \
124            -background pink
125 #          -background "#cc85d5c2777d" 
126                 # yuck --ari
127    pack   $leftLabels.tip3 -side top -fill x -expand false
128
129    label $rightLabels.tip0 -relief groove \
130            -font "*-Helvetica-*-r-*-12-*" \
131            -text "instrumented" \
132            -foreground ivory \
133            -background gray
134    pack  $rightLabels.tip0 -side top -fill x
135
136    label $rightLabels.tip1 -relief groove \
137            -font "*-Helvetica-*-r-*-12-*" \
138            -text "uninstrumented" \
139            -foreground black \
140            -background gray
141    pack  $rightLabels.tip1 -side top -fill x
142
143    label $rightLabels.tip2 -relief groove \
144            -font "*-Helvetica-*-o-*-12-*" \
145            -text "instrumented; shadow node" \
146            -foreground ivory \
147            -background gray
148    pack  $rightLabels.tip2 -side top -fill x
149
150    label $rightLabels.tip3 -relief groove \
151            -font "*-Helvetica-*-o-*-12-*" \
152            -text "uninstrumented; shadow node" \
153            -foreground black \
154            -background gray
155    pack  $rightLabels.tip3 -side top -fill x
156 }
157
158 proc shgEraseKey {} {
159    set keyArea .shg.nontop.keyarea
160    if { ![winfo exists $keyArea.left] } {
161       return
162    }
163
164    destroy $keyArea
165
166    shgDrawKeyBase
167 }
168
169
170 # ####################################################################
171
172 proc shgDrawTipsBase {} {
173    set tipArea .shg.nontop.tiparea
174    frame $tipArea
175    pack  $tipArea -side top -fill x
176 }
177
178 proc shgDrawTips {} {
179    set tipArea .shg.nontop.tiparea
180    if { [winfo exists $tipArea.tip0 ] } {
181       return
182    }
183
184    label $tipArea.tip0 -relief groove \
185            -text "Hold down Alt and move the mouse to scroll freely" \
186            -font "*-Helvetica-*-r-*-12-*"
187    pack $tipArea.tip0 -side top -fill both
188       # fill both prevents shrinking when window is made shorter
189
190    label $tipArea.tip1 -relief groove \
191            -text "Click middle button on a node to obtain more info on it" \
192            -font "*-Helvetica-*-r-*-12-*"
193    pack $tipArea.tip1 -side top -fill both
194       # fill both prevents shrinking when window is made shorter
195
196 }
197
198 proc shgEraseTips {} {
199    set tipArea .shg.nontop.tiparea
200    if { ![winfo exists $tipArea.tip0] } {
201       return
202    }
203
204    destroy $tipArea
205    shgDrawTipsBase
206 }
207
208 # ####################################################################
209
210 proc shgClickOnSearch {} {
211    if {[shgSearchCommand]} {
212       .shg.nontop.buttonarea.left.search config -state disabled -text "Resume"
213       .shg.nontop.buttonarea.middle.pause config -state normal
214    }
215 }
216
217 proc shgClickOnPause {} {
218    if {[shgPauseCommand]} {
219       .shg.nontop.buttonarea.left.search config -state normal
220       .shg.nontop.buttonarea.middle.pause config -state disabled
221    }
222 }
223
224 # ####################################################################
225
226 proc shgInitialize {iDeveloperMode} {
227    if {[winfo exists .shg]} {
228 #      puts stderr "(shg window already exists; not creating)"
229       wm deiconify .shg
230       raise .shg
231       return
232    }
233
234    toplevel .shg -class "Shg"
235    option add *shg*Background grey
236    option add *shg*activeBackground LightGrey
237    option add *shg*activeForeground black
238    wm protocol .shg WM_DELETE_WINDOW {wm iconify .shg}
239
240    # area for title, menubar, logo
241    frame .shg.titlearea
242    pack  .shg.titlearea -side top -fill x -expand false -anchor n
243
244    frame .shg.titlearea.right
245    pack  .shg.titlearea.right -side right -fill y -expand false
246
247    makeLogo .shg.titlearea.right.logo paradynLogo raised 2 mediumseagreen
248    pack  .shg.titlearea.right.logo -side top
249
250    frame .shg.titlearea.left
251    pack  .shg.titlearea.left -side left -fill both -expand true
252
253    label .shg.titlearea.left.title -text "The Performance Consultant" \
254            -foreground white -anchor c \
255            -font *-New*Century*Schoolbook-Bold-R-*-14-* \
256            -relief raised \
257            -background mediumseagreen
258    pack  .shg.titlearea.left.title -side top -fill both -expand true
259
260    # area for menubar:
261    frame .shg.titlearea.left.menu
262    pack  .shg.titlearea.left.menu -side top -fill x -expand false -anchor n
263
264    frame .shg.titlearea.left.menu.mbar -borderwidth 2 -relief raised
265    pack  .shg.titlearea.left.menu.mbar -side top -fill both -expand false
266
267    menubutton .shg.titlearea.left.menu.mbar.phase -text Searches -menu .shg.titlearea.left.menu.mbar.phase.m
268    menu .shg.titlearea.left.menu.mbar.phase.m -selectcolor cornflowerblue
269
270    pack .shg.titlearea.left.menu.mbar.phase -side left -padx 4
271
272    # -----------------------------------------------------------
273
274    frame .shg.nontop
275    pack  .shg.nontop -side bottom -fill both -expand true
276
277    # -----------------------------------------------------------
278
279    frame .shg.nontop.currphasearea
280    pack  .shg.nontop.currphasearea -side top -fill x -expand false
281
282    label .shg.nontop.currphasearea.label1 -text "Current Phase: " \
283            -font "*-Helvetica-*-r-*-12-*" -anchor e
284    pack  .shg.nontop.currphasearea.label1 -side left -fill both -expand true
285
286    label .shg.nontop.currphasearea.label2 -text "" \
287            -font "*-Helvetica-*-r-*-12-*" -anchor w
288    pack  .shg.nontop.currphasearea.label2 -side left -fill both -expand true
289
290    # -----------------------------------------------------------
291
292    frame .shg.nontop.textarea
293    pack  .shg.nontop.textarea -side top -fill x -expand false
294
295    text .shg.nontop.textarea.text -borderwidth 2 -width 40 -height 5 -relief sunken \
296            -font "*-Helvetica-*-r-*-12-*" \
297            -yscrollcommand ".shg.nontop.textarea.sb set"
298    pack .shg.nontop.textarea.text -side left -fill both -expand true
299
300    scrollbar .shg.nontop.textarea.sb -relief sunken \
301            -command ".shg.nontop.textarea.text yview"
302    pack .shg.nontop.textarea.sb -side right -fill y -expand false
303
304    # -----------------------------------------------------------
305
306    frame .shg.nontop.main -width 4i -height 3.5i
307    pack  .shg.nontop.main -side top -fill both -expand true
308
309    scrollbar .shg.nontop.main.leftsb -orient vertical -width 16 \
310            -background gray \
311            -activebackground gray \
312            -command "shgNewVertScrollPosition"
313
314    pack .shg.nontop.main.leftsb -side left -fill y -expand false
315
316    scrollbar .shg.nontop.main.bottsb -orient horizontal -width 16 \
317         -activebackground gray \
318         -command "shgNewHorizScrollPosition"
319
320    pack .shg.nontop.main.bottsb -side bottom -fill x -expand false
321
322    frame .shg.nontop.main.all -relief flat -width 3i -height 2i
323    pack .shg.nontop.main.all -side left -fill both -expand true
324
325    # -----------------------------------------------------------
326
327    frame .shg.nontop.labelarea
328    pack  .shg.nontop.labelarea -side top -fill x -expand false
329
330    text .shg.nontop.labelarea.current -relief sunken -height 1 \
331            -font "*-Helvetica-*-r-*-12-*" \
332            -wrap none
333    if {$iDeveloperMode} {
334       set numlines 4
335    } else {
336       set numlines 1
337    }
338    shgChangeCurrLabelHeight $numlines
339
340    # -----------------------------------------------------------
341
342    frame .shg.nontop.buttonarea
343    pack  .shg.nontop.buttonarea -side top -fill x -expand false
344
345    frame .shg.nontop.buttonarea.left
346    pack  .shg.nontop.buttonarea.left -side left -fill y -expand true
347
348    # Note: the search button doubles as a "Resume" button when appropriate
349    button .shg.nontop.buttonarea.left.search -text "Search" -anchor c \
350            -command shgClickOnSearch
351    pack   .shg.nontop.buttonarea.left.search -side left -ipadx 10 -fill y -expand false
352
353    frame .shg.nontop.buttonarea.middle
354    pack  .shg.nontop.buttonarea.middle -side left -fill y -expand true
355
356    button .shg.nontop.buttonarea.middle.pause -text "Pause" -state disabled -anchor c \
357            -command shgClickOnPause
358    pack   .shg.nontop.buttonarea.middle.pause -side left -fill y -expand false
359
360    # -----------------------------------------------------------
361
362    shgDrawKeyBase
363    shgDrawKey
364
365    shgDrawTipsBase
366    shgDrawTips
367
368    # -----------------------------------------------------------
369
370    bind .shg.nontop.main.all <Configure> {shgConfigureHook}
371    bind .shg.nontop.main.all <Expose>    {shgExposeHook %c}
372    bind .shg.nontop.main.all <Button-1>  {shgSingleClickHook %x %y}
373    bind .shg.nontop.main.all <Button-2>  {shgMiddleClickHook %x %y}
374    bind .shg.nontop.main.all <Double-Button-1> {shgDoubleClickHook %x %y}
375 #   bind .shg.nontop.main.all <Shift-Double-Button-1> {shgShiftDoubleClickHook %x %y}
376 #   bind .shg.nontop.main.all <Control-Double-Button-1> {shgCtrlDoubleClickHook %x %y}
377    bind .shg.nontop.main.all <Alt-Motion> {shgAltPressHook %x %y}
378    bind .shg.nontop.main.all <Motion> {shgAltReleaseHook}
379 }