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