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