Bwidget Source Code
Check-in [651774cb09]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:* tree.tcl: Integrated changes from Eric Boudaillier: [itemconfigure -open ...] optimized to only call redraw_idle 3 if node has subnodes. _cross_event: itemconfigure -open called before -opencmd/closecmd; no more call to _redraw_idle (handled by other procedures) _over_cmd: allow position {root 0} when tree is empty new [find] command: [find @x,y ?confine?] if confine is "confine" returns the node at window coordinate x,y (x,y must be inside the bbox of the node) else returns the node found on the line (in pixel) pixel y [find line] returns the node on the line $line (in -deltay coords) new [line] command: [line node] returns the line where node is drawn -selectfill option added: if true, selection is draw on full width of tree (instead of just highlighting the bbox of the selected nodes)

* combobox.tcl: Integrated changes from Eric Boudaillier: internal widget restructuring.

* tree.tcl: Added "range" subcommand to selection. Given two nodes, node1 and node2, it will set the selection to the visible nodes between (and including) node1 and node2. If node1 or node2 is not visible, it will find the first visible ancestor of the node and use that as the start/end point instead.

* listbox.tcl: Integrated changes from Eric Boudaillier: _over_cmd: allow position 0 when listbox is empty find command, similar to tree find command.

* spinbox.tcl: Integrated changes from Eric Boudaillier: cosmetic changes.

* color.tcl: Integrated changes from Eric Boudaillier: split widget into two commands: SelectColor::menu and SelectColor::dialog.

* progressbar.tcl: Integrated changes from Eric Boudaillier: added -idle option to prevent call to update in case where task is done in idle (ie, fileevents)

* scrollview.tcl: Integrated changes from Eric Boudaillier: bindings changed.

* scrollw.tcl: Integrated changes from Eric Boudaillier: -managed option: if true, scrollbar are managed during creation, so their size are included in the requested size of the ScrolledWindow. If false, they are not. -sides option: specifies the side of the scrollbar. -size option: specifies size of scrollbar. -ipad option: specifies pad between scrollbar and scrolled widget.

* mainframe.tcl: Integrated changes from Eric Boudaillier: support for function keys in accelerators, support for no modifier in accelerators.

* notebook.tcl: Integrated changes from Eric Boudaillier: -internalborderwidth (-ibd) option specifies pad around pages; -foreground, -background, -activeforeground, -activebackground, -disabledforeground options for each tab. Code cleanup.

Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 651774cb09726bc04f43e77e51b90a9df7321817
User & Date: ericm 2000-02-11 22:54:25
Context
2000-02-16
16:43
* tree.tcl: Changed the <KeyPress-space> binding to use "+", so it will not overwrite existing bindings (if there are any). Also added some extra protection in the keynav procedure against the user typing <Left> on a root node (this used to cause a stack trace). check-in: aa5dc5c579 user: sven tags: trunk
2000-02-11
22:54
* tree.tcl: Integrated changes from Eric Boudaillier: [itemconfigure -open ...] optimized to only call redraw_idle 3 if node has subnodes. _cross_event: itemconfigure -open called before -opencmd/closecmd; no more call to _redraw_idle (handled by other procedures) _over_cmd: allow position {root 0} when tree is empty new [find] command: [find @x,y ?confine?] if confine is "confine" returns the node at window coordinate x,y (x,y must be inside the bbox of the node) else returns the node found on the line (in pixel) pixel y [find line] returns the node on the line $line (in -deltay coords) new [line] command: [line node] returns the line where node is drawn -selectfill option added: if true, selection is draw on full width of tree (instead of just highlighting the bbox of the selected nodes)

* combobox.tcl: Integrated changes from Eric Boudaillier: internal widget restructuring.

* tree.tcl: Added "range" subcommand to selection. Given two nodes, node1 and node2, it will set the selection to the visible nodes between (and including) node1 and node2. If node1 or node2 is not visible, it will find the first visible ancestor of the node and use that as the start/end point instead.

* listbox.tcl: Integrated changes from Eric Boudaillier: _over_cmd: allow position 0 when listbox is empty find command, similar to tree find command.

* spinbox.tcl: Integrated changes from Eric Boudaillier: cosmetic changes.

* color.tcl: Integrated changes from Eric Boudaillier: split widget into two commands: SelectColor::menu and SelectColor::dialog.

* progressbar.tcl: Integrated changes from Eric Boudaillier: added -idle option to prevent call to update in case where task is done in idle (ie, fileevents)

* scrollview.tcl: Integrated changes from Eric Boudaillier: bindings changed.

* scrollw.tcl: Integrated changes from Eric Boudaillier: -managed option: if true, scrollbar are managed during creation, so their size are included in the requested size of the ScrolledWindow. If false, they are not. -sides option: specifies the side of the scrollbar. -size option: specifies size of scrollbar. -ipad option: specifies pad between scrollbar and scrolled widget.

* mainframe.tcl: Integrated changes from Eric Boudaillier: support for function keys in accelerators, support for no modifier in accelerators.

* notebook.tcl: Integrated changes from Eric Boudaillier: -internalborderwidth (-ibd) option specifies pad around pages; -foreground, -background, -activeforeground, -activebackground, -disabledforeground options for each tab. Code cleanup. check-in: 651774cb09 user: ericm tags: trunk

00:16
Slight modification to algorithm to handle non-visible nodes. check-in: 6bdb5e8a71 user: ericm tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.

















































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

22
23
24
25
26
27
28

29
30
31
32
33
34












35
36
37
38
39
40
41















































































1998-12-13  Eric Melski  <[email protected]>

	* buttonbox.tcl: Added a getbuttonstate function, which retrieves the value
	of a tag used on a button in the buttonbox.

1999-12-08  Eric Melski  <[email protected]>

	* combobox.tcl: Removed code that cleared entry selection on focus out 
	events, as this crippled exportselection.

1999-10-29  Eric Melski  <[email protected]>

	* buttonbox.tcl: Added a gettags function, which allows the user to query
	the tags that are used on buttons in the buttonbox.

1999-10-29  Eric Melski  <[email protected]>

	* font.tcl: Added one new flag: -querysystem.  This lets the user 
	control whether the font selector queries the system (via font families)
	for the list of fonts, or if it uses a preset list of fonts (which is
	much faster and less likely to crash some systems).


1999-10-25  Eric Melski  <[email protected]>

	* font.tcl: Added support for two new flags: -families and -styles; 
	-families allows you to specify one of all, fixed, or variable, to limit 
	the choice of fonts to those fonts; -styles allows you to specify a list
	of styles that can be set with the widget (ie, bold, italic, etc).


1999-10-22  Eric Melski  <[email protected]>

	* tree.tcl: Fixed some problems with keyboard traversal.  Added
	support for left/right arrows a la MS Explorer.
	Added support for keyboard-based scrolling.












	
1999-10-21  Eric Melski  <[email protected]>

	* tree.tcl: Added a -selectable option to tree nodes, which
	controls whether or not a given node is selectable (duh).  This
	works with the new -selectcommand option for the tree, and with
	keyboard traversal (also new).  Now, whenever the tree gets a
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

|
|








|
|




|
|
|
>




|
|
|
>






>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
2000-02-11  Eric Melski  <[email protected]>

	* tree.tcl: Integrated changes from Eric Boudaillier:
	[itemconfigure -open ...]
	    optimized to only call redraw_idle 3 if node has subnodes.
	_cross_event:
	    itemconfigure -open called before -opencmd/closecmd; no more
	    call to _redraw_idle (handled by other procedures)
	_over_cmd:
	    allow position {root 0} when tree is empty
	new [find] command:  
	    [find @x,y ?confine?]
	    	    if confine is "confine" returns the node at window
		    coordinate x,y (x,y must be inside the bbox of the
		    node) else returns the node found on the line (in
		    pixel) pixel y
	    [find line]
	            returns the node on the line $line (in -deltay coords)
	new [line] command:
	    [line node]
	            returns the line where node is drawn
	-selectfill option added:
	    if true, selection is draw on full width of tree (instead of
	    just highlighting the bbox of the selected nodes)
	
	* combobox.tcl: Integrated changes from Eric Boudaillier:
	internal widget restructuring.

	* tree.tcl: Added "range" subcommand to selection.  Given two
	nodes, node1 and node2, it will set the selection to the visible
	nodes between (and including) node1 and node2.  If node1 or node2
	is not visible, it will find the first visible ancestor of the
	node and use that as the start/end point instead.

	* listbox.tcl: Integrated changes from Eric Boudaillier:
	_over_cmd: allow position 0 when listbox is empty
	find command, similar to tree find command.
	
	* spinbox.tcl: Integrated changes from Eric Boudaillier:
	cosmetic changes.
	
	* color.tcl: Integrated changes from Eric Boudaillier:
	split widget into two commands: SelectColor::menu and
	SelectColor::dialog.

	* progressbar.tcl: Integrated changes from Eric Boudaillier:
	added -idle option to prevent call to update in case where task is
	done in idle (ie, fileevents)

	* scrollview.tcl: Integrated changes from Eric Boudaillier:
	bindings changed.

	* scrollw.tcl: Integrated changes from Eric Boudaillier:
	-managed option: if true, scrollbar are managed during creation,
	so their size are included in the requested size of the
	ScrolledWindow.  If false, they are not.
	-sides option: specifies the side of the scrollbar.
	-size option: specifies size of scrollbar.
	-ipad option: specifies pad between scrollbar and scrolled widget.

	* mainframe.tcl: Integrated changes from Eric Boudaillier: support
	for function keys in accelerators, support for no modifier in
	accelerators.

	* notebook.tcl: Integrated changes from Eric Boudaillier:
	-internalborderwidth (-ibd) option specifies pad around pages;
	-foreground, -background, -activeforeground, -activebackground,
	-disabledforeground options for each tab.
	Code cleanup.

1999-12-23  Sven Delmas  <[email protected]>

	* scrollw.tcl: Added "update idletask" to scrollbar update to
	prevent loss of update events.

1999-12-14  Sven Delmas  <[email protected]>

	* combobox.tcl: When the selected item is changed, the selection
	is now set to the entire string.

1999-12-13  Eric Melski  <[email protected]>

	* buttonbox.tcl: Added a getbuttonstate function, which retrieves 
	the value of a tag used on a button in the buttonbox.

1999-12-08  Eric Melski  <[email protected]>

	* combobox.tcl: Removed code that cleared entry selection on focus out 
	events, as this crippled exportselection.

1999-10-29  Eric Melski  <[email protected]>

	* buttonbox.tcl: Added a gettags function, which allows the user
	to query the tags that are used on buttons in the buttonbox.

1999-10-29  Eric Melski  <[email protected]>

	* font.tcl: Added one new flag: -querysystem.  This lets the user 
	control whether the font selector queries the system 
	(via font families) for the list of fonts, or if it uses a preset 
	list of fonts (which is much faster and less likely to crash some 
	systems).

1999-10-25  Eric Melski  <[email protected]>

	* font.tcl: Added support for two new flags: -families and -styles; 
	-families allows you to specify one of all, fixed, or variable, to
	limit the choice of fonts to those fonts; -styles allows you to
	specify a list of styles that can be set with the widget (ie,
	bold, italic, etc).

1999-10-22  Eric Melski  <[email protected]>

	* tree.tcl: Fixed some problems with keyboard traversal.  Added
	support for left/right arrows a la MS Explorer.
	Added support for keyboard-based scrolling.
	
1999-10-21  Sven Delmas  <[email protected]>

	* combobox.tcl: Added support for keyboard traversal.  The widget
	will now tab in even when it is not editable.  Also the entry
	widget content will be selected when the user tabs in. The key
	bindings now allow a traversal of the list (<Down> brings up the
	list). The arrow button no longer switches to an up button, but
	instead changes relief. The button is now more Windows NT like
	(for Windows NT).  Changed keyboard bindings:  down/up now
	display/hide the listbox; control-{up|down|prev|next} move through
	the options without displaying the listbox.
	
1999-10-21  Eric Melski  <[email protected]>

	* tree.tcl: Added a -selectable option to tree nodes, which
	controls whether or not a given node is selectable (duh).  This
	works with the new -selectcommand option for the tree, and with
	keyboard traversal (also new).  Now, whenever the tree gets a

Changes to color.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36



37
38
39
40
41
42
43


44
45
46
47




48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207

208
209
210




211
212
213
214

215
216
217


218
219

220
221
222
223
224
225

226
227
228
229
230
231


232
233
234

235
236
237


238
239
240

241
242
243



244







245
246
247
248
249
250

251
252

253



254
255













































































































256
257
258
259
260
261

262
263
264
265
266
267
268
269


























270





























271
272
273




274
275


276






277
278
279
280


281
282
283
284




285
286
287
288
289
290
291



292




293
294
295
296






297
298










299
300
301
302
303
304
305


306
307
308
309
310
311
312
313








314














































































# ------------------------------------------------------------------------------
#  color.tcl
#  This file is part of Unifix BWidget Toolkit
# ------------------------------------------------------------------------------
#  Index of commands:
#     - SelectColor::create
#     - SelectColor::setcolor
#     - SelectColor::_destroy
#     - SelectColor::_update_var
#     - SelectColor::_post_menu
#     - SelectColor::_tk_choose_color
#     - SelectColor::_activate
# ------------------------------------------------------------------------------

namespace eval SelectColor {
    Widget::declare SelectColor {
        {-title    String     "" 0}
        {-parent   String     "" 0}
        {-type     Enum       dialog 1 {dialog menubutton}}
        {-command  String     ""     0}
        {-color    TkResource ""     0 {label -background}}
        {-variable String     ""     0}
        {-width    TkResource 15     0 frame}
        {-height   TkResource 15     0 frame}
    }

    Widget::addmap      SelectColor "" :cmd {-width {} -height {}}
    Widget::syncoptions SelectColor "" :cmd {-color -background}

    variable _tabcolors {
        \#0000ff \#000099 \#000000 white
        \#00ff00 \#009900 \#333333 white
        \#00ffff \#009999 \#666666 white
        \#ff0000 \#990000 \#999999 white
        \#ff00ff \#990099 \#cccccc white
        \#ffff00 \#999900 \#ffffff



    }

    # bindings
    bind SelectColor <ButtonPress-1> {SelectColor::_post_menu %W %X %Y}
    bind SelectColor <Destroy>       {SelectColor::_destroy %W}

    variable _widget



    proc ::SelectColor { path args } { return [eval SelectColor::create $path $args] }
    proc use {} {}
}






# ------------------------------------------------------------------------------
#  Command SelectColor::create
# ------------------------------------------------------------------------------
proc SelectColor::create { path args } {
    variable _tabcolors
    variable _widget

    Widget::init SelectColor $path $args

    if { ![string compare [Widget::getoption $path -type] "menubutton"] } {
        if { [set var [Widget::getoption $path -variable]] != "" } {
            set _widget($path,var) $var
            if { [GlobalVar::exists $var] } {
                Widget::setoption $path -color [GlobalVar::getvar $var]
            } else {
                GlobalVar::setvar $var [Widget::getoption $path -color]
            }
            GlobalVar::tracevar variable $var w "SelectColor::_update_var $path"
        } else {
            set _widget($path,var) ""
        }

        eval frame $path [Widget::subcget $path :cmd] \
            -background [Widget::getoption $path -color] \
            -relief raised -borderwidth 2 -highlightthickness 0
        bindtags $path [list $path SelectColor . all]
        set _widget($path,idx) 0

        rename $path ::$path:cmd
        proc ::$path { cmd args } "return \[eval SelectColor::\$cmd $path \$args\]"
    } else {
        set parent [Widget::getoption $path -parent]
        set title  [Widget::getoption $path -title]
        set lopt   [list -initialcolor [Widget::getoption $path -color]]
        if { [winfo exists $parent] } {
            lappend lopt -parent $parent
        }
        if { $title != "" } {
            lappend lopt -title $title
        }
        set col [eval tk_chooseColor $lopt]
        Widget::destroy $path
        return $col
    }

    return $path
}


# ------------------------------------------------------------------------------
#  Command SelectColor::configure
# ------------------------------------------------------------------------------
proc SelectColor::configure { path args } {
    variable _widget

    set res [Widget::configure $path $args]

    if { [Widget::hasChanged $path -variable var] } {
        if { [string length $_widget($path,var)] } {
            GlobalVar::tracevar vdelete $_widget($path,var) w "SelectColor::_update_var $path"
        }
        set _widget($path,var) $var
        if { [string length $_widget($path,var)] } {
            Widget::hasChanged $path -color curval
            if { [GlobalVar::exists $_widget($path,var)] } {
                Widget::setoption $path -color [set curval [GlobalVar::getvar $_widget($path,var)]]
            } else {
                GlobalVar::setvar $_widget($path,var) $curval
            }
            GlobalVar::tracevar variable $_widget($path,var) w "SelectColor::_update_var $path"
            $path:cmd configure -background $curval
        }
    }

    if { [Widget::hasChanged $path -color curval] } {
        if { [string length $_widget($path,var)] } {
            Widget::setoption $path -color [GlobalVar::getvar $_widget($path,var)]
        } else {
            $path:cmd configure -background $curval
        }
    }
    return $res
}


# ------------------------------------------------------------------------------
#  Command SelectColor::cget
# ------------------------------------------------------------------------------
proc SelectColor::cget { path option } {
    return [Widget::cget $path $option]
}


# ------------------------------------------------------------------------------
#  Command SelectColor::setcolor
# ------------------------------------------------------------------------------
proc SelectColor::setcolor { index color } {
    variable _tabcolors
    variable _widget

    if { $index >= 1 && $index <= 5 } {
        set idx        [expr {int($idx) * 3}]
        set _tabcolors [lreplace $_tabcolors $idx $idx $color]
        return 1
    }
    return 0
}


# ------------------------------------------------------------------------------
#  Command SelectColor::_destroy
# ------------------------------------------------------------------------------
proc SelectColor::_destroy { path } {
    variable _widget

    if { [string length $_widget($path,var)] } {
        GlobalVar::tracevar vdelete $_widget($path,var) w "SelectColor::_update_var $path"
    }
    unset _widget($path,var)
    unset _widget($path,idx)
    Widget::destroy $path
    rename $path {}
}


# ------------------------------------------------------------------------------
#  Command SelectColor::_update_var
# ------------------------------------------------------------------------------
proc SelectColor::_update_var { path args } {
    variable _tabcolors
    variable _widget

    set col [GlobalVar::getvar $_widget($path,var)]
    $path:cmd configure -background $col
    Widget::setoption $path -color $col
    set _widget($path,idx) [lsearch $_tabcolors $col]
    if { $_widget($path,idx) == -1 } {
        set _widget($path,idx) 0
    }
}


# ------------------------------------------------------------------------------
#  Command SelectColor::_post_menu
# ------------------------------------------------------------------------------
proc SelectColor::_post_menu { path X Y } {
    global   env
    variable _tabcolors
    variable _widget

    if { [winfo exists $path.menu] } {
        if { [string compare [winfo containing $X $Y] $path] } {
            BWidget::grab release $path
            destroy $path.menu
        }
        return
    }


    set top [menu $path.menu]
    wm withdraw $top
    wm transient $top [winfo toplevel $path]




    set col 0
    set row 0
    set count 0
    set frame [frame $top.frame -highlightthickness 0 -relief raised -borderwidth 2]

    foreach color $_tabcolors {
        set f [frame $frame.c$count \
                   -relief flat -bd 0 -highlightthickness 1 \


                   -width 16 -height 16 -background $color]
        bind $f <ButtonRelease-1> "SelectColor::_activate $path %W"

        bind $f <Enter>           {focus %W}
        grid $f -column $col -row $row -padx 1 -pady 1
        bindtags $f $f
        incr row
        incr count
        if { $row == 4 } {

            set row 0
            incr col
        }
    }
    set f [label $frame.c$count \
               -relief flat -bd 0 -highlightthickness 1 \


               -width 16 -height 16 -image [Bitmap::get palette]]
    grid $f -column $col -row $row -padx 1 -pady 1
    bind $f <ButtonRelease-1> "SelectColor::_tk_choose_color $path"

    bind $f <Enter>           {focus %W}
    pack $frame



    BWidget::place $top 0 0 below $path

    wm deiconify $top

    raise $top
    focus $frame
    focus $top.frame.c$_widget($path,idx)



    BWidget::grab set $path







}


# ------------------------------------------------------------------------------
#  Command SelectColor::_tk_choose_color
# ------------------------------------------------------------------------------

proc SelectColor::_tk_choose_color { path } {
    variable _tabcolors

    variable _widget




    BWidget::grab release $path













































































































    destroy $path.menu
    set parent [Widget::getoption $path -parent]
    set title  [Widget::getoption $path -title]
    set lopt   [list -initialcolor [$path:cmd cget -background]]
    if { [winfo exists $parent] } {
        lappend lopt -parent $parent

    }
    if { $title != "" } {
        lappend lopt -title $title
    }
    set col [eval tk_chooseColor $lopt]
    if { $col != "" } {
        if { $_widget($path,idx) % 4 == 3 } {
            set idx $_widget($path,idx)


























        } else {





























            set idx -1
            for {set i 3} {$i < 15} {incr i 4} {
                if { [lindex $_tabcolors $i] == "white" } {




                    set idx $i
                    break


                }






            }
        }
        if { $idx != -1 } {
            set _tabcolors [lreplace $_tabcolors $idx $idx $col]


            set _widget($path,idx) $idx
        }
        if { [info exists _widget($path,var)] } {
            GlobalVar::setvar $_widget($path,var) $col




        }
        if { [set cmd [Widget::getoption $path -command]] != "" } {
            uplevel \#0 $cmd
        }
        $path:cmd configure -background $col
    }
}









# ------------------------------------------------------------------------------
#  Command SelectColor::_activate
# ------------------------------------------------------------------------------






proc SelectColor::_activate { path cell } {
    variable _tabcolors










    variable _widget

    BWidget::grab release $path
    set col [$cell cget -background]
    destroy $path.menu
    if { [string length $_widget($path,var)] } {
        GlobalVar::setvar $_widget($path,var) $col


    }
    Widget::setoption $path -color $col
    $path:cmd configure -background $col

    if { [set cmd [Widget::getoption $path -command]] != "" } {
        uplevel \#0 $cmd
    }
    set _widget($path,idx) [string range [lindex [split $cell "."] end] 1 end]








}














































































<
<
<
<
<
<
<
<
<
<
<
<
<
<


|

<
<
|
<
<
<


<
<
<
|
<
<
<
<
<
<
>
>
>


<
<
<
<
|
>
>
|
<
<
|
>
>
>
>
|

<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
<
<
<
<
|
<
|
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|

<
<
<
<
<
<
<
<
>
|
|
|
>
>
>
>
|
|
|
<
>
|

|
>
>

<
>
|


<

<
>
|
|



|
>
>


<
>
|


>
>
|


>

|
<
>
>
>
|
>
>
>
>
>
>
>
|
|

<
<
<
>
|
|
>

>
>
>

<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
<
<
<
>
|
<
<
|
<
<
<
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
>
>
>
>
|
<
>
>
|
>
>
>
>
>
>
|
|
<
<
>
>
|
|
<
<
>
>
>
>
|
<
<
|
<
|
|
>
>
>

>
>
>
>
|
<
<
<
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>


<
<
<
<
<
>
>
|
<
<

<
<
|
<
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













1
2
3
4


5



6
7



8






9
10
11
12
13




14
15
16
17


18
19
20
21
22
23
24




25
26















































27











































28
29
30




31

32





33
34















35
36
















37
38
39








40
41
42
43
44
45
46
47
48
49
50

51
52
53
54
55
56
57

58
59
60
61

62

63
64
65
66
67
68
69
70
71
72
73

74
75
76
77
78
79
80
81
82
83
84
85

86
87
88
89
90
91
92
93
94
95
96
97
98
99



100
101
102
103
104
105
106
107
108

109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218





219
220


221




222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278


279
280
281
282
283

284
285
286
287
288
289
290
291
292
293
294


295
296
297
298


