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