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