299
300
301
302
303


304

305
306
307
308
309
310
311
312
313
314
315



316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335





336
337
338


339


340

341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427













namespace eval SelectColor {
    Widget::declare SelectColor {
        {-title    String     "Select a color" 0}
        {-parent   String     "" 0}


        {-color    TkResource "" 0 {label -background}}



    }




    variable _baseColors {






        \#0000ff \#00ff00 \#00ffff \#ff0000 \#ff00ff \#ffff00
        \#000099 \#009900 \#009999 \#990000 \#990099 \#999900
        \#000000 \#333333 \#666666 \#999999 \#cccccc \#ffffff
    }





    variable _userColors {
        \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff
        \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff
    }



    if {![string compare $::tcl_platform(platform) "unix"]} {
        set useTkDialogue 0
    } else {
        set useTkDialogue 1
    }





    variable _selectype
    variable _selection















































    variable _wcolor











































    variable _image
    variable _hsv
}












proc SelectColor::menu {path placement args} {
    variable _baseColors















    variable _userColors
    variable _wcolor
















    variable _selectype
    variable _selection









    Widget::init SelectColor $path $args
    set top [::menu $path]
    wm withdraw  $top
    wm transient $top [winfo toplevel [winfo parent $top]]

    set frame [frame $top.frame \
                   -highlightthickness 0 \
                   -relief raised -borderwidth 2]
    set col    0
    set row    0
    set count  0

    set colors [concat $_baseColors $_userColors]
    foreach color $colors {
        set f [frame $frame.c$count \
                   -highlightthickness 1 \
                   -highlightcolor white \
                   -relief solid -borderwidth 1 \
                   -width 16 -height 16 -background $color]

        bind $f <ButtonPress-1> "set SelectColor::_selection $count"
        bind $f <Enter>         {focus %W}
        grid $f -column $col -row $row -padx 1 -pady 1
        bindtags $f $f

        incr count

        if {[incr col] == 6 } {
            set  col 0
            incr row
        }
    }
    set f [label $frame.c$count \
               -highlightthickness 1 \
               -highlightcolor white \
               -relief flat -borderwidth 0 \
               -width 16 -height 16 -image [Bitmap::get palette]]
    grid $f -column $col -row $row -padx 1 -pady 1

    bind $f <ButtonPress-1> "set SelectColor::_selection $count"
    bind $f <Enter>         {focus %W}
    pack $frame

    bind $frame <ButtonPress-1> {set SelectColor::_selection -1}
    bind $frame <FocusOut>      {set SelectColor::_selection -2}
    eval BWidget::place $top 0 0 $placement

    wm deiconify $top
    focus -force $frame
    raise $top
    BWidget::grab set $frame


    tkwait variable SelectColor::_selection
    update
    BWidget::grab release $frame
    destroy $top
    update
    Widget::destroy $top
    if {$_selection == $count} {
        return [eval dialogue $path $args]
    } else {
        return [lindex $colors $_selection]
    }
}





proc SelectColor::dialogue {path args} {
    variable _baseColors
    variable _userColors
    variable _widget
    variable _selection
    variable _image
    variable _hsv


    Widget::init SelectColor $path:SelectColor $args
    set top   [Dialog::create $path \
                   -title  [Widget::cget $path:SelectColor -title]  \
                   -parent [Widget::cget $path:SelectColor -parent] \
                   -separator 1 -default 0 -cancel 1]
    wm resizable $top 0 0
    set dlgf  [$top getframe]  
    set fg    [frame $dlgf.fg]
    set desc  [list \
                   base _baseColors "Base colors" \
                   user _userColors "User colors"]
    set count 0
    foreach {type varcol defTitle} $desc {
        set col   0
        set lin   0
        set title [lindex [BWidget::getname "${type}Colors"] 0]
        if {![string length $title]} {
            set title $defTitle
        }
        set titf  [TitleFrame $fg.$type -text $title]
        set subf  [$titf getframe]
        foreach color [set $varcol] {
            set fround [frame $fg.round$count \
                            -highlightthickness 1 \
                            -relief sunken -borderwidth 2]
            set fcolor [frame $fg.color$count -width 16 -height 12 \
                            -highlightthickness 0 \
                            -relief flat -borderwidth 0 \
                            -background $color]
            pack $fcolor -in $fround
            grid $fround -in $subf -row $lin -column $col -padx 1 -pady 1

            bind $fround <ButtonPress-1> "SelectColor::_select_rgb $count"
            bind $fcolor <ButtonPress-1> "SelectColor::_select_rgb $count"

            incr count
            if {[incr col] == 6} {
                incr lin
                set  col 0
            }
        }
        pack $titf -anchor w -pady 2
    }
    set fround [frame $fg.round \
                    -highlightthickness 0 \
                    -relief sunken -borderwidth 2]
    set fcolor [frame $fg.color \
                    -width 50 \
                    -highlightthickness 0 \
                    -relief flat -borderwidth 0]
    pack $fcolor -in $fround -fill y -expand yes
    pack $fround -anchor e -pady 2 -fill y -expand yes

    set fd  [frame $dlgf.fd]
    set f1  [frame $fd.f1 -relief sunken -borderwidth 2]
    set f2  [frame $fd.f2 -relief sunken -borderwidth 2]
    set c1  [canvas $f1.c -width 200 -height 200 -bd 0 -highlightthickness 0]
    set c2  [canvas $f2.c -width 15  -height 200 -bd 0 -highlightthickness 0]

    for {set val 0} {$val < 40} {incr val} {
        $c2 create rectangle 0 [expr 5*$val] 15 [expr 5*$val+5] -tags val[expr 39-$val]
    }
    $c2 create polygon 0 0 10 5 0 10 -fill black -outline white -tags target

    pack $c1 $c2
    pack $f1 $f2 -side left -padx 10 -anchor n

    pack $fg $fd -side left -anchor n -fill y

    bind $c1 <ButtonPress-1> "SelectColor::_select_hue_sat %x %y"
    bind $c1 <B1-Motion>     "SelectColor::_select_hue_sat %x %y"

    bind $c2 <ButtonPress-1> "SelectColor::_select_value %x %y"
    bind $c2 <B1-Motion>     "SelectColor::_select_value %x %y"

    if {![info exists _image] || [catch {image type $_image}]} {
        set _image [image create photo -width 200 -height 200]
        for {set x 0} {$x < 200} {incr x 4} {
            for {set y 0} {$y < 200} {incr y 4} {
                $_image put \
                    [eval format "\#%04x%04x%04x" \
                         [hsvToRgb [expr $x/196.0] [expr (196-$y)/196.0] 0.85]] \
                    -to $x $y [expr $x+4] [expr $y+4]
            }
        }
    }
    $c1 create image  0 0 -anchor nw -image $_image
    $c1 create bitmap 0 0 \
        -bitmap @[file join $::env(BWIDGET_LIBRARY) "images" "target.xbm"] \
        -anchor nw -tags target

    set _selection -1
    set _widget(fcolor) $fg
    set _widget(chs)    $c1
    set _widget(cv)     $c2
    set rgb             [winfo rgb $path [Widget::cget $path:SelectColor -color]]
    set _hsv            [eval rgbToHsv $rgb]
    _set_rgb     [eval format "\#%04x%04x%04x" $rgb]
    _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1]
    _set_value   [lindex $_hsv 2]

    $top add -name ok
    $top add -name cancel
    set res [$top draw]
    if {$res == 0} {
        set color [$fg.color cget -background]
    } else {
        set color ""
    }
    destroy $top





    return $color
}








proc SelectColor::_select_rgb {count} {
    variable _baseColors
    variable _userColors
    variable _selection
    variable _widget
    variable _hsv

    set frame $_widget(fcolor)
    if {$_selection >= 0} {
        $frame.round$_selection configure \
            -relief sunken -highlightthickness 1 -borderwidth 2
    }
    $frame.round$count configure \
        -relief flat -highlightthickness 2 -borderwidth 1
    focus $frame.round$count
    set _selection $count
    set bg   [$frame.color$count cget -background]
    set user [expr {$_selection-[llength $_baseColors]}]
    if {$user >= 0 &&
        ![string compare \
              [winfo rgb $frame.color$_selection $bg] \
              [winfo rgb $frame.color$_selection white]]} {
        set bg [$frame.color cget -bg]
        $frame.color$_selection configure -background $bg
        set _userColors [lreplace $_userColors $user $user $bg]
    } else {
        set _hsv [eval rgbToHsv [winfo rgb $frame.color$count $bg]]
        _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1]
        _set_value   [lindex $_hsv 2]
        $frame.color configure -background $bg
    }
}


proc SelectColor::_set_rgb {rgb} {
    variable _selection
    variable _baseColors
    variable _userColors
    variable _widget

    set frame $_widget(fcolor)
    $frame.color configure -background $rgb
    set user [expr {$_selection-[llength $_baseColors]}]
    if {$user >= 0} {
        $frame.color$_selection configure -background $rgb
        set _userColors [lreplace $_userColors $user $user $rgb]
    }
}


proc SelectColor::_select_hue_sat {x y} {
    variable _widget
    variable _hsv

    if {$x < 0} {
        set x 0


    } elseif {$x > 200} {
        set x 200
    }
    if {$y < 0 } {
        set y 0

    } elseif {$y > 200} {
        set y 200
    }
    set hue  [expr $x/200.0]
    set sat  [expr (200-$y)/200.0]
    set _hsv [lreplace $_hsv 0 1 $hue $sat]
    $_widget(chs) coords target [expr {$x-9}] [expr {$y-9}]
    _draw_values $hue $sat
    _set_rgb [eval format "\#%04x%04x%04x" [eval hsvToRgb $_hsv]]
}




proc SelectColor::_set_hue_sat {hue sat} {
    variable _widget



    set x [expr {$hue*200-9}]
    set y [expr {(1-$sat)*200-9}]
    $_widget(chs) coords target $x $y
    _draw_values $hue $sat
}






proc SelectColor::_select_value {x y} {
    variable _widget
    variable _hsv

    if {$y < 0} {
        set y 0
    } elseif {$y > 200} {
        set y 200
    }



    $_widget(cv) coords target 0 [expr {$y-5}] 10 $y 0 [expr {$y+5}]
    set _hsv [lreplace $_hsv 2 2 [expr (200-$y)/200.0]]
    _set_rgb [eval format "\#%04x%04x%04x" [eval hsvToRgb $_hsv]]
}


proc SelectColor::_draw_values {hue sat} {
    variable _widget

    for {set val 0} {$val < 40} {incr val} {
        set l   [hsvToRgb $hue $sat [expr $val/39.0]]
        set col [eval format "\#%04x%04x%04x" $l]
        $_widget(cv) itemconfigure val$val -fill $col -outline $col
    }
}


proc SelectColor::_set_value {value} {
    variable _widget






    set y [expr {int((1-$value)*200)}]
    $_widget(cv) coords target 0 [expr {$y-5}] 10 $y 0 [expr {$y+5}]
}







# --
#  Taken from tk8.0/demos/tcolor.tcl
# --
# The procedure below converts an HSB value to RGB.  It takes hue, saturation,
# and value components (floating-point, 0-1.0) as arguments, and returns a
# list containing RGB components (integers, 0-65535) as result.  The code
# here is a copy of the code on page 616 of "Fundamentals of Interactive
# Computer Graphics" by Foley and Van Dam.

proc SelectColor::hsvToRgb {hue sat val} {
    set v [expr {round(65535.0*$val)}]
    if {$sat == 0} {
	return [list $v $v $v]
    } else {
	set hue [expr {$hue*6.0}]
	if {$hue >= 6.0} {
	    set hue 0.0
	}
	set i [expr {int($hue)}]
	set f [expr {$hue-$i}]
	set p [expr {round(65535.0*$val*(1 - $sat))}]
        set q [expr {round(65535.0*$val*(1 - ($sat*$f)))}]
        set t [expr {round(65535.0*$val*(1 - ($sat*(1 - $f))))}]
        switch $i {
	    0 {return [list $v $t $p]}
	    1 {return [list $q $v $p]}
	    2 {return [list $p $v $t]}
	    3 {return [list $p $q $v]}
	    4 {return [list $t $p $v]}
            5 {return [list $v $p $q]}
        }
    }
}


# --
#  Taken from tk8.0/demos/tcolor.tcl
# --
# The procedure below converts an RGB value to HSB.  It takes red, green,
# and blue components (0-65535) as arguments, and returns a list containing
# HSB components (floating-point, 0-1) as result.  The code here is a copy
# of the code on page 615 of "Fundamentals of Interactive Computer Graphics"
# by Foley and Van Dam.

proc SelectColor::rgbToHsv {red green blue} {
    if {$red > $green} {
	set max $red.0
	set min $green.0
    } else {
	set max $green.0
	set min $red.0
    }
    if {$blue > $max} {
	set max $blue.0
    } else {
	if {$blue < $min} {
	    set min $blue.0
	}
    }
    set range [expr $max-$min]
    if {$max == 0} {
	set sat 0
    } else {
	set sat [expr {($max-$min)/$max}]
    }
    if {$sat == 0} {
	set hue 0
    } else {
	set rc [expr {($max - $red)/$range}]
	set gc [expr {($max - $green)/$range}]
	set bc [expr {($max - $blue)/$range}]
	if {$red == $max} {
	    set hue [expr {.166667*($bc - $gc)}]
	} else {
	    if {$green == $max} {
		set hue [expr {.166667*(2 + $rc - $bc)}]
	    } else {
		set hue [expr {.166667*(4 + $gc - $rc)}]
	    }
	}
	if {$hue < 0.0} {
	    set hue [expr $hue + 1.0]
	}
    }
    return [list $hue $sat [expr {$max/65535}]]
}

Changes to combobox.tcl.

1
2
3
4
5
6
7
8
9
10
11
..
16
17
18
19
20
21
22

23
24
25
26
27
28
29
..
30
31
32
33
34
35
36


37
38
39
40
41
42
43

44
45
46
47
48
49
50
..
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132

133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
...
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245

246
247
248

249





250

251
252
253



254
255
256
257




258
259
260







261
262
263
264
265
266
267
268
269
270
271








272
273
274
275
276
277
278
279
280
281
282
283
284

285
286
287
288
289
290
291
...
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

324
325
326
327
328
329
330
331
332


333



334
335


336
337
338
339
340
341
342
...
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
# ------------------------------------------------------------------------------
#  combobox.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: combobox.tcl,v 1.4 1999/12/14 20:12:09 sven Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - ComboBox::create
#     - ComboBox::configure
#     - ComboBox::cget
#     - ComboBox::setvalue
#     - ComboBox::getvalue
................................................................................
#     - ComboBox::_modify_value
# ------------------------------------------------------------------------------

namespace eval ComboBox {
    ArrowButton::use
    Entry::use
    LabelFrame::use


    Widget::bwinclude ComboBox LabelFrame .labf \
        rename     {-text -label} \
        remove     {-focus} \
        prefix     {label -justify -width -anchor -height -font} \
        initialize {-relief sunken -borderwidth 2}

................................................................................
    Widget::bwinclude ComboBox Entry .e \
        remove {-relief -bd -borderwidth -bg -fg} \
        rename {-foreground -entryfg -background -entrybg}

    Widget::declare ComboBox {
        {-height      TkResource 0  0 listbox}
        {-values      String     "" 0}


        {-modifycmd   String     "" 0}
        {-postcommand String     "" 0}
    }

    Widget::addmap ComboBox "" :cmd {-background {}}
    Widget::addmap ComboBox ArrowButton .a \
        {-foreground {} -background {} -disabledforeground {} -state {}}


    Widget::syncoptions ComboBox Entry .e {-text {}}
    Widget::syncoptions ComboBox LabelFrame .labf {-label -text -underline {}}

    ::bind BwComboBox <FocusIn> {focus %W.labf}
    ::bind BwComboBox <Destroy> {Widget::destroy %W; rename %W {}}

................................................................................
}


# ------------------------------------------------------------------------------
#  Command ComboBox::create
# ------------------------------------------------------------------------------
proc ComboBox::create { path args } {
    global tcl_platform
    
    Widget::init ComboBox $path $args

    frame $path -background [Widget::getoption $path -background] \
        -highlightthickness 0 -bd 0 -relief flat -takefocus 0

    bindtags $path [list $path BwComboBox [winfo toplevel $path] all]

    set labf  [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
                   -focus $path.e]
    set entry [eval Entry::create $path.e [Widget::subcget $path .e] \
                   -relief flat -borderwidth 0 -takefocus 1]
    ::bind $path.e <FocusIn> "$path _focus_in"
    ::bind $path.e <FocusOut> "$path _focus_out"
    
    if {![string compare $tcl_platform(platform) "unix"]} {
        set ipadx 0
        set width  11
    } else {
        set ipadx 2
        set width  15
    }
    set height [winfo reqheight $entry]
    set arrow [eval ArrowButton::create $path.a [Widget::subcget $path .a] \
                   -width $width -height $height \
                   -highlightthickness 0 -borderwidth 1 -takefocus 0 \
                   -dir   bottom \
                   -type  button \
                   -ipadx $ipadx \
                   -command [list "ComboBox::_mapliste $path"]]
    
    
    set frame [LabelFrame::getframe $labf]

    pack $arrow -in $frame -side right -fill y
    pack $entry -in $frame -side left  -fill both -expand yes
    pack $labf  -fill x -expand yes

    if { [Widget::getoption $path -editable] != 0 } {
................................................................................
        ::bind $entry <ButtonPress-1> "ArrowButton::invoke $path.a"
        $path.e config -state disabled
    }

    ::bind $path  <ButtonPress-1> "ComboBox::_unmapliste $path"
    ::bind $entry <Key-Up>        "ComboBox::_unmapliste $path"
    ::bind $entry <Key-Down>      "ComboBox::_mapliste $path"
    ::bind $entry <Control-Up>    "ComboBox::_modify_value $path previous"
    ::bind $entry <Control-Down>  "ComboBox::_modify_value $path next"
    ::bind $entry <Control-Prior> "ComboBox::_modify_value $path first"
    ::bind $entry <Control-Next>  "ComboBox::_modify_value $path last"
    
    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[eval ComboBox::\$cmd $path \$args\]"

    return $path
}


# ------------------------------------------------------------------------------
#  Command ComboBox::configure
# ------------------------------------------------------------------------------
proc ComboBox::configure { path args } {
    set res [Widget::configure $path $args]

    if { [Widget::hasChanged $path -values values] |
         [Widget::hasChanged $path -height h] |
         [Widget::hasChanged $path -font f] } {
        destroy $path.shell.listb
    }


    if { [Widget::hasChanged $path -editable ed] } {
        if { $ed } {
            ::bind $path.e <ButtonPress-1> "ComboBox::_unmapliste $path"
            $path.e config -state normal
        } else {
            ::bind $path.e <ButtonPress-1> "ArrowButton::invoke $path.a"
            $path.e config -state disabled
        }
    }

    return $res
}


# ------------------------------------------------------------------------------
#  Command ComboBox::cget
# ------------------------------------------------------------------------------
proc ComboBox::cget { path option } {
    Widget::setoption $path -text [Entry::cget $path.e -text]
    return [Widget::cget $path $option]
}


# ------------------------------------------------------------------------------
#  Command ComboBox::setvalue
# ------------------------------------------------------------------------------
................................................................................
}


# ------------------------------------------------------------------------------
#  Command ComboBox::_create_popup
# ------------------------------------------------------------------------------
proc ComboBox::_create_popup { path } {
    set shell [menu $path.shell -tearoff 0 -relief flat -bd 0]
    wm overrideredirect $shell 1
    wm withdraw $shell
    wm transient $shell [winfo toplevel $path]
    wm group $shell [winfo toplevel $path]
    set lval [Widget::getoption $path -values]
    set h    [Widget::getoption $path -height] 
    set sb   0
    if { $h <= 0 } {
        set len [llength $lval]
        if { $len < 3 } {
            set h 3
        } elseif { $len > 10 } {
            set h  10

	    set sb 1
        }
    }

    set frame  [frame $shell.frame -relief sunken -bd 2]





    set listb  [listbox $shell.listb -relief flat -bd 0 -highlightthickness 0 \

                    -exportselection false \
                    -font   [Widget::getoption $path -font]  \
                    -height $h]




    if { $sb } {
	set scroll [scrollbar $shell.scroll \
		-orient vertical \




		-command "$shell.listb yview" \
		-highlightthickness 0 -takefocus 0 -width 9]
	$listb configure -yscrollcommand "$scroll set"







    }
    $listb delete 0 end
    foreach val $lval {
        $listb insert end $val
    }

    if { $sb } {
	pack $scroll -in $frame -side right -fill y
    }
    pack $listb  -in $frame -side left  -fill both -expand yes
    pack $frame  -fill both -expand yes -padx 1 -padx 1









    ::bind $listb <ButtonRelease-1> "ComboBox::_select $path @%x,%y"
    ::bind $listb <Return>          "ComboBox::_select $path active"
    ::bind $listb <Escape>          "ComboBox::_unmapliste $path"
}


# ------------------------------------------------------------------------------
#  Command ComboBox::_mapliste
# ------------------------------------------------------------------------------
proc ComboBox::_mapliste { path } {
    set listb $path.shell.listb
    if { [winfo exists $path.shell] } {

	_unmapliste $path
        return
    }

    if { [Widget::getoption $path -state] == "disabled" } {
        return
    }
................................................................................
    if { ![llength [Widget::getoption $path -values]] } {
        return
    }
    _create_popup $path

    ArrowButton::configure $path.a -relief sunken
    update
    
    $listb selection clear 0 end
    set values [$listb get 0 end]
    set curval [Entry::cget $path.e -text]
    if { [set idx [lsearch $values $curval]] != -1 ||
         [set idx [lsearch $values "$curval*"]] != -1 } {
        $listb selection set $idx
        $listb activate $idx
        $listb see $idx
    } else {
        $listb selection set 0
        $listb activate 0
        $listb see 0
    }

    ::bind $listb <Escape> "ComboBox::_unmapliste $path; break"
    
    set frame [LabelFrame::getframe $path.labf]
    BWidget::place $path.shell [winfo width $frame] 0 below $frame
    focus -force $listb
    wm deiconify $path.shell
    raise $path.shell

    BWidget::grab global $path
    ArrowButton::configure $path.a -relief raised
}


# ------------------------------------------------------------------------------
#  Command ComboBox::_unmapliste
# ------------------------------------------------------------------------------
proc ComboBox::_unmapliste { path } {


    BWidget::grab release $path



    focus -force $path.e
    destroy $path.shell


}


