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