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