# ------------------------------------------------------------------------------
#  Command ComboBox::_select
# ------------------------------------------------------------------------------
proc ComboBox::_select { path index } {
................................................................................
    if { [setvalue $path $direction] } {
        if { [set cmd [Widget::getoption $path -modifycmd]] != "" } {
            uplevel \#0 $cmd
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ComboBox::_focus_in
# ------------------------------------------------------------------------------
proc ComboBox::_focus_in { path } {
    variable background
    variable foreground

    if { [Widget::getoption $path -editable] == 0 } {
        set value  [Entry::cget $path.e -text]
        if {[string equal $value ""]} {
................................................................................
        }
    }
    $path.e selection clear
    $path.e selection range 0 end
}


# ------------------------------------------------------------------------------
#  Command ComboBox::_focus_out
# ------------------------------------------------------------------------------
proc ComboBox::_focus_out { path } {
    variable background
    variable foreground

    if { [Widget::getoption $path -editable] == 0 } {
        if {[info exists background]} {
            $path.e configure -bg $background
            $path.e configure -fg $foreground
            unset background
            unset foreground
        }
    }
    # [email protected] It's not clear why you would want to clear selection
    # on a focus out event.  That basically disables -exportselection, which
    # seems like something users might want to do.  This feels like an 
    # application specific, rather than a widget general, behaviour.  Thus, I
    # am removing this behaviour:
    # $path.e selection clear
    # [email protected]
}


|







 







>







 







>
>





|
|
>







 







<
<













|
|

|


|







|

|
<







 







|
|
|
|
|













|
|
|
|
<
>




|
|













|







 







|
<
<
<
<
|
|
<





|
>
|


>
|
>
>
>
>
>
|
>
|
|
|
>
>
>

<
<
<
>
>
>
>
|
<
<
>
>
>
>
>
>
>

<
<
<
|

<
<
|
<
<
>
>
>
>
>
>
>
>
|
<
<
<








|
>







 







|

|







|




<
<


<


>

<







>
>
|
>
>
>
|
|
>
>







 







<
|

|







 







|

|












<
<
<
<
<
<
<

1
2
3
4
5
6
7
8
9
10
11
..
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
..
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
..
57
58
59
60
61
62
63


64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93

94
95
96
97
98
99
100
...
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132

133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
...
226
227
228
229
230
231
232
233




234
235

236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261



262
263
264
265
266


267
268
269
270
271
272
273
274



275
276


277


278
279
280
281
282
283
284
285
286



287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
...
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328


329
330

331
332
333
334

335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
...
378
379
380
381
382
383
384

385
386
387
388
389
390
391
392
393
394
...
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427







428
# ------------------------------------------------------------------------------
#  combobox.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: combobox.tcl,v 1.5 2000/02/11 22:54:26 ericm Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - ComboBox::create
#     - ComboBox::configure
#     - ComboBox::cget
#     - ComboBox::setvalue
#     - ComboBox::getvalue
................................................................................
#     - ComboBox::_modify_value
# ------------------------------------------------------------------------------

namespace eval ComboBox {
    ArrowButton::use
    Entry::use
    LabelFrame::use
    ListBox::use

    Widget::bwinclude ComboBox LabelFrame .labf \
        rename     {-text -label} \
        remove     {-focus} \
        prefix     {label -justify -width -anchor -height -font} \
        initialize {-relief sunken -borderwidth 2}

................................................................................
    Widget::bwinclude ComboBox Entry .e \
        remove {-relief -bd -borderwidth -bg -fg} \
        rename {-foreground -entryfg -background -entrybg}

    Widget::declare ComboBox {
        {-height      TkResource 0  0 listbox}
        {-values      String     "" 0}
        {-images      String     "" 0}
        {-indents     String     "" 0}
        {-modifycmd   String     "" 0}
        {-postcommand String     "" 0}
    }

    Widget::addmap ComboBox "" :cmd {-background {}}
    Widget::addmap ComboBox ArrowButton .a {
        -foreground {} -background {} -disabledforeground {} -state {}
    }

    Widget::syncoptions ComboBox Entry .e {-text {}}
    Widget::syncoptions ComboBox LabelFrame .labf {-label -text -underline {}}

    ::bind BwComboBox <FocusIn> {focus %W.labf}
    ::bind BwComboBox <Destroy> {Widget::destroy %W; rename %W {}}

................................................................................
}


# ------------------------------------------------------------------------------
#  Command ComboBox::create
# ------------------------------------------------------------------------------
proc ComboBox::create { path args } {


    Widget::init ComboBox $path $args

    frame $path -background [Widget::getoption $path -background] \
        -highlightthickness 0 -bd 0 -relief flat -takefocus 0

    bindtags $path [list $path BwComboBox [winfo toplevel $path] all]

    set labf  [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
                   -focus $path.e]
    set entry [eval Entry::create $path.e [Widget::subcget $path .e] \
                   -relief flat -borderwidth 0 -takefocus 1]
    ::bind $path.e <FocusIn> "$path _focus_in"
    ::bind $path.e <FocusOut> "$path _focus_out"

    if {[string equal $::tcl_platform(platform) "unix"]} {
        set ipadx 0
        set width 11
    } else {
        set ipadx 2
        set width 15
    }
    set height [winfo reqheight $entry]
    set arrow [eval ArrowButton::create $path.a [Widget::subcget $path .a] \
                   -width $width -height $height \
                   -highlightthickness 0 -borderwidth 1 -takefocus 0 \
                   -dir   bottom \
                   -type  button \
		   -ipadx $ipadx \
                   -command [list "ComboBox::_mapliste $path"]]


    set frame [LabelFrame::getframe $labf]

    pack $arrow -in $frame -side right -fill y
    pack $entry -in $frame -side left  -fill both -expand yes
    pack $labf  -fill x -expand yes

    if { [Widget::getoption $path -editable] != 0 } {
................................................................................
        ::bind $entry <ButtonPress-1> "ArrowButton::invoke $path.a"
        $path.e config -state disabled
    }

    ::bind $path  <ButtonPress-1> "ComboBox::_unmapliste $path"
    ::bind $entry <Key-Up>        "ComboBox::_unmapliste $path"
    ::bind $entry <Key-Down>      "ComboBox::_mapliste $path"
    ::bind $entry <Control-Up>        "ComboBox::_modify_value $path previous"
    ::bind $entry <Control-Down>      "ComboBox::_modify_value $path next"
    ::bind $entry <Control-Prior>     "ComboBox::_modify_value $path first"
    ::bind $entry <Control-Next>      "ComboBox::_modify_value $path last"

    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[eval ComboBox::\$cmd $path \$args\]"

    return $path
}


# ------------------------------------------------------------------------------
#  Command ComboBox::configure
# ------------------------------------------------------------------------------
proc ComboBox::configure { path args } {
    set res [Widget::configure $path $args]

#     if { [Widget::hasChanged $path -values values] |
#          [Widget::hasChanged $path -height h] |
#          [Widget::hasChanged $path -font f] } {
#         destroy $path.shell.listb

#     }

    if { [Widget::hasChanged $path -editable ed] } {
        if { $ed } {
            ::bind $path.e <ButtonPress-1> "ComboBox::_unmapliste $path"
             $path.e config -state normal
       } else {
            ::bind $path.e <ButtonPress-1> "ArrowButton::invoke $path.a"
            $path.e config -state disabled
        }
    }

    return $res
}


# ------------------------------------------------------------------------------
#  Command ComboBox::cget
# ------------------------------------------------------------------------------
proc ComboBox::cget { path option } {
#    Widget::setoption $path -text [Entry::cget $path.e -text]
    return [Widget::cget $path $option]
}


# ------------------------------------------------------------------------------
#  Command ComboBox::setvalue
# ------------------------------------------------------------------------------
................................................................................
}


# ------------------------------------------------------------------------------
#  Command ComboBox::_create_popup
# ------------------------------------------------------------------------------
proc ComboBox::_create_popup { path } {
    set shell $path.shell




    set lval  [Widget::getoption $path -values]
    set h     [Widget::getoption $path -height] 

    if { $h <= 0 } {
        set len [llength $lval]
        if { $len < 3 } {
            set h 3
        } elseif { $len > 10 } {
            set h 10
        } else {
            set h $len
        }
    }
    if {![winfo exists $path.shell]} {
        set shell [toplevel $path.shell -relief sunken -bd 2]
        wm overrideredirect $shell 1
        wm transient $shell [winfo toplevel $path]
        wm withdraw  $shell

        set sw     [ScrolledWindow $shell.sw -managed 0 -size 11 -ipad 0]
        set listb  [listbox $shell.listb \
                        -relief flat -borderwidth 0 -highlightthickness 0 \
                        -exportselection false \
                        -font   [Widget::getoption $path -font]  \
                        -height $h]
        pack $sw -fill both -expand yes
        $sw setwidget $listb
        _update_listbox $path 1




        ::bind $listb <ButtonRelease-1> "ComboBox::_select $path @%x,%y"
        ::bind $listb <Return>          "ComboBox::_select $path active; break"
        ::bind $listb <Escape>          "ComboBox::_unmapliste $path; break"
    } else {
        set listb $shell.listb


        destroy $shell.sw
        set sw [ScrolledWindow $shell.sw -managed 0 -size 11 -ipad 0]
        $listb configure -height $h -font [Widget::getoption $path -font]
        pack $sw -fill both -expand yes
        $sw setwidget $listb
        raise $listb
        _update_listbox $path 0
    }



}






# ------------------------------------------------------------------------------
#  Command ComboBox::_update_listbox
# ------------------------------------------------------------------------------
proc ComboBox::_update_listbox {path force} {
    if {[Widget::hasChanged $path -values values] || $force} {
        set listb $path.shell.listb
        $listb delete 0 end
        eval $listb insert end $values
    }



}


# ------------------------------------------------------------------------------
#  Command ComboBox::_mapliste
# ------------------------------------------------------------------------------
proc ComboBox::_mapliste { path } {
    set listb $path.shell.listb
    if {[winfo exists $path.shell] &&
        ![string compare [wm state $path.shell] "normal"]} {
	_unmapliste $path
        return
    }

    if { [Widget::getoption $path -state] == "disabled" } {
        return
    }
................................................................................
    if { ![llength [Widget::getoption $path -values]] } {
        return
    }
    _create_popup $path

    ArrowButton::configure $path.a -relief sunken
    update

    $listb selection clear 0 end
    set values [Widget::getoption $path -values]
    set curval [Entry::cget $path.e -text]
    if { [set idx [lsearch $values $curval]] != -1 ||
         [set idx [lsearch $values "$curval*"]] != -1 } {
        $listb selection set $idx
        $listb activate $idx
        $listb see $idx
    } else {
	$listb selection set 0
        $listb activate 0
        $listb see 0
    }



    set frame [LabelFrame::getframe $path.labf]
    BWidget::place $path.shell [winfo width $frame] 0 below $frame

    wm deiconify $path.shell
    raise $path.shell
    BWidget::focus set $listb
    BWidget::grab global $path

}


# ------------------------------------------------------------------------------
#  Command ComboBox::_unmapliste
# ------------------------------------------------------------------------------
proc ComboBox::_unmapliste { path } {
    if {[winfo exists $path.shell] && \
	    ![string compare [wm state $path.shell] "normal"]} {
        BWidget::grab release $path
        BWidget::focus release $path.shell.listb
	# Update now because otherwise [focus -force...] makes the app hang!
	update
	focus -force $path.e
        wm withdraw $path.shell
        ArrowButton::configure $path.a -relief raised
    }
}


# ------------------------------------------------------------------------------
#  Command ComboBox::_select
# ------------------------------------------------------------------------------
proc ComboBox::_select { path index } {
................................................................................
    if { [setvalue $path $direction] } {
        if { [set cmd [Widget::getoption $path -modifycmd]] != "" } {
            uplevel \#0 $cmd
        }
    }
}


# ----------------------------------------------------------------------------
#  Command ComboBox::_focus_in
# ----------------------------------------------------------------------------
proc ComboBox::_focus_in { path } {
    variable background
    variable foreground

    if { [Widget::getoption $path -editable] == 0 } {
        set value  [Entry::cget $path.e -text]
        if {[string equal $value ""]} {
................................................................................
        }
    }
    $path.e selection clear
    $path.e selection range 0 end
}


# ----------------------------------------------------------------------------
#  Command ComboBox::_focus_out
# ----------------------------------------------------------------------------
proc ComboBox::_focus_out { path } {
    variable background
    variable foreground

    if { [Widget::getoption $path -editable] == 0 } {
        if {[info exists background]} {
            $path.e configure -bg $background
            $path.e configure -fg $foreground
            unset background
            unset foreground
        }
    }







}

Changes to listbox.tcl.

1
2
3
4
5
6
7
8
9
10
11
..
41
42
43
44
45
46
47
48
49
50

51
52
53
54



55
56
57
58

59
60
61


62
63

64
65
66
67
68

69
70
71

72
73
74
75
76


77
78
79
80
81
82
83
...
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
...
267
268
269
270
271
272
273
274


275
276
277
278
279
280
281
...
427
428
429
430
431
432
433



434
435
436
437
438
439
440
...
456
457
458
459
460
461
462


























































463
464
465
466
467
468
469
...
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
...
571
572
573
574
575
576
577

578
579
580
581
582
583
584
...
629
630
631
632
633
634
635














636
637
638
639
640
641
642
...
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
...
811
812
813
814
815
816
817
818
819
820
821
822
823

824
825
826
827
828
829
830
831
...
986
987
988
989
990
991
992




993

994
995
996
997
998
999
1000
1001
....
1014
1015
1016
1017
1018
1019
1020

1021
1022
1023
1024
1025
1026
1027
....
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
....
1091
1092
1093
1094
1095
1096
1097

1098
1099
1100
1101
1102
1103
1104
1105
1106
1107

1108
1109
1110
1111
1112
1113
1114
# ------------------------------------------------------------------------------
#  listbox.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: listbox.tcl,v 1.1.1.1 1999/08/03 20:20:23 ericm Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - ListBox::create
#     - ListBox::configure
#     - ListBox::cget
#     - ListBox::insert
#     - ListBox::itemconfigure
................................................................................
#     - ListBox::_scroll
# ------------------------------------------------------------------------------


namespace eval ListBox {
    namespace eval Item {
        Widget::declare ListBox::Item {
            {-indent     Int        0       0 {=0}}
            {-text       String     ""      0}
            {-font       TkResource ""      0 listbox}

            {-image      TkResource ""      0 label}
            {-window     String     ""      0}
            {-fill       TkResource black   0 {listbox -foreground}}
            {-data       String     ""      0}



        }
    }

    Widget::tkinclude ListBox canvas :cmd \

        remove     {-insertwidth -insertbackground -insertborderwidth -insertofftime \
                        -insertontime -selectborderwidth -closeenough -confine -scrollregion \
                        -xscrollincrement -yscrollincrement -width -height} \


        initialize {-relief sunken -borderwidth 2 -takefocus 1 \
                        -highlightthickness 1 -width 200}


    Widget::declare ListBox {
        {-deltax           Int 10 0 {=0 ""}}
        {-deltay           Int 15 0 {=0 ""}}
        {-padx             Int 20 0 {=0 ""}}

        {-background       TkResource "" 0 listbox}
        {-selectbackground TkResource "" 0 listbox}
        {-selectforeground TkResource "" 0 listbox}

        {-width            TkResource "" 0 listbox}
        {-height           TkResource "" 0 listbox}
        {-redraw           Boolean 1  0}
        {-multicolumn      Boolean 0  0}
        {-dropovermode     Flag    "wpi" 0 "wpi"}


        {-bg               Synonym -background}
    }
    DragSite::include ListBox "LISTBOX_ITEM" 1
    DropSite::include ListBox {
        LISTBOX_ITEM {copy {} move {}}
    }

................................................................................

    set res   [Widget::configure $path.$item $args]
    set chind [Widget::hasChanged $path.$item -indent indent]
    set chw   [Widget::hasChanged $path.$item -window win]
    set chi   [Widget::hasChanged $path.$item -image  img]
    set cht   [Widget::hasChanged $path.$item -text txt]
    set chf   [Widget::hasChanged $path.$item -font fnt]
    set chfg  [Widget::hasChanged $path.$item -fill fg]
    set idn   [$path:cmd find withtag n:$item]

    if { $idn == "" } {
        # item is not drawn yet
        _redraw_idle $path 2
        return $res
    }
................................................................................
            }
        } else {
            $path:cmd delete $idi
        }
    }

    if { $cht || $chf || $chfg } {
        # -text or -font modified, or -fill modified


        $path:cmd itemconfigure $idn -text $txt -font $fnt -fill $fg
        _redraw_idle $path 1
    }

    if { $chind } {
        # -indent modified
        $path:cmd coords $idn [expr {$x0+$padx}] $y0
................................................................................
        }
        clear {
            set data(selitems) {}
        }
        get {
            return $data(selitems)
        }



        default {
            return
        }
    }
    _redraw_idle $path 1
}

................................................................................
proc ListBox::index { path item } {
    variable $path
    upvar 0  $path data

    return [lsearch $data(items) $item]
}




























































# ------------------------------------------------------------------------------
#  Command ListBox::item - deprecated
# ------------------------------------------------------------------------------
proc ListBox::item { path first {last ""} } {
    variable $path
    upvar 0  $path data
................................................................................
                        -relief flat -borderwidth 0 -highlightthickness 0 \
                        -background [Widget::getoption $path -background]]
        set ent    [entry $frame.edit \
                        -width              0     \
                        -relief             solid \
                        -borderwidth        1     \
                        -highlightthickness 0     \
                        -foreground         [Widget::getoption $path.$item -fill] \
                        -background         [Widget::getoption $path -background] \
                        -selectforeground   [Widget::getoption $path -selectforeground] \
                        -selectbackground   $sbg  \
                        -font               [Widget::getoption $path.$item -font] \
                        -textvariable       ListBox::_edit(text)]
        pack $ent -ipadx 8 -anchor w

        set idw [$path:cmd create window $x $y -window $frame -anchor w]
        trace variable ListBox::_edit(text) w "ListBox::_update_edit_size $path $ent $idw $wmax"
        tkwait visibility $ent
        grab  $frame
................................................................................
        update
        if { $select } {
            $ent selection range 0 end
            $ent icursor end
            $ent xview end
        }


        bind $ent <Escape> {set ListBox::_edit(wait) 0}
        bind $ent <Return> {set ListBox::_edit(wait) 1}
	if { $clickres == 0 || $clickres == 1 } {
	    bind $frame <Button>  "set ListBox::_edit(wait) $clickres"
	}

        set ok 0
................................................................................
    if { $entw >= $wmax } {
        $path:cmd itemconfigure $idw -width $wmax
    } else {
        $path:cmd itemconfigure $idw -width 0
    }
}
















# ------------------------------------------------------------------------------
#  Command ListBox::_destroy
# ------------------------------------------------------------------------------
proc ListBox::_destroy { path } {
    variable $path
    upvar 0  $path data
................................................................................
# ------------------------------------------------------------------------------
#  Command ListBox::_draw_item
# ------------------------------------------------------------------------------
proc ListBox::_draw_item { path item x0 x1 y } {
    set indent [Widget::getoption $path.$item -indent]
    $path:cmd create text [expr {$x1+$indent}] $y \
        -text   [Widget::getoption $path.$item -text] \
        -fill   [Widget::getoption $path.$item -fill] \
        -font   [Widget::getoption $path.$item -font] \
        -anchor w \
        -tags   "item n:$item"
    if { [set win [Widget::getoption $path.$item -window]] != "" } {
        $path:cmd create window [expr {$x0+$indent}] $y \
            -window $win -anchor w -tags "win i:$item"
    } elseif { [set img [Widget::getoption $path.$item -image]] != "" } {
        $path:cmd create image [expr {$x0+$indent}] $y \
................................................................................
    variable $path
    upvar 0  $path data

    set selbg [Widget::getoption $path -selectbackground]
    set selfg [Widget::getoption $path -selectforeground]
    foreach id [$path:cmd find withtag sel] {
        set item [string range [lindex [$path:cmd gettags $id] 1] 2 end]
        $path:cmd itemconfigure "n:$item" -fill [Widget::getoption $path.$item -fill]
    }
    $path:cmd delete sel
    foreach item $data(selitems) {
        set bbox [$path:cmd bbox "n:$item"]
        if { [llength $bbox] } {

            set id [eval $path:cmd create rectangle $bbox -fill $selbg -outline $selbg -tags [list "sel s:$item"]]
            $path:cmd itemconfigure "n:$item" -fill $selfg
            $path:cmd lower $id
        }
    }
}


................................................................................
        # dropovermode includes widget
        set target [list widget]
        set vmode  4
    } else {
        set target [list ""]
        set vmode  0
    }






    if { $data(dnd,mode) & 3 } {
        # dropovermode includes item or position
        # we extract the box (xi,yi,xs,ys) where we can find item around x,y
        set len  [llength $data(items)]
        set xc   [$path:cmd canvasx $x]
        set yc   [$path:cmd canvasy $y]
        set dy   [$path:cmd cget -yscrollincrement]
        set line [expr {int($yc/$dy)}]
................................................................................
                    break
                }
                set  xi  $xs
                incr pos $nrows
            }
            if { $pos < $len } {
                set item [lindex $data(items) $pos]

                if { $data(dnd,mode) & 1 } {
                    # dropovermode includes item
                    lappend target $item
                    set vmode [expr {$vmode | 1}]
                } else {
                    lappend target ""
                }
................................................................................
    }

    if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
        # user-defined dropover command
        set res   [uplevel \#0 $cmd [list $source $target $op $type $dnddata]]
        set code  [lindex $res 0]
        set vmode 0
        if { $code & 1 } {
            # update vmode
            set mode [lindex $res 1]
            if { ![string compare $mode "item"] } {
                set vmode 1
            } elseif { ![string compare $mode "position"] } {
                set vmode 2
            } elseif { ![string compare $mode "widget"] } {
                set vmode 4
            }
        }
    } else {
        if { ($vmode & 3) == 3 } {
            # result have both item and position
            # we choose the preferred method
            if { ![string compare [lindex $target 3] "position"] } {
................................................................................
            set code 1
        } else {
            set code 3
        }
    }

    # draw dnd visual following vmode

    if { $vmode & 1 } {
        set data(dnd,item) [list "item" [lindex $target 1]]
        $path:cmd create rectangle $xi $yi $xs $ys -tags drop
    } elseif { $vmode & 2 } {
        set data(dnd,item) [concat "position" [lindex $target 2]]
        $path:cmd create line $xi $yl $xs $yl -tags drop
    } elseif { $vmode & 4 } {
        set data(dnd,item) [list "widget"]
    } else {
        set code [expr {$code & 2}]

    }

    if { $code & 1 } {
        DropSite::setcursor based_arrow_down
    } else {
        DropSite::setcursor dot
    }


|







 







|
|
|
>
|
|
<
|
>
>
>




>
|
|
|
>
>
|
|
>





>



>





>
>







 







|







 







|
>
>







 







>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|



|







 







>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
|







 







|





>
|







 







>
>
>
>
|
>
|







 







>







 







|

|
<
|
<
|
<
|







 







>
|
|
|
|
|
|
|
|
|
|
>







1
2
3
4
5
6
7
8
9
10
11
..
41
42
43
44
45
46
47
48
49
50
51
52
53

54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
...
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
...
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
...
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
...
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
...
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
...
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
...
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
...
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
...
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
....
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
....
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
....
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165

1166

1167

1168
1169
1170
1171
1172
1173
1174
1175
....
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
# ------------------------------------------------------------------------------
#  listbox.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: listbox.tcl,v 1.2 2000/02/11 22:54:26 ericm Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - ListBox::create
#     - ListBox::configure
#     - ListBox::cget
#     - ListBox::insert
#     - ListBox::itemconfigure
................................................................................
#     - ListBox::_scroll
# ------------------------------------------------------------------------------


namespace eval ListBox {
    namespace eval Item {
        Widget::declare ListBox::Item {
            {-indent     Int        0   0 {=0}}
            {-text       String     ""  0}
            {-font       String     ""  0}
            {-foreground String     ""  0}
            {-image      TkResource ""  0 label}
            {-window     String     ""  0}

            {-data       String     ""  0}

            {-fill       Synonym    -foreground}
            {-fg         Synonym    -foreground}
        }
    }

    Widget::tkinclude ListBox canvas :cmd \
        remove {
            -insertwidth -insertbackground -insertborderwidth -insertofftime
            -insertontime -selectborderwidth -closeenough -confine -scrollregion
            -xscrollincrement -yscrollincrement -width -height
        } \
        initialize {
            -relief sunken -borderwidth 2 -takefocus 1
            -highlightthickness 1 -width 200
        }

    Widget::declare ListBox {
        {-deltax           Int 10 0 {=0 ""}}
        {-deltay           Int 15 0 {=0 ""}}
        {-padx             Int 20 0 {=0 ""}}
        {-foreground       TkResource "" 0 listbox}
        {-background       TkResource "" 0 listbox}
        {-selectbackground TkResource "" 0 listbox}
        {-selectforeground TkResource "" 0 listbox}
        {-font             TkResource "" 0 listbox}
        {-width            TkResource "" 0 listbox}
        {-height           TkResource "" 0 listbox}
        {-redraw           Boolean 1  0}
        {-multicolumn      Boolean 0  0}
        {-dropovermode     Flag    "wpi" 0 "wpi"}

        {-fg               Synonym -foreground}
        {-bg               Synonym -background}
    }
    DragSite::include ListBox "LISTBOX_ITEM" 1
    DropSite::include ListBox {
        LISTBOX_ITEM {copy {} move {}}
    }

................................................................................

    set res   [Widget::configure $path.$item $args]
    set chind [Widget::hasChanged $path.$item -indent indent]
    set chw   [Widget::hasChanged $path.$item -window win]
    set chi   [Widget::hasChanged $path.$item -image  img]
    set cht   [Widget::hasChanged $path.$item -text txt]
    set chf   [Widget::hasChanged $path.$item -font fnt]
    set chfg  [Widget::hasChanged $path.$item -foreground fg]
    set idn   [$path:cmd find withtag n:$item]

    if { $idn == "" } {
        # item is not drawn yet
        _redraw_idle $path 2
        return $res
    }
................................................................................
            }
        } else {
            $path:cmd delete $idi
        }
    }

    if { $cht || $chf || $chfg } {
        # -text or -font modified, or -foreground modified
        set fnt [_getoption $path $item -font]
        set fg  [_getoption $path $item -foreground]
        $path:cmd itemconfigure $idn -text $txt -font $fnt -fill $fg
        _redraw_idle $path 1
    }

    if { $chind } {
        # -indent modified
        $path:cmd coords $idn [expr {$x0+$padx}] $y0
................................................................................
        }
        clear {
            set data(selitems) {}
        }
        get {
            return $data(selitems)
        }
        includes {
            return [expr {[lsearch $data(selitems) $args] != -1}]
        }
        default {
            return
        }
    }
    _redraw_idle $path 1
}

