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