Added ctrl-double-click to select/unselect an entire subtree (nonrecursive).
[dyninst.git] / paradyn / tcl / whereAxis.tcl
1 # whereAxis.tcl
2 # Ariel Tamches
3
4 #
5 # $Log: whereAxis.tcl,v $
6 # Revision 1.2  1995/07/18 03:38:08  tamches
7 # Added ctrl-double-click to select/unselect an entire subtree (nonrecursive).
8 # Added "clear" menu item to clear all selections.
9 #
10 # Revision 1.1  1995/07/17  05:00:34  tamches
11 # First version of new where axis
12 #
13 #
14
15 proc resize1Scrollbar {sbname newTotal newVisible} {
16    # This is a nice n' generic routine  --ari
17    # However, it is (currently) only called from C++ code.  If this
18    # situation doesn't change, then we might want to just
19    # zap this and turn it into C++ code...
20
21    # 'newTotal' and 'newVisible' are tentative values;
22    # We use them to calculate 'newFirst' and 'newLast'.
23    # We make an effort to keep 'newFirst' as close as possible to 'oldFirst'.
24
25    set oldConfig [$sbname get]
26    set oldFirst  [lindex $oldConfig 0]
27    set oldLast   [lindex $oldConfig 1]
28 #   puts stderr "oldFirst=$oldFirst; oldLast=$oldLast"
29
30    if {$newVisible < $newTotal} {
31       # The usual case: not everything fits
32       set fracVisible [expr 1.0 * $newVisible / $newTotal]
33 #      puts stderr "newVisible=$newVisible; newTotal=$newTotal; fracVisible=$fracVisible"
34
35       set newFirst $oldFirst
36       set newLast [expr $newFirst + $fracVisible]
37
38 #      puts stderr "tentative newFirst=$newFirst; newLast=$newLast"
39      
40       if {$newLast > 1.0} {
41          set theOverflow [expr $newLast - 1.0]
42 #         puts stderr "resize1Scrollbar: would overflow by fraction of $theOverflow; moving newFirst back"
43          set newFirst [expr $oldFirst - $theOverflow]
44          set newLast  [expr $newFirst + $fracVisible]
45       } else {
46 #         puts stderr "resize1Scrollbar: yea, we were able to keep newFirst unchanged at $newFirst"
47       }
48    } else {
49       # the unusual case: everything fits (visible >= total)
50       set newFirst 0.0
51       set newLast  1.0
52    }
53
54    if {$newFirst < 0} {
55       # This is an assertion failure
56       puts stderr "resize1Scrollbar warning: newFirst is $newFirst"
57    }
58    if {$newLast > 1} {
59       # This is an assertion failure
60       puts stderr "resize1Scrollbar warning: newLast is $newLast"
61    }
62   
63    $sbname set $newFirst $newLast
64 }
65
66 # ##################################################################
67
68 proc whereAxisCatchDeleteWindow {} {
69    # change the delete into an iconify
70    wm iconify .whereAxis
71 }
72
73 # ##################################################################
74
75 proc whereAxisShowSelections {} {
76 }
77
78 # ##################################################################
79
80 proc whereAxisInitialize {} {
81    toplevel .whereAxis -class "WhereAxis"
82    option add *whereAxis*Background grey
83    wm protocol .whereAxis WM_DELETE_WINDOW whereAxisCatchDeleteWindow
84    
85    frame .whereAxis.top
86    pack  .whereAxis.top -side top -fill x -expand false -anchor n
87       # area for menubar
88    
89    frame .whereAxis.top.mbar -borderwidth 2 -relief raised
90    pack  .whereAxis.top.mbar -side top -fill both -expand false
91    
92    menubutton .whereAxis.top.mbar.file -text Window -menu .whereAxis.top.mbar.file.m
93    menu .whereAxis.top.mbar.file.m -selectcolor cornflowerblue
94    .whereAxis.top.mbar.file.m add command -label "Iconify" -command "wm iconify .whereAxis"
95    
96    menubutton .whereAxis.top.mbar.sel -text Selections -menu .whereAxis.top.mbar.sel.m
97    menu .whereAxis.top.mbar.sel.m -selectcolor cornflowerblue
98    .whereAxis.top.mbar.sel.m add command -label "Clear" -command whereAxisClearSelections
99 #   .whereAxis.top.mbar.sel.m add command -label "Show" -command whereAxisShowSelections
100    
101    menubutton .whereAxis.top.mbar.nav -text Navigate -menu .whereAxis.top.mbar.nav.m
102    menu .whereAxis.top.mbar.nav.m -selectcolor cornflowerblue
103    
104    menubutton .whereAxis.top.mbar.abs -text Abstraction -menu .whereAxis.top.mbar.abs.m
105    menu .whereAxis.top.mbar.abs.m -selectcolor cornflowerblue
106    
107    pack .whereAxis.top.mbar.file .whereAxis.top.mbar.sel .whereAxis.top.mbar.nav .whereAxis.top.mbar.abs -side left -padx 4
108    tk_menuBar .whereAxis.top.mbar .whereAxis.top.mbar.file .whereAxis.top.mbar.sel .whereAxis.top.mbar.nav .whereAxis.top.mbar.abs
109    
110    # -----------------------------------------------------------
111    
112    frame .whereAxis.nontop
113    pack  .whereAxis.nontop -side bottom -fill both -expand true
114    
115    # -----------------------------------------------------------
116    
117    frame .whereAxis.nontop.main -width 3i -height 2.5i
118    pack  .whereAxis.nontop.main -side top -fill both -expand true
119    
120    scrollbar .whereAxis.nontop.main.leftsb -orient vertical -width 16 -background gray \
121         -activebackground gray \
122         -command "newVertScrollPosition"
123    
124    pack .whereAxis.nontop.main.leftsb -side left -fill y -expand false
125    
126    scrollbar .whereAxis.nontop.main.bottsb -orient horizontal -width 16 \
127         -activebackground gray \
128         -command "newHorizScrollPosition"
129    
130    pack .whereAxis.nontop.main.bottsb -side bottom -fill x -expand false
131    
132    #canvas .whereAxis.nontop.main.all -relief flat -width 3i -height 2i \
133    #    -yscrollcommand myYScrollCommand \
134    #    -xscrollcommand myXScrollCommand \
135    #    -scrollincrement 1
136    frame .whereAxis.nontop.main.all -relief flat -width 3i -height 2i
137    pack .whereAxis.nontop.main.all -side left -fill both -expand true
138    
139    # -----------------------------------------------------------
140    
141    label .whereAxis.nontop.tip1 -relief sunken \
142            -text "Click to select; double-click to expand/un-expand" \
143            -font "*-Helvetica-*-r-*-12-*"
144    pack  .whereAxis.nontop.tip1 -side top -fill both -expand false
145       # fill both (instead of just x) seems needed to prevent from shrinking
146       # when window made shorter
147    
148    label .whereAxis.nontop.tip2 -relief sunken \
149            -text "Shift-double-click to expand/un-expand all subtrees of a node" \
150            -font "*-Helvetica-*-r-*-12-*"
151    pack  .whereAxis.nontop.tip2 -side top -fill both -expand false
152       # fill both (instead of just x) seems needed to prevent from shrinking
153       # when window made shorter
154    
155    label .whereAxis.nontop.tip3 -relief sunken \
156            -text "Ctrl-double-click to select/un-select all subtrees of a node" \
157            -font "*-Helvetica-*-r-*-12-*"
158    pack  .whereAxis.nontop.tip3 -side top -fill both -expand false
159       # fill both (instead of just x) seems needed to prevent from shrinking
160       # when window made shorter
161    
162    # -----------------------------------------------------------
163    
164    frame .whereAxis.nontop.find
165    pack  .whereAxis.nontop.find -side top -fill both -expand false
166    
167    label .whereAxis.nontop.find.label -relief sunken -font "*-Helvetica-*-r-*-12-*" -text "Search:"
168    pack  .whereAxis.nontop.find.label -side left -fill y -expand false
169    
170    entry .whereAxis.nontop.find.entry -relief sunken -font "*-Helvetica-*-r-*-12-*"
171    pack  .whereAxis.nontop.find.entry -side left -fill x -expand true
172    
173    bind  .whereAxis.nontop.find.entry <Return> {findHook [.whereAxis.nontop.find.entry get]}
174    
175    # -----------------------------------------------------------
176    
177    # install resize, expose, and button event hooks for .whereAxis.nontop.main.all
178    bind .whereAxis.nontop.main.all <Configure> {configureHook %w %h}
179    bind .whereAxis.nontop.main.all <Expose>    {exposeHook %c}
180    bind .whereAxis.nontop.main.all <Button-1>  {singleClickHook %x %y}
181    bind .whereAxis.nontop.main.all <Double-Button-1> {doubleClickHook %x %y}
182    bind .whereAxis.nontop.main.all <Shift-Double-Button-1> {shiftDoubleClickHook %x %y}
183    bind .whereAxis.nontop.main.all <Control-Double-Button-1> {ctrlDoubleClickHook %x %y}
184    
185    set currMenuAbstraction 1
186 }