................................................................................
proc ListBox::index { path item } {
    variable $path
    upvar 0  $path data

    return [lsearch $data(items) $item]
}


# ------------------------------------------------------------------------------
#  ListBox::find
#     Returns the item given a position.
#  findInfo     @x,y ?confine?
#               lineNumber
# ------------------------------------------------------------------------------
proc ListBox::find {path findInfo {confine ""}} {
    variable $path
    upvar 0  $path widgetData

    if {[regexp -- {^@([0-9]+),([0-9]+)$} $findInfo match x y]} {
        set x [$path:cmd canvasx $x]
        set y [$path:cmd canvasy $y]
    } elseif {[regexp -- {^[0-9]+$} $findInfo lineNumber]} {
        set dy [Widget::getoption $path -deltay]
        set y  [expr {$dy*($lineNumber+0.5)}]
        set confine ""
    } else {
        return -code error "invalid find spec \"$findInfo\""
    }

    set found 0
    set xi    0
    foreach xs $widgetData(xlist) {
        if {$x <= $xs} {
            foreach id [$path:cmd find overlapping $xi $y $xs $y] {
                set ltags [$path:cmd gettags $id]
                set item  [lindex $ltags 0]
                if { ![string compare $item "item"] ||
                     ![string compare $item "img"]  ||
                     ![string compare $item "win"] } {
                    # item is the label or image/window of the node
                    set item [string range [lindex $ltags 1] 2 end]
                    set found 1
                    break
                }
            }
            break
        }
        set  xi  $xs
    }

    if {$found} {
        if {[string compare $confine "confine" 0] == 0} {
            # test if x stand inside node bbox
            set xi [expr {[lindex [$path:cmd coords n:$item] 0]-[Widget::getoption $path -padx]}]
            set xs [lindex [$path:cmd bbox n:$item] 2]
            if {$x >= $xi && $x <= $xs} {
                return $item
            }
        } else {
            return $item
        }
    }
    return ""
}


# ------------------------------------------------------------------------------
#  Command ListBox::item - deprecated
# ------------------------------------------------------------------------------
proc ListBox::item { path first {last ""} } {
    variable $path
    upvar 0  $path data
................................................................................
                        -relief flat -borderwidth 0 -highlightthickness 0 \
                        -background [Widget::getoption $path -background]]
        set ent    [entry $frame.edit \
                        -width              0     \
                        -relief             solid \
                        -borderwidth        1     \
                        -highlightthickness 0     \
                        -foreground         [_getoption $path $item -foreground] \
                        -background         [Widget::getoption $path -background] \
                        -selectforeground   [Widget::getoption $path -selectforeground] \
                        -selectbackground   $sbg  \
                        -font               [_getoption $path $item -font] \
                        -textvariable       ListBox::_edit(text)]
        pack $ent -ipadx 8 -anchor w

        set idw [$path:cmd create window $x $y -window $frame -anchor w]
        trace variable ListBox::_edit(text) w "ListBox::_update_edit_size $path $ent $idw $wmax"
        tkwait visibility $ent
        grab  $frame
................................................................................
        update
        if { $select } {
            $ent selection range 0 end
            $ent icursor end
            $ent xview end
        }

        bindtags $ent [list $ent Entry]
        bind $ent <Escape> {set ListBox::_edit(wait) 0}
        bind $ent <Return> {set ListBox::_edit(wait) 1}
	if { $clickres == 0 || $clickres == 1 } {
	    bind $frame <Button>  "set ListBox::_edit(wait) $clickres"
	}

        set ok 0
................................................................................
    if { $entw >= $wmax } {
        $path:cmd itemconfigure $idw -width $wmax
    } else {
        $path:cmd itemconfigure $idw -width 0
    }
}


# ------------------------------------------------------------------------------
#  Command ListBox::_getoption
#     Returns the value of option for node. If empty, returned value is those
#  of the ListBox.
# ------------------------------------------------------------------------------
proc ListBox::_getoption { path item option } {
    set value [Widget::getoption $path.$item $option]
    if {![string length $value]} {
        set value [Widget::getoption $path $option]
    }
    return $value
}


# ------------------------------------------------------------------------------
#  Command ListBox::_destroy
# ------------------------------------------------------------------------------
proc ListBox::_destroy { path } {
    variable $path
    upvar 0  $path data
................................................................................
# ------------------------------------------------------------------------------
#  Command ListBox::_draw_item
# ------------------------------------------------------------------------------
proc ListBox::_draw_item { path item x0 x1 y } {
    set indent [Widget::getoption $path.$item -indent]
    $path:cmd create text [expr {$x1+$indent}] $y \
        -text   [Widget::getoption $path.$item -text] \
        -fill   [_getoption        $path $item -foreground] \
        -font   [_getoption        $path $item -font] \
        -anchor w \
        -tags   "item n:$item"
    if { [set win [Widget::getoption $path.$item -window]] != "" } {
        $path:cmd create window [expr {$x0+$indent}] $y \
            -window $win -anchor w -tags "win i:$item"
    } elseif { [set img [Widget::getoption $path.$item -image]] != "" } {
        $path:cmd create image [expr {$x0+$indent}] $y \
................................................................................
    variable $path
    upvar 0  $path data

    set selbg [Widget::getoption $path -selectbackground]
    set selfg [Widget::getoption $path -selectforeground]
    foreach id [$path:cmd find withtag sel] {
        set item [string range [lindex [$path:cmd gettags $id] 1] 2 end]
        $path:cmd itemconfigure "n:$item" -fill [_getoption $path $item -foreground]
    }
    $path:cmd delete sel
    foreach item $data(selitems) {
        set bbox [$path:cmd bbox "n:$item"]
        if { [llength $bbox] } {
            set id [eval $path:cmd create rectangle $bbox \
                        -fill $selbg -outline $selbg -tags [list "sel s:$item"]]
            $path:cmd itemconfigure "n:$item" -fill $selfg
            $path:cmd lower $id
        }
    }
}


................................................................................
        # dropovermode includes widget
        set target [list widget]
        set vmode  4
    } else {
        set target [list ""]
        set vmode  0
    }
    if { ($data(dnd,mode) & 2) && ![llength $data(items)] } {
        # dropovermode includes position and listbox is empty
        lappend target "" 0
        set vmode [expr {$vmode | 2}]
    }

    if { ($data(dnd,mode) & 3) && [llength $data(items)]} {
        # dropovermode includes item or position
        # we extract the box (xi,yi,xs,ys) where we can find item around x,y
        set len  [llength $data(items)]
        set xc   [$path:cmd canvasx $x]
        set yc   [$path:cmd canvasy $y]
        set dy   [$path:cmd cget -yscrollincrement]
        set line [expr {int($yc/$dy)}]
................................................................................
                    break
                }
                set  xi  $xs
                incr pos $nrows
            }
            if { $pos < $len } {
                set item [lindex $data(items) $pos]
                set xi   [expr {[lindex [$path:cmd coords n:$item] 0]-[Widget::getoption $path -padx]-1}]
                if { $data(dnd,mode) & 1 } {
                    # dropovermode includes item
                    lappend target $item
                    set vmode [expr {$vmode | 1}]
                } else {
                    lappend target ""
                }
................................................................................
    }

    if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
        # user-defined dropover command
        set res   [uplevel \#0 $cmd [list $source $target $op $type $dnddata]]
        set code  [lindex $res 0]
        set vmode 0
        if {$code & 1} {
            # update vmode
            switch -exact -- [lindex $res 1] {

                item     {set vmode 1}

                position {set vmode 2}

                widget   {set vmode 4}
            }
        }
    } else {
        if { ($vmode & 3) == 3 } {
            # result have both item and position
            # we choose the preferred method
            if { ![string compare [lindex $target 3] "position"] } {
................................................................................
            set code 1
        } else {
            set code 3
        }
    }

    # draw dnd visual following vmode
    if {[llength $data(items)]} {
        if { $vmode & 1 } {
            set data(dnd,item) [list "item" [lindex $target 1]]
            $path:cmd create rectangle $xi $yi $xs $ys -tags drop
        } elseif { $vmode & 2 } {
            set data(dnd,item) [concat "position" [lindex $target 2]]
            $path:cmd create line $xi $yl $xs $yl -tags drop
        } elseif { $vmode & 4 } {
            set data(dnd,item) [list "widget"]
        } else {
            set code [expr {$code & 2}]
        }
    }

    if { $code & 1 } {
        DropSite::setcursor based_arrow_down
    } else {
        DropSite::setcursor dot
    }

Changes to mainframe.tcl.

1
2
3
4
5
6
7
8
9
10
11
...
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
...
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
...
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
...
529
530
531
532
533
534
535
536
537

538












539



540
541
542

543
544
545



546




547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
# ------------------------------------------------------------------------------
#  mainframe.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: mainframe.tcl,v 1.4 2000/01/24 16:35:38 sven Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - MainFrame::create
#     - MainFrame::configure
#     - MainFrame::cget
#     - MainFrame::getframe
#     - MainFrame::addtoolbar
................................................................................
                      -takefocus 0 -highlightthickness 0 -background $bg]
    set indframe [frame $status.indf -relief flat -borderwidth 0 \
                      -takefocus 0 -highlightthickness 0 -background $bg]
    set prgframe [frame $status.prgf -relief flat -borderwidth 0 \
                      -takefocus 0 -highlightthickness 0 -background $bg]

    place $label    -anchor w -x 0 -rely 0.5
    place $indframe -anchor e -relx 1 -rely 0.5
    pack  $prgframe -in $indframe -side left -padx 2
    $status configure -height [winfo reqheight $label]

    set progress [eval ProgressBar::create $status.prg [Widget::subcget $path .status.prg] \
                      -width       50 \
                      -height      [expr {[winfo reqheight $label]-2}] \
                      -borderwidth 1 \
................................................................................
    variable _widget

    set index $_widget($path,nindic)
    set indic $path.status.indf.f$index
    eval label $indic $args -relief sunken -borderwidth 1 \
        -takefocus 0 -highlightthickness 0

    pack $indic -side left -anchor w -padx 2

    incr _widget($path,nindic)

    return $indic
}


................................................................................
proc MainFrame::_destroy { path } {
    variable _widget

    Widget::destroy $path
    catch {destroy [$_widget($path,top) cget -menu]}
    $_widget($path,top) configure -menu {}

    # [email protected]
    # We really want to unset ALL of the state vars, not just some of them
    # Otherwise, if we ever create a MainFrame with the same pathname, it has
    # some residual (incorrect) state.
    foreach var [array names _widget $path*] {
	unset _widget($var)
    }
#    unset _widget($path,top)
#    unset _widget($path,ntoolbar)
#    unset _widget($path,nindic)
    # [email protected]
    rename $path {}
}


# ------------------------------------------------------------------------------
#  Command MainFrame::_create_menubar
# ------------------------------------------------------------------------------
................................................................................
        set end [string range $menuname [expr $idx+1] end]
        append beg $end
        return [list -label $beg -underline $idx]
    }
}


# ------------------------------------------------------------------------------
#  Command MainFrame::_parse_accelerator

# ------------------------------------------------------------------------------












proc MainFrame::_parse_accelerator { desc } {



    if { [llength $desc] == 2 } {
        set seq [lindex $desc 0]
        set key [lindex $desc 1]

        if {![regexp {F[1]?[0-9]*} $key]} {
            set key [string tolower $key]
        }



        switch -- $seq {




            Ctrl {
                set accel "Ctrl+[string toupper $key]"
                set event "<Control-Key-$key>"
            }
            Alt {
                set accel "Atl+[string toupper $key]"
                set event "<Alt-Key-$key>"
            }
            CtrlAlt {
                set accel "Ctrl+Alt+[string toupper $key]"
                set event "<Control-Alt-Key-$key>"
            }
            default {
                return -code error "invalid accelerator code $seq"
            }
        }
        return [list $accel $event]
    }
    return {}
}




|







 







|







 







|







 







|
<
<
<
|
|

<
<
<
<







 







<
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>

>
>
>
|

|
>
|
|
|
>
>
>
|
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<



1
2
3
4
5
6
7
8
9
10
11
...
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
...
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
...
372
373
374
375
376
377
378
379



380
381
382




383
384
385
386
387
388
389
...
522
523
524
525
526
527
528

529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579


580
581
582
# ------------------------------------------------------------------------------
#  mainframe.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: mainframe.tcl,v 1.5 2000/02/11 22:54:27 ericm Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - MainFrame::create
#     - MainFrame::configure
#     - MainFrame::cget
#     - MainFrame::getframe
#     - MainFrame::addtoolbar
................................................................................
                      -takefocus 0 -highlightthickness 0 -background $bg]
    set indframe [frame $status.indf -relief flat -borderwidth 0 \
                      -takefocus 0 -highlightthickness 0 -background $bg]
    set prgframe [frame $status.prgf -relief flat -borderwidth 0 \
                      -takefocus 0 -highlightthickness 0 -background $bg]

    place $label    -anchor w -x 0 -rely 0.5
    place $indframe -anchor ne -relx 1 -y 0 -relheight 1
    pack  $prgframe -in $indframe -side left -padx 2
    $status configure -height [winfo reqheight $label]

    set progress [eval ProgressBar::create $status.prg [Widget::subcget $path .status.prg] \
                      -width       50 \
                      -height      [expr {[winfo reqheight $label]-2}] \
                      -borderwidth 1 \
................................................................................
    variable _widget

    set index $_widget($path,nindic)
    set indic $path.status.indf.f$index
    eval label $indic $args -relief sunken -borderwidth 1 \
        -takefocus 0 -highlightthickness 0

    pack $indic -side left -anchor w -padx 2 -fill y -expand 1

    incr _widget($path,nindic)

    return $indic
}


................................................................................
proc MainFrame::_destroy { path } {
    variable _widget

    Widget::destroy $path
    catch {destroy [$_widget($path,top) cget -menu]}
    $_widget($path,top) configure -menu {}

    # Unset all of the state vars associated with this main frame.



    foreach index [array names _widget $path,*] {
	unset _widget($index)
    }




    rename $path {}
}


# ------------------------------------------------------------------------------
#  Command MainFrame::_create_menubar
# ------------------------------------------------------------------------------
................................................................................
        set end [string range $menuname [expr $idx+1] end]
        append beg $end
        return [list -label $beg -underline $idx]
    }
}



# MainFrame::_parse_accelerator --
#
#	Given a key combo description, construct an appropriate human readable
#	string (for display on as a menu accelerator) and the corresponding
#	bind event.
#
# Arguments:
#	desc	a list with the following format:
#			?sequence? key
#		sequence may be None, Ctrl, Alt, or CtrlAlt
#		key may be any key
#
# Results:
#	{accel event}	a list containing the accelerator string and the event

proc MainFrame::_parse_accelerator { desc } {
    if { [llength $desc] == 1 } {
	set seq None
	set key [string tolower [lindex $desc 0]]
    } elseif { [llength $desc] == 2 } {
        set seq [lindex $desc 0]
        set key [string tolower [lindex $desc 1]]
	# If the key is an F key (ie, F1, F2, etc), it has to be capitalized
	if {[regexp {f[1]?[0-9]*} $key]} {
	    set key [string toupper $key]
	}
    } else {
	return {}
    }
    switch -- $seq {
	None {
	    set accel "[string toupper $key]"
	    set event "<Key-$key>"
	}
	Ctrl {
	    set accel "Ctrl+[string toupper $key]"
	    set event "<Control-Key-$key>"
	}
	Alt {
	    set accel "Atl+[string toupper $key]"
	    set event "<Alt-Key-$key>"
	}
	CtrlAlt {
	    set accel "Ctrl+Alt+[string toupper $key]"
	    set event "<Control-Alt-Key-$key>"
	}
	default {
	    return -code error "invalid accelerator code $seq"
	}
    }
    return [list $accel $event]


}


Changes to notebook.tcl.

1
2
3
4
5
6
7
8
9
10
11
..
41
42
43
44
45
46
47





48
49
50
51
52
53
54
55
56
57
58
59
60

61
62
63
64
65
66
67
68
69

70
71
72
73

74
75

76

77
78

79
80
81
82
83
84
85
..
99
100
101
102
103
104
105
106
107
108



109



110
111

112
113
114
115
116
117
118
...
146
147
148
149
150
151
152

153








154
155
156
157
158
159
160
161
162
163
164
165


166

167
168
169
170
171
172
173
174
...
213
214
215
216
217
218
219

220
221

222

223




224
225
226
227
228
229
230
...
421
422
423
424
425
426
427







428
429
430
431
432
433
434
...
545
546
547
548
549
550
551
552

553

554
555
556

557

558
559
560
561
562
563
564
...
566
567
568
569
570
571
572
573
574

575

576
577
578
579
580
581
582
583
584
585
586

587
588
589
590

591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
...
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
...
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
...
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696


697
698
699
700
701
702
703
704
705
706
707
...
712
713
714
715
716
717
718
719
720
721
722
723
724



725
726
727
728
729

730
731
732
733
734
735
736
737
738
739
...
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
...
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
...
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
# ------------------------------------------------------------------------------
#  notebook.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: notebook.tcl,v 1.3 1999/09/21 01:50:17 sven Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - NoteBook::create
#     - NoteBook::configure
#     - NoteBook::cget
#     - NoteBook::compute_size
#     - NoteBook::insert
................................................................................
        Widget::declare NoteBook::Page {
            {-state      Enum       normal 0 {normal disabled}}
            {-createcmd  String     ""     0}
            {-raisecmd   String     ""     0}
            {-leavecmd   String     ""     0}
            {-image      TkResource ""     0 label}
            {-text       String     ""     0}





        }
    }

    Widget::declare NoteBook {
        {-foreground         TkResource "" 0 button}
        {-background         TkResource "" 0 button}
        {-activebackground   TkResource "" 0 button}
        {-activeforeground   TkResource "" 0 button}
        {-disabledforeground TkResource "" 0 button}
        {-font               TkResource "" 0 button}
        {-side               Enum       top 1 {top bottom}}
        {-homogeneous        Boolean 0   0}
        {-borderwidth        Int 1   0 {=1 =2}}

        {-width              Int 0   0 {=0 ""}}
        {-height             Int 0   0 {=0 ""}}

        {-repeatdelay        BwResource ""  0 ArrowButton}
        {-repeatinterval     BwResource ""  0 ArrowButton}

        {-fg                 Synonym -foreground}
        {-bg                 Synonym -background}
        {-bd                 Synonym -borderwidth}

    }

    Widget::addmap NoteBook "" :cmd {-background {}}
    Widget::addmap NoteBook ArrowButton .fg \

        {-foreground {} -background {} -activeforeground {} -activebackground {} \
             -borderwidth {} -repeatinterval {} -repeatdelay {} -disabledforeground {}}

    Widget::addmap NoteBook ArrowButton .fd \

        {-foreground {} -background {} -activeforeground {} -activebackground {} \
             -borderwidth {} -repeatinterval {} -repeatdelay {} -disabledforeground {}}


    variable _warrow 12

    proc ::NoteBook { path args } { return [eval NoteBook::create $path $args] }
    proc use {} {}
}

................................................................................
    set data(pages)    {}
    set data(cpt)      0
    set data(realized) 0
    set data(wpage)    0
    set data(hpage)    [expr {[font metrics [Widget::getoption $path -font] -linespace] + 6}]
    set bg             [Widget::getoption $path -background]

    # --- creation du canvas -----------------------------------------------------------------
    set w [expr {[Widget::getoption $path -width]+4}]
    set h [expr {[Widget::getoption $path -height]+$data(hpage)+4}]



    canvas $path -relief flat -bd 0 -highlightthickness 0 -bg $bg -width $w -height $h




    # --- creation des arrow -----------------------------------------------------------------

    eval ArrowButton::create $path.fg [Widget::subcget $path .fg] \
        -highlightthickness 0 \
        -type button  -dir left \
        -armcommand [list "NoteBook::_xview $path -1"]

    eval ArrowButton::create $path.fd [Widget::subcget $path .fd] \
        -highlightthickness 0 \
................................................................................
         [Widget::hasChanged $path -homogeneous foo] } {
        if { $chf } {
            set data(hpage) [expr {[font metrics $font -linespace] + 6}]
        }
        _compute_width $path
        set redraw 1
    }

    if { [Widget::hasChanged $path -background bg] } {








        set col [BWidget::get3dcolor $path $bg]
        set data(dbg)  [lindex $col 0]
        set data(lbg)  [lindex $col 1]
        set redraw 1
    }
    if { [Widget::hasChanged $path -foreground  fg] ||
         [Widget::hasChanged $path -borderwidth bd] } {
        set redraw 1
    }
    set wc [Widget::hasChanged $path -width  w]
    set hc [Widget::hasChanged $path -height h]
    if { $wc || $hc } {


        $path:cmd configure -width [expr {$w+4}] -height [expr {$h + $data(hpage)+4}]

    } elseif { $redraw } {
        _redraw $path
    }

    return $res
}


................................................................................
    if { [lsearch $data(pages) $page] != -1 } {
        return -code error "page \"$page\" already exists"
    }

    Widget::init NoteBook::Page $path.f$page $args

    set data(pages) [linsert $data(pages) $index $page]

    if { ![winfo exists $path.f$page] } {
        frame $path.f$page \

            -relief flat -background [Widget::getoption $path -background] -borderwidth 10

        set data($page,realized) 0




    }
    _compute_width $path
    _draw_page $path $page 1
    _redraw $path

    return $path.f$page
}
................................................................................

    if { [set pos [lsearch $data(pages) $page]] == -1 } {
        return -code error "page \"$page\" does not exists"
    }
    return $pos
}









# ------------------------------------------------------------------------------
#  Command NoteBook::_itemconfigure
# ------------------------------------------------------------------------------
proc NoteBook::_itemconfigure { path page lres } {
    variable $path
    upvar 0  $path data
................................................................................

    if { ![string compare [Widget::getoption $path.f$page -state] "disabled"] } {
        return
    }

    switch -- $type {
        on {
            $path:cmd itemconfigure "$page:poly" -fill [Widget::getoption $path -activebackground]

            $path:cmd itemconfigure "$page:text" -fill [Widget::getoption $path -activeforeground]

        }
        off {
            $path:cmd itemconfigure "$page:poly" -fill [Widget::getoption $path -background]

            $path:cmd itemconfigure "$page:text" -fill [Widget::getoption $path -foreground]

        }
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_select
................................................................................
proc NoteBook::_select { path page } {
    variable $path
    upvar 0  $path data

    if { ![string compare [Widget::getoption $path.f$page -state] "normal"] } {
        set oldsel $data(select)
        if { [string compare $page $oldsel] } {
            if { $oldsel != "" } {
                if { [set cmd [Widget::getoption $path.f$oldsel -leavecmd]] != "" } {

                    if { [set code [catch {uplevel \#0 $cmd} res]] == 1 || $res == 0 } {

                        return -code $code $res
                    }
                }
                set data(select) ""
                _draw_page $path $oldsel 0
            }
            set data(select) $page
            if { $page != "" } {
                if { !$data($page,realized) } {
                    set data($page,realized) 1
                    if { [set cmd [Widget::getoption $path.f$page -createcmd]] != "" } {

                        uplevel \#0 $cmd
                    }
                }
                if { [set cmd [Widget::getoption $path.f$page -raisecmd]] != "" } {

                    uplevel \#0 $cmd
                }
                _draw_page $path $page 0
            }
            _draw_area $path
        }
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_redraw
# ------------------------------------------------------------------------------
proc NoteBook::_redraw { path } {
    variable $path
    upvar 0  $path data

    if { !$data(realized) } {
        return
    }
................................................................................
        _draw_page $path $page 0
    }
    _draw_area   $path
    _draw_arrows $path
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_draw_page
# -----------------------------------------------------------------------------
proc NoteBook::_draw_page { path page create } {
    variable $path
    upvar 0  $path data

    # --- calcul des coordonnees et des couleurs de l'onglet ---------------------------------
    set pos [lsearch $data(pages) $page]
    set bg  [Widget::getoption $path -background]
    set h   $data(hpage)
    set xd  [_get_x_page $path $pos]
    set xf  [expr {$xd + $data($page,width)}]
    # Sven
    set side [Widget::getoption $path -side]
    set h1 [expr {[winfo height $path]}]
    set bd [Widget::getoption $path -borderwidth]
................................................................................
        if { $img == "" } {
            set xtext [expr {$xd+9}]
        } else {
            set ximg  [expr {$xd+9}]
            set xtext [expr {$ximg+[image width $img]+4}]
        }
        set bd    [Widget::getoption $path -borderwidth]
        set fg    [Widget::getoption $path -foreground]
    } else {
        set fgt   $data(dbg)
        set fgb   $fgt
        # Sven
        if {"$side" == "bottom"} {
            set ytext [expr {$h1 - ($h/2) - 1}]
        } else {
................................................................................
            set xtext [expr {$xd+10}]
        } else {
            set ximg  [expr {$xd+10}]
            set xtext [expr {$ximg+[image width $img]+4}]
        }
        set bd    1
        if { [Widget::getoption $path.f$page -state] == "normal" } {
            set fg [Widget::getoption $path -foreground]
        } else {
            set fg [Widget::getoption $path -disabledforeground]
        }
    }

    # --- creation ou modification de l'onglet -----------------------------------------------
    # Sven
    if { $create } {
        eval $path:cmd create polygon [concat $lt $lb] \
            -tag     {"page p:$page $page:poly"}


        eval $path:cmd create line $lt \
            -tags {"page p:$page $page:top top"}
        eval $path:cmd create line $lb \
            -tags {"page p:$page $page:bot bot"}
        $path:cmd create text $xtext $ytext           \
            -text   [Widget::getoption $path.f$page -text] \
            -font   [Widget::getoption $path -font]        \
            -fill   $fg                               \
            -anchor w                                 \
            -tags   "page p:$page $page:text"

................................................................................
        $path:cmd coords "$page:text" $xtext $ytext

        $path:cmd itemconfigure "$page:text"    \
            -text [Widget::getoption $path.f$page -text]     \
            -font [Widget::getoption $path -font]    \
            -fill $fg
    }
    $path:cmd itemconfigure "$page:poly" -fill $bg  -outline $bg
    $path:cmd itemconfigure "$page:top"  -fill $fgt -width $bd
    $path:cmd itemconfigure "$page:bot"  -fill $fgb -width $bd
    eval $path:cmd coords "$page:poly" [concat $lt $lb]
    eval $path:cmd coords "$page:top"  $lt
    eval $path:cmd coords "$page:bot"  $lb



    # Sven end
        
    if { $img != "" } {
        # Sven
        if { [set id [$path:cmd find withtag $page:img]] == "" } {

            set id [$path:cmd create image $ximg $ytext \
                -anchor w    \
                -tags   "page p:$page $page:img"]
        }
        $path:cmd coords $id $ximg $ytext
        $path:cmd itemconfigure $id -image $img
        # Sven end
    } else {
        $path:cmd delete $page:img
    }
................................................................................
        } else {
            $path:cmd lower p:$page p:[lindex $data(pages) [expr {$pos-2}]]
        }
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_draw_arrows
# ------------------------------------------------------------------------------
proc NoteBook::_draw_arrows { path } {
    variable _warrow
    variable $path
    upvar 0  $path data

    set w       [expr {[winfo width $path]-1}]
    set h       [expr {$data(hpage)-1}]
    set nbpages [llength $data(pages)]
    set xl      0
    set xr      [expr {$w-$_warrow+1}]
    # Sven
    set side [Widget::getoption $path -side]
    if {"$side" == "bottom"} {
        set h1 [expr {[winfo height $path]-1}]
        set bd [Widget::getoption $path -borderwidth]
        set y0 [expr {$h1 - $data(hpage) + $bd}]
    } else {
        set y0 1
    }
    # Sven end (all y positions where replaced with $y0 later)
................................................................................
        # Sven end
    } else {
        $path:cmd delete "rightarrow"
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_draw_area
# ------------------------------------------------------------------------------
proc NoteBook::_draw_area { path } {
    variable $path
    upvar 0  $path data

    set w   [expr {[winfo width  $path]-1}]
    set h   [expr {[winfo height $path]-1}]
    set bd  [Widget::getoption $path -borderwidth]
................................................................................
        # Sven end
    } else {
        $path:cmd delete "window"
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_resize
# ------------------------------------------------------------------------------
proc NoteBook::_resize { path } {
    # Sven
    NoteBook::_redraw $path
    # Sven
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_realize
# ------------------------------------------------------------------------------
proc NoteBook::_realize { path } {
    variable $path
    upvar 0  $path data

    if { [set width  [Widget::getoption $path -width]]  == 0 ||
         [set height [Widget::getoption $path -height]] == 0 } {
        compute_size $path


|







 







>
>
>
>
>




|
|
|
|
|
|
|
|
|
>
|
|







>



|
>
|
|
>
|
>
|
|
>







 







|


>
>
>
|
>
>
>

<
>







 







>
|
>
>
>
>
>
>
>
>












>
>
|
>
|







 







>

|
>
|
>

>
>
>
>







 







>
>
>
>
>
>
>







 







|
>
|
>


|
>
|
>







 







|
|
>
|
>







|


|
>



|
>










|

|







 







|

|




|

|







 







|







 







|

|



|


|
|
>
>

|

|







 







<
<
<



>
>
>




|
>
|
|
|







 







|

|












|







 







|

|







 







|

|







|

|







1
2
3
4
5
6
7
8
9
10
11
..
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
...
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127

128
129
130
131
132
133
134
135
...
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
...
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
...
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
...
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
...
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
...
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
...
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
...
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
...
765
766
767
768
769
770
771



772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
...
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
...
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
...
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
# ------------------------------------------------------------------------------
#  notebook.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: notebook.tcl,v 1.4 2000/02/11 22:54:27 ericm Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - NoteBook::create
#     - NoteBook::configure
#     - NoteBook::cget
#     - NoteBook::compute_size
#     - NoteBook::insert
................................................................................
        Widget::declare NoteBook::Page {
            {-state      Enum       normal 0 {normal disabled}}
            {-createcmd  String     ""     0}
            {-raisecmd   String     ""     0}
            {-leavecmd   String     ""     0}
            {-image      TkResource ""     0 label}
            {-text       String     ""     0}
            {-foreground         String     ""     0}
            {-background         String     ""     0}
            {-activeforeground   String     ""     0}
            {-activebackground   String     ""     0}
            {-disabledforeground String     ""     0}
        }
    }

    Widget::declare NoteBook {
	{-foreground		TkResource "" 0 button}
        {-background		TkResource "" 0 button}
        {-activebackground	TkResource "" 0 button}
        {-activeforeground	TkResource "" 0 button}
        {-disabledforeground	TkResource "" 0 button}
        {-font			TkResource "" 0 button}
        {-side			Enum       top 1 {top bottom}}
        {-homogeneous		Boolean 0   0}
        {-borderwidth		Int 1   0 {=1 =2}}
 	{-internalborderwidth	Int 10  0 {=0 ""}}
        {-width			Int 0   0 {=0 ""}}
        {-height		Int 0   0 {=0 ""}}

        {-repeatdelay        BwResource ""  0 ArrowButton}
        {-repeatinterval     BwResource ""  0 ArrowButton}

        {-fg                 Synonym -foreground}
        {-bg                 Synonym -background}
        {-bd                 Synonym -borderwidth}
        {-ibd                Synonym -internalborderwidth}
    }

    Widget::addmap NoteBook "" :cmd {-background {}}
    Widget::addmap NoteBook ArrowButton .fg {
        -foreground {} -background {} 
	-activeforeground {} -activebackground {} -disabledforeground {}
	-borderwidth {} -repeatinterval {} -repeatdelay {}
    }
    Widget::addmap NoteBook ArrowButton .fd {
        -foreground {} -background {}
        -activeforeground {} -activebackground {} -disabledforeground {}
        -borderwidth {} -repeatinterval {} -repeatdelay {}
    }

    variable _warrow 12

    proc ::NoteBook { path args } { return [eval NoteBook::create $path $args] }
    proc use {} {}
}

................................................................................
    set data(pages)    {}
    set data(cpt)      0
    set data(realized) 0
    set data(wpage)    0
    set data(hpage)    [expr {[font metrics [Widget::getoption $path -font] -linespace] + 6}]
    set bg             [Widget::getoption $path -background]

    # Create the canvas
    set w [expr {[Widget::getoption $path -width]+4}]
    set h [expr {[Widget::getoption $path -height]+$data(hpage)+4}]
    canvas $path			\
	    -relief flat		\
	    -borderwidth 0		\
	    -highlightthickness 0	\
	    -background $bg		\
	    -width $w			\
	    -height $h


    # Create the arrow button
    eval ArrowButton::create $path.fg [Widget::subcget $path .fg] \
        -highlightthickness 0 \
        -type button  -dir left \
        -armcommand [list "NoteBook::_xview $path -1"]

    eval ArrowButton::create $path.fd [Widget::subcget $path .fd] \
        -highlightthickness 0 \
................................................................................
         [Widget::hasChanged $path -homogeneous foo] } {
        if { $chf } {
            set data(hpage) [expr {[font metrics $font -linespace] + 6}]
        }
        _compute_width $path
        set redraw 1
    }
    set chibd [Widget::hasChanged $path -internalborderwidth ibd]
    set chbg  [Widget::hasChanged $path -background bg]
    if {$chibd || $chbg} {
        foreach page $data(pages) {
            $path.f$page configure \
                -borderwidth $ibd -background $bg
        }
    }

    if {$chbg} {
        set col [BWidget::get3dcolor $path $bg]
        set data(dbg)  [lindex $col 0]
        set data(lbg)  [lindex $col 1]
        set redraw 1
    }
    if { [Widget::hasChanged $path -foreground  fg] ||
         [Widget::hasChanged $path -borderwidth bd] } {
        set redraw 1
    }
    set wc [Widget::hasChanged $path -width  w]
    set hc [Widget::hasChanged $path -height h]
    if { $wc || $hc } {
        $path:cmd configure \
		-width [expr {$w+4}] \
		-height [expr {$h + $data(hpage)+4}]
    }
    if { $redraw } {
        _redraw $path
    }

    return $res
}


................................................................................
    if { [lsearch $data(pages) $page] != -1 } {
        return -code error "page \"$page\" already exists"
    }

    Widget::init NoteBook::Page $path.f$page $args

    set data(pages) [linsert $data(pages) $index $page]
    # If the page doesn't exist, create it; if it does reset its bg and ibd
    if { ![winfo exists $path.f$page] } {
        frame $path.f$page 						\
		-relief flat						\
		-background	[Widget::getoption $path -background]	\
		-borderwidth	[Widget::getoption $path -internalborderwidth]
        set data($page,realized) 0
    } else {
	$path.f$page configure						\
		-background	[Widget::getoption $path -background]	\
		-borderwidth	[Widget::getoption $path -internalborderwidth]
    }
    _compute_width $path
    _draw_page $path $page 1
    _redraw $path

    return $path.f$page
}
................................................................................

    if { [set pos [lsearch $data(pages) $page]] == -1 } {
        return -code error "page \"$page\" does not exists"
    }
    return $pos
}

proc NoteBook::_getoption { path page option } {
    set value [Widget::cget $path.f$page $option]
    if {![string length $value]} {
        set value [Widget::cget $path $option]
    }
    return $value
}

# ------------------------------------------------------------------------------
#  Command NoteBook::_itemconfigure
# ------------------------------------------------------------------------------
proc NoteBook::_itemconfigure { path page lres } {
    variable $path
    upvar 0  $path data
................................................................................

    if { ![string compare [Widget::getoption $path.f$page -state] "disabled"] } {
        return
    }

    switch -- $type {
        on {
            $path:cmd itemconfigure "$page:poly" \
		    -fill [_getoption $path $page -activebackground]
            $path:cmd itemconfigure "$page:text" \
		    -fill [_getoption $path $page -activeforeground]
        }
        off {
            $path:cmd itemconfigure "$page:poly" \
		    -fill [_getoption $path $page -background]
            $path:cmd itemconfigure "$page:text" \
		    -fill [_getoption $path $page -foreground]
        }
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_select
................................................................................
proc NoteBook::_select { path page } {
    variable $path
    upvar 0  $path data

    if { ![string compare [Widget::getoption $path.f$page -state] "normal"] } {
        set oldsel $data(select)
        if { [string compare $page $oldsel] } {
            if { ![string equal $oldsel ""] } {
		set cmd [Widget::getoption $path.f$oldsel -leavecmd]
                if { ![string equal $cmd ""] } {
		    set code [catch {uplevel \#0 $cmd} res]
                    if { $code == 1 || $res == 0 } {
                        return -code $code $res
                    }
                }
                set data(select) ""
                _draw_page $path $oldsel 0
            }
            set data(select) $page
            if { ![string equal $page ""] } {
                if { !$data($page,realized) } {
                    set data($page,realized) 1
		    set cmd [Widget::getoption $path.f$page -createcmd]
                    if { ![string equal $cmd ""] } {
                        uplevel \#0 $cmd
                    }
                }
		set cmd [Widget::getoption $path.f$page -raisecmd]
                if { ![string equal $cmd ""] } {
                    uplevel \#0 $cmd
                }
                _draw_page $path $page 0
            }
            _draw_area $path
        }
    }
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_redraw
# -----------------------------------------------------------------------------
proc NoteBook::_redraw { path } {
    variable $path
    upvar 0  $path data

    if { !$data(realized) } {
        return
    }
................................................................................
        _draw_page $path $page 0
    }
    _draw_area   $path
    _draw_arrows $path
}


# ----------------------------------------------------------------------------
#  Command NoteBook::_draw_page
# ----------------------------------------------------------------------------
proc NoteBook::_draw_page { path page create } {
    variable $path
    upvar 0  $path data

    # --- calcul des coordonnees et des couleurs de l'onglet ------------------
    set pos [lsearch $data(pages) $page]
    set bg  [_getoption $path $page -background]
    set h   $data(hpage)
    set xd  [_get_x_page $path $pos]
    set xf  [expr {$xd + $data($page,width)}]
    # Sven
    set side [Widget::getoption $path -side]
    set h1 [expr {[winfo height $path]}]
    set bd [Widget::getoption $path -borderwidth]
................................................................................
        if { $img == "" } {
            set xtext [expr {$xd+9}]
        } else {
            set ximg  [expr {$xd+9}]
            set xtext [expr {$ximg+[image width $img]+4}]
        }
        set bd    [Widget::getoption $path -borderwidth]
        set fg    [_getoption $path $page -foreground]
    } else {
        set fgt   $data(dbg)
        set fgb   $fgt
        # Sven
        if {"$side" == "bottom"} {
            set ytext [expr {$h1 - ($h/2) - 1}]
        } else {
................................................................................
            set xtext [expr {$xd+10}]
        } else {
            set ximg  [expr {$xd+10}]
            set xtext [expr {$ximg+[image width $img]+4}]
        }
        set bd    1
        if { [Widget::getoption $path.f$page -state] == "normal" } {
            set fg [_getoption $path $page -foreground]
        } else {
            set fg [_getoption $path $page -disabledforeground]
        }
    }

    # --- creation ou modification de l'onglet --------------------------------
    # Sven
    if { $create } {
        eval $path:cmd create polygon [concat $lt $lb]		\
		-tag		{"page p:$page $page:poly"}	\
		-outline	$bg				\
		-fill		$bg
        eval $path:cmd create line $lt \
            -tags {"page p:$page $page:top top"} -fill $fgt -width $bd
        eval $path:cmd create line $lb \
            -tags {"page p:$page $page:bot bot"} -fill $fgb -width $bd
        $path:cmd create text $xtext $ytext           \
            -text   [Widget::getoption $path.f$page -text] \
            -font   [Widget::getoption $path -font]        \
            -fill   $fg                               \
            -anchor w                                 \
            -tags   "page p:$page $page:text"

................................................................................
        $path:cmd coords "$page:text" $xtext $ytext

        $path:cmd itemconfigure "$page:text"    \
            -text [Widget::getoption $path.f$page -text]     \
            -font [Widget::getoption $path -font]    \
            -fill $fg
    }



    eval $path:cmd coords "$page:poly" [concat $lt $lb]
    eval $path:cmd coords "$page:top"  $lt
    eval $path:cmd coords "$page:bot"  $lb
    $path:cmd itemconfigure "$page:poly" -fill $bg  -outline $bg
    $path:cmd itemconfigure "$page:top"  -fill $fgt -width $bd
    $path:cmd itemconfigure "$page:bot"  -fill $fgb -width $bd
    # Sven end
        
    if { $img != "" } {
        # Sven
	set id [$path:cmd find withtag $page:img]
	if { [string equal $id ""] } {
	    set id [$path:cmd create image $ximg $ytext \
		    -anchor w    \
		    -tags   "page p:$page $page:img"]
        }
        $path:cmd coords $id $ximg $ytext
        $path:cmd itemconfigure $id -image $img
        # Sven end
    } else {
        $path:cmd delete $page:img
    }
................................................................................
        } else {
            $path:cmd lower p:$page p:[lindex $data(pages) [expr {$pos-2}]]
        }
    }
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_draw_arrows
# -----------------------------------------------------------------------------
proc NoteBook::_draw_arrows { path } {
    variable _warrow
    variable $path
    upvar 0  $path data

    set w       [expr {[winfo width $path]-1}]
    set h       [expr {$data(hpage)-1}]
    set nbpages [llength $data(pages)]
    set xl      0
    set xr      [expr {$w-$_warrow+1}]
    # Sven
    set side [Widget::getoption $path -side]
    if { [string equal $side "bottom"] } {
        set h1 [expr {[winfo height $path]-1}]
        set bd [Widget::getoption $path -borderwidth]
        set y0 [expr {$h1 - $data(hpage) + $bd}]
    } else {
        set y0 1
    }
    # Sven end (all y positions where replaced with $y0 later)
................................................................................
        # Sven end
    } else {
        $path:cmd delete "rightarrow"
    }
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_draw_area
# -----------------------------------------------------------------------------
proc NoteBook::_draw_area { path } {
    variable $path
    upvar 0  $path data

    set w   [expr {[winfo width  $path]-1}]
    set h   [expr {[winfo height $path]-1}]
    set bd  [Widget::getoption $path -borderwidth]
................................................................................
        # Sven end
    } else {
        $path:cmd delete "window"
    }
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_resize
# -----------------------------------------------------------------------------
proc NoteBook::_resize { path } {
    # Sven
    NoteBook::_redraw $path
    # Sven
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_realize
# -----------------------------------------------------------------------------
proc NoteBook::_realize { path } {
    variable $path
    upvar 0  $path data

    if { [set width  [Widget::getoption $path -width]]  == 0 ||
         [set height [Widget::getoption $path -height]] == 0 } {
        compute_size $path

Changes to progressbar.tcl.

17
18
19
20
21
22
23

24
25
26
27
28
29
30
...
178
179
180
181
182
183
184

185
186

        {-background  TkResource ""         0 frame}
        {-foreground  TkResource blue       0 label}
        {-borderwidth TkResource 2          0 frame}
        {-troughcolor TkResource ""         0 scrollbar}
        {-relief      TkResource sunken     0 label}
        {-orient      Enum       horizontal 1 {horizontal vertical}}
        {-variable    String     ""         0}

        {-width       TkResource 100        0 frame}
        {-height      TkResource 4m         0 frame}
        {-bg          Synonym    -background}
        {-fg          Synonym    -foreground}
        {-bd          Synonym    -borderwidth}
    }

................................................................................
            if { ![string compare [Widget::getoption $path -orient] "horizontal"] } {
                $path.bar coords rect -1 0 [expr {$val*$w/$max}] $h
            } else {
                $path.bar coords rect 0 [expr {$h+1}] $w [expr {$h*($max-$val)}]
            }
        }
    }

    update
}







>







 







>
|
|
>
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
...
179
180
181
182
183
184
185
186
187
188
189
        {-background  TkResource ""         0 frame}
        {-foreground  TkResource blue       0 label}
        {-borderwidth TkResource 2          0 frame}
        {-troughcolor TkResource ""         0 scrollbar}
        {-relief      TkResource sunken     0 label}
        {-orient      Enum       horizontal 1 {horizontal vertical}}
        {-variable    String     ""         0}
        {-idle        Boolean    0          0}
        {-width       TkResource 100        0 frame}
        {-height      TkResource 4m         0 frame}
        {-bg          Synonym    -background}
        {-fg          Synonym    -foreground}
        {-bd          Synonym    -borderwidth}
    }

................................................................................
            if { ![string compare [Widget::getoption $path -orient] "horizontal"] } {
                $path.bar coords rect -1 0 [expr {$val*$w/$max}] $h
            } else {
                $path.bar coords rect 0 [expr {$h+1}] $w [expr {$h*($max-$val)}]
            }
        }
    }
    if {![Widget::cget $path -idle]} {
        update
    }
}

Changes to scrollview.tcl.

1
2
3
4
5
6
7
8
9
10
11
..
26
27
28
29
30
31
32
33
34

35
36

37
38
39
40
41

42


43
44
45
46
47
48
49
..
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
..
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
...
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
...
214
215
216
217
218
219
220
221
222
223
224
225




226
227

228







229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
# ------------------------------------------------------------------------------
#  scrollview.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: scrollview.tcl,v 1.1.1.1 1999/08/03 20:20:23 ericm Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - ScrolledWindow::create
#     - ScrolledWindow::configure
#     - ScrolledWindow::cget
#     - ScrolledWindow::_set_hscroll
#     - ScrolledWindow::_set_vscroll
................................................................................
        {-cursor      TkResource crosshair 0 canvas}
        {-window      String     ""        0}
        {-fg          Synonym    -foreground}
        {-bg          Synonym    -background}
        {-bd          Synonym    -borderwidth}
    }

    Widget::addmap ScrollView "" :cmd \
        {-relief {} -borderwidth {} -background {} -width {} -height {} -cursor {}}


    bind BwScrollView <ButtonPress-3> {ScrollView::_set_view %W set %x %y}

    bind BwScrollView <ButtonPress-1> {ScrollView::_set_view %W start %x %y}
    bind BwScrollView <B1-Motion>     {ScrollView::_set_view %W motion %x %y}
    bind BwScrollView <Configure>     {ScrollView::_resize %W}
    bind BwScrollView <Destroy>       {ScrollView::_destroy %W}


    proc ::ScrollView { path args } { return [eval ScrollView::create $path $args] }


    proc use {} {}

    variable _widget
}


# ------------------------------------------------------------------------------
................................................................................
    Widget::init ScrollView $path $args

    set w                     [Widget::getoption $path -window]
    set _widget($path,bd)     [Widget::getoption $path -borderwidth]
    set _widget($path,width)  [Widget::getoption $path -width]
    set _widget($path,height) [Widget::getoption $path -height]

    if { [winfo exists $w] } {
        set _widget($path,oldxscroll) [$w cget -xscrollcommand]
        set _widget($path,oldyscroll) [$w cget -yscrollcommand]
        $w configure \
            -xscrollcommand "ScrollView::_set_hscroll $path" \
            -yscrollcommand "ScrollView::_set_vscroll $path"
    }
    eval canvas $path [Widget::subcget $path :cmd] -highlightthickness 0
    $path create rectangle -2 -2 -2 -2 \
        -fill    [Widget::getoption $path -fill]       \
        -outline [Widget::getoption $path -foreground] \
        -tags    view

    bindtags $path [list $path BwScrollView [winfo toplevel $path] all]

    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[eval ScrollView::\$cmd $path \$args\]"

    return $path
}


# ------------------------------------------------------------------------------
................................................................................
        if { [winfo exists $w] } {
            set _widget($path,oldxscroll) [$w cget -xscrollcommand]
            set _widget($path,oldyscroll) [$w cget -yscrollcommand]
            $w configure \
                -xscrollcommand "ScrollView::_set_hscroll $path" \
                -yscrollcommand "ScrollView::_set_vscroll $path"
        } else {
            $path:cmd coords view -2 -2 -2 -2
            set _widget($path,oldxscroll) {}
            set _widget($path,oldyscroll) {}
        }
    }

    if { [Widget::hasChanged $path -fill fill] |
         [Widget::hasChanged $path -foreground fg] } {
        $path:cmd itemconfigure view \
            -fill    $fill \
            -outline $fg
    }

    return $res
}

................................................................................

# ------------------------------------------------------------------------------
#  Command ScrollView::_set_hscroll
# ------------------------------------------------------------------------------
proc ScrollView::_set_hscroll { path vmin vmax } {
    variable _widget

    set c  [$path:cmd coords view]
    set x0 [expr {$vmin*$_widget($path,width)+$_widget($path,bd)}]
    set x1 [expr {$vmax*$_widget($path,width)+$_widget($path,bd)-1}]
    $path:cmd coords view $x0 [lindex $c 1] $x1 [lindex $c 3]
    if { $_widget($path,oldxscroll) != "" } {
        uplevel \#0 $_widget($path,oldxscroll) $vmin $vmax
    }
}


# ------------------------------------------------------------------------------
#  Command ScrollView::_set_vscroll
# ------------------------------------------------------------------------------
proc ScrollView::_set_vscroll { path vmin vmax } {
    variable _widget

    set c  [$path:cmd coords view]
    set y0 [expr {$vmin*$_widget($path,height)+$_widget($path,bd)}]
    set y1 [expr {$vmax*$_widget($path,height)+$_widget($path,bd)-1}]
    $path:cmd coords view [lindex $c 0] $y0 [lindex $c 2] $y1
    if { $_widget($path,oldyscroll) != "" } {
        uplevel \#0 $_widget($path,oldyscroll) $vmin $vmax
    }
}


# ------------------------------------------------------------------------------
#  Command ScrollView::_update_scroll
# ------------------------------------------------------------------------------
proc ScrollView::_update_scroll { path callscroll hminmax vminmax } {
    variable _widget

    set c    [$path:cmd coords view]
    set hmin [lindex $hminmax 0]
    set hmax [lindex $hminmax 1]
    set vmin [lindex $vminmax 0]
    set vmax [lindex $vminmax 1]
    set x0   [expr {$hmin*$_widget($path,width)+$_widget($path,bd)}]
    set x1   [expr {$hmax*$_widget($path,width)+$_widget($path,bd)-1}]
    set y0   [expr {$vmin*$_widget($path,height)+$_widget($path,bd)}]
    set y1   [expr {$vmax*$_widget($path,height)+$_widget($path,bd)-1}]
    $path:cmd coords view $x0 $y0 $x1 $y1
    if { $callscroll } {
        if { $_widget($path,oldxscroll) != "" } {
            uplevel \#0 $_widget($path,oldxscroll) $hmin $hmax
        }
        if { $_widget($path,oldyscroll) != "" } {
            uplevel \#0 $_widget($path,oldyscroll) $vmin $vmax
        }
................................................................................
# ------------------------------------------------------------------------------
#  Command ScrollView::_set_view
# ------------------------------------------------------------------------------
proc ScrollView::_set_view { path cmd x y } {
    variable _widget

    set w [Widget::getoption $path -window]
    if { [winfo exists $w] } {
        if { ![string compare $cmd "start"] } {
            set c  [$path:cmd coords view]
            set x0 [lindex $c 0]
            set y0 [lindex $c 1]




            set _widget($path,dx) [expr {$x-$x0}]
            set _widget($path,dy) [expr {$y-$y0}]

        } else {







            if { ![string compare $cmd "motion"] } {
                set vh [expr {double($x-$_widget($path,dx)-$_widget($path,bd))/$_widget($path,width)}]
                set vv [expr {double($y-$_widget($path,dy)-$_widget($path,bd))/$_widget($path,height)}]
            } else {
                set vh [expr {double($x-$_widget($path,bd))/$_widget($path,width)}]
                set vv [expr {double($y-$_widget($path,bd))/$_widget($path,height)}]
            }
            $w xview moveto $vh
            $w yview moveto $vv
            _update_scroll $path 1 [$w xview] [$w yview]
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ScrollView::_resize
# ------------------------------------------------------------------------------


|







 







|
|
>
|
<
>
|




>
|
>
>







 







|






|







|







 







|







|







 







|


|












|


|












|








|







 







|
|
|


>
>
>
>
|
|
>
|
>
>
>
>
>
>
>
|
|
|
<
<
<
|
|
|
|
<







1
2
3
4
5
6
7
8
9
10
11
..
26
27
28
29
30
31
32
33
34
35
36

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
..
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
...
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
...
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247



248
249
250
251

252
253
254
255
256
257
258
# ------------------------------------------------------------------------------
#  scrollview.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: scrollview.tcl,v 1.2 2000/02/11 22:54:28 ericm Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - ScrolledWindow::create
#     - ScrolledWindow::configure
#     - ScrolledWindow::cget
#     - ScrolledWindow::_set_hscroll
#     - ScrolledWindow::_set_vscroll
................................................................................
        {-cursor      TkResource crosshair 0 canvas}
        {-window      String     ""        0}
        {-fg          Synonym    -foreground}
        {-bg          Synonym    -background}
        {-bd          Synonym    -borderwidth}
    }

    Widget::addmap ScrollView "" :canvas {
        -relief {} -borderwidth {} -background {}
        -width {} -height {} -cursor {}
    }


    bind BwScrollView <ButtonPress-1> {ScrollView::_set_view %W set %x %y}
    bind BwScrollView <B1-Motion>     {ScrollView::_set_view %W motion %x %y}
    bind BwScrollView <Configure>     {ScrollView::_resize %W}
    bind BwScrollView <Destroy>       {ScrollView::_destroy %W}

    proc ::ScrollView {path args} {
        return [eval ScrollView::create $path $args]
    }

    proc use {} {}

    variable _widget
}


# ------------------------------------------------------------------------------
................................................................................
    Widget::init ScrollView $path $args

    set w                     [Widget::getoption $path -window]
    set _widget($path,bd)     [Widget::getoption $path -borderwidth]
    set _widget($path,width)  [Widget::getoption $path -width]
    set _widget($path,height) [Widget::getoption $path -height]

    if {[winfo exists $w]} {
        set _widget($path,oldxscroll) [$w cget -xscrollcommand]
        set _widget($path,oldyscroll) [$w cget -yscrollcommand]
        $w configure \
            -xscrollcommand "ScrollView::_set_hscroll $path" \
            -yscrollcommand "ScrollView::_set_vscroll $path"
    }
    eval canvas $path [Widget::subcget $path :canvas] -highlightthickness 0
    $path create rectangle -2 -2 -2 -2 \
        -fill    [Widget::getoption $path -fill]       \
        -outline [Widget::getoption $path -foreground] \
        -tags    view

    bindtags $path [list $path BwScrollView [winfo toplevel $path] all]

    rename $path ::$path:canvas
    proc ::$path { cmd args } "return \[eval ScrollView::\$cmd $path \$args\]"

    return $path
}


# ------------------------------------------------------------------------------
................................................................................
        if { [winfo exists $w] } {
            set _widget($path,oldxscroll) [$w cget -xscrollcommand]
            set _widget($path,oldyscroll) [$w cget -yscrollcommand]
            $w configure \
                -xscrollcommand "ScrollView::_set_hscroll $path" \
                -yscrollcommand "ScrollView::_set_vscroll $path"
        } else {
            $path:canvas coords view -2 -2 -2 -2
            set _widget($path,oldxscroll) {}
            set _widget($path,oldyscroll) {}
        }
    }

    if { [Widget::hasChanged $path -fill fill] |
         [Widget::hasChanged $path -foreground fg] } {
        $path:canvas itemconfigure view \
            -fill    $fill \
            -outline $fg
    }

    return $res
}

................................................................................

# ------------------------------------------------------------------------------
#  Command ScrollView::_set_hscroll
# ------------------------------------------------------------------------------
proc ScrollView::_set_hscroll { path vmin vmax } {
    variable _widget

    set c  [$path:canvas coords view]
    set x0 [expr {$vmin*$_widget($path,width)+$_widget($path,bd)}]
    set x1 [expr {$vmax*$_widget($path,width)+$_widget($path,bd)-1}]
    $path:canvas coords view $x0 [lindex $c 1] $x1 [lindex $c 3]
    if { $_widget($path,oldxscroll) != "" } {
        uplevel \#0 $_widget($path,oldxscroll) $vmin $vmax
    }
}


# ------------------------------------------------------------------------------
#  Command ScrollView::_set_vscroll
# ------------------------------------------------------------------------------
proc ScrollView::_set_vscroll { path vmin vmax } {
    variable _widget

    set c  [$path:canvas coords view]
    set y0 [expr {$vmin*$_widget($path,height)+$_widget($path,bd)}]
    set y1 [expr {$vmax*$_widget($path,height)+$_widget($path,bd)-1}]
    $path:canvas coords view [lindex $c 0] $y0 [lindex $c 2] $y1
    if { $_widget($path,oldyscroll) != "" } {
        uplevel \#0 $_widget($path,oldyscroll) $vmin $vmax
    }
}


# ------------------------------------------------------------------------------
#  Command ScrollView::_update_scroll
# ------------------------------------------------------------------------------
proc ScrollView::_update_scroll { path callscroll hminmax vminmax } {
    variable _widget

    set c    [$path:canvas coords view]
    set hmin [lindex $hminmax 0]
    set hmax [lindex $hminmax 1]
    set vmin [lindex $vminmax 0]
    set vmax [lindex $vminmax 1]
    set x0   [expr {$hmin*$_widget($path,width)+$_widget($path,bd)}]
    set x1   [expr {$hmax*$_widget($path,width)+$_widget($path,bd)-1}]
    set y0   [expr {$vmin*$_widget($path,height)+$_widget($path,bd)}]
    set y1   [expr {$vmax*$_widget($path,height)+$_widget($path,bd)-1}]
    $path:canvas coords view $x0 $y0 $x1 $y1
    if { $callscroll } {
        if { $_widget($path,oldxscroll) != "" } {
            uplevel \#0 $_widget($path,oldxscroll) $hmin $hmax
        }
        if { $_widget($path,oldyscroll) != "" } {
            uplevel \#0 $_widget($path,oldyscroll) $vmin $vmax
        }
................................................................................
# ------------------------------------------------------------------------------
#  Command ScrollView::_set_view
# ------------------------------------------------------------------------------
proc ScrollView::_set_view { path cmd x y } {
    variable _widget

    set w [Widget::getoption $path -window]
    if {[winfo exists $w]} {
        if {![string compare $cmd "set"]} {
            set c  [$path:canvas coords view]
            set x0 [lindex $c 0]
            set y0 [lindex $c 1]
            set x1 [lindex $c 2]
            set y1 [lindex $c 3]
            if {$x >= $x0 && $x <= $x1 &&
                $y >= $y0 && $y <= $y1} {
                set _widget($path,dx) [expr {$x-$x0}]
                set _widget($path,dy) [expr {$y-$y0}]
                return
            } else {
                set x0 [expr {$x-($x1-$x0)/2}]
                set y0 [expr {$y-($y1-$y0)/2}]
                set _widget($path,dx) [expr {$x-$x0}]
                set _widget($path,dy) [expr {$y-$y0}]
                set vh [expr {double($x0-$_widget($path,bd))/$_widget($path,width)}]
                set vv [expr {double($y0-$_widget($path,bd))/$_widget($path,height)}]
            }
        } elseif {![string compare $cmd "motion"]} {
            set vh [expr {double($x-$_widget($path,dx)-$_widget($path,bd))/$_widget($path,width)}]
            set vv [expr {double($y-$_widget($path,dy)-$_widget($path,bd))/$_widget($path,height)}]



        }
        $w xview moveto $vh
        $w yview moveto $vv
        _update_scroll $path 1 [$w xview] [$w yview]

    }
}


# ------------------------------------------------------------------------------
#  Command ScrollView::_resize
# ------------------------------------------------------------------------------

Changes to scrollw.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13


14
15
16
17
18
19
20
21




22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45


46

47
48
49
50
51
52
53

54
55
56
57
58



59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77


































78
79

80










81
82
83







84
85
86
87
88
89
90

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131


132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149


150
151
152


153









154
155

156



157

















158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195

196
197
198
199
200
201

202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224

225
226
227
228
229
230

231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249



250
251

252
253











254
255
256











# ------------------------------------------------------------------------------
#  scrollw.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: scrollw.tcl,v 1.2 1999/12/23 19:30:59 sven Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - ScrolledWindow::create
#     - ScrolledWindow::getframe
#     - ScrolledWindow::setwidget
#     - ScrolledWindow::configure
#     - ScrolledWindow::cget
#     - ScrolledWindow::_set_hscroll
#     - ScrolledWindow::_set_vscroll


#     - ScrolledWindow::_realize
# ------------------------------------------------------------------------------

namespace eval ScrolledWindow {
    Widget::declare ScrolledWindow {
        {-background  TkResource ""   0 button}
        {-scrollbar   Enum       both 1 {none both vertical horizontal}}
        {-auto        Enum       both 0 {none both vertical horizontal}}




        {-relief      TkResource flat 0 frame}
        {-borderwidth TkResource 0    0 frame}
        {-bg          Synonym    -background}
        {-bd          Synonym    -borderwidth}
    }

    Widget::addmap ScrolledWindow "" ._grid.f {-relief {} -borderwidth {}}


    proc ::ScrolledWindow { path args } { return [eval ScrolledWindow::create $path $args] }
    proc use {} {}

    variable _widget
}


# ------------------------------------------------------------------------------
#  Command ScrolledWindow::create
# ------------------------------------------------------------------------------
proc ScrolledWindow::create { path args } {
    variable _widget

    Widget::init ScrolledWindow $path $args

    set bg     [Widget::cget $path -background]


    set sw     [frame $path -relief flat -bd 0 -bg $bg -highlightthickness 0 -takefocus 0]

    set grid   [frame $path._grid -relief flat -bd 0 -bg $bg -highlightthickness 0 -takefocus 0]

    set sb    [lsearch {none horizontal vertical both} [Widget::cget $path -scrollbar]]
    set auto  [lsearch {none horizontal vertical both} [Widget::cget $path -auto]]
    set rspan [expr {1 + !($sb & 1)}]
    set cspan [expr {1 + !($sb & 2)}]


    set _widget($path,realized) 0
    set _widget($path,sb)       $sb
    set _widget($path,auto)     $auto
    set _widget($path,hpack)    [expr {$rspan == 1}]
    set _widget($path,vpack)    [expr {$cspan == 1}]




    # scrollbar horizontale ou les deux
    if { $sb & 1 } {
        scrollbar $grid.hscroll \
            -highlightthickness 0 -takefocus 0 \
            -orient  horiz	\
            -relief  sunken	\
            -bg      $bg
        $grid.hscroll set 0 1
        grid $grid.hscroll -column 0 -row 1 -sticky we -columnspan $cspan -pady 1
    }

    # scrollbar verticale ou les deux
    if { $sb & 2 } {
        scrollbar $grid.vscroll \
            -highlightthickness 0 -takefocus 0 \
            -orient  vert  	\
            -relief  sunken 	\
            -bg      $bg


































        $grid.vscroll set 0 1
        grid $grid.vscroll -column 1 -row 0 -sticky ns -rowspan $rspan -padx 1

    }











    eval frame $grid.f -bg $bg -highlightthickness 0 [Widget::subcget $path ._grid.f]
    grid $grid.f -column 0 -row 0 -sticky nwse -columnspan $cspan -rowspan $rspan







    grid columnconfigure $grid 0 -weight 1
    grid rowconfigure    $grid 0 -weight 1
    pack $grid -fill both -expand yes

    bind $grid <Configure> "ScrolledWindow::_realize $path"
    bind $grid <Destroy>   "ScrolledWindow::_destroy $path"


    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[eval ScrolledWindow::\$cmd $path \$args\]"

    return $path
}


# ------------------------------------------------------------------------------
#  Command ScrolledWindow::getframe
# ------------------------------------------------------------------------------
proc ScrolledWindow::getframe { path } {
    return $path
}


# ------------------------------------------------------------------------------
#  Command ScrolledWindow::setwidget
# ------------------------------------------------------------------------------
proc ScrolledWindow::setwidget { path widget } {
    variable _widget

    set grid   $path._grid
    set sb     $_widget($path,sb)
    set option {}

    pack $widget -in $grid.f -fill both -expand yes

    # scrollbar horizontale ou les deux
    if { $sb & 1 } {
        $grid.hscroll configure -command "$widget xview"
        lappend option  "-xscrollcommand" "ScrolledWindow::_set_hscroll $path"
    }

    # scrollbar verticale ou les deux
    if { $sb & 2 } {
        $grid.vscroll configure -command "$widget yview"
        lappend option  "-yscrollcommand" "ScrolledWindow::_set_vscroll $path"
    }
    if { [llength $option] } {
        eval $widget configure $option
    }


}


# ------------------------------------------------------------------------------
#  Command ScrolledWindow::configure
# ------------------------------------------------------------------------------
proc ScrolledWindow::configure { path args } {
    variable _widget

    set grid $path._grid
    set res [Widget::configure $path $args]
    if { [Widget::hasChanged $path -background bg] } {
        $path configure -background $bg
        $grid configure -background $bg
        $grid.f configure -background $bg
        catch {$grid.hscroll configure -background $bg}
        catch {$grid.vscroll configure -background $bg}
    }


    if { [Widget::hasChanged $path -auto auto] } {
        set _widget($path,auto) [lsearch {none horizontal vertical both} $auto]
        if { $_widget($path,sb) & 1 } {


            eval _set_hscroll $path [$grid.hscroll get]









        }
        if { $_widget($path,sb) & 2 } {

            eval _set_vscroll $path [$grid.vscroll get]



        }

















    }
    return $res
}


# ------------------------------------------------------------------------------
#  Command ScrolledWindow::cget
# ------------------------------------------------------------------------------
proc ScrolledWindow::cget { path option } {
    return [Widget::cget $path $option]
}


# ------------------------------------------------------------------------------
#  Command ScrolledWindow::_destroy
# ------------------------------------------------------------------------------
proc ScrolledWindow::_destroy { path } {
    variable _widget

    unset _widget($path,sb)
    unset _widget($path,auto)
    unset _widget($path,hpack)
    unset _widget($path,vpack)
    Widget::destroy $path
    rename $path {}
}


# ------------------------------------------------------------------------------
#  Command ScrolledWindow::_set_hscroll
# ------------------------------------------------------------------------------
proc ScrolledWindow::_set_hscroll { path vmin vmax } {
    variable _widget

    if { $_widget($path,realized) } {
        set grid $path._grid
        if { $_widget($path,auto) & 1 } {
            if { $_widget($path,hpack) && $vmin == 0 && $vmax == 1 } {

                grid configure $grid.f -rowspan 2
                if { $_widget($path,sb) & 2 } {
                    grid configure $grid.vscroll -rowspan 2
                }
                set _widget($path,hpack) 0
            } elseif { !$_widget($path,hpack) && ($vmin != 0 || $vmax != 1) } {

                grid configure $grid.f -rowspan 1
                if { $_widget($path,sb) & 2 } {
                    grid configure $grid.vscroll -rowspan 1
                }
                set _widget($path,hpack) 1
            }
        }
        update idletask
        $grid.hscroll set $vmin $vmax
    }
}


# ------------------------------------------------------------------------------
#  Command ScrolledWindow::_set_vscroll
# ------------------------------------------------------------------------------
proc ScrolledWindow::_set_vscroll { path vmin vmax } {
    variable _widget

    if { $_widget($path,realized) } {
        set grid $path._grid
        if { $_widget($path,auto) & 2 } {
            if { $_widget($path,vpack) && $vmin == 0 && $vmax == 1 } {

                grid configure $grid.f -columnspan 2
                if { $_widget($path,sb) & 1 } {
                    grid configure $grid.hscroll -columnspan 2
                }
                set _widget($path,vpack) 0
            } elseif { !$_widget($path,vpack) && ($vmin != 0 || $vmax != 1) } {

                grid configure $grid.f -columnspan 1
                if { $_widget($path,sb) & 1 } {
                    grid configure $grid.hscroll -columnspan 1
                }
                set _widget($path,vpack) 1
            }
        }
        update idletask
        $grid.vscroll set $vmin $vmax
    }
}


# ------------------------------------------------------------------------------
#  Command ScrolledWindow::_realize
# ------------------------------------------------------------------------------
proc ScrolledWindow::_realize { path } {
    variable _widget




    set grid $path._grid
    bind  $grid <Configure> {}

    set _widget($path,realized) 1
    place $grid -anchor nw -x 0 -y 0 -relwidth 1.0 -relheight 1.0











}













|


|
|






|

>
>

|




|

>
>
>
>








>
|
<
|
|



|

|

|




>
>
|
>
|
<
<
<
|
|
<
>
|
|
|
|
|
>
>
>

<
<
|
|
|
|
|
<
<
<
<
<
<
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
>
|
>
>
>
>
>
>
>
>
>
>

<
<
>
>
>
>
>
>
>
|
|




<
>







|

|





|

|

|


<
<



<
<
|
<
<
<
<
<
|
<
<
<
|
<
>
>



|

|

|










>
>
|
<
<
>
>
|
>
>
>
>
>
>
>
>
>
|
<
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|

|





|

|

|

|
<
<
<





|

|

|

|

|
|
>
|
<
<
<
<
|
>
|
<
<
|
<
|
<
|





|

|

|

|

|
|
>
|
<
<
<
<
|
>
|
<
<
|
<
|
<
|





<
|
<
|
<

>
>
>
|
<
>
|
|
>
>
>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56



57
58

59
60
61
62
63
64
65
66
67
68


69
70
71
72
73






74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113

114
115
116
117
118
119
120
121
122
123
124
125
126


127
128
129
130
131
132
133
134
135
136
137
138
139

140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162


163
164
165


166





167



168

169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191


192
193
194
195
196
197
198
199
200
201
202
203
204

205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247



248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264




265
266
267


268

269

270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287




288
289
290


291

292

293
294
295
296
297
298

299

300

301
302
303
304
305

306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
# -----------------------------------------------------------------------------
#  scrollw.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: scrollw.tcl,v 1.3 2000/02/11 22:54:28 ericm Exp $
# -----------------------------------------------------------------------------
#  Index of commands:
#     - ScrolledWindow::create
#     - ScrolledWindow::getframe
#     - ScrolledWindow::setwidget
#     - ScrolledWindow::configure
#     - ScrolledWindow::cget
#     - ScrolledWindow::_set_hframe
#     - ScrolledWindow::_set_vscroll
#     - ScrolledWindow::_setData
#     - ScrolledWindow::_setSBSize
#     - ScrolledWindow::_realize
# -----------------------------------------------------------------------------

namespace eval ScrolledWindow {
    Widget::declare ScrolledWindow {
        {-background  TkResource ""   0 button}
        {-scrollbar   Enum       both 0 {none both vertical horizontal}}
        {-auto        Enum       both 0 {none both vertical horizontal}}
        {-sides       Enum       se   0 {ne en nw wn se es sw ws}}
        {-size        Int        0    1 {=0}}
        {-ipad        Int        1    1 {=0}}
        {-managed     Boolean    1    1}
        {-relief      TkResource flat 0 frame}
        {-borderwidth TkResource 0    0 frame}
        {-bg          Synonym    -background}
        {-bd          Synonym    -borderwidth}
    }

    Widget::addmap ScrolledWindow "" ._grid.f {-relief {} -borderwidth {}}

    proc ::ScrolledWindow {path args} {
        return [eval ScrolledWindow::create $path $args]

    }
    proc use {} {}
}


# -----------------------------------------------------------------------------
#  Command ScrolledWindow::create
# -----------------------------------------------------------------------------
proc ScrolledWindow::create { path args } {
    upvar \#0 ScrolledWindow::$path data

    Widget::init ScrolledWindow $path $args

    set bg     [Widget::cget $path -background]
    set sbsize [Widget::cget $path -size]
    set ipad   [Widget::cget $path -ipad]
    set sw     [frame $path \
                    -relief flat -borderwidth 0 -background $bg \
                    -highlightthickness 0 -takefocus 0]



    set grid   [frame $path._grid \
                    -relief flat -borderwidth 0 -background $bg \

                    -highlightthickness 0 -takefocus 0]
    set fv     [frame $grid.vframe \
                    -relief flat -borderwidth 0 -background $bg \
                    -highlightthickness 0 -takefocus 0]
    set fh     [frame $grid.hframe \
                    -relief flat -borderwidth 0 -background $bg \
                    -highlightthickness 0 -takefocus 0]
    eval frame $grid.f -background $bg -highlightthickness 0 \
        [Widget::subcget $path ._grid.f]



    scrollbar $grid.hscroll \
        -highlightthickness 0 -takefocus 0 \
        -orient  horiz	\
        -relief  sunken	\
        -bg      $bg






    scrollbar $grid.vscroll \
        -highlightthickness 0 -takefocus 0 \
        -orient  vert  	\
        -relief  sunken	\
        -bg      $bg

    set data(realized) 0

    _setData $path \
        [Widget::cget $path -scrollbar] \
        [Widget::cget $path -auto] \
        [Widget::cget $path -sides]

    if {[Widget::cget $path -managed]} {
        set data(hsb,packed) $data(hsb,present)
        set data(vsb,packed) $data(vsb,present)
    } else {
        set data(hsb,packed) 0
        set data(vsb,packed) 0
    }
    if {$sbsize} {
        $grid.vscroll configure -width $sbsize
        $grid.hscroll configure -width $sbsize
    } else {
        set sbsize [$grid.vscroll cget -width]
    }
    set size [expr {$sbsize+$ipad}]

    $grid.vframe configure -width  $size
    $grid.hframe configure -height $size
    set vplaceopt [list -in $grid.vframe -x [expr {(1-$data(vsb,west))*$ipad}] -y 0 -width [expr {-$ipad}]]
    set hplaceopt [list -in $grid.hframe -x 0 -y [expr {(1-$data(hsb,north))*$ipad}] -height [expr {-$ipad}]]
    pack propagate $grid.vframe 0
    pack propagate $grid.hframe 0
    pack $grid.vscroll -in $grid.vframe
    pack $grid.hscroll -in $grid.hframe

    bind $grid.hscroll <Configure> \
        "ScrolledWindow::_setSBSize $grid.hscroll $size -relwidth 1.0 -relheight 1.0 $hplaceopt"
    bind $grid.vscroll <Configure> \

        "ScrolledWindow::_setSBSize $grid.vscroll $size -relwidth 1.0 -relheight 1.0 $vplaceopt"

    grid $grid.hframe \
        -column     [expr {$data(vsb,west)*$data(vsb,packed)}] \
        -row        [expr {1-$data(hsb,north)}]  \
        -columnspan [expr {2-$data(vsb,packed)}] \
        -sticky we
    grid $grid.vframe \
        -column  [expr {1-$data(vsb,west)}] \
        -row     [expr {$data(hsb,north)*$data(hsb,packed)}] \
        -rowspan [expr {2-$data(hsb,packed)}] \
        -sticky ns



    grid $grid.f \
        -column     [expr {$data(vsb,west)*$data(vsb,packed)}]  \
        -row        [expr {$data(hsb,north)*$data(hsb,packed)}] \
        -columnspan [expr {2-$data(vsb,packed)}] \
        -rowspan    [expr {2-$data(hsb,packed)}] \
        -sticky     nwse

    grid columnconfigure $grid $data(vsb,west)  -weight 1
    grid rowconfigure    $grid $data(hsb,north) -weight 1
    pack $grid -fill both -expand yes

    bind $grid <Configure> "ScrolledWindow::_realize $path"
    bind $grid <Destroy>   "ScrolledWindow::_destroy $path"

    raise $grid.f
    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[eval ScrolledWindow::\$cmd $path \$args\]"

    return $path
}


# -----------------------------------------------------------------------------
#  Command ScrolledWindow::getframe
# -----------------------------------------------------------------------------
proc ScrolledWindow::getframe { path } {
    return $path
}


# -----------------------------------------------------------------------------
#  Command ScrolledWindow::setwidget
# -----------------------------------------------------------------------------
proc ScrolledWindow::setwidget { path widget } {
    upvar \#0 ScrolledWindow::$path data

    set grid   $path._grid



    pack $widget -in $grid.f -fill both -expand yes



    $grid.hscroll configure -command "$widget xview"





    $grid.vscroll configure -command "$widget yview"



    $widget configure \

        -xscrollcommand "ScrolledWindow::_set_hscroll $path" \
        -yscrollcommand "ScrolledWindow::_set_vscroll $path"
}


# -----------------------------------------------------------------------------
#  Command ScrolledWindow::configure
# -----------------------------------------------------------------------------
proc ScrolledWindow::configure { path args } {
    upvar \#0 ScrolledWindow::$path data

    set grid $path._grid
    set res [Widget::configure $path $args]
    if { [Widget::hasChanged $path -background bg] } {
        $path configure -background $bg
        $grid configure -background $bg
        $grid.f configure -background $bg
        catch {$grid.hscroll configure -background $bg}
        catch {$grid.vscroll configure -background $bg}
    }

    if {[Widget::hasChanged $path -scrollbar scrollbar] |
        [Widget::hasChanged $path -auto      auto]     |


        [Widget::hasChanged $path -sides     sides]} {
        _setData $path $scrollbar $auto $sides
        set hscroll [$grid.hscroll get]
        set vmin    [lindex $hscroll 0]
        set vmax    [lindex $hscroll 1]
        set data(hsb,packed) [expr {$data(hsb,present) &&
                                    (!$data(hsb,auto) || ($vmin != 0 || $vmax != 1))}]
        set vscroll [$grid.vscroll get]
        set vmin    [lindex $vscroll 0]
        set vmax    [lindex $vscroll 1]
        set data(vsb,packed) [expr {$data(vsb,present) &&
                                    (!$data(vsb,auto) || ($vmin != 0 || $vmax != 1))}]


        set ipad [Widget::cget $path -ipad]
        place configure $grid.vscroll \
            -x [expr {(1-$data(vsb,west))*$ipad}]
        place configure $grid.hscroll \
            -y [expr {(1-$data(hsb,north))*$ipad}]

        grid configure $grid.hframe \
            -column     [expr {$data(vsb,west)*$data(vsb,packed)}] \
            -row        [expr {1-$data(hsb,north)}]  \
            -columnspan [expr {2-$data(vsb,packed)}]
        grid configure $grid.vframe \
            -column  [expr {1-$data(vsb,west)}] \
            -row     [expr {$data(hsb,north)*$data(hsb,packed)}] \
            -rowspan [expr {2-$data(hsb,packed)}]
        grid configure $grid.f \
            -column     [expr {$data(vsb,west)*$data(vsb,packed)}] \
            -row        [expr {$data(hsb,north)*$data(hsb,packed)}] \
            -columnspan [expr {2-$data(vsb,packed)}] \
            -rowspan    [expr {2-$data(hsb,packed)}]
        grid columnconfigure $grid $data(vsb,west)             -weight 1
        grid columnconfigure $grid [expr {1-$data(vsb,west)}]  -weight 0
        grid rowconfigure    $grid $data(hsb,north)            -weight 1
        grid rowconfigure    $grid [expr {1-$data(hsb,north)}] -weight 0
    }
    return $res
}


# -----------------------------------------------------------------------------
#  Command ScrolledWindow::cget
# -----------------------------------------------------------------------------
proc ScrolledWindow::cget { path option } {
    return [Widget::cget $path $option]
}


# -----------------------------------------------------------------------------
#  Command ScrolledWindow::_destroy
# -----------------------------------------------------------------------------
proc ScrolledWindow::_destroy { path } {
    upvar \#0 ScrolledWindow::$path data

    unset data



    Widget::destroy $path
    rename $path {}
}


# -----------------------------------------------------------------------------
#  Command ScrolledWindow::_set_hscroll
# -----------------------------------------------------------------------------
proc ScrolledWindow::_set_hscroll { path vmin vmax } {
    upvar \#0 ScrolledWindow::$path data

    if {$data(realized) && $data(hsb,present)} {
        set grid $path._grid
        if {$data(hsb,auto)} {
            if {$data(hsb,packed) && $vmin == 0 && $vmax == 1} {
                set data(hsb,packed) 0
                grid configure $grid.f $grid.vframe -row 0 -rowspan 2




            } elseif {!$data(hsb,packed) && ($vmin != 0 || $vmax != 1)} {
                set data(hsb,packed) 1
                grid configure $grid.f $grid.vframe -row $data(hsb,north) -rowspan 1


            }

        }

	update idletask
        $grid.hscroll set $vmin $vmax
    }
}


# -----------------------------------------------------------------------------
#  Command ScrolledWindow::_set_vscroll
# -----------------------------------------------------------------------------
proc ScrolledWindow::_set_vscroll { path vmin vmax } {
    upvar \#0 ScrolledWindow::$path data

    if {$data(realized) && $data(vsb,present)} {
        set grid $path._grid
        if {$data(vsb,auto)} {
            if {$data(vsb,packed) && $vmin == 0 && $vmax == 1} {
                set data(vsb,packed) 0
                grid configure $grid.f $grid.hframe -column 0 -columnspan 2




            } elseif {!$data(vsb,packed) && ($vmin != 0 || $vmax != 1) } {
                set data(vsb,packed) 1
                grid configure $grid.f $grid.hframe -column $data(vsb,west) -columnspan 1


            }

        }

	update idletask
        $grid.vscroll set $vmin $vmax
    }
}



proc ScrolledWindow::_setData {path scrollbar auto sides} {

    upvar \#0 ScrolledWindow::$path data


    set sb    [lsearch {none horizontal vertical both} $scrollbar]
    set auto  [lsearch {none horizontal vertical both} $auto]
    set north [string match *n* $sides]
    set west  [string match *w* $sides]


    set data(hsb,present)  [expr {($sb & 1) != 0}]
    set data(hsb,auto)     [expr {($auto & 1) != 0}]
    set data(hsb,north)    $north

    set data(vsb,present)  [expr {($sb & 2) != 0}]
    set data(vsb,auto)     [expr {($auto & 2) != 0}]
    set data(vsb,west)     $west
}


proc ScrolledWindow::_setSBSize {sb size args} {
    $sb configure -width $size
    eval place $sb $args
}


# -----------------------------------------------------------------------------
#  Command ScrolledWindow::_realize
# -----------------------------------------------------------------------------
proc ScrolledWindow::_realize { path } {
    upvar \#0 ScrolledWindow::$path data

    set grid $path._grid
    bind $grid <Configure> {}
    set data(realized) 1
    place $grid -anchor nw -x 0 -y 0 -relwidth 1.0 -relheight 1.0
}

Changes to spinbox.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
...
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
...
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
...
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
# ------------------------------------------------------------------------------
#  spinbox.tcl
#  This file is part of Unifix BWidget Toolkit
# ------------------------------------------------------------------------------
#  Index of commands:
#     - SpinBox::create
#     - SpinBox::configure
#     - SpinBox::cget
#     - SpinBox::setvalue
#     - SpinBox::_destroy
#     - SpinBox::_modify_value
#     - SpinBox::_test_options
# ------------------------------------------------------------------------------

namespace eval SpinBox {
    ArrowButton::use
    Entry::use
    LabelFrame::use

    Widget::bwinclude SpinBox LabelFrame .labf \
................................................................................
    proc ::SpinBox { path args } { return [eval SpinBox::create $path $args] }
    proc use {} {}

    variable _widget
}


# ------------------------------------------------------------------------------
#  Command SpinBox::create
# ------------------------------------------------------------------------------
proc SpinBox::create { path args } {
    variable _widget

    Widget::init SpinBox $path $args

    _test_options $path
    eval frame $path [Widget::subcget $path :cmd] \
        -highlightthickness 0 -bd 0 -relief flat -takefocus 0
    set labf [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
                  -borderwidth 2 -relief sunken -focus $path.e]
    set entry [eval Entry::create $path.e [Widget::subcget $path .e] \
                   -relief flat -borderwidth 0]

    bindtags $path [list $path BwSpinBox [winfo toplevel $path] all]

    set farr   [frame $path.farr -relief flat -bd 0 -highlightthickness 0]
    set height [expr {[winfo reqheight $path.e]/2-2}]
    set width  11
    set arrup  [eval ArrowButton::create $path.arrup -dir top \
                    [Widget::subcget $path .arrup] \
................................................................................
    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[eval SpinBox::\$cmd $path \$args\]"

    return $path
}


# ------------------------------------------------------------------------------
#  Command SpinBox::configure
# ------------------------------------------------------------------------------
proc SpinBox::configure { path args } {
    set res [Widget::configure $path $args]
    if { [Widget::hasChanged $path -values val] ||
         [Widget::hasChanged $path -range  val] } {
        _test_options $path
    }
    return $res
}


# ------------------------------------------------------------------------------
#  Command SpinBox::cget
# ------------------------------------------------------------------------------
proc SpinBox::cget { path option } {
    return [Widget::cget $path $option]
}


# ------------------------------------------------------------------------------
#  Command SpinBox::setvalue
# ------------------------------------------------------------------------------
proc SpinBox::setvalue { path index } {
    variable _widget

    set values [Widget::getoption $path -values]
    set value  [Entry::cget $path.e -text]

    if { [llength $values] } {
................................................................................
    } else {
        Entry::configure $path.e -text $newval
    }
    return 1
}


# ------------------------------------------------------------------------------
#  Command SpinBox::getvalue
# ------------------------------------------------------------------------------
proc SpinBox::getvalue { path } {
    variable _widget

    set values [Widget::getoption $path -values]
    set value  [Entry::cget $path.e -text]

    if { [llength $values] } {
................................................................................
            return [expr {int($idx)}]
        }
        return -1
    }
}


# ------------------------------------------------------------------------------
#  Command SpinBox::bind
# ------------------------------------------------------------------------------
proc SpinBox::bind { path args } {
    return [eval ::bind $path.e $args]
}


# ------------------------------------------------------------------------------
#  Command SpinBox::_destroy
# ------------------------------------------------------------------------------
proc SpinBox::_destroy { path } {
    variable _widget

    unset _widget($path,curval)
    Widget::destroy $path
    rename $path {}
}


# ------------------------------------------------------------------------------
#  Command SpinBox::_modify_value
# ------------------------------------------------------------------------------
proc SpinBox::_modify_value { path direction reason } {
    if { $reason == "arm" || $reason == "activate" } {
        SpinBox::setvalue $path $direction
    }
    if { ($reason == "disarm" || $reason == "activate") &&
         [set cmd [Widget::getoption $path -modifycmd]] != "" } {
        uplevel \#0 $cmd
    }
}


# ------------------------------------------------------------------------------
#  Command SpinBox::_test_options
# ------------------------------------------------------------------------------
proc SpinBox::_test_options { path } {
    variable _widget

    set values [Widget::getoption $path -values]
    if { [llength $values] } {
        set _widget($path,curval) [lindex $values 0]
    } else {
|


|








|







 







|

|









|


<







 







|

|










|

|





|

|







 







|

|







 







|

|





|

|









|

|










<
|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75

76
77
78
79
80
81
82
...
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
...
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
...
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

324
325
326
327
328
329
330
331
332
333
# -----------------------------------------------------------------------------
#  spinbox.tcl
#  This file is part of Unifix BWidget Toolkit
# -----------------------------------------------------------------------------
#  Index of commands:
#     - SpinBox::create
#     - SpinBox::configure
#     - SpinBox::cget
#     - SpinBox::setvalue
#     - SpinBox::_destroy
#     - SpinBox::_modify_value
#     - SpinBox::_test_options
# -----------------------------------------------------------------------------

namespace eval SpinBox {
    ArrowButton::use
    Entry::use
    LabelFrame::use

    Widget::bwinclude SpinBox LabelFrame .labf \
................................................................................
    proc ::SpinBox { path args } { return [eval SpinBox::create $path $args] }
    proc use {} {}

    variable _widget
}


# -----------------------------------------------------------------------------
#  Command SpinBox::create
# -----------------------------------------------------------------------------
proc SpinBox::create { path args } {
    variable _widget

    Widget::init SpinBox $path $args

    _test_options $path
    eval frame $path [Widget::subcget $path :cmd] \
        -highlightthickness 0 -bd 0 -relief flat -takefocus 0
    set labf [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
                  -focus $path.e]
    set entry [eval Entry::create $path.e [Widget::subcget $path .e] \
                   -relief flat -borderwidth 0]

    bindtags $path [list $path BwSpinBox [winfo toplevel $path] all]

    set farr   [frame $path.farr -relief flat -bd 0 -highlightthickness 0]
    set height [expr {[winfo reqheight $path.e]/2-2}]
    set width  11
    set arrup  [eval ArrowButton::create $path.arrup -dir top \
                    [Widget::subcget $path .arrup] \
................................................................................
    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[eval SpinBox::\$cmd $path \$args\]"

    return $path
}


# -----------------------------------------------------------------------------
#  Command SpinBox::configure
# -----------------------------------------------------------------------------
proc SpinBox::configure { path args } {
    set res [Widget::configure $path $args]
    if { [Widget::hasChanged $path -values val] ||
         [Widget::hasChanged $path -range  val] } {
        _test_options $path
    }
    return $res
}


# -----------------------------------------------------------------------------
#  Command SpinBox::cget
# -----------------------------------------------------------------------------
proc SpinBox::cget { path option } {
    return [Widget::cget $path $option]
}


# -----------------------------------------------------------------------------
#  Command SpinBox::setvalue
# -----------------------------------------------------------------------------
proc SpinBox::setvalue { path index } {
    variable _widget

    set values [Widget::getoption $path -values]
    set value  [Entry::cget $path.e -text]

    if { [llength $values] } {
................................................................................
    } else {
        Entry::configure $path.e -text $newval
    }
    return 1
}


# -----------------------------------------------------------------------------
#  Command SpinBox::getvalue
# -----------------------------------------------------------------------------
proc SpinBox::getvalue { path } {
    variable _widget

    set values [Widget::getoption $path -values]
    set value  [Entry::cget $path.e -text]

    if { [llength $values] } {
................................................................................
            return [expr {int($idx)}]
        }
        return -1
    }
}


# -----------------------------------------------------------------------------
#  Command SpinBox::bind
# -----------------------------------------------------------------------------
proc SpinBox::bind { path args } {
    return [eval ::bind $path.e $args]
}


# -----------------------------------------------------------------------------
#  Command SpinBox::_destroy
# -----------------------------------------------------------------------------
proc SpinBox::_destroy { path } {
    variable _widget

    unset _widget($path,curval)
    Widget::destroy $path
    rename $path {}
}


# -----------------------------------------------------------------------------
#  Command SpinBox::_modify_value
# -----------------------------------------------------------------------------
proc SpinBox::_modify_value { path direction reason } {
    if { $reason == "arm" || $reason == "activate" } {
        SpinBox::setvalue $path $direction
    }
    if { ($reason == "disarm" || $reason == "activate") &&
         [set cmd [Widget::getoption $path -modifycmd]] != "" } {
        uplevel \#0 $cmd
    }
}


# -----------------------------------------------------------------------------
#  Command SpinBox::_test_options
# -----------------------------------------------------------------------------
proc SpinBox::_test_options { path } {
    variable _widget

    set values [Widget::getoption $path -values]
    if { [llength $values] } {
        set _widget($path,curval) [lindex $values 0]
    } else {

Changes to tree.tcl.

1
2
3
4
5
6
7
8
9
10
11
..
59
60
61
62
63
64
65

66
67
68


69
70

71
72
73
74
75
76
77
78
79
80
81

82
83
84
85
86
87
88
89
90
...
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
...
281
282
283
284
285
286
287


288





289
290
291
292
293
294
295
296
...
514
515
516
517
518
519
520



521
522
523
524
525
526
527
...
570
571
572
573
574
575
576






































































577
578
579
580
581
582
583
...
707
708
709
710
711
712
713

714
715
716
717
718
719
720
...
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
...
898
899
900
901
902
903
904




905
906
907
908
909
910
911
912
913
914
915
916

917
918
919
920
921

922
923
924
925
926
927
928
929
930
931
932
933
934
....
1129
1130
1131
1132
1133
1134
1135









1136
1137
1138
1139
1140
1141
1142
1143




1144
1145
1146
1147
1148
1149
1150
1151
....
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
....
1241
1242
1243
1244
1245
1246
1247

1248
1249

1250
1251
1252
1253
1254
1255
1256
....
1265
1266
1267
1268
1269
1270
1271





1272
1273
1274
1275
1276
1277
1278
1279
1280
1281

1282
1283
1284
1285
1286
1287
1288
1289
1290

1291



1292
1293
1294
1295
1296
1297
1298
....
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
....
1376
1377
1378
1379
1380
1381
1382

1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393

1394
1395
1396
1397
1398
1399
1400
....
1584
1585
1586
1587
1588
1589
1590
1591
# ------------------------------------------------------------------------------
#  tree.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: tree.tcl,v 1.7 2000/02/11 00:16:30 ericm Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - Tree::create
#     - Tree::configure
#     - Tree::cget
#     - Tree::insert
#     - Tree::itemconfigure
................................................................................
            {-open       Boolean    0       0}
	    {-selectable Boolean    1       0}
            {-drawcross  Enum       auto    0 {auto allways never}}
        }
    }

    Widget::tkinclude Tree canvas :cmd \

        remove     {-insertwidth -insertbackground -insertborderwidth -insertofftime \
                        -insertontime -selectborderwidth -closeenough -confine -scrollregion \
                        -xscrollincrement -yscrollincrement -width -height} \


        initialize {-relief sunken -borderwidth 2 -takefocus 1 \
                        -highlightthickness 1 -width 200}


    Widget::declare Tree {
        {-deltax           Int 10 0 {=0 ""}}
        {-deltay           Int 15 0 {=0 ""}}
        {-padx             Int 20 0 {=0 ""}}
        {-background       TkResource "" 0 listbox}
        {-selectbackground TkResource "" 0 listbox}
        {-selectforeground TkResource "" 0 listbox}
	{-selectcommand    String     "" 0}
        {-width            TkResource "" 0 listbox}
        {-height           TkResource "" 0 listbox}

        {-showlines        Boolean 1  0}
        {-linesfill        TkResource black  0 {frame -background}}
        {-linestipple      TkResource ""     0 {label -bitmap}}
        {-redraw           Boolean 1  0}
        {-opencmd          String  "" 0}
        {-closecmd         String  "" 0}
        {-dropovermode     Flag    "wpn" 0 "wpn"}
        {-bg               Synonym -background}
    }
................................................................................
    bind $path <KeyPress-space> "Tree::_keynav space %W"

    # These allow keyboard control of the scrolling
    bind $path <Control-KeyPress-Up>    "$path yview scroll -1 units"
    bind $path <Control-KeyPress-Down>  "$path yview scroll  1 units"
    bind $path <Control-KeyPress-Left>  "$path xview scroll -1 units"
    bind $path <Control-KeyPress-Right> "$path xview scroll  1 units"

    bind $path
    # [email protected]

    bind $path <Configure> "Tree::_update_scrollregion $path"
    bind $path <Destroy>   "Tree::_destroy $path"

    DragSite::setdrag $path $path Tree::_init_drag_cmd [Widget::getoption $path -dragendcmd] 1
    DropSite::setdrop $path $path Tree::_over_cmd Tree::_drop_cmd 1
................................................................................
            set flag [expr {$flag << 1}]
            if { [Widget::hasChanged $path.$node $opt val] } {
                set flag [expr {$flag | 1}]
            }
        }

        if { [Widget::hasChanged $path.$node -open val] } {


            _redraw_idle $path 3





        } elseif { $data(upd,level) < 3 && $flag } {
            if { [set idx [lsearch $data(upd,nodes) $node]] == -1 } {
                lappend data(upd,nodes) $node $flag
            } else {
                incr idx
                set flag [expr {[lindex $data(upd,nodes) $idx] | $flag}]
                set data(upd,nodes) [lreplace $data(upd,nodes) $idx $idx $flag]
            }
................................................................................
        }
        clear {
            set data(selnodes) {}
        }
        get {
            return $data(selnodes)
        }



        default {
            return
        }
    }
    _redraw_idle $path 1
}

................................................................................
    if { ![string compare $node "root"] || ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }
    set parent [lindex $data($node) 0]
    return [expr {[lsearch $data($parent) $node] - 1}]
}








































































# ------------------------------------------------------------------------------
#  Command Tree::nodes
# ------------------------------------------------------------------------------
proc Tree::nodes { path node {first ""} {last ""} } {
    variable $path
    upvar 0  $path data
................................................................................
        update
        if { $select } {
            $ent selection range 0 end
            $ent icursor end
            $ent xview end
        }


        bind $ent <Escape> {set Tree::_edit(wait) 0}
        bind $ent <Return> {set Tree::_edit(wait) 1}
        if { $clickres == 0 || $clickres == 1 } {
            bind $frame <Button>  "set Tree::_edit(wait) $clickres"
        }

        set ok 0
................................................................................
# ------------------------------------------------------------------------------
proc Tree::_update_scrollregion { path } {
    set bd   [expr {2*([$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness])}]
    set w    [expr {[winfo width  $path] - $bd}]
    set h    [expr {[winfo height $path] - $bd}]
    set xinc [$path:cmd cget -xscrollincrement]
    set yinc [$path:cmd cget -yscrollincrement]
    set bbox [$path:cmd bbox all]
    if { [llength $bbox] } {
        set xs [lindex $bbox 2]
        set ys [lindex $bbox 3]

        if { $w < $xs } {
            set w [expr {int($xs)}]
            if { [set r [expr {$w % $xinc}]] } {
................................................................................
            if { [set r [expr {$h % $yinc}]] } {
                set h [expr {$h+$yinc-$r}]
            }
        }
    }

    $path:cmd configure -scrollregion [list 0 0 $w $h]




}


# ------------------------------------------------------------------------------
#  Command Tree::_cross_event
# ------------------------------------------------------------------------------
proc Tree::_cross_event { path } {
    variable $path
    upvar 0  $path data

    set node [string range [lindex [$path:cmd gettags current] 1] 2 end]
    if { [Widget::getoption $path.$node -open] } {

        if { [set cmd [Widget::getoption $path -closecmd]] != "" } {
            uplevel \#0 $cmd $node
        }
        Widget::setoption $path.$node -open 0
    } else {

        if { [set cmd [Widget::getoption $path -opencmd]] != "" } {
            uplevel \#0 $cmd $node
        }
        Widget::setoption $path.$node -open 1
    }
    _redraw_idle $path 3
}


# ------------------------------------------------------------------------------
#  Command Tree::_draw_node
# ------------------------------------------------------------------------------
proc Tree::_draw_node { path node x0 y0 deltax deltay padx showlines } {
................................................................................
# ------------------------------------------------------------------------------
proc Tree::_redraw_selection { path } {
    variable $path
    upvar 0  $path data

    set selbg [Widget::getoption $path -selectbackground]
    set selfg [Widget::getoption $path -selectforeground]









    foreach id [$path:cmd find withtag sel] {
        set node [string range [lindex [$path:cmd gettags $id] 1] 2 end]
        $path:cmd itemconfigure "n:$node" -fill [Widget::getoption $path.$node -fill]
    }
    $path:cmd delete sel
    foreach node $data(selnodes) {
        set bbox [$path:cmd bbox "n:$node"]
        if { [llength $bbox] } {




            set id [eval $path:cmd create rectangle $bbox -fill $selbg -outline $selbg -tags [list "sel s:$node"]]
            $path:cmd itemconfigure "n:$node" -fill $selfg
            $path:cmd lower $id
        }
    }
}


................................................................................
    }
    if { $level > $data(upd,level) } {
        set data(upd,level) $level
    }
    return ""
}


# --------------------------------------------------------------------------------------------
# Commandes pour le Drag and Drop


# ------------------------------------------------------------------------------
#  Command Tree::_init_drag_cmd
# ------------------------------------------------------------------------------
proc Tree::_init_drag_cmd { path X Y top } {
    set ltags [$path:cmd gettags current]
    set item  [lindex $ltags 0]
................................................................................
        set data(dnd,mode) 0
        foreach c {w p n} {
            set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}]
        }
        set bbox [$path:cmd bbox all]
        if { [llength $bbox] } {
            set data(dnd,xs) [lindex $bbox 2]

        } else {
            set data(dnd,xs) 0

        }
        set data(dnd,node) {}
    }

    set x [expr {$X-[winfo rootx $path]}]
    set y [expr {$Y-[winfo rooty $path]}]
    $path:cmd delete drop
................................................................................
        # dropovermode includes widget
        set target [list widget]
        set vmode  4
    } else {
        set target [list ""]
        set vmode  0
    }






    set xc [$path:cmd canvasx $x]
    set xs $data(dnd,xs)
    if { $xc <= $xs } {
        set yc   [$path:cmd canvasy $y]
        set dy   [$path:cmd cget -yscrollincrement]
        set line [expr {int($yc/$dy)}]
        set xi   0
        set yi   [expr {$line*$dy}]
        set ys   [expr {$yi+$dy}]

        foreach id [$path:cmd find overlapping $xi $yi $xs $ys] {
            set ltags [$path:cmd gettags $id]
            set item  [lindex $ltags 0]
            if { ![string compare $item "node"] ||
                 ![string compare $item "img"]  ||
                 ![string compare $item "win"] } {
                # item is the label or image/window of the node
                set node [string range [lindex $ltags 1] 2 end]
                set xi   [expr {[lindex [$path:cmd coords n:$node] 0]-[Widget::getoption $path -padx]}]





                if { $data(dnd,mode) & 1 } {
                    # dropovermode includes node
                    lappend target $node
                    set vmode [expr {$vmode | 1}]
                } else {
                    lappend target ""
                }
................................................................................
                    # we compute what is the preferred method
                    if { $yc-$yi <= 3 || $ys-$yc <= 3 } {
                        lappend target "position"
                    } else {
                        lappend target "node"
                    }
                }
                break
            }
        }
    }

    if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
        # user-defined dropover command
        set res     [uplevel \#0 $cmd [list $path $source $target $op $type $dnddata]]
        set code    [lindex $res 0]
        set newmode 0
        if { $code & 1 } {
................................................................................
            # dropovermode is widget or empty - recall is not necessary
            set code 1
        } else {
            set code 3
        }
    }


    # draw dnd visual following vmode
    if { $vmode & 1 } {
        set data(dnd,node) [list "node" [lindex $target 1]]
        $path:cmd create rectangle $xi $yi $xs $ys -tags drop
    } elseif { $vmode & 2 } {
        set data(dnd,node) [concat "position" [lindex $target 2]]
        $path:cmd create line $xli [expr {$yl-$dy/2}] $xli $yl $xs $yl -tags drop
    } elseif { $vmode & 4 } {
        set data(dnd,node) [list "widget"]
    } else {
        set code [expr {$code & 2}]

    }

    if { $code & 1 } {
        DropSite::setcursor based_arrow_down
    } else {
        DropSite::setcursor dot
    }
................................................................................
	    if { [llength [$win nodes $node]] } {
		$win itemconfigure $node -open [expr {$open?0:1}]
	    }
	}
    }
    return
}



|







 







>
|
|
|
>
>
|
|
>











>

|







 







<
<







 







>
>
|
>
>
>
>
>
|







 







>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>







 







|







 







>
>
>
>












>



<

>



<

<







 







>
>
>
>
>
>
>
>
>








>
>
>
>
|







 







<
<
<
<







 







>


>







 







>
>
>
>
>










>








|
>
|
>
>
>







 







<


<







 







>
|
|
|
|
|
|
|
|
|
|
|
>







 







<
1
2
3
4
5
6
7
8
9
10
11
..
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
...
142
143
144
145
146
147
148


149
150
151
152
153
154
155
...
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
...
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
...
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
...
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
...
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
...
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008

1009
1010
1011
1012
1013

1014

1015
1016
1017
1018
1019
1020
1021
....
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
....
1261
1262
1263
1264
1265
1266
1267




1268
1269
1270
1271
1272
1273
1274
....
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
....
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
....
1443
1444
1445
1446
1447
1448
1449

1450
1451

1452
1453
1454
1455
1456
1457
1458
....
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
....
1692
1693
1694
1695
1696
1697
1698

# ------------------------------------------------------------------------------
#  tree.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: tree.tcl,v 1.8 2000/02/11 22:54:29 ericm Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - Tree::create
#     - Tree::configure
#     - Tree::cget
#     - Tree::insert
#     - Tree::itemconfigure
................................................................................
            {-open       Boolean    0       0}
	    {-selectable Boolean    1       0}
            {-drawcross  Enum       auto    0 {auto allways never}}
        }
    }

    Widget::tkinclude Tree canvas :cmd \
	    remove     {
	-insertwidth -insertbackground -insertborderwidth -insertofftime
	-insertontime -selectborderwidth -closeenough -confine -scrollregion 
	-xscrollincrement -yscrollincrement -width -height
    } \
	    initialize {
	-relief sunken -borderwidth 2 -takefocus 1 
	-highlightthickness 1 -width 200
    }

    Widget::declare Tree {
        {-deltax           Int 10 0 {=0 ""}}
        {-deltay           Int 15 0 {=0 ""}}
        {-padx             Int 20 0 {=0 ""}}
        {-background       TkResource "" 0 listbox}
        {-selectbackground TkResource "" 0 listbox}
        {-selectforeground TkResource "" 0 listbox}
	{-selectcommand    String     "" 0}
        {-width            TkResource "" 0 listbox}
        {-height           TkResource "" 0 listbox}
        {-selectfill       Boolean 0  0}
        {-showlines        Boolean 1  0}
        {-linesfill        TkResource black  0 {listbox -foreground}}
        {-linestipple      TkResource ""     0 {label -bitmap}}
        {-redraw           Boolean 1  0}
        {-opencmd          String  "" 0}
        {-closecmd         String  "" 0}
        {-dropovermode     Flag    "wpn" 0 "wpn"}
        {-bg               Synonym -background}
    }
................................................................................
    bind $path <KeyPress-space> "Tree::_keynav space %W"

    # These allow keyboard control of the scrolling
    bind $path <Control-KeyPress-Up>    "$path yview scroll -1 units"
    bind $path <Control-KeyPress-Down>  "$path yview scroll  1 units"
    bind $path <Control-KeyPress-Left>  "$path xview scroll -1 units"
    bind $path <Control-KeyPress-Right> "$path xview scroll  1 units"


    # [email protected]

    bind $path <Configure> "Tree::_update_scrollregion $path"
    bind $path <Destroy>   "Tree::_destroy $path"

    DragSite::setdrag $path $path Tree::_init_drag_cmd [Widget::getoption $path -dragendcmd] 1
    DropSite::setdrop $path $path Tree::_over_cmd Tree::_drop_cmd 1
................................................................................
            set flag [expr {$flag << 1}]
            if { [Widget::hasChanged $path.$node $opt val] } {
                set flag [expr {$flag | 1}]
            }
        }

        if { [Widget::hasChanged $path.$node -open val] } {
            if {[llength $data($node)] > 1} {
                # node have subnodes - full redraw
                _redraw_idle $path 3
            } else {
                # force a redraw of the plus/minus sign
                set flag [expr {$flag | 8}]
            }
        } 
	if { $data(upd,level) < 3 && $flag } {
            if { [set idx [lsearch $data(upd,nodes) $node]] == -1 } {
                lappend data(upd,nodes) $node $flag
            } else {
                incr idx
                set flag [expr {[lindex $data(upd,nodes) $idx] | $flag}]
                set data(upd,nodes) [lreplace $data(upd,nodes) $idx $idx $flag]
            }
................................................................................
        }
        clear {
            set data(selnodes) {}
        }
        get {
            return $data(selnodes)
        }
        includes {
            return [expr {[lsearch $data(selnodes) $args] != -1}]
        }
        default {
            return
        }
    }
    _redraw_idle $path 1
}

................................................................................
    if { ![string compare $node "root"] || ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }
    set parent [lindex $data($node) 0]
    return [expr {[lsearch $data($parent) $node] - 1}]
}


# ------------------------------------------------------------------------------
#  Tree::find
#     Returns the node given a position.
#  findInfo     @x,y ?confine?
#               lineNumber
# ------------------------------------------------------------------------------
proc Tree::find {path findInfo {confine ""}} {
    if {[regexp -- {^@([0-9]+),([0-9]+)$} $findInfo match x y]} {
        set x [$path:cmd canvasx $x]
        set y [$path:cmd canvasy $y]
    } elseif {[regexp -- {^[0-9]+$} $findInfo lineNumber]} {
        set dy [Widget::getoption $path -deltay]
        set y  [expr {$dy*($lineNumber+0.5)}]
        set confine ""
    } else {
        return -code error "invalid find spec \"$findInfo\""
    }

    set found  0
    set region [$path:cmd bbox all]
    if {[llengh $region]} {
        set xi [lindex $region 0]
        set xs [lindex $region 2]
        foreach id [$path:cmd find overlapping $xi $y $xs $y] {
            set ltags [$path:cmd gettags $id]
            set item  [lindex $ltags 0]
            if { ![string compare $item "node"] ||
                 ![string compare $item "img"]  ||
                 ![string compare $item "win"] } {
                # item is the label or image/window of the node
                set node  [string range [lindex $ltags 1] 2 end]
                set found 1
                break
            }
        }
    }

    if {$found} {
        if {[string compare $confine "confine"] == 0} {
            # test if x stand inside node bbox
            set xi [expr {[lindex [$path:cmd coords n:$node] 0]-[Widget::cget $path -padx]}]
            set xs [lindex [$path:cmd bbox n:$node] 2]
            if {$x >= $xi && $x <= $xs} {
                return $node
            }
        } else {
            return $node
        }
    }
    return ""
}


# ------------------------------------------------------------------------------
#  Command Tree::line
#     Returns the line where is drawn a node.
# ------------------------------------------------------------------------------
proc Tree::line {path node} {
    set item [$path:cmd find withtag n:$node]
    if {[string length $item]} {
        set dy   [Widget::getoption $path -deltay]
        set y    [lindex [$path:cmd coords $item] 1]
        set line [expr {int($y/$dy)}]
    } else {
        set line -1
    }
    return $line
}


# ------------------------------------------------------------------------------
#  Command Tree::nodes
# ------------------------------------------------------------------------------
proc Tree::nodes { path node {first ""} {last ""} } {
    variable $path
    upvar 0  $path data
................................................................................
        update
        if { $select } {
            $ent selection range 0 end
            $ent icursor end
            $ent xview end
        }

        bindtags $ent [list $ent Entry]
        bind $ent <Escape> {set Tree::_edit(wait) 0}
        bind $ent <Return> {set Tree::_edit(wait) 1}
        if { $clickres == 0 || $clickres == 1 } {
            bind $frame <Button>  "set Tree::_edit(wait) $clickres"
        }

        set ok 0
................................................................................
# ------------------------------------------------------------------------------
proc Tree::_update_scrollregion { path } {
    set bd   [expr {2*([$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness])}]
    set w    [expr {[winfo width  $path] - $bd}]
    set h    [expr {[winfo height $path] - $bd}]
    set xinc [$path:cmd cget -xscrollincrement]
    set yinc [$path:cmd cget -yscrollincrement]
    set bbox [$path:cmd bbox node]
    if { [llength $bbox] } {
        set xs [lindex $bbox 2]
        set ys [lindex $bbox 3]

        if { $w < $xs } {
            set w [expr {int($xs)}]
            if { [set r [expr {$w % $xinc}]] } {
................................................................................
            if { [set r [expr {$h % $yinc}]] } {
                set h [expr {$h+$yinc-$r}]
            }
        }
    }

    $path:cmd configure -scrollregion [list 0 0 $w $h]

    if {[Widget::getoption $path -selectfill]} {
        _redraw_selection $path
    }
}


# ------------------------------------------------------------------------------
#  Command Tree::_cross_event
# ------------------------------------------------------------------------------
proc Tree::_cross_event { path } {
    variable $path
    upvar 0  $path data

    set node [string range [lindex [$path:cmd gettags current] 1] 2 end]
    if { [Widget::getoption $path.$node -open] } {
        Tree::itemconfigure $path $node -open 0
        if { [set cmd [Widget::getoption $path -closecmd]] != "" } {
            uplevel \#0 $cmd $node
        }

    } else {
        Tree::itemconfigure $path $node -open 1
        if { [set cmd [Widget::getoption $path -opencmd]] != "" } {
            uplevel \#0 $cmd $node
        }

    }

}


# ------------------------------------------------------------------------------
#  Command Tree::_draw_node
# ------------------------------------------------------------------------------
proc Tree::_draw_node { path node x0 y0 deltax deltay padx showlines } {
................................................................................
# ------------------------------------------------------------------------------
proc Tree::_redraw_selection { path } {
    variable $path
    upvar 0  $path data

    set selbg [Widget::getoption $path -selectbackground]
    set selfg [Widget::getoption $path -selectforeground]
    set fill  [Widget::getoption $path -selectfill]
    if {$fill} {
        set scroll [$path:cmd cget -scrollregion]
        if {[llength $scroll]} {
            set xmax [expr {[lindex $scroll 2]-1}]
        } else {
            set xmax [winfo width $path]
        }
    }
    foreach id [$path:cmd find withtag sel] {
        set node [string range [lindex [$path:cmd gettags $id] 1] 2 end]
        $path:cmd itemconfigure "n:$node" -fill [Widget::getoption $path.$node -fill]
    }
    $path:cmd delete sel
    foreach node $data(selnodes) {
        set bbox [$path:cmd bbox "n:$node"]
        if { [llength $bbox] } {
            if {$fill} {
                set bbox [list 0 [lindex $bbox 1] $xmax [lindex $bbox 3]]
            }
            set id [eval $path:cmd create rectangle $bbox \
		    -fill $selbg -outline $selbg -tags [list "sel s:$node"]]
            $path:cmd itemconfigure "n:$node" -fill $selfg
            $path:cmd lower $id
        }
    }
}


................................................................................
    }
    if { $level > $data(upd,level) } {
        set data(upd,level) $level
    }
    return ""
}






# ------------------------------------------------------------------------------
#  Command Tree::_init_drag_cmd
# ------------------------------------------------------------------------------
proc Tree::_init_drag_cmd { path X Y top } {
    set ltags [$path:cmd gettags current]
    set item  [lindex $ltags 0]
................................................................................
        set data(dnd,mode) 0
        foreach c {w p n} {
            set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}]
        }
        set bbox [$path:cmd bbox all]
        if { [llength $bbox] } {
            set data(dnd,xs) [lindex $bbox 2]
            set data(dnd,empty) 0
        } else {
            set data(dnd,xs) 0
            set data(dnd,empty) 1
        }
        set data(dnd,node) {}
    }

    set x [expr {$X-[winfo rootx $path]}]
    set y [expr {$Y-[winfo rooty $path]}]
    $path:cmd delete drop
................................................................................
        # dropovermode includes widget
        set target [list widget]
        set vmode  4
    } else {
        set target [list ""]
        set vmode  0
    }
    if { ($data(dnd,mode) & 2) && $data(dnd,empty) } {
        # dropovermode includes position and tree is empty
        lappend target [list root 0]
        set vmode  [expr {$vmode | 2}]
    }

    set xc [$path:cmd canvasx $x]
    set xs $data(dnd,xs)
    if { $xc <= $xs } {
        set yc   [$path:cmd canvasy $y]
        set dy   [$path:cmd cget -yscrollincrement]
        set line [expr {int($yc/$dy)}]
        set xi   0
        set yi   [expr {$line*$dy}]
        set ys   [expr {$yi+$dy}]
        set found 0
        foreach id [$path:cmd find overlapping $xi $yi $xs $ys] {
            set ltags [$path:cmd gettags $id]
            set item  [lindex $ltags 0]
            if { ![string compare $item "node"] ||
                 ![string compare $item "img"]  ||
                 ![string compare $item "win"] } {
                # item is the label or image/window of the node
                set node [string range [lindex $ltags 1] 2 end]
		set found 1
		break
	    }
	}
	if {$found} {
            set xi [expr {[lindex [$path:cmd coords n:$node] 0]-[Widget::getoption $path -padx]-1}]
                if { $data(dnd,mode) & 1 } {
                    # dropovermode includes node
                    lappend target $node
                    set vmode [expr {$vmode | 1}]
                } else {
                    lappend target ""
                }
................................................................................
                    # we compute what is the preferred method
                    if { $yc-$yi <= 3 || $ys-$yc <= 3 } {
                        lappend target "position"
                    } else {
                        lappend target "node"
                    }
                }

            }
        }


    if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
        # user-defined dropover command
        set res     [uplevel \#0 $cmd [list $path $source $target $op $type $dnddata]]
        set code    [lindex $res 0]
        set newmode 0
        if { $code & 1 } {
................................................................................
            # dropovermode is widget or empty - recall is not necessary
            set code 1
        } else {
            set code 3
        }
    }

    if {!$data(dnd,empty)} {
	# draw dnd visual following vmode
	if { $vmode & 1 } {
	    set data(dnd,node) [list "node" [lindex $target 1]]
	    $path:cmd create rectangle $xi $yi $xs $ys -tags drop
	} elseif { $vmode & 2 } {
	    set data(dnd,node) [concat "position" [lindex $target 2]]
	    $path:cmd create line $xli [expr {$yl-$dy/2}] $xli $yl $xs $yl -tags drop
	} elseif { $vmode & 4 } {
	    set data(dnd,node) [list "widget"]
	} else {
	    set code [expr {$code & 2}]
	}
    }

    if { $code & 1 } {
        DropSite::setcursor based_arrow_down
    } else {
        DropSite::setcursor dot
    }
................................................................................
	    if { [llength [$win nodes $node]] } {
		$win itemconfigure $node -open [expr {$open?0:1}]
	    }
	}
    }
    return
}