Stringscan

Check-in [b2f9f853cf]
Login

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

Overview
Comment:Updates for 2.0
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: b2f9f853cf0f25bf848a1b2e605c8bad671dd429f0869c4bf33e3377caea4e08
User & Date: kevin 2020-05-07 15:59:56
Context
2020-05-08
13:44
More refinements for 2.0 check-in: 5d9fdc49ca user: kevin tags: trunk
2020-05-07
15:59
Updates for 2.0 check-in: b2f9f853cf user: kevin tags: trunk
2020-05-01
13:55
Tweaks for Windows check-in: 493de1fdc7 user: kevin tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to buildapp.

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
<plist version="1.0">
<dict>
	<key>CFBundleDevelopmentRegion</key>
	<string>English</string>
	<key>CFBundleExecutable</key>
	<string>Stringscan</string>
	<key>CFBundleGetInfoString</key>
	<string>Stringscan $1 (c) 2018 WordTech Communications LLC</string>
        <key>NSPrincipalClass</key>
        <string>NSApplication</string>
<key>NSHighResolutionCapable</key>
	<true/>
	<key>LSMinimumSystemVersionByArchitecture</key>
	<dict>
	<key>i386</key>
	<string>10.13</string>
	<key>x86_64</key>
	<string>10.13</string>
	</dict>
	<key>LSArchitecturePriority</key>
<array>
<string>x86_64</string>
<string>i386</string>
</array>
	<key>LSApplicationCategoryType</key>
	<string>public.app-category.utilities</string>
	<key>NSHumanReadableCopyright</key>
	<string>(c) 2018 WordTech Communications LLC</string>
	<key>CFBundleIconFile</key>
	<string>stringscan.icns</string>
	<key>CFBundleInfoDictionaryVersion</key>
	<string>6.0</string>
	<key>CFBundleDocumentTypes</key>
	<array>
		<dict>







|






<
<

|









|







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
<plist version="1.0">
<dict>
	<key>CFBundleDevelopmentRegion</key>
	<string>English</string>
	<key>CFBundleExecutable</key>
	<string>Stringscan</string>
	<key>CFBundleGetInfoString</key>
	<string>Stringscan $1 (c) 2020 WordTech Communications LLC</string>
        <key>NSPrincipalClass</key>
        <string>NSApplication</string>
<key>NSHighResolutionCapable</key>
	<true/>
	<key>LSMinimumSystemVersionByArchitecture</key>
	<dict>


	<key>x86_64</key>
	<string>10.15</string>
	</dict>
	<key>LSArchitecturePriority</key>
<array>
<string>x86_64</string>
<string>i386</string>
</array>
	<key>LSApplicationCategoryType</key>
	<string>public.app-category.utilities</string>
	<key>NSHumanReadableCopyright</key>
	<string>(c) 2020 WordTech Communications LLC</string>
	<key>CFBundleIconFile</key>
	<string>stringscan.icns</string>
	<key>CFBundleInfoDictionaryVersion</key>
	<string>6.0</string>
	<key>CFBundleDocumentTypes</key>
	<array>
		<dict>
78
79
80
81
82
83
84
85
86
87
88
89
90
91






92
93
94
95
96
97
98
	<key>CFBundlePackageType</key>
	<string>APPL</string>
	<key>CFBundleShortVersionString</key>
	<string>$1</string>
	<key>CFBundleVersion</key>
	<string>$1</string>
	<key>LSMinimumSystemVersion</key>
	<string>10.13</string>
	<key>LSRequiresCarbon</key>
	<true/>	
	<key>NSSupportsAutomaticTermination</key>
	<string>YES</string>
	<key>NSSupportsSuddenTermination</key>
	<string>YES</string>






</dict>
</plist>
EOT


/usr/local/ruby/bin/ruby-beautify -c 4 -s stringscan.rb > main.rb
ruby2app







|






>
>
>
>
>
>







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
	<key>CFBundlePackageType</key>
	<string>APPL</string>
	<key>CFBundleShortVersionString</key>
	<string>$1</string>
	<key>CFBundleVersion</key>
	<string>$1</string>
	<key>LSMinimumSystemVersion</key>
	<string>10.15</string>
	<key>LSRequiresCarbon</key>
	<true/>	
	<key>NSSupportsAutomaticTermination</key>
	<string>YES</string>
	<key>NSSupportsSuddenTermination</key>
	<string>YES</string>
	<key>OSAScriptingDefinition</key>
	<string>Wish.sdef</string>
<key>CFBundleHelpBookFolder</key>
	<string>Stringscan User Help.help</string>
	<key>CFBundleHelpBookName</key>
	<string>Stringscan User Help</string>
</dict>
</plist>
EOT


/usr/local/ruby/bin/ruby-beautify -c 4 -s stringscan.rb > main.rb
ruby2app
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

xattr -cr build/Stringscan.app

codesign  --signature-size 9400 -f -s "Developer ID Application: Kevin Walzer" --verbose=2  build/Stringscan.app

echo "Creating and signing DMG file..."

hdiutil create  -srcfolder build -fs HFS+ -volname Stringscan Stringscan.dmg

codesign  --signature-size 9400 -f -s "Developer ID Application: Kevin Walzer" --verbose=2  Stringscan.dmg

echo "Uploading DMG..."

upload Stringscan.dmg updates

upload stringscan-changes.tcl

upload stringscan-version.tcl

cd ../

#create archive of entire source tree
tar cvfz Stringscan-$1.tgz Stringscan


echo "Done."










|

|



|

|

|




|






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

xattr -cr build/Stringscan.app

codesign  --signature-size 9400 -f -s "Developer ID Application: Kevin Walzer" --verbose=2  build/Stringscan.app

echo "Creating and signing DMG file..."

#hdiutil create  -srcfolder build -fs HFS+ -volname Stringscan Stringscan.dmg

#codesign  --signature-size 9400 -f -s "Developer ID Application: Kevin Walzer" --verbose=2  Stringscan.dmg

echo "Uploading DMG..."

#upload Stringscan.dmg updates

#upload stringscan-changes.tcl

#upload stringscan-version.tcl

cd ../

#create archive of entire source tree
#tar cvfz Stringscan-$1.tgz Stringscan


echo "Done."



Deleted maclibs/aem1.0/libaem1.0.dylib.

cannot compute difference between binary files

Deleted maclibs/aem1.0/pkgIndex.tcl.

1
2
3
4
5
6
7
#
# Tcl package index file
#
package ifneeded aem 1.0 "
    package require Tk 8.5-
    if {\"AppKit\" ni \[winfo server .\]} {error {TkAqua Cocoa required}}
        load [list [file join $dir libaem1.0.dylib]] aem"
<
<
<
<
<
<
<














Changes to scriptlibs/darkaqua/darkaqua.tcl.

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












	    event generate . <<DarkAqua>>
	} else {
	    event generate . <<LightAqua>>
	}
    }
    
    
    bind all <<LightAqua>> {changeImagesLight}
    bind all <<DarkAqua>> {changeImagesDark}
    
    namespace export *
    
}



















<
<
<



>
>
>
>
>
>
>
>
>
>
>
>
30
31
32
33
34
35
36



37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
	    event generate . <<DarkAqua>>
	} else {
	    event generate . <<LightAqua>>
	}
    }
    
    



    namespace export *
    
}

    #raise window if closed--dock click
    proc ::tk::mac::ReopenApplication {} {
	if { [wm state .] == "withdrawn"} {
	    wm state . normal
	    raise .
	} else {
	    wm deiconify .
	    raise .
	}
    }

Deleted scriptlibs/tklib0.5/autoscroll/autoscroll.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
# autoscroll.tcl --
#
#       Package to create scroll bars that automatically appear when
#       a window is too small to display its content.
#
# Copyright (c) 2003    Kevin B Kenny <kennykb@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: autoscroll.tcl,v 1.8 2005/06/01 02:37:51 andreas_kupries Exp $

package require Tk
package provide autoscroll 1.1

namespace eval ::autoscroll {
    namespace export autoscroll unautoscroll
    bind Autoscroll <Destroy> [namespace code [list destroyed %W]]
    bind Autoscroll <Map> [namespace code [list map %W]]
}

 #----------------------------------------------------------------------
 #
 # ::autoscroll::autoscroll --
 #
 #       Create a scroll bar that disappears when it is not needed, and
 #       reappears when it is.
 #
 # Parameters:
 #       w    -- Path name of the scroll bar, which should already exist
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       The widget command is renamed, so that the 'set' command can
 #       be intercepted and determine whether the widget should appear.
 #       In addition, the 'Autoscroll' bind tag is added to the widget,
 #       so that the <Destroy> event can be intercepted.
 #
 #----------------------------------------------------------------------

proc ::autoscroll::autoscroll { w } {
    if { [info commands ::autoscroll::renamed$w] != "" } { return $w }
    rename $w ::autoscroll::renamed$w
    interp alias {} ::$w {} ::autoscroll::widgetCommand $w
    bindtags $w [linsert [bindtags $w] 1 Autoscroll]
    eval [list ::$w set] [renamed$w get]
    return $w
}

 #----------------------------------------------------------------------
 #
 # ::autoscroll::unautoscroll --
 #
 #       Return a scrollbar to its normal static behavior by removing
 #       it from the control of this package.
 #
 # Parameters:
 #       w    -- Path name of the scroll bar, which must have previously
 #               had ::autoscroll::autoscroll called on it.
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       The widget command is renamed to its original name. The widget
 #       is mapped if it was not currently displayed. The widgets
 #       bindtags are returned to their original state. Internal memory
 #       is cleaned up.
 #
 #----------------------------------------------------------------------

proc ::autoscroll::unautoscroll { w } {
    if { [info commands ::autoscroll::renamed$w] != "" } {
        variable grid
        rename ::$w {}
        rename ::autoscroll::renamed$w ::$w
        if { [set i [lsearch -exact [bindtags $w] Autoscroll]] > -1 } {
            bindtags $w [lreplace [bindtags $w] $i $i]
        }
        if { [info exists grid($w)] } {
            eval [join $grid($w) \;]
            unset grid($w)
        }
    }
}

 #----------------------------------------------------------------------
 #
 # ::autoscroll::widgetCommand --
 #
 #       Widget command on an 'autoscroll' scrollbar
 #
 # Parameters:
 #       w       -- Path name of the scroll bar
 #       command -- Widget command being executed
 #       args    -- Arguments to the commane
 #
 # Results:
 #       Returns whatever the widget command returns
 #
 # Side effects:
 #       Has whatever side effects the widget command has.  In
 #       addition, the 'set' widget command is handled specially,
 #       by gridding/packing the scroll bar according to whether
 #       it is required.
 #
 #------------------------------------------------------------

proc ::autoscroll::widgetCommand { w command args } {
    variable grid
    if { $command == "set" } {
        foreach { min max } $args {}
        if { $min <= 0 && $max >= 1 } {
            switch -exact -- [winfo manager $w] {
                grid {
                    lappend grid($w) "[list grid $w] [grid info $w]"
                    grid forget $w
                }
                pack {
                    foreach x [pack slaves [winfo parent $w]] {
                        lappend grid($w) "[list pack $x] [pack info $x]"
                    }
                    pack forget $w
                }
            }
        } elseif { [info exists grid($w)] } {
            eval [join $grid($w) \;]
            unset grid($w)
        }
    }
    return [eval [list renamed$w $command] $args]
}


 #----------------------------------------------------------------------
 #
 # ::autoscroll::destroyed --
 #
 #       Callback executed when an automatic scroll bar is destroyed.
 #
 # Parameters:
 #       w -- Path name of the scroll bar
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       Cleans up internal memory.
 #
 #----------------------------------------------------------------------

proc ::autoscroll::destroyed { w } {
    variable grid
    catch { unset grid($w) }
    rename ::$w {}
}


 #----------------------------------------------------------------------
 #
 # ::autoscroll::map --
 #
 #       Callback executed when an automatic scroll bar is mapped.
 #
 # Parameters:
 #       w -- Path name of the scroll bar.
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       Geometry of the scroll bar's top-level window is constrained.
 #
 # This procedure keeps the top-level window associated with an
 # automatic scroll bar from being resized automatically after the
 # scroll bar is mapped.  This effect avoids a potential endless loop
 # in the case where the resize of the top-level window resizes the
 # widget being scrolled, causing the scroll bar no longer to be needed.
 #
 #----------------------------------------------------------------------

proc ::autoscroll::map { w } {
    wm geometry [winfo toplevel $w] [wm geometry [winfo toplevel $w]]
}

 #----------------------------------------------------------------------
 #
 # ::autoscroll::wrap --
 #
 #       Arrange for all new scrollbars to be automatically autoscrolled
 #
 # Parameters:
 #       None.
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       ::scrollbar is overloaded to automatically autoscroll any new
 #          scrollbars.
 #
 #----------------------------------------------------------------------

proc ::autoscroll::wrap {} {
    if {[info commands ::autoscroll::_scrollbar] != ""} {return}
    rename ::scrollbar ::autoscroll::_scrollbar
    proc ::scrollbar {w args} {
        eval ::autoscroll::_scrollbar [list $w] $args
        ::autoscroll::autoscroll $w
        return $w
    }
}

 #----------------------------------------------------------------------
 #
 # ::autoscroll::unwrap --
 #
 #       Turns off automatic autoscrolling of new scrollbars. Does not
 #         effect existing scrollbars.
 #
 # Parameters:
 #       None.
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       ::scrollbar is returned to its original state
 #
 #----------------------------------------------------------------------

proc ::autoscroll::unwrap {} {
    if {[info commands ::autoscroll::_scrollbar] == ""} {return}
    rename ::scrollbar {}
    rename ::autoscroll::_scrollbar ::scrollbar
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/autoscroll/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if { ![package vsatisfies [package provide Tcl] 8.2] } { return }
package ifneeded autoscroll 1.1 [list source [file join $dir autoscroll.tcl]]

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


























Deleted scriptlibs/tklib0.5/canvas/canvas_sqmap.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
## -*- tcl -*-
# ### ### ### ######### ######### #########

# Known issue :: It is unspecified who is responsible for the images
#                after they are used in the canvas. The canvas
#                currently doesn't delete them. Meaning, this is
#                likely leaking memory like mad when switching between
#                sources, and dragging around.

# sqmap = square map.

# Ideas to work on ...

# -- Factor the low-level viewport tracking and viewport stabilization
#    across scroll-region changes out into its own canvas class.

# -- Factor the grid layer handling into its own class. That is a
#    requisite for the handling of multiple layers,

# -- Create a hexmap, i.e. hexagonal tiling. This can be done with
#    images as well, with parts properly transparent and then
#    positioned to overlap. Regarding coordinates this can be seen
#    as a skewed cartesian system, so only 2 coordinates required

# -- Consider viewport stabilization for when the canvas is resized.

# ### ### ### ######### ######### #########
## Requisites

package require Tcl 8.4          ; # No {*}-expansion! :(
package require snit             ; # 
package require uevent::onidle   ; # Some defered actions.
package require cache::async 0.3 ; # Internal tile cache.

# ### ### ### ######### ######### #########
##

snit::widgetadaptor canvas::sqmap {
    # ### ### ### ######### ######### #########
    ## API

    # All canvas options, except for -scrollregion are accepted by
    # this widget(adaptor), and propagated to the embedded canvas. The
    # region is always implicitly (0,0,w,h), with w and h computed
    # from the number of grid rows, columns and the cell dimensions.

    delegate option * to hull except -scrollregion

    # All canvas methods are accepted and propagated to the embedded
    # canvas. Some of them we intercept however, to either impose
    # restrictions (*), or get information we need and not available
    # otherwise (**).

    # (*) The images used as background have to stay lower than all
    #     user-created items, to be that background. We cannot allow
    #     them to be raised, nor must others go below them.

    #     If we were extremely rigourous we would have to intercept
    #     all methods and filter out our internal tags and items ids,
    #     to make them completely invisible to the user. The last 5%
    #     needing 90% of the effort. *** Defered ***

    # (**) Dragging changes the viewport, we do not see this without
    #      interception.

    delegate method *           to hull except {lower raise scan xview yview}
    delegate method {scan mark} to hull as {scan mark}

    # New options: Information about the grid, and where to get the
    # images.
    # rows    = number of rows the grid consists of. <0 <=> unlimited
    # columns = s.a., columns
    # cell-width   = width of a cell in the grid, in pixels
    # cell-height  = s.a., height
    # cell-source  = command prefix called to get the image for a cell in the grid.

    option -grid-cell-width   -default 0  -configuremethod O-ReconfigureNum -type {snit::integer -min 0}
    option -grid-cell-height  -default 0  -configuremethod O-ReconfigureNum -type {snit::integer -min 0}
    option -grid-cell-command -default {} -configuremethod O-ReconfigureStr
    option -scrollregion      -default {} -configuremethod O-ReconfigureStr

    # NOTE AK, maybe, for the future.
    # rows/columns - we may wish to have min/max values, if any to represent
    #              - grid boundaries.
    #option -grid-rows        -default 0  -configuremethod O-ReconfigureNum
    #option -grid-columns     -default 0  -configuremethod O-ReconfigureNum

    # NOTE !!! Use -grid-show-borders only for short-term debugging.
    # NOTE !!! The items created when true are never deleted, i.e. leaking memory

    option -grid-show-borders -default 0 -type snit::boolean

    option -viewport-command -default {} -configuremethod O-vp-command

    constructor {args} {
	installhull using canvas

	install reconfigure using uevent::onidle ${selfns}::reconfigure \
	    [mymethod Reconfigure]

	install redraw using uevent::onidle ${selfns}::redraw \
	    [mymethod Redraw]

	install tilecache using cache::async ${selfns}::tilecache \
	    [mymethod Tile] -full-async-results 0
	# Configuration means synchronous return of in-cache results.
	# This is needed to get proper use and disposal of ->
	# myfreeitems.

	bind $win <Configure> [mymethod Configure]

	$self configurelist $args
	return
    }

    # ### ### ### ######### ######### #########
    ## API. Define/Remove images from grid cells. These are the main
    ## commands to control grid appearance. The -grid-cell-command should
    ## use these commands as well to provide its results to the
    ## widget.

    method {image set} {at image} {
	$tilecache set $at $image

	# Nothing more is required for an invisible cell.
	if {![info exists myvisible($at)]} return

	# For empty cells we create proper items now.
	set theitem $myvisible($at)
	if {$theitem eq ""} {
	    set theitem [$self GetItem [GridToPixel $at]]
	    set myvisible($at) $theitem
	}

	# Show the chosen image
	$hull itemconfigure $theitem -image $image
	return
    }

    method {image unset} {at} {
	$tilecache unset $at

	# Nothing more is required for an invisible cell.
	if {![info exists myvisible($at)]} return

	# Nothing more is required for an empty cell.
	set theitem $myvisible($at)
	if {$theitem eq ""} return

	# Mark the cell as empty and drop the associated item.
	set myvisible($at) ""
	$hull delete $theitem
	return
    }

    # ### ### ### ######### ######### #########
    ## Force a full reload of all (visible) cells.

    method flush {} {
	$tilecache clear
	set mypixelview {}
	#puts REDRAW-RQ/flush
	$redraw request
	return
    }

    # ### ### ### ######### ######### #########
    ## Intercepting the methods changing the display order, to ensure
    ## that our grid is kept at the bottom. It is the background after
    ## all.

    method raise {args} {
	eval [linsert $args 0 $hull raise]
	# Ensure that our cells stay at the bottom.
	$hull lower $ourtag
	return
    }

    method lower {args} {
	eval [linsert $args 0 $hull lower]
	# Ensure that our cells stay at the bottom.
	$hull lower $ourtag
	return
    }

    # ### ### ### ######### ######### #########
    ## Intercepting the dragto command to keep track of the
    ## viewport. See the scroll method interception below too.

    # NOTE: 'scan mark' interception will be needed if we wish to
    # allow items to float in place regardless of dragging (i.e. as UI
    # elements, for example a zoom-scale).

    method {scan dragto} {x y {gain 1}} {
	# Regular handling of dragging ...
	$hull scan dragto $x $y $gain

	# ... then compute and record the changed viewport, and
	# request a redraw to be done when the system has time for it
	$self SetPixelView
	return
    }

    # ### ### ### ######### ######### #########
    ## Intercepting the scroll methods to keep track of the viewport.
    ## The canvas has no way to report changes on its own. No
    ## callbacks, nothing. See the dragto interception above too.

    method xview {args} {
	# Regular handling of scrolling ...
	set res [eval [linsert $args 0 $hull xview]]
	# Keep track of the viewport in case of changes.
	if {[llength $args]} { $self SetPixelView }
	return $res
    }

    method yview {args} {
	# Regular handling of scrolling ...
	set res [eval [linsert $args 0 $hull yview]]
	# Keep track of the viewport in case of changes.
	if {[llength $args]} { $self SetPixelView }
	return $res
    }

    # ### ### ### ######### ######### #########
    ## Intercept <Configure> events on the canvas. This changes the
    ## viewport. At the time the event happens the new viewport is not
    ## yet known, as this is done in a canvas-internal idle-handler. We
    ## simply trigger our redraw in our idle-handler, and force it to
    ## recompute the viewport.

    method Configure {} {
	set mypixelview {} ; # Force full recalculation.
	#puts REDRAW-RQ/configure
	$redraw request
	return
    }

    # ### ### ### ######### ######### #########

    method O-vp-command {o v} {
        #puts $o=$v
        if {$options($o) eq $v} return
        set  options($o) $v
        set myhasvpcommand [expr {!![llength $v]}]
        if {!$myhasvpcommand} return
        # Callback changed and ok, request first call with current
        # settings.
        $self PixelViewExport
        return
    }

    variable myhasvpcommand     0 ; # Track use of viewport-command callback

    method PixelViewExport {} {
        if {!$myhasvpcommand} return
	if {![llength $mypixelview]} return
        foreach {xl yt xr yb} $mypixelview break
        uplevel \#0 [linsert $options(-viewport-command) end $xl $yt $xr $yb]
        return
    }

    method SetPixelView {} {
	set mypixelview [PV]
	$self PixelViewExport
	# Viewport changes imply redraws
	#puts REDRAW-RQ/set-pixel-view
	$redraw request
	return
    }

    proc PV {} {
        upvar 1 hull hull win win
        return [list \
                    [$hull canvasx 0] \
                    [$hull canvasy 0] \
                    [$hull canvasx [winfo width $win]] \
                    [$hull canvasy [winfo height $win]]]
    }

    # ### ### ### ######### ######### #########
    ## Option processing. Any changes force a refresh of the grid
    ## information, and then a redraw.

    method O-ReconfigureNum {o v} {
	#puts $o=$v
	if {$options($o) == $v} return
	set  options($o) $v
	$reconfigure request
	return
    }

    method O-ReconfigureStr {o v} {
	#puts $o=$v
	if {$options($o) eq $v} return
	set  options($o) $v
	$reconfigure request
	return
    }

    component reconfigure
    method Reconfigure {} {
	#puts /reconfigure

	# The grid definition has changed, in parts, or all. We have
	# to redraw the background, even if nothing else was changed.
	# Here we commit all changed option values to the engine.
	# This is the only place accessing the options array.

	set oldsr $myscrollregion

	set mygridwidth    $options(-grid-cell-width)
	set mygridheight   $options(-grid-cell-height)
	set mygridcmd      $options(-grid-cell-command)
	set myscrollregion $options(-scrollregion)

	# Commit region change to the canvas itself

	$hull configure -scrollregion $myscrollregion

	# Flush the cache to force a reload of the entire visible
	# area now, and of the invisible part later when scrolling.
	$tilecache clear

	# Now save and restore the view, keeping the center of the
	# view as stable as possible across the transition. Note, the
	# scrapyard at the end of this file contains the same
	# calculations in long form, i.e. all steps written out. Here
	# the various expressions are inlined and simplified.

	foreach { sxl  syt  sxr  syb} $oldsr break
	if {[llength $oldsr] && (($sxr - $sxl) > 0) && (($syb - $syt) > 0)} {
	    # Old and new scroll regions.
	    foreach {nsxl nsyt nsxr nsyb} $myscrollregion break

	    #puts OSR=($oldsr)
	    #puts NSR=($myscrollregion)

	    # Get current pixel view, and limit it to the old
	    # scrollregion (as the canvas may show more than the
	    # scrollregion).
	    foreach {xl yt xr yb} $mypixelview break
	    if {$xl < $sxl} { set xl $sxl }
	    if {$xr > $sxr} { set xr $sxr }
	    if {$yt < $syt} { set yt $syt }
	    if {$yb > $syb} { set yb $syb }

	    # Determine the center of the pixel view, as fractions
	    # relative to old scroll origin.
	    set xcfrac [expr {double((($xr + $xl)/2) - $sxl) / ($sxr - $sxl)}]
	    set ycfrac [expr {double((($yt + $yb)/2) - $syt) / ($syb - $syt)}]

	    # The fractions for the topleft corner are the fractions
	    # of the center less the (fractional manhattan radii
	    # around the center, relative to the new region).
	    set nxlfrac [expr {$xcfrac - double(($xr - $xl)/2) / ($nsxr - $nsxl)}]
	    set nytfrac [expr {$ycfrac - double(($yb - $yt)/2) / ($nsyb - $nsyt)}]

	    # Limit the fractions to the scroll origin (>= 0).
	    if {$nxlfrac < 0} { set nxlfrac 0 }
	    if {$nytfrac < 0} { set nytfrac 0 }

	    # Adjust canvas view to keep the center as stable as
	    # possible across the transition. Note that this goes
	    # through our own xview/yview method, calls SetPixelView,
	    # and through that requests a redraw. No need to have the
	    # redraw done by this method.

	    #puts MOVETO\t$nxlfrac,$nytfrac
	    $self xview moveto $nxlfrac
	    $self yview moveto $nytfrac

	    # Note however that we still have to force the redraw to
	    # be fully done.
	    set mypixelview {}
	} else {
	    # Nearly last, redraw full. This happens only because no
	    # view adjustments were done which would have forced it
	    # (see above), so in this cause we have to do it
	    # ourselves.
	    $self Redraw 1
	}
	#puts reconfigure/done
	return
    }

    # ### ### ### ######### ######### #########
    ## Grid redraw. This is done after changes to the viewport,
    ## and when the system is idle.

    component redraw
    method Redraw {{forced 0}} {
	#puts /redraw/$forced

	# Compute viewport in tile coordinates and compare to last.
	# This will tell us where to update and how, if any.

	if {![llength $mypixelview]} {
	    # Undefined viewport, generate baseline, and force
	    # redraw. Scheduling another redraw is however not needed,
	    # so we are inlining only parts of SetPixelView.
	    set mypixelview [PV]
	    $self PixelViewExport
	    #puts \tforce-due-undefined-viewport
	    set forced 1
	}

	set gridview [PixelToGrid $mypixelview]
	foreach {xl yt xr yb} $gridview        break
	foreach {ll lt lr lb} $myshowngridview break

	#puts \tVP=($mypixelview)
	#puts \tVG=($gridview)
	#puts \tVL=($myshowngridview)
	#puts \tF'=$forced

	if {!$forced} {
	    # Viewport unchanged, nothing to do.
	    if {($xl == $ll) && ($xr == $lr) &&
		($yt == $lt) && ($yb == $lb)} {
		#puts \tunchanged,ignore
		return
	    }
	}

	set myfreeitems {}

	# NOTE. The code below is suboptimal. While already better
	# than dropping and recreating all items, we could optimize by
	# using the structure of the viewport (rectangles) to
	# determine directly which grid cells became (in)visible, from
	# the viewport boundary coordinates. This will however be also
	# quite more complex, with all the possible cases of
	# overlapping old and new views.

	if {$forced} {
	    # Forced redraw, simply make all items available
	    # for the upcoming fill.

	    foreach at [array names myvisible] {
		$self FreeCell $at
	    }
	} elseif {[llength $myshowngridview]} {
	    # Scan through the grid cells of the view used at the ast
	    # redraw, and check which of them have become
	    # invisible. Put these on the list of items we can reuse
	    # for the cells which just became visible and thus in need
	    # of items.

	    for {set r $lt} {$r <= $lb} {incr r} {
		for {set c $ll} {$c <= $lr} {incr c} {
		    if {($r < $yt) || ($yb < $r) || ($c < $xl) || ($xr < $c)} {
			# The grid cell dropped out of the viewport.
			$self FreeCell [list $r $c]
			#puts /drop/$idx
		    }
		}
	    }
	}

	# Remember location for next redraw.
	set myshowngridview $gridview

	for {set r $yt} {$r <= $yb} {incr r} {
	    for {set c $xl} {$c <= $xr} {incr c} {
		# Now scan through the cells of the new viewport.
		# Ignore those which are still visible, and create the
		# remainder.
		set at [list $r $c]
		if {[info exists myvisible($at)]} continue
		#puts /make/$idx
		set myvisible($at) "" ; # placeholder
		$tilecache get $at [mymethod image]
		# This cache access re-uses the items in myfreeitems
		# as images already in the cache are delivered
		# synchronously, going through 'image set' and
		# GetItem. Only unknown cells will come later.
	    }
	}

	# Delete all items which were not reused.

	# No, no need. Canvas image items without an image configured
	# for display are effectively invisible, regardless of
	# location. Keep them around for late coming provider results.
	#$self DropFreeItems
	#puts redraw/done
	return
    }

    method FreeCell {at} {
	# Ignore already invisible cells
	if {![info exists myvisible($at)]} return

	# Clear empty cells, nothing more
	set theitem $myvisible($at)
	unset myvisible($at)
	if {$theitem eq ""} return

	# Record re-usable item and clear the image it used. Note that
	# this doesn't delete the image!
	lappend myfreeitems $theitem
	$hull itemconfigure $theitem -image {}
	return
    }

    method {Tile get} {at donecmd} {
	# Tile cache provider callback. The request is routed to the
	# canvas's own tile provider. Responses go to the cache. The
	# cache is set up that its responses go to the 'image ...'
	# methods.

	if {![llength $mygridcmd]} return
	#puts \t\t\t\tGet($at)
	uplevel #0 [linsert $mygridcmd end get $at $donecmd]
	return
    }

    method GetItem {location} {
	# location = pixel position, list (x y)
	if {[llength $myfreeitems]} {
	    # Free items were found, reuse one of them.

	    set theitem     [lindex   $myfreeitems end]
	    set myfreeitems [lreplace $myfreeitems end end]

	    $hull coords        $theitem $location
	    $hull itemconfigure $theitem -image {}
	} else {
	    # Nothing available for reuse, create a new item.

	    if {$options(-grid-show-borders)} {
		# Helper markers for debugging, showing cell borders
		# and coordinates.

		# NOTE !!! Use -grid-show-borders only for short-term debugging.
		# NOTE !!! The items create here are never deleted, i.e. leaking memory

		foreach {x y} $location break
		set x [expr {int($x)}]
		set y [expr {int($y)}]
		set t "<[expr {$y/$mygridheight}],[expr {$x/$mygridwidth}]>"

		incr x 2 ; incr y 2
		set x1 $x ; incr x1 $mygridwidth  ; incr x1 -2
		set y1 $y ; incr y1 $mygridheight ; incr y1 -2

		$hull create rectangle $x $y $x1 $y1 -outline red
		incr x 4 ; incr y 4
		set t [$hull create text $x $y -fill red -anchor nw -text $t]
		$hull raise $t
	    }

	    set theitem [$hull create image $location -anchor nw -tags [list $ourtag]]
	    $hull lower $theitem
	}
	return $theitem
    }

    method DropFreeItems {} {
	if {[llength $myfreeitems]} {
	    eval [linsert $myfreeitems 0 $hull delete]
	    set myfreeitems {}
	}
	return
    }

    # ### ### ### ######### ######### #########

    proc PixelToGrid {pixelview} {
	# Import grid definitions ...
	upvar 1 mygridwidth gcw mygridheight gch
	foreach {xl yt xr yb} $pixelview break

	set coll [expr {int($xl / double($gcw))}]
	set colr [expr {int($xr / double($gcw))}]
	set rowt [expr {int($yt / double($gch))}]
	set rowb [expr {int($yb / double($gch))}]

	# NOTE AK: Maybe limit cell coordinates to boundaries, if
	# NOTE AK: so requested.

	return [list $coll $rowt $colr $rowb]
    }

    proc GridToPixel {at} {
	# Import grid definitions ...
	upvar 1 mygridwidth gcw mygridheight gch
	foreach {r c} $at break
	set y [expr {int($r * double($gch))}]
	set x [expr {int($c * double($gcw))}]
	return [list $x $y]
    }

    # ### ### ### ######### ######### #########
    ## State

    # Active copies of various options. Their use prevents races in
    # the redraw logic using new option values while other parts are
    # not adapted to the changes. The 'Reconfigure' method is
    # responsible for the atomic commit of external changes to the
    # internal engine.

    variable mygridwidth    {} ; # Grid definition used by the engine.
    variable mygridheight   {} ; # s.a.
    variable mygridcmd      {} ; # s.a.
    variable myscrollregion {} ; # s.a.

    # All arrays using grid cells as keys, i.e. 'myvisible', use grid
    # cell coordinates to reference grid cell, in the form
    # 	tuple(row, col)
    #
    # This is the same form taken by the grid-cell-command command prefix and makes
    # use of keys easier as it they are the same across the board.

    # Cache for quick lookup of images and image misses we have seen
    # before, to avoid async round-trips through the
    # grid-cell-command, aka image provider.

    component tilecache

    # Tracking the viewport, i.e. the visible area of the canvas
    # within the scrollregion.

    variable mypixelview     {} ; # Current viewport of the hull, in pixels.
    variable myshowngridview {} ; # Viewport set by last Redraw, in grid cell coordinates

    # Tracking the grid cells shown in the viewport and their canvas
    # items.

    variable myvisible -array {} ; # Visible grid cells, mapped to their canvas items.

    # Transient list of items available for reassignment.

    variable myfreeitems {}

    # Tag used to mark all canvas items used for the grid cell display.

    typevariable ourtag canvas::sqmap::cells

    # ### ### ### ######### ######### #########
}

# ### ### ### ######### ######### #########
## Ready

package provide canvas::sqmap 0.2
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/canvas/canvas_zoom.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
## -*- tcl -*-
# ### ### ### ######### ######### #########

## A discrete zoom-control widget based on buttons. The API is similar
## to a scale.

# ### ### ### ######### ######### #########
## Requisites

package require Tcl 8.4        ; # No {*}-expansion :(
package require snit           ; # 
package require uevent::onidle ; # Some defered actions.

# ### ### ### ######### ######### #########
##

snit::widget canvas::zoom {
    # ### ### ### ######### ######### #########
    ## API

    option -orient   -default vertical -configuremethod O-orient -type {snit::enum -values {vertical horizontal}}
    option -levels   -default 0        -configuremethod O-levels -type {snit::integer -min 0}
    option -variable -default {}       -configuremethod O-variable
    option -command  -default {}       -configuremethod O-command

    constructor {args} {
	install reconfigure using uevent::onidle ${selfns}::reconfigure \
	    [mymethod Reconfigure]

	$self configurelist $args
	return
    }

    # ### ### ### ######### ######### #########
    ## Option processing. Any changes force a refresh of the grid
    ## information, and then a redraw.

    method O-orient {o v} {
	#puts $o=$v
	if {$options($o) eq $v} return
	set  options($o) $v
	$reconfigure request
	return
    }

    method O-levels {o v} {
	#puts $o=$v
	if {$options($o) == $v} return
	set  options($o) $v
	$reconfigure request
	return
    }

    method O-variable {o v} {
	if {$v eq $options(-variable)} return
	if {$options(-variable) ne ""} {
	    # Drop tracing of now disconnected variable.
	    trace remove variable $options(-variable) write [mymethod ZoomChanged]
	}
	set options(-variable) $v
	if {$options(-variable) ne ""} {
	    # Start to trace the now connected variable. Also import
	    # the zoomlevel external value.
	    upvar #0 $options(-variable) zoomlevel
	    set myzoomlevel $zoomlevel
	    trace add variable $options(-variable) write [mymethod ZoomChanged]
	}
	$reconfigure request
	return
    }

    method O-command {o v} {
	if {$v eq $options(-command)} return
	set options(-command) $v
	# Export current zoom level through the new callback.
	$self Callback
	return
    }

    # ### ### ### ######### ######### #########

    component reconfigure
    method Reconfigure {} {
	# (Re)generate the user interface.

	eval [linsert [winfo children $win] 0 destroy]

	set side $ourside($options(-orient))
	set max  $options(-levels)

	button $win.outz -text - -command [mymethod ZoomOut]
	pack   $win.outz -side $side -expand 0 -fill both

	set mynormalbg [$win.outz cget -bg]

	for {set level 0} {$level < $max} {incr level} {
	    button $win.l$level -text $level -command [mymethod ZoomSet $level]
	    pack   $win.l$level -side $side  -expand 0 -fill both
	}

	button $win.inz -text + -command [mymethod ZoomIn]
	pack   $win.inz -side $side -expand 0 -fill both

	# Validate the current zoom level, it may have become invalid
	# due to a change to max allowed levels.

	set z [Cap $myzoomlevel]
	if {$z == $myzoomlevel} return
	$self Update $z
	return
    }

    # ### ### ### ######### ######### #########
    ## Handle option changes

    # ### ### ### ######### ######### #########
    ## Events from inside and outside which act on the zoomlevel.

    method ZoomChanged {args} {
	upvar #0 $options(-variable) zoomlevel
	set z [Cap $zoomlevel]
	if {$myzoomlevel == $z} return
	$self Update $z
	return
    }

    method ZoomSet {new} {
	if {$new == $myzoomlevel} return
	$self Update $new
	return
    }

    method ZoomIn {} {
	if {$myzoomlevel >= ($options(-levels)-1)} return
	set  new $myzoomlevel
	incr new
	$self Update $new
	return
    }

    method ZoomOut {} {
	if {$myzoomlevel <= 0} return
	set  new $myzoomlevel
	incr new -1
	$self Update $new
	return
    }

    proc Cap {n} {
	upvar 1 options(-levels) max
	if {$n < 0 } { return 0 }
	if {$n >= $max } { return [expr {$max - 1}] }
	return $n
    }

    # ### ### ### ######### ######### #########
    ## Helper, update visible widget state for new level, and
    ## propagate new level to the model as well, via either -variable
    ## or -command.

    method Update {newlevel} {
	catch { $win.l$myzoomlevel configure -bg $mynormalbg }
	set myzoomlevel $newlevel
	catch { $win.l$myzoomlevel configure -bg steelblue }

	if {$options(-variable) ne ""} {
	    upvar #0 $options(-variable) zoomlevel
	    set zoomlevel $myzoomlevel
	}

	$self Callback
	return
    }

    method Callback {} {
	if {![llength $options(-command)]} return
	uplevel #0 [linsert $options(-command) end $win $myzoomlevel]
	return
    }

    # ### ### ### ######### ######### #########
    ## State

    variable mynormalbg {} ; # Color of non-highlighted button.
    variable myzoomlevel 0 ; # Currently chosen zoom level.

    # Map from the -orientation to the widget -side to use for
    # pack'ing.

    typevariable ourside -array {
	vertical   bottom
	horizontal right
    }

    # ### ### ### ######### ######### #########
}

# ### ### ### ######### ######### #########
## Ready

package provide canvas::zoom 0.1
return

# ### ### ### ######### ######### #########
## Scrap yard.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/canvas/pkgIndex.tcl.

1
2
3
if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded canvas::sqmap 0.2 [list source [file join $dir canvas_sqmap.tcl]]
package ifneeded canvas::zoom  0.1 [list source [file join $dir canvas_zoom.tcl]]
<
<
<






Deleted scriptlibs/tklib0.5/chatwidget/chatwidget.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
# chatwidget.tcl --
#
#	This package provides a composite widget suitable for use in chat
#	applications. A number of panes managed by panedwidgets are available
#	for displaying user names, chat text and for entering new comments.
#	The main display area makes use of text widget peers to enable a split
#	view for history or searching.
#
# Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: chatwidget.tcl,v 1.4 2008/06/20 22:53:54 patthoyts Exp $

package require Tk 8.5

namespace eval chatwidget {
    variable version 1.1.0

    namespace export chatwidget

    ttk::style layout ChatwidgetFrame {
        Entry.field -sticky news -border 1 -children {
            ChatwidgetFrame.padding -sticky news
        }
    }
    if {[lsearch -exact [font names] ChatwidgetFont] == -1} {
        eval [list font create ChatwidgetFont] [font configure TkTextFont]
        eval [list font create ChatwidgetBoldFont] \
            [font configure ChatwidgetFont] -weight bold
        eval [list font create ChatwidgetItalicFont] \
            [font configure ChatwidgetFont] -slant italic
    }
}

proc chatwidget::chatwidget {w args} {
    Create $w
    interp hide {} $w
    interp alias {} $w {} [namespace origin WidgetProc] $w
    return $w
}

proc chatwidget::WidgetProc {self cmd args} {
    upvar #0 [namespace current]::$self state
    switch -- $cmd {
        hook {
            if {[llength $args] < 2} {
                return -code error "wrong \# args: should be\
                    \"\$widget hook add|remove|list hook_type ?script? ?priority?\""
            }
            return [uplevel 1 [list [namespace origin Hook] $self] $args]
        }
        cget {
            return [uplevel 1 [list [namespace origin Cget] $self] $args]
        }
        configure {
            return [uplevel 1 [list [namespace origin Configure] $self] $args]
        }
        insert {
            return [uplevel 1 [list [namespace origin Insert] $self] $args]
        }
        message {
            return [uplevel 1 [list [namespace origin Message] $self] $args]
        }
        name {
            return [uplevel 1 [list [namespace origin Name] $self] $args]
        }
        topic {
            return [uplevel 1 [list [namespace origin Topic] $self] $args]
        }
        names {
            return [uplevel 1 [list [namespace origin Names] $self] $args]
        }
        entry {
            return [uplevel 1 [list [namespace origin Entry] $self] $args]
        }
        peer {
            return [uplevel 1 [list [namespace origin Peer] $self] $args]
        }
        chat - 
        default {
            return [uplevel 1 [list [namespace origin Chat] $self] $args]
        }
    }
    return
}

proc chatwidget::Chat {self args} {
    upvar #0 [namespace current]::$self state
    if {[llength $args] == 0} {
        return $state(chat_widget)
    }
    return [uplevel 1 [list $state(chat_widget)] $args]
}

proc chatwidget::Cget {self args} {
    upvar #0 [namespace current]::$self state
    switch -exact -- [set what [lindex $args 0]] {
        -chatstate { return $state(chatstate) }
        -history { return $state(history) }
        default {
            return [uplevel 1 [list $state(chat_widget) cget] $args]
        }
    }
}

proc chatwidget::Configure {self args} {
    upvar #0 [namespace current]::$self state
    switch -exact -- [set option [lindex $args 0]] {
        -chatstate {
            if {[llength $args] > 1} { set state(chatstate) [Pop args 1] }
            else { return $state(chatstate) }
        }
        -history {
            if {[llength $args] > 1} { set state(history) [Pop args 1] }
            else { return $state(history) }
        }
        -font {
            if {[llength $args] > 1} {
                set font [Pop args 1]
                set family [font actual $font -family]
                set size [font actual $font -size]
                font configure ChatwidgetFont -family $family -size $size
                font configure ChatwidgetBoldFont -family $family -size $size
                font configure ChatwidgetItalicFont -family $family -size $size
            } else { return [$state(chat_widget) cget -font] }
        }
        default {
            return [uplevel 1 [list $state(chat_widget) configure] $args]
        }
    }
}

proc chatwidget::Peer {self args} {
    upvar #0 [namespace current]::$self state
    if {[llength $args] == 0} {
        return $state(chat_peer_widget)
    }
    return [uplevel 1 [list $state(chat_peer_widget)] $args]
}

proc chatwidget::Topic {self cmd args} {
    upvar #0 [namespace current]::$self state
    switch -exact -- $cmd {
        show { grid $self.topic -row 0 -column 0 -sticky new }
        hide { grid forget $self.topic }
        set  { set state(topic) [lindex $args 0] }
        default {
            return -code error "bad option \"$cmd\":\
                must be show, hide or set"
        }
    }
}

proc chatwidget::Names {self args} {
    upvar #0 [namespace current]::$self state
    set frame [winfo parent $state(names_widget)]
    set pane [winfo parent $frame]
    if {[llength $args] == 0} {
        return $state(names_widget)
    }
    if {[llength $args] == 1 && [lindex $args 0] eq "hide"} {
        return [$pane forget $frame]
    }
    if {[llength $args] == 1 && [lindex $args 0] eq "show"} {
        return [$pane add $frame]
    }
    return [uplevel 1 [list $state(names_widget)] $args] 
}

proc chatwidget::Entry {self args} {
    upvar #0 [namespace current]::$self state
    if {[llength $args] == 0} {
        return $state(entry_widget)
    }
    if {[llength $args] == 1 && [lindex $args 0] eq "text"} {
        return [$state(entry_widget) get 1.0 end-1c]
    }
    return [uplevel 1 [list $state(entry_widget)] $args]
}

proc chatwidget::Message {self text args} {
    upvar #0 [namespace current]::$self state
    set chat $state(chat_widget)

    set mark end
    set type normal
    set nick Unknown
    set time [clock seconds]
    set tags {}

    while {[string match -* [set option [lindex $args 0]]]} {
        switch -exact -- $option {
            -nick { set nick [Pop args 1] }
            -time { set time [Pop args 1] }
            -type { set type [Pop args 1] }
            -mark { set mark [Pop args 1] }
            -tags { set tags [Pop args 1] }
            default {
                return -code error "unknown option \"$option\""
            }
        }
        Pop args
    }

    if {[catch {Hook $self run message $text \
                    -mark $mark -type $type -nick $nick \
                    -time $time -tags $tags}] == 3} then {
        return
    }

    if {$type ne "system"} { lappend tags NICK-$nick }
    lappend tags TYPE-$type
    $chat configure -state normal
    set ts [clock format $time -format "\[%H:%M\]\t"]
    $chat insert $mark $ts [concat BOOKMARK STAMP $tags]
    if {$type eq "action"} {
        $chat insert $mark "   * $nick " [concat BOOKMARK NICK $tags]
        lappend tags ACTION
    } elseif {$type eq "system"} {
    } else {
        $chat insert $mark "$nick\t" [concat BOOKMARK NICK $tags]
    }
    if {$type ne "system"} { lappend tags MSG NICK-$nick }
    #$chat insert $mark $text $tags
    Insert $self $mark $text $tags
    $chat insert $mark "\n" $tags
    $chat configure -state disabled
    if {$state(autoscroll)} {
        $chat see $mark
    }
    return
}

proc chatwidget::Insert {self mark args} {
    upvar #0 [namespace current]::$self state
    if {![info exists state(urluid)]} {set state(urluid) 0}
    set w $state(chat_widget)
    set parts {}
    foreach {s t} $args {
        while {[regexp -indices {\m(https?://[^\s]+)} $s -> ndx]} {
            foreach {fr bk} $ndx break
            lappend parts [string range $s 0 [expr {$fr - 1}]] $t
            lappend parts [string range $s $fr $bk] \
                [linsert $t end URL URL-[incr state(urluid)]]
            set s [string range $s [incr bk] end]
        }
        lappend parts $s $t
    }
    set ws [$w cget -state]
    $w configure -state normal
    eval [list $w insert $mark] $parts
    $w configure -state $ws
}

# $w name add ericthered -group admin -color red
# state(names) {{pat -color red -group admin -thing wilf} {eric ....}}
proc chatwidget::Name {self cmd args} {
    upvar #0 [namespace current]::$self state
    switch -exact -- $cmd {
        list {
            switch -exact -- [lindex $args 0] {
                -full {
                    return $state(names)
                }
                default {
                    foreach item $state(names) { lappend r [lindex $item 0] }
                    return $r
                }
            }
        }
        add {
            if {[llength $args] < 1 || ([llength $args] % 2) != 1} {
                return -code error "wrong # args: should be\
                    \"add nick ?-group group ...?\""
            }
            set nick [lindex $args 0]
            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] == -1} {
                array set opts {-group {} -colour black}
                array set opts [lrange $args 1 end]
                lappend state(names) [linsert [array get opts] 0 $nick]
            } else {
                array set opts [lrange [lindex $state(names) $ndx] 1 end]
                array set opts [lrange $args 1 end]
                lset state(names) $ndx [linsert [array get opts] 0 $nick]
            }
            UpdateNames $self
        }
        delete {
            if {[llength $args] != 1} {
                return -code error "wrong # args: should be \"delete nick\""
            }
            set nick [lindex $args 0]
            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
                set state(names) [lreplace $state(names) $ndx $ndx]
                UpdateNames $self
            }
        }
        get {
            if {[llength $args] < 1} {
                return -code error "wrong # args:\
                    should be \"get nick\" ?option?"
            }
            set result {}
            set nick [lindex $args 0]
            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
                set result [lindex $state(names) $ndx]
                if {[llength $args] > 1} {
                    if {[set ndx [lsearch $result [lindex $args 1]]] != -1} {
                        set result [lindex $result [incr ndx]]
                    } else {
                        set result {}
                    }
                }
            }
            return $result
        }
        default {
            return -code error "bad name option \"$cmd\":\
                must be list, names, add or delete"
        }
    }
}

proc chatwidget::UpdateNames {self} {
    upvar #0 [namespace current]::$self state
    if {[info exists state(updatenames)]} {
        after cancel $state(updatenames)
    }
    set state(updatenames) [after idle [list [namespace origin UpdateNamesExec] $self]]
}

proc chatwidget::UpdateNamesExec {self} {
    upvar #0 [namespace current]::$self state
    unset state(updatenames)
    set names $state(names_widget)
    set chat  $state(chat_widget)
    
    foreach tagname [lsearch -all -inline [$names tag names] NICK-*] {
        $names tag delete $tagname
    }
    foreach tagname [lsearch -all -inline [$names tag names] GROUP-*] {
        $names tag delete $tagname
    }

    $names configure -state normal
    $names delete 1.0 end
    array set groups {}
    foreach item $state(names) {
        set group {}
        if {[set ndx [lsearch $item -group]] != -1} {
            set group [lindex $item [incr ndx]]
        }
        lappend groups($group) [lindex $item 0]
    }

    foreach group [lsort [array names groups]] {
        Hook $self run names_group $group
        $names insert end "$group\n" [list SUBTITLE GROUP-$group]
        foreach nick [lsort -dictionary $groups($group)] {
            $names tag configure NICK-$nick
            unset -nocomplain opts ; array set opts {}
            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
                array set opts [lrange [lindex $state(names) $ndx] 1 end]
                if {[info exists opts(-color)]} {
                    $names tag configure NICK-$nick -foreground $opts(-color)
                    $chat  tag configure NICK-$nick -foreground $opts(-color)
                }
                eval [linsert [lindex $state(names) $ndx] 0 \
                          Hook $self run names_nick]
            }
            $names insert end $nick\n [list NICK NICK-$nick GROUP-$group]
        }
    }
    $names insert end "[llength $state(names)] nicks\n" [list SUBTITLE]

    $names configure -state disabled
}

proc chatwidget::Pop {varname {nth 0}} {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

proc chatwidget::Hook {self do type args} {
    upvar #0 [namespace current]::$self state
    set valid {message post names_group names_nick chatstate url}
    if {[lsearch -exact $valid $type] == -1} {
        return -code error "unknown hook type \"$type\":\
                must be one of [join $valid ,]"
    }
    switch -exact -- $do {
	add {
            if {[llength $args] < 1 || [llength $args] > 2} {
                return -code error "wrong # args: should be \"add hook cmd ?priority?\""
            }
            foreach {cmd pri} $args break
            if {$pri eq {}} { set pri 50 }
            lappend state(hook,$type) [list $cmd $pri]
            set state(hook,$type) [lsort -real -index 1 [lsort -unique $state(hook,$type)]]
	}
        remove {
            if {[llength $args] != 1} {
                return -code error "wrong # args: should be \"remove hook cmd\""
            }
            if {![info exists state(hook,$type)]} { return }
            for {set ndx 0} {$ndx < [llength $state(hook,$type)]} {incr ndx} {
                set item [lindex $state(hook,$type) $ndx]
                if {[lindex $item 0] eq [lindex $args 0]} {
                    set state(hook,$type) [lreplace $state(hook,$type) $ndx $ndx]
                    break
                }
            }
            set state(hook,$type)
        }
        run {
            if {![info exists state(hook,$type)]} { return }
            set res ""
            foreach item $state(hook,$type) {
                foreach {cmd pri} $item break
                set code [catch {eval $cmd $args} err]
                if {$code} {
                    ::bgerror "error running \"$type\" hook: $err"
                    break
                } else {
                    lappend res $err
                }
            }
            return $res
        }
        list {
            if {[info exists state(hook,$type)]} {
                return $state(hook,$type)
            }
        }
	default {
	    return -code error "unknown hook action \"$do\":\
                must be add, remove, list or run"
	}
    }
}

proc chatwidget::Grid {w {row 0} {column 0}} {
    grid rowconfigure $w $row -weight 1
    grid columnconfigure $w $column -weight 1
}

proc chatwidget::Create {self} {
    upvar #0 [set State [namespace current]::$self] state
    set state(history) {}
    set state(current) 0
    set state(autoscroll) 1
    set state(names) {}
    set state(chatstatetimer) {}
    set state(chatstate) active

    # NOTE: By using a non-ttk frame as the outermost part we are able
    # to be [wm manage]d. The outermost frame should be invisible at all times.
    set self [frame $self -class Chatwidget \
                  -borderwidth 0 -highlightthickness 0 -relief flat]
    set outer [ttk::panedwindow $self.outer -orient vertical]
    set inner [ttk::panedwindow $outer.inner -orient horizontal]

    # Create a topic/subject header
    set topic [ttk::frame $self.topic]
    ttk::label $topic.label -anchor w -text Topic
    ttk::entry $topic.text -state disabled -textvariable [set State](topic)
    grid $topic.label $topic.text -sticky new -pady {2 0} -padx 1
    Grid $topic 0 1

    # Create the usernames scrolled text
    set names [ttk::frame $inner.names -style ChatwidgetFrame]
    text $names.text -borderwidth 0 -relief flat -font ChatwidgetFont
    ttk::scrollbar $names.vs -command [list $names.text yview]
    $names.text configure -width 10 -height 10 -state disabled \
        -yscrollcommand [list [namespace origin scroll_set] $names.vs $inner 0]
    bindtags $names.text [linsert [bindtags $names.text] 1 ChatwidgetNames]
    grid $names.text $names.vs -sticky news -padx 1 -pady 1
    Grid $names 0 0
    set state(names_widget) $names.text

    # Create the chat display
    set chatf [ttk::frame $inner.chat -style ChatwidgetFrame]
    set peers [ttk::panedwindow $chatf.peers -orient vertical]
    set upper [ttk::frame $peers.upper]
    set lower [ttk::frame $peers.lower]

    set chat [text $lower.text -borderwidth 0 -relief flat -wrap word \
                  -state disabled -font ChatwidgetFont]
    set chatvs [ttk::scrollbar $lower.vs -command [list $chat yview]]
    $chat configure -height 10 -state disabled \
        -yscrollcommand [list [namespace origin scroll_set] $chatvs $peers 1]
    grid $chat $chatvs -sticky news
    Grid $lower 0 0
    set peer [$chat peer create $upper.text -borderwidth 0 -relief flat \
                  -wrap word -state disabled -font ChatwidgetFont]
    set peervs [ttk::scrollbar $upper.vs -command [list $peer yview]]
    $peer configure -height 0 \
        -yscrollcommand [list [namespace origin scroll_set] $peervs $peers 0]
    grid $peer $peervs -sticky news
    Grid $upper 0 0
    $peers add $upper
    $peers add $lower -weight 1
    grid $peers -sticky news -padx 1 -pady 1
    Grid $chatf 0 0
    bindtags $chat [linsert [bindtags $chat] 1 ChatwidgetText]
    set state(chat_widget) $chat
    set state(chat_peer_widget) $peer
    
    # Create the entry widget
    set entry [ttk::frame $outer.entry -style ChatwidgetFrame]
    text $entry.text -borderwidth 0 -relief flat -font ChatwidgetFont
    ttk::scrollbar $entry.vs -command [list $entry.text yview]
    $entry.text configure -height 1 \
        -yscrollcommand [list [namespace origin scroll_set] $entry.vs $outer 0]
    bindtags $entry.text [linsert [bindtags $entry.text] 1 ChatwidgetEntry]
    grid $entry.text $entry.vs -sticky news -padx 1 -pady 1
    Grid $entry 0 0
    set state(entry_widget) $entry.text

    bind ChatwidgetEntry <Return> "[namespace origin Post] \[[namespace origin Self] %W\]"
    bind ChatwidgetEntry <KP_Enter> "[namespace origin Post] \[[namespace origin Self] %W\]"
    bind ChatwidgetEntry <Shift-Return> "#"
    bind ChatwidgetEntry <Control-Return> "#"
    bind ChatwidgetEntry <Key-Up>   "[namespace origin History] \[[namespace origin Self] %W\] prev"
    bind ChatwidgetEntry <Key-Down> "[namespace origin History] \[[namespace origin Self] %W\] next"
    bind ChatwidgetEntry <Key-Tab> "[namespace origin Nickcomplete] \[[namespace origin Self] %W\]"
    bind ChatwidgetEntry <Key-Prior> "\[[namespace origin Self] %W\] chat yview scroll -1 pages"
    bind ChatwidgetEntry <Key-Next> "\[[namespace origin Self] %W\] chat yview scroll 1 pages"
    bind ChatwidgetEntry <Key> "+[namespace origin Chatstate] \[[namespace origin Self] %W\] composing"
    bind ChatwidgetEntry <FocusIn> "+[namespace origin Chatstate] \[[namespace origin Self] %W\] active"
    bind $self <Destroy> "+unset -nocomplain [namespace current]::%W"
    bind $peer       <Map> [list [namespace origin PaneMap] %W $peers 0]
    bind $names.text <Map> [list [namespace origin PaneMap] %W $inner -90]
    bind $entry.text <Map> [list [namespace origin PaneMap] %W $outer -28]

    bind ChatwidgetText <<ThemeChanged>> {
        ttk::style layout ChatwidgetFrame {
            Entry.field -sticky news -border 1 -children {
                ChatwidgetFrame.padding -sticky news
            }
        }
    }

    $names.text tag configure SUBTITLE \
        -background grey80 -font ChatwidgetBoldFont
    $chat tag configure NICK        -font ChatwidgetBoldFont
    $chat tag configure TYPE-system -font ChatwidgetItalicFont
    $chat tag configure URL         -underline 1

    $inner add $chatf -weight 1
    $inner add $names
    $outer add $inner -weight 1
    $outer add $entry
    
    grid $outer -row 1 -column 0 -sticky news -padx 1 -pady 1
    Grid $self 1 0
    return $self
}

proc chatwidget::Self {widget} {
    set class [winfo class [set w $widget]]
    while {[winfo exists $w] && [winfo class $w] ne "Chatwidget"} {
        set w [winfo parent $w]
    }
    if {![winfo exists $w]} {
        return -code error "invalid window $widget" 
    }
    return $w
}

# Set initial position of sash
proc chatwidget::PaneMap {w pane offset} {
    bind $pane <Map> {}
    if {[llength [$pane panes]] > 1} {
        if {$offset < 0} {
            if {[$pane cget -orient] eq "horizontal"} {
                set axis width
            } else {
                set axis height
            }
            #after idle [list $pane sashpos 0 [expr {[winfo $axis $pane] + $offset}]]
            after idle [namespace code [list PaneMapImpl $pane $axis $offset]]
        } else {
            #after idle [list $pane sashpos 0 $offset]
            after idle [namespace code [list PaneMapImpl $pane {} $offset]]
        }
    }
}

proc chatwidget::PaneMapImpl {pane axis offset} {
    if {$axis eq {}} {
        set size 0
    } else {
        set size [winfo $axis $pane]
    }
    set sashpos [expr {$size + $offset}]
    #puts stderr "PaneMapImpl $pane $axis $offset : size:$size sashpos:$sashpos"
    after 0 [list $pane sashpos 0 $sashpos]
}

# Handle auto-scroll smarts. This will cause the scrollbar to be removed if
# not required and to disable autoscroll for the text widget if we are not
# tracking the bottom line.
proc chatwidget::scroll_set {scrollbar pw set f1 f2} {
    $scrollbar set $f1 $f2
    if {($f1 == 0) && ($f2 == 1)} {
	grid remove $scrollbar
    } else {
        if {[winfo manager $scrollbar] eq {}} {}
            if {[llength [$pw panes]] > 1} {
                set pos [$pw sashpos 0]
                grid $scrollbar
                after idle [list $pw sashpos 0 $pos]
            } else {
                grid $scrollbar
            }
        
    }
    if {$set} {
        upvar #0 [namespace current]::[Self $scrollbar] state
        set state(autoscroll) [expr {(1.0 - $f2) < 1.0e-6 }]
    }
}

proc chatwidget::Post {self} {
    set msg [$self entry get 1.0 end-1c]
    if {$msg eq ""} { return -code break "" }
    if {[catch {Hook $self run post $msg}] != 3} {
        $self entry delete 1.0 end
        upvar #0 [namespace current]::$self state
        set state(history) [lrange [lappend state(history) $msg] end-50 end]
        set state(current) [llength $state(history)]
    }
    return -code break ""
}

proc chatwidget::History {self dir} {
    upvar #0 [namespace current]::$self state
    switch -exact -- $dir {
        prev {
            if {$state(current) == 0} { return }
            if {$state(current) == [llength $state(history)]} {
                set state(temp) [$self entry get 1.0 end-1c]
            }
            if {$state(current)} { incr state(current) -1 }
            $self entry delete 1.0 end
            $self entry insert 1.0 [lindex $state(history) $state(current)]
            return
        }
        next {
            if {$state(current) == [llength $state(history)]} { return }
            if {[incr state(current)] == [llength $state(history)] && [info exists state(temp)]} {
                set msg $state(temp)
            } else {
                set msg [lindex $state(history) $state(current)]
            }
            $self entry delete 1.0 end
            $self entry insert 1.0 $msg
        }
        default {
            return -code error "invalid direction \"$dir\":
                must be either prev or next"
        }
    }
}

proc chatwidget::Nickcomplete {self} {
    upvar #0 [namespace current]::$self state
    if {[info exists state(nickcompletion)]} {
        foreach {index matches after} $state(nickcompletion) break
        after cancel $after
        incr index
        if {$index > [llength $matches]} { set index 0 }
        set delta 2c
    } else {
        set delta 1c
        set partial [$self entry get "insert - $delta wordstart" "insert - $delta wordend"]
        set matches [lsearch -all -inline -glob -index 0 $state(names) $partial*]
        set index 0
    }
    switch -exact -- [llength $matches] {
        0 { bell ; return -code break ""}
        1 { set match [lindex [lindex $matches 0] 0]}
        default {
            set match [lindex [lindex $matches $index] 0]
            set state(nickcompletion) [list $index $matches \
                [after 2000 [list [namespace origin NickcompleteCleanup] $self]]]
        }
    }
    $self entry delete "insert - $delta wordstart" "insert - $delta wordend"
    $self entry insert insert "$match "
    return -code break ""
}

proc chatwidget::NickcompleteCleanup {self} {
    upvar #0 [namespace current]::$self state
    if {[info exists state(nickcompletion)]} {
        unset state(nickcompletion)
    }
}

# Update the widget chatstate (one of active, composing, paused, inactive, gone)
# These are from XEP-0085 but seem likey useful in many chat-type environments.
# Note: this state is _per-widget_. This is not the same as [tk inactive]
# active = got focus and recently active
#   composing = typing
#   paused = 5 secs non typing
# inactive = no activity for 30 seconds
# gone = no activity for 2 minutes or closed the window
proc chatwidget::Chatstate {self what} {
    upvar #0 [namespace current]::$self state
    after cancel $state(chatstatetimer)
    switch -exact -- $what {
        composing - active {
            set state(chatstatetimer) [after 5000 [namespace code [list Chatstate $self paused]]]
        }
        paused {
            set state(chatstatetimer) [after 25000 [namespace code [list Chatstate $self inactive]]]
        }
        inactive {
            set state(chatstatetimer) [after 120000 [namespace code [list Chatstate $self gone]]]
        }
        gone {}
    }
    set fire [expr {$state(chatstate) eq $what ? 0 : 1}]
    set state(chatstate) $what
    if {$fire} {
        catch {Hook $self run chatstate $what}
        event generate $self <<ChatwidgetChatstate>>
    }
}
    
package provide chatwidget $chatwidget::version
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/chatwidget/pkgIndex.tcl.

1
package ifneeded chatwidget 1.1.0 [list source [file join $dir chatwidget.tcl]]
<


Deleted scriptlibs/tklib0.5/crosshair/crosshair.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
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
# crosshair.tcl -
#
# Kevin's mouse-tracking crosshair in Tk's canvas widget.
#
# This package displays a mouse-tracking crosshair in the canvas widget.
#
# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
# Redistribution permitted under the terms in
#  http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/tcl/tcl/license.terms?rev=1.3&content-type=text/plain
#
# Copyright (c) 2008 Andreas Kupries. Added ability to provide the tracking
#               information to external users.
#

# ### ### ### ######### ######### #########
## Requisites

package require Tcl 8.4
package require Tk  8.4

namespace eval ::crosshair {}

# ### ### ### ######### ######### #########
## API 

#----------------------------------------------------------------------
#
# ::crosshair::crosshair --
#
#       Displays a pair of cross-hairs in a canvas widget.  The
#       cross-hairs track the pointing device.
#
# Parameters:
#       w    - The path name of the canvas
#       args - Remaining args are treated as options as for
#              [$w create line].  Of particular interest are
#              -fill and -dash.
#
# Results:
#       None.
#
# Side effects:
#       Adds the 'crosshair' bind tag to the widget so that 
#       crosshairs will be displayed on pointing device motion.
#
#----------------------------------------------------------------------

proc ::crosshair::crosshair { w args } {
    variable config
    set opts(args) $args
    bindtags $w [linsert [bindtags $w] 1 Crosshair]
    set config($w) [array get opts]
    return
}

#----------------------------------------------------------------------
#
# ::crosshair::off -
#
#       Removes the crosshairs from a canvas widget
#
# Parameters:
#       w - The canvas from which the crosshairs should be removed
#
# Results:
#       None.
#
# Side effects:
#       If the widget has crosshairs, they are removed. The 'Crosshair'
#       bind tag is removed so that mouse motion will not restore them.
#
#----------------------------------------------------------------------

proc ::crosshair::off { w } {
    variable config
    if { ![info exists config($w)] } return
    array set opts $config($w)
    if { [winfo exists $w] } {
	Hide
	set bindtags [bindtags $w]
	set pos [lsearch -exact $bindtags Configure]
	if { $pos >= 0 } {
	    eval [list bindtags $w] [lreplace $bindtags $pos $pos]
	}
    }
    unset config($w)
    return
}

#----------------------------------------------------------------------
#
# ::crosshair::configure --
#
#       Changes the appearance of crosshairs in the canvas widget.
#
# Parameters:
#       w    - Path name of the widget
#       args - Additional args are flags to [$w create line]. Interesting
#              ones include -fill and -dash
#
# Results:
#       Returns the crosshairs' current configuration settings. 
#
#----------------------------------------------------------------------

proc ::crosshair::configure { w args } {
    variable config
    if { ![info exists config($w)] } {
	return -code error "no crosshairs in $w"
    }
    array set opts $config($w)
    if { [llength $args] > 0 } {
	array set flags $opts(args)
	array set flags $args
	set opts(args) [array get flags]
	if { [info exists opts(hhairl)] } {
	    eval [list $w itemconfig $opts(hhairl)] $args
	    eval [list $w itemconfig $opts(hhairr)] $args
	    eval [list $w itemconfig $opts(vhaird)] $args
	    eval [list $w itemconfig $opts(vhairu)] $args
	}
	set config($w) [array get opts]
    }
    return $opts(args)
}

#----------------------------------------------------------------------
#
# ::crosshair::track --
#
#       (De)activates reporting of the cross-hair coordinates through
#       a user-specified callback.
#
# Parameters:
#       which - What to do (legal values: 'on', 'off').
#       w     - The path name of the canvas
#       cmd   - Only for which == 'on', the command prefix to
#               use for execute.
#
#	The cmd is called with 7 arguments: The widget, and the x- and
#	y-coordinates of 3 points: Crosshair position, and the topleft
#	and bottomright corners of the canvas viewport. All position
#	data in pixels.
#
# Results:
#       None.
#
# Side effects:
#      See description.
#
#----------------------------------------------------------------------

proc ::crosshair::track { which w args } {
    variable config

    if { ![info exists config($w)] } {
	return -code error "no crosshairs in $w"
    }

    if { ![info exists config($w)] } return
    array set opts $config($w)

    switch -exact -- $which {
	on {
	    if {[llength $args] != 1} {
		return -code error "wrong\#args: Expected 'on w cmdprefix'"
	    }
	    set opts(track) [lindex $args 0]
	}
	off {
	    if {[llength $args] != 0} {
		return -code error "wrong\#args: Expected 'off w'"
	    }
	    catch { unset opts(track) }
	}
    }

    set config($w) [array get opts]
    return
}

# ### ### ### ######### ######### #########
## Internal commands.

#----------------------------------------------------------------------
#
# ::crosshair::Hide --
#
#       Hides the crosshair temporarily
#
# Parameters:
#       w - Canvas widget containing crosshairs
#
# Results:
#       None.
#
# Side effects:
#       If the canvas contains crosshairs, they are hidden.
#
# This procedure is invoked in response to the <Leave> event to
# hide the crosshair when the pointer is not in the window.
#
#----------------------------------------------------------------------

proc ::crosshair::Hide { w } {
    variable config
    if { ![info exists config($w)] } return
    array set opts $config($w)
    if { ![info exists opts(hhairl)] } return
    $w delete $opts(hhairl)
    $w delete $opts(hhairr)
    $w delete $opts(vhaird)
    $w delete $opts(vhairu)
    unset opts(hhairl)
    unset opts(hhairr)
    unset opts(vhairu)
    unset opts(vhaird)
    set config($w) [array get opts]
    return
}

#----------------------------------------------------------------------
#
# ::crosshair::Unhide --
#
#       Places a hidden crosshair back on display
#
# Parameters:
#       w - Canvas widget containing crosshairs
#       x - x co-ordinate relative to the window where the vertical
#           crosshair should appear
#       y - y co-ordinate relative to the window where the horizontal
#           crosshair should appear.
#
# Results:
#       None.
#
# Side effects:
#       Crosshairs are put on display.
#
# This procedure is invoked in response to the <Enter> event to
# restore the crosshair to the display.
#
#----------------------------------------------------------------------

proc ::crosshair::Unhide { w x y } {
    variable config
    if { ![info exists config($w)] } return
    array set opts $config($w)
    if { ![info exists opts(hhairl)] } {
	set opts(hhairl) [eval [list $w create line 0 0 0 0] $opts(args)]
	set opts(hhairr) [eval [list $w create line 0 0 0 0] $opts(args)]
	set opts(vhaird) [eval [list $w create line 0 0 0 0] $opts(args)]
	set opts(vhairu) [eval [list $w create line 0 0 0 0] $opts(args)]
    }
    set config($w) [array get opts]
    Move $w $x $y
    return
}

#----------------------------------------------------------------------
#
# ::crosshair::Move --
#
#       Moves the crosshairs in a camvas
#
# Parameters:
#       w - Canvas widget containing crosshairs
#       x - x co-ordinate relative to the window where the vertical
#           crosshair should appear
#       y - y co-ordinate relative to the window where the horizontal
#           crosshair should appear.
#
# Results:
#       None.
#
# Side effects:
#       Crosshairs move.
#
# This procedure is called in response to a <Motion> event in a canvas
# with crosshairs.
#
#----------------------------------------------------------------------

proc ::crosshair::Move { w x y } {
    variable config
    array set opts $config($w)
    set opts(x) [$w canvasx $x]
    set opts(y) [$w canvasy $y]
    set opts(x0) [$w canvasx 0]
    set opts(x1) [$w canvasx [winfo width $w]]
    set opts(y0) [$w canvasy 0]
    set opts(y1) [$w canvasy [winfo height $w]]
    if { [info exists opts(hhairl)] } {
	# +/-4 is the minimal possible distance which still prevents
	# the canvas from choosing the crosshairs as 'current' object
	# under the cursor.
	set n 4
	$w coords $opts(hhairl) $opts(x0) $opts(y) [expr {$opts(x)-$n}] $opts(y)
	$w coords $opts(hhairr) [expr {$opts(x)+$n}] $opts(y) $opts(x1) $opts(y)
	$w coords $opts(vhairu) $opts(x) $opts(y0) $opts(x) [expr {$opts(y)-$n}]
	$w coords $opts(vhaird) $opts(x) [expr {$opts(y)+$n}] $opts(x) $opts(y1)
	$w raise $opts(hhairl)
	$w raise $opts(hhairr)
	$w raise $opts(vhaird)
	$w raise $opts(vhairu)
    }
    set config($w) [array get opts]
    if {[info exists opts(track)]} {
	uplevel \#0 [linsert $opts(track) end $w $opts(x) $opts(y) $opts(x0) $opts(y0) $opts(x1) $opts(y1)]
    }
    return
}

# ### ### ### ######### ######### #########
## State

namespace eval ::crosshair {
    
    # Array holding information describing crosshairs in canvases
    
    variable  config
    array set config {}
    
    # Controller that positions crosshairs according to user actions
    
    bind Crosshair <Destroy> "[namespace code off] %W"
    bind Crosshair <Enter>   "[namespace code Unhide] %W %x %y"
    bind Crosshair <Leave>   "[namespace code Hide] %W"
    bind Crosshair <Motion>  "[namespace code Move] %W %x %y"
}

# ### ### ### ######### ######### #########
## Ready

package provide crosshair 1.0.2
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/crosshair/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded crosshair 1.0.2 [list source [file join $dir crosshair.tcl]]
<
<




Deleted scriptlibs/tklib0.5/ctext/ctext.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
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
981
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
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
# By George Peter Staplin
# See also the README for a list of contributors
# RCS: @(#) $Id: ctext.tcl,v 1.7 2008/08/19 21:08:27 georgeps Exp $

package require Tk
package provide ctext 3.2

namespace eval ctext {}

#win is used as a unique token to create arrays for each ctext instance
proc ctext::getAr {win suffix name} {
	set arName __ctext[set win][set suffix]
	uplevel [list upvar #0 $arName $name]
	return $arName
}

proc ctext {win args} {
	if {[llength $args] & 1} {
		return -code error "invalid number of arguments given to ctext (uneven number after window) : $args"
	}

	frame $win -class Ctext

	set tmp [text .__ctextTemp]

	ctext::getAr $win config ar

	set ar(-fg) [$tmp cget -foreground]
	set ar(-bg) [$tmp cget -background]
	set ar(-font) [$tmp cget -font]
	set ar(-relief) [$tmp cget -relief]
	destroy $tmp
	set ar(-yscrollcommand) ""
	set ar(-linemap) 1
	set ar(-linemapfg) $ar(-fg)
	set ar(-linemapbg) $ar(-bg)
	set ar(-linemap_mark_command) {}
	set ar(-linemap_markable) 1
	set ar(-linemap_select_fg) black
	set ar(-linemap_select_bg) yellow
	set ar(-highlight) 1
	set ar(win) $win
	set ar(modified) 0
	set ar(commentsAfterId) ""
	set ar(highlightAfterId) ""
	set ar(blinkAfterId) ""

	set ar(ctextFlags) [list -yscrollcommand -linemap -linemapfg -linemapbg \
-font -linemap_mark_command -highlight -linemap_markable -linemap_select_fg \
-linemap_select_bg]

	array set ar $args

	foreach flag {foreground background} short {fg bg} {
		if {[info exists ar(-$flag)] == 1} {
			set ar(-$short) $ar(-$flag)
			unset ar(-$flag)
		}
	}

	#Now remove flags that will confuse text and those that need modification:
	foreach arg $ar(ctextFlags) {
		if {[set loc [lsearch $args $arg]] >= 0} {
			set args [lreplace $args $loc [expr {$loc + 1}]]
		}
	}

	text $win.l -font $ar(-font) -width 1 -height 1 \
		-relief $ar(-relief) -fg $ar(-linemapfg) \
		-bg $ar(-linemapbg) -takefocus 0

	set topWin [winfo toplevel $win]
	bindtags $win.l [list $win.l $topWin all]

	if {$ar(-linemap) == 1} {
		grid $win.l -sticky ns -row 0 -column 0
	}

	set args [concat $args [list -yscrollcommand [list ctext::event:yscroll $win $ar(-yscrollcommand)]]]

	#escape $win, because it could have a space
	eval text \$win.t -font \$ar(-font) $args

	grid $win.t -row 0 -column 1 -sticky news
	grid rowconfigure $win 0 -weight 100
	grid columnconfigure $win 1 -weight 100

	bind $win.t <Configure> [list ctext::linemapUpdate $win]
	bind $win.l <ButtonPress-1> [list ctext::linemapToggleMark $win %y]
	bind $win.t <KeyRelease-Return> [list ctext::linemapUpdate $win]
	rename $win __ctextJunk$win
	rename $win.t $win._t

	bind $win <Destroy> [list ctext::event:Destroy $win %W]
	bindtags $win.t [linsert [bindtags $win.t] 0 $win]

	interp alias {} $win {} ctext::instanceCmd $win
	interp alias {} $win.t {} $win

	#If the user wants C comments they should call ctext::enableComments
	ctext::disableComments $win
	ctext::modified $win 0
	ctext::buildArgParseTable $win

	return $win
}

proc ctext::event:yscroll {win clientData args} {
	ctext::linemapUpdate $win

	if {$clientData == ""} {
		return
	}
	uplevel #0 $clientData $args
}

proc ctext::event:Destroy {win dWin} {
	if {![string equal $win $dWin]} {
		return
	}

	ctext::getAr $win config configAr

	catch {after cancel $configAr(commentsAfterId)}
	catch {after cancel $configAr(highlightAfterId)}
	catch {after cancel $configAr(blinkAfterId)}

	catch {rename $win {}}
	interp alias {} $win.t {}
	ctext::clearHighlightClasses $win
	array unset [ctext::getAr $win config ar]
}

#This stores the arg table within the config array for each instance.
#It's used by the configure instance command.
proc ctext::buildArgParseTable win {
	set argTable [list]

	lappend argTable any -linemap_mark_command {
		set configAr(-linemap_mark_command) $value
		break
	}

	lappend argTable {1 true yes} -linemap {
		grid $self.l -sticky ns -row 0 -column 0
		grid columnconfigure $self 0 \
			-minsize [winfo reqwidth $self.l]
		set configAr(-linemap) 1
		break
	}

	lappend argTable {0 false no} -linemap {
		grid forget $self.l
		grid columnconfigure $self 0 -minsize 0
		set configAr(-linemap) 0
		break
	}

	lappend argTable any -yscrollcommand {
		set cmd [list $self._t config -yscrollcommand [list ctext::event:yscroll $self $value]]

		if {[catch $cmd res]} {
			return $res
		}
		set configAr(-yscrollcommand) $value
		break
	}

	lappend argTable any -linemapfg {
		if {[catch {winfo rgb $self $value} res]} {
			return -code error $res
		}
		$self.l config -fg $value
		set configAr(-linemapfg) $value
		break
	}

	lappend argTable any -linemapbg {
		if {[catch {winfo rgb $self $value} res]} {
			return -code error $res
		}
		$self.l config -bg $value
		set configAr(-linemapbg) $value
		break
	}

	lappend argTable any -font {
		if {[catch {$self.l config -font $value} res]} {
			return -code error $res
		}
		$self._t config -font $value
		set configAr(-font) $value
		break
	}

	lappend argTable {0 false no} -highlight {
		set configAr(-highlight) 0
		break
	}

	lappend argTable {1 true yes} -highlight {
		set configAr(-highlight) 1
		break
	}

	lappend argTable {0 false no} -linemap_markable {
		set configAr(-linemap_markable) 0
		break
	}

	lappend argTable {1 true yes} -linemap_markable {
		set configAr(-linemap_markable) 1
		break
	}

	lappend argTable any -linemap_select_fg {
		if {[catch {winfo rgb $self $value} res]} {
			return -code error $res
		}
		set configAr(-linemap_select_fg) $value
		$self.l tag configure lmark -foreground $value
		break
	}

	lappend argTable any -linemap_select_bg {
		if {[catch {winfo rgb $self $value} res]} {
			return -code error $res
		}
		set configAr(-linemap_select_bg) $value
		$self.l tag configure lmark -background $value
		break
	}

	ctext::getAr $win config ar
	set ar(argTable) $argTable
}

proc ctext::commentsAfterIdle {win} {
	ctext::getAr $win config configAr

	if {"" eq $configAr(commentsAfterId)} {
		set configAr(commentsAfterId) [after idle [list ctext::comments $win [set afterTriggered 1]]]
	}
}

proc ctext::highlightAfterIdle {win lineStart lineEnd} {
	ctext::getAr $win config configAr

	if {"" eq $configAr(highlightAfterId)} {
		set configAr(highlightAfterId) [after idle [list ctext::highlight $win $lineStart $lineEnd [set afterTriggered 1]]]
	}
}

proc ctext::instanceCmd {self cmd args} {
	#slightly different than the RE used in ctext::comments
	set commentRE {\"|\\|'|/|\*}

	switch -glob -- $cmd {
		append {
			if {[catch {$self._t get sel.first sel.last} data] == 0} {
				clipboard append -displayof $self $data
			}
		}

		cget {
			set arg [lindex $args 0]
			ctext::getAr $self config configAr

			foreach flag $configAr(ctextFlags) {
				if {[string match ${arg}* $flag]} {
					return [set configAr($flag)]
				}
			}
			return [$self._t cget $arg]
		}

		conf* {
			ctext::getAr $self config configAr

			if {0 == [llength $args]} {
				set res [$self._t configure]
				set del [lsearch -glob $res -yscrollcommand*]
				set res [lreplace $res $del $del]
				foreach flag $configAr(ctextFlags) {
					lappend res [list $flag [set configAr($flag)]]
				}
				return $res
			}

			array set flags {}
			foreach flag $configAr(ctextFlags) {
				set loc [lsearch $args $flag]
				if {$loc < 0} {
					continue
				}

				if {[llength $args] <= ($loc + 1)} {
					#.t config -flag
					return [set configAr($flag)]
				}

				set flagArg [lindex $args [expr {$loc + 1}]]
				set args [lreplace $args $loc [expr {$loc + 1}]]
				set flags($flag) $flagArg
			}

			foreach {valueList flag cmd} $configAr(argTable) {
				if {[info exists flags($flag)]} {
					foreach valueToCheckFor $valueList {
						set value [set flags($flag)]
						if {[string equal "any" $valueToCheckFor]} $cmd \
						elseif {[string equal $valueToCheckFor [set flags($flag)]]} $cmd
					}
				}
			}

			if {[llength $args]} {
				#we take care of configure without args at the top of this branch
				uplevel 1 [linsert $args 0 $self._t configure]
			}
		}

		copy {
			tk_textCopy $self
		}

		cut {
			if {[catch {$self.t get sel.first sel.last} data] == 0} {
				clipboard clear -displayof $self.t
				clipboard append -displayof $self.t $data
				$self delete [$self.t index sel.first] [$self.t index sel.last]
				ctext::modified $self 1
			}
		}

		delete {
			#delete n.n ?n.n
		
			set argsLength [llength $args]

			#first deal with delete n.n
			if {$argsLength == 1} {
				set deletePos [lindex $args 0]
				set prevChar [$self._t get $deletePos]

				$self._t delete $deletePos
				set char [$self._t get $deletePos]

				set prevSpace [ctext::findPreviousSpace $self._t $deletePos]
				set nextSpace [ctext::findNextSpace $self._t $deletePos]

				set lineStart [$self._t index "$deletePos linestart"]
				set lineEnd [$self._t index "$deletePos + 1 chars lineend"]

				#This pattern was used in 3.1.  We may want to investigate using it again
				#eventually to reduce flicker.  It caused a bug with some patterns.
				#if {[string equal $prevChar "#"] || [string equal $char "#"]} {
				#	set removeStart $lineStart
				#	set removeEnd $lineEnd
				#} else {
				#	set removeStart $prevSpace
				#	set removeEnd $nextSpace
				#}
				set removeStart $lineStart
				set removeEnd $lineEnd

				foreach tag [$self._t tag names] {
					if {[string equal $tag "_cComment"] != 1} {
						$self._t tag remove $tag $removeStart $removeEnd
					}
				}

				set checkStr "$prevChar[set char]"

				if {[regexp $commentRE $checkStr]} {
					ctext::commentsAfterIdle $self
				}

				ctext::highlightAfterIdle $self $lineStart $lineEnd
				ctext::linemapUpdate $self
			} elseif {$argsLength == 2} {
				#now deal with delete n.n ?n.n?
				set deleteStartPos [lindex $args 0]
				set deleteEndPos [lindex $args 1]

				set data [$self._t get $deleteStartPos $deleteEndPos]

				set lineStart [$self._t index "$deleteStartPos linestart"]
				set lineEnd [$self._t index "$deleteEndPos + 1 chars lineend"]
				eval \$self._t delete $args

				foreach tag [$self._t tag names] {
					if {[string equal $tag "_cComment"] != 1} {
						$self._t tag remove $tag $lineStart $lineEnd
					}
				}

				if {[regexp $commentRE $data]} {
					ctext::commentsAfterIdle $self
				}

				ctext::highlightAfterIdle $self $lineStart $lineEnd
				if {[string first "\n" $data] >= 0} {
					ctext::linemapUpdate $self
				}
			} else {
				return -code error "invalid argument(s) sent to $self delete: $args"
			}
			ctext::modified $self 1
		}

		fastdelete {
			eval \$self._t delete $args
			ctext::modified $self 1
			ctext::linemapUpdate $self
		}

		fastinsert {
			eval \$self._t insert $args
			ctext::modified $self 1
			ctext::linemapUpdate $self
		}

		highlight {
			ctext::highlight $self [lindex $args 0] [lindex $args 1]
			ctext::comments $self
		}

		insert {
			if {[llength $args] < 2} {
				return -code error "please use at least 2 arguments to $self insert"
			}

			set insertPos [lindex $args 0]
			set prevChar [$self._t get "$insertPos - 1 chars"]
			set nextChar [$self._t get $insertPos]
			set lineStart [$self._t index "$insertPos linestart"]
			set prevSpace [ctext::findPreviousSpace $self._t ${insertPos}-1c]
			set data [lindex $args 1]
			eval \$self._t insert $args

			set nextSpace [ctext::findNextSpace $self._t insert]
			set lineEnd [$self._t index "insert lineend"]

			if {[$self._t compare $prevSpace < $lineStart]} {
				set prevSpace $lineStart
			}

			if {[$self._t compare $nextSpace > $lineEnd]} {
				set nextSpace $lineEnd
			}

			foreach tag [$self._t tag names] {
				if {[string equal $tag "_cComment"] != 1} {
					$self._t tag remove $tag $prevSpace $nextSpace
				}
			}

			set REData $prevChar
			append REData $data
			append REData $nextChar
			if {[regexp $commentRE $REData]} {
				ctext::commentsAfterIdle $self
			}

			ctext::highlightAfterIdle $self $lineStart $lineEnd
			
			switch -- $data {
				"\}" {
					ctext::matchPair $self "\\\{" "\\\}" "\\"
				}
				"\]" {
					ctext::matchPair $self "\\\[" "\\\]" "\\"
				}
				"\)" {
					ctext::matchPair $self "\\(" "\\)" ""
				}
				"\"" {
					ctext::matchQuote $self
				}
			}
			ctext::modified $self 1
			ctext::linemapUpdate $self
		}

		paste {
			tk_textPaste $self
			ctext::modified $self 1
		}

		edit {
			set subCmd [lindex $args 0]
			set argsLength [llength $args]

			ctext::getAr $self config ar

			if {"modified" == $subCmd} {
				if {$argsLength == 1} {
					return $ar(modified)
				} elseif {$argsLength == 2} {
					set value [lindex $args 1]
					set ar(modified) $value
				} else {
					return -code error "invalid arg(s) to $self edit modified: $args"
				}
			} else {
				#Tk 8.4 has other edit subcommands that I don't want to emulate.
				return [uplevel 1 [linsert $args 0 $self._t $cmd]]
			}
		}

		default {
			return [uplevel 1 [linsert $args 0 $self._t $cmd]]
		}
	}
}

proc ctext::tag:blink {win count {afterTriggered 0}} {
	if {$count & 1} {
		$win tag configure __ctext_blink -foreground [$win cget -bg] -background [$win cget -fg]
	} else {
		$win tag configure __ctext_blink -foreground [$win cget -fg] -background [$win cget -bg]
	}

	ctext::getAr $win config configAr
	if {$afterTriggered} {
		set configAr(blinkAfterId) ""
	}

	if {$count == 4} {
		$win tag delete __ctext_blink 1.0 end
		return
	}

	incr count
	if {"" eq $configAr(blinkAfterId)} {
		set configAr(blinkAfterId) [after 50 [list ctext::tag:blink $win $count [set afterTriggered 1]]]
	}
}

proc ctext::matchPair {win str1 str2 escape} {
	set prevChar [$win get "insert - 2 chars"]

	if {[string equal $prevChar $escape]} {
		#The char that we thought might be the end is actually escaped.
		return
	}

	set searchRE "[set str1]|[set str2]"
	set count 1

	set pos [$win index "insert - 1 chars"]
	set endPair $pos
	set lastFound ""
	while 1 {
		set found [$win search -backwards -regexp $searchRE $pos]

		if {$found == "" || [$win compare $found > $pos]} {
			return
		}

		if {$lastFound != "" && [$win compare $found == $lastFound]} {
			#The search wrapped and found the previous search
			return
		}

		set lastFound $found
		set char [$win get $found]
		set prevChar [$win get "$found - 1 chars"]
		set pos $found

		if {[string equal $prevChar $escape]} {
			continue
		} elseif {[string equal $char [subst $str2]]} {
			incr count
		} elseif {[string equal $char [subst $str1]]} {
			incr count -1
			if {$count == 0} {
				set startPair $found
				break
			}
		} else {
			#This shouldn't happen.  I may in the future make it return -code error
			puts stderr "ctext seems to have encountered a bug in ctext::matchPair"
			return
		}
	}

	$win tag add __ctext_blink $startPair
	$win tag add __ctext_blink $endPair
	ctext::tag:blink $win 0
}

proc ctext::matchQuote {win} {
	set endQuote [$win index insert]
	set start [$win index "insert - 1 chars"]

	if {[$win get "$start - 1 chars"] == "\\"} {
		#the quote really isn't the end
		return
	}
	set lastFound ""
	while 1 {
		set startQuote [$win search -backwards \" $start]
		if {$startQuote == "" || [$win compare $startQuote > $start]} {
			#The search found nothing or it wrapped.
			return
		}

		if {$lastFound != "" && [$win compare $lastFound == $startQuote]} {
			#We found the character we found before, so it wrapped.
			return
		}
		set lastFound $startQuote
		set start [$win index "$startQuote - 1 chars"]
		set prevChar [$win get $start]

		if {$prevChar == "\\"} {
			continue
		}
		break
	}

	if {[$win compare $endQuote == $startQuote]} {
		#probably just \"
		return
	}

	$win tag add __ctext_blink $startQuote $endQuote
	ctext::tag:blink $win 0
}

proc ctext::enableComments {win} {
	$win tag configure _cComment -foreground khaki
}
proc ctext::disableComments {win} {
	catch {$win tag delete _cComment}
}

proc ctext::comments {win {afterTriggered 0}} {
	if {[catch {$win tag cget _cComment -foreground}]} {
		#C comments are disabled
		return
	}

	if {$afterTriggered} {
		ctext::getAr $win config configAr
		set configAr(commentsAfterId) ""
	}

	set startIndex 1.0
	set commentRE {\\\\|\"|\\\"|\\'|'|/\*|\*/}
	set commentStart 0
	set isQuote 0
	set isSingleQuote 0
	set isComment 0
	$win tag remove _cComment 1.0 end
	while 1 {
		set index [$win search -count length -regexp $commentRE $startIndex end]

		if {$index == ""} {
			break
		}

		set endIndex [$win index "$index + $length chars"]
		set str [$win get $index $endIndex]
		set startIndex $endIndex

		if {$str == "\\\\"} {
			continue
		} elseif {$str == "\\\""} {
			continue
		} elseif {$str == "\\'"} {
			continue
		} elseif {$str == "\"" && $isComment == 0 && $isSingleQuote == 0} {
			if {$isQuote} {
				set isQuote 0
			} else {
				set isQuote 1
			}
		} elseif {$str == "'" && $isComment == 0 && $isQuote == 0} {
			if {$isSingleQuote} {
				set isSingleQuote 0
			} else {
				set isSingleQuote 1
			}
		} elseif {$str == "/*" && $isQuote == 0 && $isSingleQuote == 0} {
			if {$isComment} {
				#comment in comment
				break
			} else {
				set isComment 1
				set commentStart $index
			}
		} elseif {$str == "*/" && $isQuote == 0 && $isSingleQuote == 0} {
			if {$isComment} {
				set isComment 0
				$win tag add _cComment $commentStart $endIndex
				$win tag raise _cComment
			} else {
				#comment end without beginning
				break
			}
		}
	}
}

proc ctext::addHighlightClass {win class color keywords} {
	set ref [ctext::getAr $win highlight ar]
	foreach word $keywords {
		set ar($word) [list $class $color]
	}
	$win tag configure $class

	ctext::getAr $win classes classesAr
	set classesAr($class) [list $ref $keywords]
}

#For [ ] { } # etc.
proc ctext::addHighlightClassForSpecialChars {win class color chars} {
	set charList [split $chars ""]

	set ref [ctext::getAr $win highlightSpecialChars ar]
	foreach char $charList {
		set ar($char) [list $class $color]
	}
	$win tag configure $class

	ctext::getAr $win classes classesAr
	set classesAr($class) [list $ref $charList]
}

proc ctext::addHighlightClassForRegexp {win class color re} {
	set ref [ctext::getAr $win highlightRegexp ar]

	set ar($class) [list $re $color]
	$win tag configure $class

	ctext::getAr $win classes classesAr
	set classesAr($class) [list $ref $class]
}

#For things like $blah
proc ctext::addHighlightClassWithOnlyCharStart {win class color char} {
	set ref [ctext::getAr $win highlightCharStart ar]

	set ar($char) [list $class $color]
	$win tag configure $class

	ctext::getAr $win classes classesAr
	set classesAr($class) [list $ref $char]
}

proc ctext::deleteHighlightClass {win classToDelete} {
	ctext::getAr $win classes classesAr

	if {![info exists classesAr($classToDelete)]} {
		return -code error "$classToDelete doesn't exist"
	}

	foreach {ref keyList} [set classesAr($classToDelete)] {
		upvar #0 $ref refAr
		foreach key $keyList {
			if {![info exists refAr($key)]} {
				continue
			}
			unset refAr($key)
		}
	}
	unset classesAr($classToDelete)
}

proc ctext::getHighlightClasses win {
	ctext::getAr $win classes classesAr

	array names classesAr
}

proc ctext::findNextChar {win index char} {
	set i [$win index "$index + 1 chars"]
	set lineend [$win index "$i lineend"]
	while 1 {
		set ch [$win get $i]
		if {[$win compare $i >= $lineend]} {
			return ""
		}
		if {$ch == $char} {
			return $i
		}
		set i [$win index "$i + 1 chars"]
	}
}

proc ctext::findNextSpace {win index} {
	set i [$win index $index]
	set lineStart [$win index "$i linestart"]
	set lineEnd [$win index "$i lineend"]
	#Sometimes the lineend fails (I don't know why), so add 1 and try again.
	if {[$win compare $lineEnd == $lineStart]} {
		set lineEnd [$win index "$i + 1 chars lineend"]
	}

	while {1} {
		set ch [$win get $i]

		if {[$win compare $i >= $lineEnd]} {
			set i $lineEnd
			break
		}

		if {[string is space $ch]} {
			break
		}
		set i [$win index "$i + 1 chars"]
	}
	return $i
}

proc ctext::findPreviousSpace {win index} {
	set i [$win index $index]
	set lineStart [$win index "$i linestart"]
	while {1} {
		set ch [$win get $i]

		if {[$win compare $i <= $lineStart]} {
			set i $lineStart
			break
		}

		if {[string is space $ch]} {
			break
		}

		set i [$win index "$i - 1 chars"]
	}
	return $i
}

proc ctext::clearHighlightClasses {win} {
	#no need to catch, because array unset doesn't complain
	#puts [array exists ::ctext::highlight$win]

	ctext::getAr $win highlight ar
	array unset ar

	ctext::getAr $win highlightSpecialChars ar
	array unset ar

	ctext::getAr $win highlightRegexp ar
	array unset ar

	ctext::getAr $win highlightCharStart ar
	array unset ar

	ctext::getAr $win classes ar
	array unset ar
}

#This is a proc designed to be overwritten by the user.
#It can be used to update a cursor or animation while
#the text is being highlighted.
proc ctext::update {} {

}

proc ctext::highlight {win start end {afterTriggered 0}} {
	ctext::getAr $win config configAr

	if {$afterTriggered} {
		set configAr(highlightAfterId) ""
	}

	if {!$configAr(-highlight)} {
		return
	}

	set si $start
	set twin "$win._t"

	#The number of times the loop has run.
	set numTimesLooped 0
	set numUntilUpdate 600

	ctext::getAr $win highlight highlightAr
	ctext::getAr $win highlightSpecialChars highlightSpecialCharsAr
	ctext::getAr $win highlightRegexp highlightRegexpAr
	ctext::getAr $win highlightCharStart highlightCharStartAr

	while 1 {
		set res [$twin search -count length -regexp -- {([^\s\(\{\[\}\]\)\.\t\n\r;\"'\|,]+)} $si $end]
		if {$res == ""} {
			break
		}

		set wordEnd [$twin index "$res + $length chars"]
		set word [$twin get $res $wordEnd]
		set firstOfWord [string index $word 0]

		if {[info exists highlightAr($word)] == 1} {
			set wordAttributes [set highlightAr($word)]
			foreach {tagClass color} $wordAttributes break

			$twin tag add $tagClass $res $wordEnd
			$twin tag configure $tagClass -foreground $color

		} elseif {[info exists highlightCharStartAr($firstOfWord)] == 1} {
			set wordAttributes [set highlightCharStartAr($firstOfWord)]
			foreach {tagClass color} $wordAttributes break

			$twin tag add $tagClass $res $wordEnd
			$twin tag configure $tagClass -foreground $color
		}
		set si $wordEnd

		incr numTimesLooped
		if {$numTimesLooped >= $numUntilUpdate} {
			ctext::update
			set numTimesLooped 0
		}
	}

	foreach {ichar tagInfo} [array get highlightSpecialCharsAr] {
		set si $start
		foreach {tagClass color} $tagInfo break

		while 1 {
			set res [$twin search -- $ichar $si $end]
			if {"" == $res} {
				break
			}
			set wordEnd [$twin index "$res + 1 chars"]

			$twin tag add $tagClass $res $wordEnd
			$twin tag configure $tagClass -foreground $color
			set si $wordEnd

			incr numTimesLooped
			if {$numTimesLooped >= $numUntilUpdate} {
				ctext::update
				set numTimesLooped 0
			}
		}
	}

	foreach {tagClass tagInfo} [array get highlightRegexpAr] {
		set si $start
		foreach {re color} $tagInfo break
		while 1 {
			set res [$twin search -count length -regexp -- $re $si $end]
			if {"" == $res} {
				break
			}

			set wordEnd [$twin index "$res + $length chars"]
			$twin tag add $tagClass $res $wordEnd
			$twin tag configure $tagClass -foreground $color
			set si $wordEnd

			incr numTimesLooped
			if {$numTimesLooped >= $numUntilUpdate} {
				ctext::update
				set numTimesLooped 0
			}
		}
	}
}

proc ctext::linemapToggleMark {win y} {
	ctext::getAr $win config configAr

	if {!$configAr(-linemap_markable)} {
		return
	}

	set markChar [$win.l index @0,$y]
	set lineSelected [lindex [split $markChar .] 0]
	set line [$win.l get $lineSelected.0 $lineSelected.end]

	if {$line == ""} {
		return
	}

	ctext::getAr $win linemap linemapAr

	if {[info exists linemapAr($line)] == 1} {
		#It's already marked, so unmark it.
		array unset linemapAr $line
		ctext::linemapUpdate $win
		set type unmarked
	} else {
		#This means that the line isn't toggled, so toggle it.
		array set linemapAr [list $line {}]
		$win.l tag add lmark $markChar [$win.l index "$markChar lineend"]
		$win.l tag configure lmark -foreground $configAr(-linemap_select_fg) \
-background $configAr(-linemap_select_bg)
		set type marked
	}

	if {[string length $configAr(-linemap_mark_command)]} {
		uplevel #0 [linsert $configAr(-linemap_mark_command) end $win $type $line]
	}
}

#args is here because -yscrollcommand may call it
proc ctext::linemapUpdate {win args} {
	if {[winfo exists $win.l] != 1} {
		return
	}

	set pixel 0
	set lastLine {}
	set lineList [list]
	set fontMetrics [font metrics [$win._t cget -font]]
	set incrBy [expr {1 + ([lindex $fontMetrics 5] / 2)}]

	while {$pixel < [winfo height $win.l]} {
		set idx [$win._t index @0,$pixel]

		if {$idx != $lastLine} {
			set line [lindex [split $idx .] 0]
			set lastLine $idx
			lappend lineList $line
		}
		incr pixel $incrBy
	}

	ctext::getAr $win linemap linemapAr

	$win.l delete 1.0 end
	set lastLine {}
	foreach line $lineList {
		if {$line == $lastLine} {
			$win.l insert end "\n"
		} else {
			if {[info exists linemapAr($line)]} {
				$win.l insert end "$line\n" lmark
			} else {
				$win.l insert end "$line\n"
			}
		}
		set lastLine $line
	}
	set endrow [lindex [split [$win._t index end-1c] .] 0]
	$win.l configure -width [string length $endrow]
}

proc ctext::modified {win value} {
	ctext::getAr $win config ar
	set ar(modified) $value
	event generate $win <<Modified>>
	return $value
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/ctext/pkgIndex.tcl.

1
package ifneeded ctext 3.2 [list source [file join $dir ctext.tcl]]
<


Deleted scriptlibs/tklib0.5/cursor/cursor.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
# cursor.tcl --
#
#       Tk cursor handling routines
#
# Copyright (c) 2001 by Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: cursor.tcl,v 1.2 2006/12/08 23:30:31 hobbs Exp $

package require Tk 8.0
package provide cursor 0.2

namespace eval ::cursor {
    namespace export propagate restore display

    variable cursors [list \
	    X_cursor arrow based_arrow_down based_arrow_up boat bogosity \
	    bottom_left_corner bottom_right_corner bottom_side bottom_tee \
	    box_spiral center_ptr circle clock coffee_mug cross cross_reverse \
	    crosshair diamond_cross dot dotbox double_arrow draft_large \
	    draft_small draped_box exchange fleur gobbler gumby hand1 hand2 \
	    heart icon iron_cross left_ptr left_side left_tee leftbutton \
	    ll_angle lr_angle man middlebutton mouse pencil pirate plus \
	    question_arrow right_ptr right_side right_tee rightbutton \
	    rtl_logo sailboat sb_down_arrow sb_h_double_arrow sb_left_arrow \
	    sb_right_arrow sb_up_arrow sb_v_double_arrow shuttle sizing \
	    spider spraycan star target tcross top_left_arrow top_left_corner \
	    top_right_corner top_side top_tee trek ul_angle umbrella \
	    ur_angle watch xterm \
	    ]

    switch -exact $::tcl_platform(os) {
	"windows" {
	    lappend cursors no starting size \
		    size_ne_sw size_ns size_nw_se size_we uparrow wait
	}
	"macintosh" {
	    lappend cursors text cross-hair
	}
	"unix" {
	    # no extra cursors
	}
    }
}

# ::cursor::propagate --
#
#	Propagates a cursor to a widget and all descendants.
#
# Arguments:
#	w	Parent widget to set cursor on (includes children)
#	cursor	The cursor to use
#
# Results:
#	Set the cursor of $w and all descendants to $cursor

proc ::cursor::propagate {w cursor} {
    variable CURSOR
    # Ignores {} cursors or widgets that don't have a -cursor option
    if {![catch {set CURSOR($w) [$w cget -cursor]}] && $CURSOR($w) != ""} {
	$w config -cursor $cursor
    } else {
	catch {unset CURSOR($w)}
    }
    foreach child [winfo children $w] { propagate $child $cursor }
}

# ::cursor::restores --
#
#	Restores original cursor of a widget and all descendants.
#
# Arguments:
#	w	Parent widget to restore cursor for (includes children)
#	cursor	The default cursor to use (if none was cached by propagate)
#
# Results:
#	Restore the cursor of $w and all descendants

proc ::cursor::restore {w {cursor {}}} {
    variable CURSOR
    if {[info exists CURSOR($w)]} {
	$w config -cursor $CURSOR($w)
    } else {
	# Not all widgets have -cursor
	catch {$w config -cursor $cursor}
    }
    foreach child [winfo children $w] { restore $child $cursor }
}


# ::cursor::display --
#
#	Show all known cursors for viewing
#
# Arguments:
#	w	Parent widget to use for dialog
#
# Results:
#	Pops up a dialog

proc ::cursor::display {{root .}} {
    variable cursors
    if {$root == "."} {
	set t .__cursorDisplay
    } else {
	set t $root.__cursorDisplay
    }
    destroy $t
    toplevel $t
    wm withdraw $t
    label $t.lbl -text "Select a cursor:" -anchor w
    listbox $t.lb -selectmode single -yscrollcommand [list $t.sy set]
    scrollbar $t.sy -orient v -command [list $t.lb yview]
    button $t.d -text Dismiss -command [list destroy $t]
    pack $t.d -side bottom
    pack $t.lbl -side top -fill x
    pack $t.sy -side right -fill y
    pack $t.lb -side right -fill both -expand 1
    eval [list $t.lb insert end] $cursors
    bind $t.lb <Button-1> { %W config -cursor [%W get [%W nearest %y]] }
    wm deiconify $t
}

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


























































































































































































































































Deleted scriptlibs/tklib0.5/cursor/pkgIndex.tcl.

1
package ifneeded cursor 0.2 [list source [file join $dir cursor.tcl]]
<


Deleted scriptlibs/tklib0.5/datefield/datefield.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
##+##########################################################################
#
# datefield.tcl
#
# Implements a datefield entry widget ala Iwidget::datefield
# by Keith Vetter (keith@ebook.gemstar.com)
#
# Datefield creates an entry widget but with a special binding to KeyPress
# (based on Iwidget::datefield) to ensure that the current value is always
# a valid date. All normal entry commands and configurations still work.
#
# Usage:
#  ::datefield::datefield .df -background yellow -textvariable myDate
#  pack .df
#
# Bugs:
#   o won't work if you programmatically put in an invalid date
#     e.g. .df insert end "abc"	  will cause it to behave erratically
#
# Revisions:
# KPV Feb 07, 2002 - initial revision
#
##+##########################################################################
#############################################################################

package require Tk 8.0
package provide datefield 0.2

namespace eval ::datefield {
    namespace export datefield

    # Have the widget use tile/ttk should it be available.

    variable entry entry
    if {![catch {
	package require tile
    }]} {
	set entry ttk::entry
    }

    proc datefield {w args} {
	variable entry

	eval $entry $w -width 10 -justify center $args
	$w insert end [clock format [clock seconds] -format "%m/%d/%Y"]
	$w icursor 0

	bind $w <KeyPress> [list ::datefield::KeyPress $w %A %K %s]
	bind $w <Button1-Motion> break
	bind $w <Button2-Motion> break
	bind $w <Double-Button>	 break
	bind $w <Triple-Button>	 break
	bind $w <2>		 break

	return $w
    }

    # internal routine for all key presses in the datefield entry widget
    proc KeyPress {w char sym state} {
	set icursor [$w index insert]

	# Handle some non-number characters first
	if {$sym == "plus" || $sym == "Up" || \
		$sym == "minus" || $sym == "Down"} {
	    set dir "1 day"
	    if {$sym == "minus" || $sym == "Down"} {
		set dir "-1 day"
	    }
	    set base [clock scan [$w get]]
	    if {[catch {set new [clock scan $dir -base $base]}] != 0} {
		bell
		return -code break
	    }
	    set date [clock format $new -format "%m/%d/%Y"]
	    if {[catch {clock scan $date}]} {
		bell
		return -code break
	    }
	    $w delete 0 end
	    $w insert end $date
	    $w icursor $icursor
	    return -code break
	} elseif {$sym == "Right" || $sym == "Left" || $sym == "BackSpace" || \
		$sym == "Delete"} {
	    set dir -1
	    if {$sym == "Right"} {set dir 1}

	    set icursor [expr {($icursor + 10 + $dir) % 10}]
	    if {$icursor == 2 || $icursor == 5} {;# Don't land on a slash
		set icursor [expr {($icursor + 10 + $dir) % 10}]
	    }
	    $w icursor $icursor
	    return -code break
	} elseif {($sym == "Control_L") || ($sym == "Shift_L") || \
		($sym == "Control_R") || ($sym == "Shift_R")} {
	    return -code break
	} elseif {$sym == "Tab" && $state == 0} {;# Tab key
	    if {$icursor < 3} {
		$w icursor 3
	    } elseif {$icursor < 6} {
		$w icursor 8
	    } else {
		return -code continue
	    }
	    return -code break
	} elseif {$sym == "Tab" && ($state == 1 || $state == 4)} {
	    if {$icursor > 4} {
		$w icursor 3
	    } elseif {$icursor > 1} {
		$w icursor 0
	    } else {
		return -code continue
	    }
	    return -code break
	}

	if {! [regexp {[0-9]} $char]} {		;# Unknown character
	    bell
	    return -code break
	}

	if {$icursor >= 10} {			;# Can't add beyond end
	    bell
	    return -code break
	}
	foreach {month day year} [split [$w get] "/"] break

	# MONTH SECTION
	if {$icursor < 2} {
	    foreach {m1 m2} [split $month ""] break
	    set cursor 3			;# Where to leave the cursor
	    if {$icursor == 0} {		;# 1st digit of month
		if {$char < 2} {
		    set month "$char$m2"
		    set cursor 1
		} else {
		    set month "0$char"
		}
		if {$month > 12} {set month 10}
		if {$month == "00"} {set month "01"}
	    } else {				;# 2nd digit of month
		set month "$m1$char"
		if {$month > 12} {set month "0$char"}
		if {$month == "00"} {
		    bell
		    return -code break
		}
	    }
	    $w delete 0 2
	    $w insert 0 $month
	    # Validate the day of the month
	    if {$day > [set endday [lastDay $month $year]]} {
		$w delete 3 5
		$w insert 3 $endday
	    }
	    $w icursor $cursor

	    return -code break
	}
	# DAY SECTION
	if {$icursor < 5} {			;# DAY
	    set endday [lastDay $month $year]
	    foreach {d1 d2} [split $day ""] break
	    set cursor 6			;# Where to leave the cursor
	    if {$icursor <= 3} {		;# 1st digit of day
		if {$char < 3 || ($char == 3 && $month != "02")} {
		    set day "$char$d2"
		    if {$day == "00"} { set day "01" }
		    if {$day > $endday} {set day $endday}
		    set cursor 4
		} else {
		    set day "0$char"
		}
	    } else {				;# 2nd digit of day
		set day "$d1$char"
		if {$day > $endday || $day == "00"} {
		    bell
		    return -code break
		}
	    }
	    $w delete 3 5
	    $w insert 3 $day
	    $w icursor $cursor
	    return -code break
	}

	# YEAR SECTION
	set y1 [lindex [split $year ""] 0]
	if {$icursor < 7} {			;# 1st digit of year
	    if {$char != "1" && $char != "2"} {
		bell
		return -code break
	    }
	    if {$char != $y1} {			;# Different century
		set y 1999
		if {$char == "2"} {set y 2000 }
		$w delete 6 end
		$w insert end $y
	    }
	    $w icursor 7
	    return -code break
	}
	$w delete $icursor
	$w insert $icursor $char
	if {[catch {clock scan [$w get]}] != 0} {;# Validate the year
	    $w delete 6 end
	    $w insert end $year			;# Put back in the old year
	    $w icursor $icursor
	    bell
	    return -code break
	}
	return -code break
    }
    # internal routine that returns the last valid day of a given month and year
    proc lastDay {month year} {
	set days [clock format [clock scan "+1 month -1 day" \
		-base [clock scan "$month/01/$year"]] -format %d]
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/datefield/pkgIndex.tcl.

1
package ifneeded datefield 0.2 [list source [file join $dir datefield.tcl]]
<


Deleted scriptlibs/tklib0.5/diagrams/draw_diagram.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
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
981
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
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
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
1210
1211
1212
1213
1214
1215
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
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
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
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
# draw_diagram.tcl
#    A toy derived from "PIC" by B. Kernighan to draw diagrams
#
# TODO:
#    - Update the arrow and line drawing routines
#    - Routines to:
#      - Re-initialise a page
#      - Collect the height and width of text (for objects that
#        have several text strings possibly in different fonts)
#    - Consolidate examples/tests in separate examples
#
#
if { 0 } {
'''Concise user documentation:'''

''General commands for positioning and setup:''

drawin $canvas
    Set the canvas widget in which to draw

saveps $filename
    Save the drawing in a PostScript file

direction $newdir
    Set the direction for moving the current position
    direction is one of:
        north  northeast  east southeast  south
        southwest west northwest
        N      NE         E    SE         S     SW        W    NW
        up     up-right   left down-right down  down-left left up-left
        centre center     C

currentpos $pos
    Set the current position explicitly (argument must be
    a position "object"

getpos $anchor $obj
    Get the position of a particular "anchor" point of an object
    anchor should be one of the direction strings

position $xcoord $ycoord
    Create a position "object"
    xcoord and ycoord are in pixels

''Drawing objects:''

box $text $width $height
    Draw a box from the current position
    (width and height are both optional; if not given, the text
    determines the width and height)

plaintext $text $width $height
    Draw plain text from the current position
    (width and height are both optional; if not given, the text
    determines the width and height)

circle $text $radius
    Draw a circle from the current position
    (the radius is optional)

slanted $text $width $height $angle
    Draw a slanted box from the current position
    (width, height and angle are optional)

diamond $text $width $height
    Draw a diamond-shaped box from the current position
    (width and height are both optional; if not given, the text
    determines the width and height)

drum $text $width $height
    (width and height are both optional; if not given, the text
    determines the width and height)

arrow $text $length
    Draw an arrow from the current position to the next.
    The text is drawn next to the arrow, the length (in pixels) is
    optional. If not given the gap parameters are used.

line $args
    Draw a line specified via positions or via line segments
    The arguments are either position or length-angle pairs

''Attributes:''

(Note: attributes are persistent)

attach $anchor
    Set the anchor point for attaching arrows to

color $name
    Set the color for the outline of a box etc.

fillcolor $name
    Set the color to fill the objects

textcolor $name
    Set the color to draw the text in

usegap $use
    Turn the gap on (1) or off (0). Note: usually a small gap is used
    when positioning objects.

xgap $value
    Size of the gap in horizontal direction (in pixels)

ygap $value
    Size of the gap in vertical direction (in pixels)

textfont $name
    Set the name of the font to use

linewidth $pixels
    Set the width of the lines (in line objects and arrows)

linestyle $style
    Set the style of the lines and arrows

spline $yesno
    Draw curved lines and arrows or not


'''Commands for implmenting new objects:'''

Note: it is best to study how for instance box objects are implemented
first.

pushstate
    Save the current global settings
    Used when defining an object that is composed of other objects

popstate
    Restore the previously saved global settings

computepos
    Compute the current position

boxcoords $x1 $y1 $x2 $y2
    Compute the anchor coordinates for a box-like object
    (this is merely a convenience routine. In general, you will
    have to compute the list of coordinates yourself - see
    for instance the diamond object)

moveobject $obj
    Move the object to the right position and return the new
    information

}

namespace eval ::Diagrams {
    variable box_coord_name \
        {north  northeast  east southeast  south southwest west northwest
         N      NE         E    SE         S     SW        W    NW
         up     up-right   left down-right down  down-left left up-left
         centre center     C}
    variable box_coord_id   \
        {0      1          2    3          4     5         6    7
         0      1          2    3          4     5         6    7
         0      1          2    3          4     5         6    7
         8      8          8}

    variable state
    variable state_saved
    variable anchors
    variable dirinfo
    variable torad [expr {3.1415926/180.0}]

    namespace export currentpos getpos direction \
                     arrow box circle diamond drum line slanted \
                     pushstate popstate \
                     drawin saveps line position plaintext linestyle

    array set state {
        attach         "northwest"
        canvas         ""
        colour         "black"
        default_dir    "east"
        dir            "init"
        textfont       "Helvetica 12"
        justify        center
        default_width  "fitting"
        default_height 20
        xdir           1
        ydir           0
        xshift         0
        yshift         0
        xcurr          10
        ycurr          10
        xgap           10
        ygap           10
        scale          {1.0}
        xprev          10
        yprev          10
        lastitem       {}
        usegap         0
        spline         0
        color          "black"
        fillcolor      {}
        textcolor      "black"
        linewidth      1
        linestyle      {}
    }

    # Name of direction, xdir, ydir, default attachment, anchor for text near arrow
    set dirinfo(south)      {south  0  1 north e}
    set dirinfo(north)      {north  0 -1 south w}
    set dirinfo(west)       {west  -1  0 east n}
    set dirinfo(east)       {east   1  0 west s}
    set dirinfo(southwest)  {southwest  -1  1 north ne}
    set dirinfo(northwest)  {northwest  -1 -1 south se}
    set dirinfo(southeast)  {southeast   1  1 north nw}
    set dirinfo(northeast)  {northeast   1 -1 south sw}
    set dirinfo(down)       $dirinfo(south)
    set dirinfo(up)         $dirinfo(north)
    set dirinfo(left)       $dirinfo(west)
    set dirinfo(right)      $dirinfo(east)
    set dirinfo(SE)         $dirinfo(southeast)
    set dirinfo(NE)         $dirinfo(northeast)
    set dirinfo(SW)         $dirinfo(southwest)
    set dirinfo(NW)         $dirinfo(northwest)
}

# attach, fillcolor, ... --
#    Procedures to set simple attributes
# Arguments:
#    args     New value for the attribute or empty to get the current value
# Result:
#    Current or new value, depending on whether a new value was given
#
foreach p {attach color fillcolor textcolor usegap xgap ygap textfont
           linewidth spline} {
    eval [string map [list PP $p] \
        {proc ::Diagrams::PP {args} {
             variable state
             if { [llength $args] == 1 } {
                 set state(PP) [lindex $args 0]
             }
             return $state(PP)
         }
         namespace eval ::Diagrams {namespace export PP}
        }]
}

# linestyle --
#    Set the line style for all objects
# Arguments:
#    style     New style
# Result:
#    None
#
proc ::Diagrams::linestyle {style} {
    variable state

    switch -- $style {
        "solid"        { set pattern "" }
        "dot"          { set pattern . }
        "dash"         { set pattern - }
        "dash-dot"     { set pattern -. }
        "dash-dot-dot" { set pattern -.. }
        default        { set pattern $style }
    }

    set state(linestyle) $pattern
}

# drawin --
#    Set the canvas widget in which to draw
# Arguments:
#    widget    Name of the canvas widget to use
# Result:
#    None
#
proc ::Diagrams::drawin {widget} {
    variable state
    set state(canvas) $widget
}

# saveps --
#    Save the drawing in a PostScript file
# Arguments:
#    filename   Name of the file to write
# Result:
#    None
#
proc ::Diagrams::saveps {filename} {
    variable state
    update
    $state(canvas) postscript -file $filename
}

# direction --
#    Set the direction for moving the current position
# Arguments:
#    newdir    Direction (down, left, up, right)
# Result:
#    None
#
proc ::Diagrams::direction {newdir} {
    variable state
    variable dirinfo

    if { [info exists dirinfo($newdir)] } {
        foreach s {dir xdir ydir attach anchor} v $dirinfo($newdir) {
            set state($s) $v
        }
    } else {
        return
    }
    #
    # TODO: problem with arrows/lines
    #
    if { $state(lastitem) != {} && [lindex $state(lastitem) 0] == "BOX" } {
        currentpos [getpos $state(dir) $state(lastitem)]
    }
}

# horizontal --
#    Compute the length of a line segment whose horizontal
#    extension is given
# Arguments:
#    length    Length over which the line extends in horizontal direction
# Result:
#    None
#
proc ::Diagrams::horizontal {length} {
    variable state
    variable dirinfo

    #
    # Does the direction allow for a horizontal component?
    #
    TODO!
    if { $state(dir) == "NW" $newdir) } {
        foreach s {dir xdir ydir attach} v $dirinfo($newdir) {
            set state($s) $v
        }
    } else {
        return
    }
    #
    # TODO: problem with arrows/lines
    #
    if { $state(lastitem) != {} && [lindex $state(lastitem) 0] == "BOX" } {
        currentpos [getpos $state(dir) $state(lastitem)]
    }
}

# pushstate
#    Save the current global settings
# Arguments:
#    None
# Result:
#    None
# Side effect:
#    Pushes the global settings up a stack for later reuse
#
proc ::Diagrams::pushstate {} {
    variable state
    variable state_saved

    lappend state_saved [array get state]
}

# popstate
#    Restore the previously saved global settings
# Arguments:
#    None
# Result:
#    None
# Side effect:
#    Restores the previous settings and pops the stack
#
proc ::Diagrams::popstate {} {
    variable state
    variable state_saved

    if { [llength $state_saved] > 0 } {
        set old_state [lindex $state_saved end]
        set state_saved [lrange $state_saved 0 end-1]
        array set state $old_state
    }
}

# currentpos
#    Set the current position explicitly
# Arguments:
#    pos       Position "object" (optional)
# Result:
#    Current position as an "object"
# Side effect:
#    Current position set
#
proc ::Diagrams::currentpos { {pos {}} } {
    variable state

    if { [lindex $pos 0] == "POSITION" } {
        set state(xprev) $state(xcurr)
        set state(yprev) $state(ycurr)
        set state(xcurr) [lindex $pos 1]
        set state(ycurr) [lindex $pos 2]
    }

    return [list POSITION $state(xcurr) $state(ycurr)]
}

# getpos
#    Get the position of a particular "anchor" point of an object
# Arguments:
#    anchor    Which point to return
#    obj       Drawable "object"
# Result:
#    Position of the requested point
#
proc ::Diagrams::getpos {anchor obj} {
    variable state
    variable box_coord_name
    variable box_coord_id

    if { $anchor == "init" } {
        direction "east"
        set anchor "east"
    }

    if { [lindex $obj 0] == "BOX" } {
        set idx [lsearch $box_coord_name $anchor]
        if { $idx < 0 } {
            return -code error "Unknown anchor - $anchor"
        }
        set idx [lindex $box_coord_id $idx]
    } else {
        set idx $anchor
    }

    set xp [lindex [lindex $obj 2] [expr {2*$idx}]]
    set yp [lindex [lindex $obj 2] [expr {2*$idx+1}]]

    return [list POSITION $xp $yp]
}

# computepos
#    Compute the new position
# Arguments:
#    None
# Result:
#    X- and Y-coordinates
#
proc ::Diagrams::computepos {} {
    variable state

    set xcoord [expr {$state(xcurr)+$state(xgap)*$state(xdir)*$state(usegap)}]
    set ycoord [expr {$state(ycurr)+$state(ygap)*$state(ydir)*$state(usegap)}]

    return [list "POSITION" $xcoord $ycoord]
}

# position
#    Create a position "object"
# Arguments:
#    xcoord    X-coordinate
#    ycoord    Y-coordinate
# Result:
#    List representing the object
#
proc ::Diagrams::position {xcoord ycoord} {

    return [list "POSITION" $xcoord $ycoord]
}

# boxcoords --
#    Compute the anchor coordinates for a box-like object
# Arguments:
#    x1        X-coordinate top-left (order is important!)
#    y1        Y-coordinate top-left
#    x2        X-coordinate bottom-right
#    y2        Y-coordinate bottom-right
# Result:
#    List of coordinates in the right order
# Note:
#    The coordinates typically come from a [canvas bbox] command
#
proc ::Diagrams::boxcoords {x1 y1 x2 y2} {
    set coords {}
    set xns    [expr {($x1+$x2)/2.0}]
    set yew    [expr {($y1+$y2)/2.0}]

    return [list $xns $y1 $x2 $y1 $x2 $yew $x2 $y2 \
                 $xns $y2 $x1 $y2 $x1 $yew $x1 $y1 $xns $yew]
}

# moveobject --
#    Move the object to the right position and return the new
#    information
# Arguments:
#    obj       Object at the default position
# Result:
#    Updated list with new object coordinates
#
proc ::Diagrams::moveobject {obj} {
    variable state

    #
    # Compute the coordinates of the object (positioned correctly)
    #
    foreach {dummy xcurr ycurr}     [computepos] {break}
    foreach {dummy xanchor yanchor} [getpos $state(attach) $obj] {break}

    set xt [expr {$xcurr-$xanchor}]
    set yt [expr {$ycurr-$yanchor}]

    set newobj [lrange $obj 0 1]
    set items  [lindex $obj 1]

    foreach i $items {
        $state(canvas) move $i $xt $yt
    }
    set newcrd {}
    foreach {x y} [lindex $obj 2] {
        set xn [expr {$x+$xt}]
        set yn [expr {$y+$yt}]
        lappend newcrd $xn $yn
    }
    lappend newobj $newcrd

    currentpos [getpos $state(dir) $newobj]

    set state(lastitem) $newobj
    return $newobj
}

# box --
#    Draw a box from the current position
# Arguments:
#    text      Text to be fitted in the box
#    width     (Optional) width in pixels or "fitting"
#    height    (Optional) height in pixels
# Result:
#    ID of the box
# Side effect:
#    Box drawn with text inside, current position set
#
proc ::Diagrams::box {text {width {}} {height {}}} {
    variable state

    #
    # Before we create the text object, we need to store the
    # current position ...
    #
    pushstate
    set textobj [plaintext $text $width $height]

    foreach {dummy x1 y1} [getpos NW $textobj] {break}
    foreach {dummy x2 y2} [getpos SE $textobj] {break}

    set x1 [expr {$x1-5}]
    set y1 [expr {$y1-5}]
    set x2 [expr {$x2+5}]
    set y2 [expr {$y2+5}]

    #
    # Construct the box
    #
    set     items [lindex $textobj 1]
    lappend items [$state(canvas) create rectangle $x1 $y1 $x2 $y2 \
                       -fill    $state(fillcolor) \
                       -outline $state(color)     \
                       -width   $state(linewidth) \
                       -dash    $state(linestyle) ]
    $state(canvas) raise [lindex $items 0]

    #
    # Move the combined object to the original "current" position
    #
    popstate
    set obj [moveobject [list BOX $items [boxcoords $x1 $y1 $x2 $y2]]]
    set state(usegap)   1
    return $obj
}

# plaintext --
#    Draw plain text from the current position
# Arguments:
#    text      Text to be fitted in the box
#    width     (Optional) width in pixels or "fitting"
#    height    (Optional) height in pixels
# Result:
#    ID of the box
# Side effect:
#    Text drawn, current position set
#
proc ::Diagrams::plaintext {text {width {}} {height {}}} {
    variable state

    if { $width == {} } {
        set width $state(default_width)
    }

    if { $height == {} } {
        set height $state(default_height)
    }

    set items [$state(canvas) create text 0 0 -text $text \
                  -font         $state(textfont) \
                  -fill         $state(textcolor) \
                  -justify      $state(justify)]


    if { $width == "fitting" } {
        foreach {x1 y1 x2 y2} [$state(canvas) bbox $items] {break}
    } else {
        set x1 [expr {-$width/2}]
        set x2 [expr {$width/2}]
        set y1 [expr {-$height/2}]
        set y2 [expr {$height/2}]
       # set width  [expr {$x2-$x1}]
       # set height [expr {$y2-$y1}]
    }

    #
    # Construct the coordinates and the object
    #
    set coords [boxcoords $x1 $y1 $x2 $y2]
    set obj    [list BOX $items $coords]

    #
    # Move the object to the right position
    #
    set obj    [moveobject $obj]
    set state(usegap)   1
    return $obj
}

# circle --
#    Draw a circle from the current position
# Arguments:
#    text      Text to be fitted in the circle
#    radius    (Optional) radius in pixels or "fitting"
# Result:
#    ID of the circle
# Side effect:
#    Circle drawn with text inside, current position set
#
proc ::Diagrams::circle {text {radius {}} } {
    variable state
    variable torad

    #
    # Before we create the text object, we need to store the
    # current state ...
    #
    pushstate
    set textobj [plaintext $text $radius $radius]

    foreach {dummy x1 y1} [getpos NW $textobj] {break}
    foreach {dummy x2 y2} [getpos SE $textobj] {break}

    set xc [expr {($x1+$x2)/2.0}]
    set yc [expr {($y1+$y2)/2.0}]
    if { $radius == {} } {
       set radius [expr {hypot($x1-$xc,$y1-$yc)}]
    }
    set x1 [expr {$xc-$radius-5}]
    set x2 [expr {$xc+$radius+5}]
    set y1 [expr {$yc-$radius-5}]
    set y2 [expr {$yc+$radius+5}]

    #
    # Construct the circle
    #
    set     items [lindex $textobj 1]
    lappend items [$state(canvas) create oval $x1 $y1 $x2 $y2 \
                       -fill    $state(fillcolor) \
                       -outline $state(color)     \
                       -width   $state(linewidth) \
                       -dash    $state(linestyle) ]
    $state(canvas) raise [lindex $items 0]

    #
    # Move the combined object to the original "current" position
    #
    popstate

    #
    # Construct the list of coordinates
    #
    set coords {}
    set radius [expr {$radius+5}]
    foreach angle {90 45 0 -45 -90 -135 180 135} {
        set x [expr {$xc+$radius*cos($angle*$torad)}]
        set y [expr {$yc-$radius*sin($angle*$torad)}]
        lappend coords $x $y
    }
    lappend coords $xc $yc
    set obj [moveobject [list BOX $items $coords]]
    set state(usegap)   1
    return $obj
}

# slanted --
#    Draw a slanted box from the current position
# Arguments:
#    text      Text to be fitted in the box
#    width     (Optional) width in pixels or "fitting"
#    height    (Optional) height in pixels
#    angle     (Optional) angle of the slant (90 degrees gives a rectangle)
# Result:
#    ID of the slanted box
# Side effect:
#    Slanted box drawn with text inside, current position set
#
proc ::Diagrams::slanted {text {width {}} {height {}} {angle 70} } {
    variable state
    variable torad

    #
    # Before we create the text object, we need to store the
    # current state ...
    #
    pushstate

    #
    # Compute the available width
    #
    set cosa [expr {cos($angle*3.1415926/180.0)}]
    set sina [expr {sin($angle*3.1415926/180.0)}]

    set twidth  $width
    set theight $height
    if { $width != {} && $width != "fitting" } {
        set twidth  [expr {($width-10)-$cosa*($height-10)}]
        set theight [expr {$height-10}]
    }

    set textobj [plaintext $text $twidth $theight]

    foreach {dummy x1 y1} [getpos NW $textobj] {break}
    foreach {dummy x2 y2} [getpos SE $textobj] {break}

    #
    # Construct the coordinates
    #
    set bwidth  [expr {10+$x2-$x1}]
    set bheight [expr {10+$y2-$y1}]
    set width   [expr {$bwidth+$cosa*$bheight}]
    set height  $bheight
    set xc      [expr {($x1+$x2)/2.0}]
    set yc      [expr {($y1+$y2)/2.0}]

    set xnw     [expr {$xc-$bwidth/2.0}]
    set ynw     [expr {$yc-$bheight/2.0}]
    set xne     [expr {$xc+$bwidth/2.0+$cosa*$bheight}]
    set yne     $ynw
    set xn      [expr {($xnw+$xne)/2.0}]
    set yn      [expr {($ynw+$yne)/2.0}]

    set xse     [expr {$xc+$bwidth/2.0}]
    set yse     [expr {$yc+$height/2.0}]
    set xe      [expr {($xne+$xse)/2.0}]
    set ye      [expr {($yne+$yse)/2.0}]

    set xsw     [expr {$xc-$bwidth/2.0-$cosa*$bheight}]
    set ysw     $yse
    set xs      [expr {($xse+$xsw)/2.0}]
    set ys      [expr {($yse+$ysw)/2.0}]
    set xw      [expr {($xnw+$xsw)/2.0}]
    set yw      [expr {($ynw+$ysw)/2.0}]

    set coords  [list $xn $yn $xne $yne $xe $ye $xse $yse $xs $ys \
                      $xsw $ysw $xw $yw $xnw $ynw $xc $yc]

    #
    # Create the object
    #
    set     items [lindex $textobj 1]
    lappend items [$state(canvas) create polygon  \
                       $xnw $ynw $xne $yne $xse $yse $xsw $ysw $xnw $ynw \
                       -fill    $state(fillcolor) \
                       -outline $state(color)     \
                       -width   $state(linewidth) \
                       -dash    $state(linestyle) ]
    $state(canvas) raise [lindex $items 0]

    #
    # Move the combined object to the original "current" position
    #
    popstate
    set obj [moveobject [list BOX $items $coords]]
    set state(usegap)   1
    return $obj
}

# diamond --
#    Draw a diamond-shaped box from the current position
# Arguments:
#    text      Text to be fitted in the diamond
#    width     (Optional) width in pixels or "fitting"
#    height    (Optional) height in pixels
# Result:
#    ID of the diamond
# Side effect:
#    Diamond-shaped box drawn with text inside, current position set
# Note:
#    The aspect ratio of the diamond in case of fitting the text
#    is set to width:heihgt = 2:1
#
proc ::Diagrams::diamond {text {width {}} {height {}} } {
    variable state

    #
    # Before we create the text object, we need to store the
    # current position ...
    #
    pushstate
    set textobj [plaintext $text $width $height]

    foreach {dummy x1 y1} [getpos NW $textobj] {break}
    foreach {dummy x2 y2} [getpos SE $textobj] {break}

    set alpha 2.0

    if { $width == {} || $width == "fitting" } {
        set width  [expr {$x2-$x1+4+($y2-$y1+4)*$alpha}]
        set height [expr {$width/$alpha}]
    }

    set xc  [expr {($x1+$x2)/2.0}]
    set yc  [expr {($y1+$y2)/2.0}]

    set xn  $xc
    set yn  [expr {$yc-$height/2.0}]

    set xs  $xc
    set ys  [expr {$yc+$height/2.0}]

    set xe  [expr {$xc+$width/2.0}]
    set ye  $yc

    set xw  [expr {$xc-$width/2.0}]
    set yw  $yc

    set xnw [expr {($xn+$xw)/2.0}]
    set ynw [expr {($yn+$yw)/2.0}]
    set xsw [expr {($xs+$xw)/2.0}]
    set ysw [expr {($ys+$yw)/2.0}]

    set xne [expr {($xn+$xe)/2.0}]
    set yne [expr {($yn+$ye)/2.0}]
    set xse [expr {($xs+$xe)/2.0}]
    set yse [expr {($ys+$ye)/2.0}]

    set coords  [list $xn $yn $xne $yne $xe $ye $xse $yse $xs $ys \
                      $xsw $ysw $xw $yw $xnw $ynw $xc $yc]

    #
    # Construct the diamond
    #
    set     items [lindex $textobj 1]
    lappend items [$state(canvas) create polygon \
                       $xn $yn $xe $ye $xs $ys $xw $yw \
                       -fill    $state(fillcolor) \
                       -outline $state(color)     \
                       -width   $state(linewidth) \
                       -dash    $state(linestyle) ]
    $state(canvas) raise [lindex $items 0]

    #
    # Move the combined object to the original "current" position
    #
    popstate
    set obj [moveobject [list BOX $items $coords]]
    set state(usegap)   1
    return $obj
}

# drum --
#    Draw a drum-shape from the current position
# Arguments:
#    text      Text to be fitted in the drum
#    width     (Optional) width in pixels or "fitting"
#    height    (Optional) height in pixels
# Result:
#    ID of the drum
# Side effect:
#    Drum-shape box drawn with text inside, current position set
#
proc ::Diagrams::drum {text {width {}} {height {}} } {
    variable state

    #
    # Before we create the text object, we need to store the
    # current position ...
    #
    pushstate
    set textobj [plaintext $text $width $height]

    foreach {dummy x1 y1} [getpos NW $textobj] {break}
    foreach {dummy x2 y2} [getpos SE $textobj] {break}

    set aspect 0.35

    if { $width == {} || $width == "fitting" } {
        set width  [expr {$x2-$x1+10}]
        set height [expr {$y2-$y1+10+$aspect*$width}]
    }

    set xc  [expr {($x1+$x2)/2.0}]
    set yc  [expr {($y1+$y2)/2.0}]

    set hellips [expr {$height*$aspect}]

    set xtop1   [expr {$xc-$width/2}]
    set xtop2   [expr {$xc+$width/2}]
    set ytop1   [expr {$yc-$height/2+$hellips/2}]
    set ytop2   [expr {$yc-$height/2-$hellips/2}]

    set xline1  $xtop1
    set xline2  $xtop2
    set yline1  [expr {$yc-$height/2}]
    set yline2  [expr {$yc+$height/2}]

    set xbot1   $xtop1
    set xbot2   $xtop2
    set ybot1   [expr {$yc+$height/2+$hellips/2}]
    set ybot2   [expr {$yc+$height/2-$hellips/2}]

    set coords  [list $xc     $ytop2  $xline2 $yline1 $xline2 $yc     \
                      $xline2 $yline2 $xc     $ybot2  $xline1 $yline2 \
                      $xline1 $yc     $xline1 $yline2 $xc     $yc     ]

    #
    # Construct the drum
    # (We need quite a few pieces here ...)
    #
    set     items [lindex $textobj 1]
    lappend items \
        [$state(canvas) create rectangle $xline1 $yline1 $xline2 $yline2 \
             -fill $state(fillcolor) -outline {}] \
        [$state(canvas) create line $xline1 $yline1 $xline1 $yline2 \
             -fill $state(color)] \
        [$state(canvas) create line $xline2 $yline1 $xline2 $yline2 \
             -fill $state(color)] \
        [$state(canvas) create oval $xtop1  $ytop1  $xtop2  $ytop2 \
             -fill  $state(fillcolor) -outline $state(color) \
             -width $state(linewidth) -dash    $state(linestyle) ] \
        [$state(canvas) create arc  $xbot1  $ybot1  $xbot2  $ybot2 \
             -fill $state(fillcolor) -outline {} \
             -dash    $state(linestyle) \
             -start 179 -extent 182 -style chord] \
        [$state(canvas) create arc  $xbot1  $ybot1  $xbot2  $ybot2 \
             -fill  $state(fillcolor) -outline $state(color) \
             -width $state(linewidth) -dash    $state(linestyle) \
             -start 179 -extent 182 -style arc]
    $state(canvas) raise [lindex $items 0]

    #
    # Move the combined object to the original "current" position
    #
    popstate
    set obj [moveobject [list BOX $items $coords]]
    set state(usegap)   1
    return $obj
}

# arrow --
#    Draw an arrow from the current position to the next
# Arguments:
#    text      (Optional) text to written above the arrow
#    length    (Optional) length in pixels
#    heads     (Optional) which arrow heads (defaults to end)
# Result:
#    ID of the arrow
# Side effect:
#    Arrow drawn
#
proc ::Diagrams::arrow { {text {}} {length {}} {heads last}} {
    variable state

    if { $length != {} } {
        set factor  [expr {hypot($state(xdir),$state(ydir))}]
        set dxarrow [expr {$length*$state(xdir)/$factor}]
        set dyarrow [expr {$length*$state(ydir)/$factor}]
    } else {
        set dxarrow [expr {$state(xdir)*$state(xgap)}]
        set dyarrow [expr {$state(ydir)*$state(ygap)}]
    }

    set x1      $state(xcurr)
    set y1      $state(ycurr)
    set x2      [expr {$state(xcurr)+$dxarrow}]
    set y2      [expr {$state(ycurr)+$dyarrow}]

    set item [$state(canvas) create line $x1 $y1 $x2 $y2 \
                 -fill    $state(colour)    \
                 -smooth  $state(spline)    \
                 -arrow   $heads            \
                 -width   $state(linewidth) \
                 -dash    $state(linestyle) ]

    set xt [expr {($x1+$x2)/2}]
    set yt [expr {($y1+$y2)/2}]

    set item [$state(canvas) create text $xt $yt -text $text \
                 -font    $state(textfont) \
                 -anchor  $state(anchor)   \
                 -justify $state(justify)]

    set item [list ARROW $item [list $x1 $y1 $x2 $y2]]

    #
    # Ignore the direction of motion - we need the end point
    #
    currentpos [position $x2 $y2]

    set state(lastitem) $item
    set state(usegap)   0
    return $item
}

# line --
#    Draw a line specified via positions or via line segments
# Arguments:
#    args        All arguments (either position or length-angle pairs)
# Result:
#    ID of the line
# Side effect:
#    Line drawn
#
proc ::Diagrams::line {args} {
    variable state
    variable torad

    #
    # Get the current position if the first arguments
    # are line segments (this guarantees that x, y are
    # defined)
    #
    if { [lindex [lindex $args 0] 0] != "POSITION" } {
        set args [linsert $args 0 [currentpos]]
    }

    set xycoords {}
    set x1       {}
    set x2       {}
    set y1       {}
    set y2       {}

    set idx 0
    set number [llength $args]
    while { $idx < $number } {
        set arg [lindex $args $idx]

        if { [lindex $arg 0] != "POSITION" } {
            incr idx
            set length $arg
            set angle  [lindex $args $idx]

            set x      [expr {$x+$length*cos($torad*$angle)}]
            set y      [expr {$y-$length*sin($torad*$angle)}]
        } else {
            foreach {dummy x y} [lindex $args $idx] {break}
        }

        lappend xycoords $x $y

        if { $x1 == {} || $x1 > $x } { set x1 $x }
        if { $x2 == {} || $x2 < $x } { set x2 $x }
        if { $y1 == {} || $y1 > $y } { set y1 $y }
        if { $y2 == {} || $y2 < $y } { set y2 $y }

        incr idx
    }

    set item [$state(canvas) create line $xycoords \
                 -smooth  $state(spline)    \
                 -fill    $state(colour)    \
                 -width   $state(linewidth) \
                 -dash    $state(linestyle) ]

    set item [list LINE $item [list $x1 $y1 $x2 $y2]]

    currentpos [getpos 1 $item] ;# Absolute index, rather than particular direction

    set state(lastitem) $item
    set state(usegap)   0
    return $item
}

# bracket --
#    Draw three line segments in the form of a square bracket from
#    one position to the next
# Arguments:
#    dir         Direction of the bracket (east, west, north or south)
#    dist        Distance of the
# Result:
#    ID of the "bracket"
# Side effect:
#    Three line segments drawn
#
proc ::Diagrams::bracket {dir dist begin end} {
    variable state

    set coords [lrange $begin 1 2]
    if { $dir == "west" } {
       lappend coords [expr {[lindex $begin 1]-$dist}] [lindex $begin 2]
       lappend coords [expr {[lindex $begin 1]-$dist}] [lindex $end 2]
    }
    if { $dir == "east" } {
       lappend coords [expr {[lindex $begin 1]+$dist}] [lindex $begin 2]
       lappend coords [expr {[lindex $begin 1]+$dist}] [lindex $end 2]
    }
    if { $dir == "south" } {
       lappend coords [lindex $begin 1] [expr {[lindex $begin 2]+$dist}]
       lappend coords [lindex $end 1]   [expr {[lindex $begin 2]+$dist}]
    }
    if { $dir == "north" } {
       lappend coords [lindex $begin 1] [expr {[lindex $begin 2]-$dist}]
       lappend coords [lindex $end 1]   [expr {[lindex $begin 2]-$dist}]
    }
    lappend coords [lindex $end 1] [lindex $end 2]

    $state(canvas) create line $coords -arrow last \
                       -width   $state(linewidth) \
                       -dash    $state(linestyle) ]

    set item [list ARROW $item [join [lrange $coords 0 1] [lrange $coords end-1 end]]]

    #
    # Ignore the direction of motion - we need the end point
    #
    currentpos [position [lindex $coords end-1] [lindex $coords end]]

    set state(lastitem) $item
    set state(usegap)   0
    return $item
}

# Announce our presence
#
package provide Diagrams 0.2

#
# A small demonstration ...
#
if { 0 } {
pack [canvas .c -width 500 -height 500 -bg white]

namespace import ::Diagrams::*

console show
drawin .c
linestyle dot

textcolor green
set C [circle "Hi there!" 20]
arrow "XX" 40 none
direction south
arrow "YY" 40
set B [box Aha]

puts "Pos: [getpos S $C]"
line [getpos S $B] 100 270
line [getpos S $B] 100 0

}
if { 0 } {
pack [canvas .c -width 500 -height 500 -bg white]

namespace import ::Diagrams::*

console show
drawin .c
#linestyle dot
#linewidth 3

textcolor green
box "There is\nstill a lot to\ndo!"
arrow "" 230
textcolor blue
box "But it looks nice"
direction south
textcolor black
color magenta; circle "Or does it?" ;color black
direction southwest
arrow "" 100
set B1 [box "Yes, it sure does!"]

fillcolor red
foreach {text dir} {A southwest B south C southeast} {
    direction $dir
    currentpos [getpos $dir $B1]
    arrow "" 100
    box $text
}
slanted "Hm, this\nis okay ..."
direction south
arrow ""
diamond "Okay\n?"
direction west
arrow "" 50
drum "Yes!"

fillcolor green
currentpos [position 70 200]
slanted Hm
direction north ; arrow N 30
#
# This does not work cleanly: lastitem = arrow :(
#
direction south
arrow S 30

#line 20 45 20 90 20 135 30 10

}
#
# Experiments with mathematical formulae
#
proc ::Diagrams::segm {args} {
    variable state
    #
    # TODO: the horizontal centre!!
    #
    set pos [currentpos]
    set items {}
    foreach text $args {
        usegap 0
        if { [lindex [split $text] 0] != "BOX" } {
            puts "text: $text"
            set text [plaintext $text]
        } else {
            puts "original object: $text"
            set text [moveobject $text]
        }
        puts "object: $text"
        set items [concat $items [lindex $text 1]]
        direction east
    }

    foreach {x1 y1 x2 y2} [eval $state(canvas) bbox $items] {break}
    set xc     [expr {($x1+$x2)/2}]
    set yc     [expr {($y1+$y2)/2}]
    set coords [list $xc $y1 $x2 $y1 $x2 $yc $x2 $y2 $xc $y2 \
                     $x1 $y2 $x1 $yc $x1 $y1 $xc $yc]
    set obj [list BOX $items $coords]
    usegap 0
    puts "result: $obj"
    currentpos $pos
    return $obj
}
proc ::Diagrams::div {numerator denominator} {
    variable state

    usegap 0
    set pos [currentpos]
    direction north
    set num [segm $numerator]
    currentpos $pos
    direction south
    usegap 0
    set den [segm $denominator]
    currentpos $pos

    foreach {dummy xn1 yn1} [getpos NW $num] {break}
    foreach {dummy xn2 yn2} [getpos SE $num] {break}
    foreach {dummy xd1 yd1} [getpos NW $den] {break}
    foreach {dummy xd2 yd2} [getpos SE $den] {break}

    set twidth [expr {$xn2-$xn1}]
    if { ($xn2-$xn1) < ($xd2-$xd1) } {
        set twidth [expr {$xd2-$xd1}]
    }
    set x1   [expr {[lindex $pos 1]-$twidth/2}]
    set x2   [expr {[lindex $pos 1]+$twidth/2}]
    set y    [lindex $pos 2]
    set item [$state(canvas) create line $x1 $y $x2 $y \
                 -fill    $state(colour)]

    puts "line: $x1 $y $x2 $y"

    set items [concat [lindex $num 1] [lindex $den 1] $item]

    set xc [expr {$x1+$x2}]
    set coords [list $xc  $yn1   $x2  $yn1   $x2  $y   \
                     $x2  $yd2   $xc  $yd2   $x1  $yd2 \
                     $x1  $y     $x1  $yn1   $xc  $y ]

   #set obj [moveobject [list BOX $items $coords]]
    set obj [list BOX $items $coords]
    usegap 1
    return $obj
}
if { 0 } {
currentpos [position 100 100]
set nn [::Diagrams::div A B]
puts "nn: $nn"
set bb [::Diagrams::segm B+C+ $nn]
currentpos [position 100 100]
puts [::Diagrams::div A $bb]


#
# Experiments with chemical structure formulae
# (Awaits update of "line")
#
if { 0 } {
proc ring {} {
   set side 20
   line $side 60 $side 0 $side -60 $side -120 $side 180 $side 120
}

proc bond {} {
   set side 20
   line $side 0
}

#
# Very primitive chemical formula
# -- order of direction/currentpos important!
#
direction east
currentpos [position 100 400]
ring; bond; ring; bond; plaintext CH3
}

saveps arjen.eps
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/diagrams/pkgIndex.tcl.

1
2
3
4
5
if {![package vsatisfies [package provide Tcl] 8.3]} {
    # PRAGMA: returnok
    return
}
package ifneeded Diagrams 0.2 [list source [file join $dir draw_diagram.tcl]]
<
<
<
<
<










Deleted scriptlibs/tklib0.5/getstring/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if { ![package vsatisfies [package provide Tcl] 8.4] } { return }
package ifneeded getstring 0.1 [list source [file join $dir tk_getString.tcl]]

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


























Deleted scriptlibs/tklib0.5/getstring/tk_getString.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
# tk_getString.tcl --
#
#       A dialog which prompts for a string input
#
# Copyright (c) 2005    Aaron Faupell <afaupell@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tk_getString.tcl,v 1.11 2005/04/13 01:29:22 andreas_kupries Exp $

package require Tk
package provide getstring 0.1

namespace eval ::getstring {
    namespace export tk_getString
}

if {[tk windowingsystem] == "win32"} {
    option add *TkSDialog*Button.width -8 widgetDefault
    option add *TkSDialog*Button.padX 1m widgetDefault
} else {
    option add *TkSDialog.borderWidth 1 widgetDefault
    option add *TkSDialog*Button.width 5 widgetDefault
}
option add *TkSDialog*Entry.width 20 widgetDefault

proc ::getstring::tk_getString {w var text args} {
    array set options {
        -allowempty 0
        -entryoptions {}
        -title "Enter Information"
    }
    parseOpts options {{-allowempty boolean} {-entryoptions {}} {-geometry {}} \
                       {-title {}}} $args

    variable ::getstring::result
    upvar $var result
    catch {destroy $w}
    set focus [focus]
    set grab [grab current .]

    toplevel $w -relief raised -class TkSDialog
    wm title $w $options(-title)
    wm iconname $w $options(-title)
    wm protocol $w WM_DELETE_WINDOW {set ::getstring::result 0}
    wm transient $w [winfo toplevel [winfo parent $w]]
    wm resizable $w 1 0

    eval [list entry $w.entry] $options(-entryoptions)
    button $w.ok -text OK -default active -command {set ::getstring::result 1}
    button $w.cancel -text Cancel -command {set ::getstring::result 0}
    label $w.label -text $text

    grid $w.label -columnspan 2 -sticky ew -padx 5 -pady 3
    grid $w.entry -columnspan 2 -sticky ew -padx 5 -pady 3
    grid $w.ok $w.cancel -padx 4 -pady 7
    grid rowconfigure $w 2 -weight 1
    grid columnconfigure $w {0 1} -uniform 1 -weight 1

    bind $w <Return> [list $w.ok invoke]
    bind $w <Escape> [list $w.cancel invoke]
    bind $w <Destroy> {set ::getstring::result 0}
    if {!$options(-allowempty)} {
        bind $w.entry <KeyPress> [list after idle [list ::getstring::getStringEnable $w]]
        $w.ok configure -state disabled 
    }

    wm withdraw $w
    update idletasks
    focus -force $w.entry
    if {[info exists options(-geometry)]} {
        wm geometry $w $options(-geometry)
    } elseif {[winfo parent $w] == "."} {
        set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}]
        set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}]
        wm geom $w +$x+$y
    } else {
        set t [winfo toplevel [winfo parent $w]]
        set x [expr {[winfo width $t]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}]
        set y [expr {[winfo height $t]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}]
        wm geom $w +$x+$y
    }
    wm deiconify $w
    grab $w

    tkwait variable ::getstring::result
    set result [$w.entry get]
    bind $w <Destroy> {}
    grab release $w
    destroy $w
    focus -force $focus
    if {$grab != ""} {grab $grab}
    update idletasks
    return $::getstring::result
}

proc ::getstring::parseOpts {var opts input} {
    upvar $var output
    for {set i 0} {$i < [llength $input]} {incr i} {
        for {set a 0} {$a < [llength $opts]} {incr a} {
           if {[lindex $opts $a 0] == [lindex $input $i]} { break }
        }
        if {$a == [llength $opts]} { error "unknown option [lindex $input $i]" }
        set opt [lindex $opts $a]
        if {[llength $opt] > 1} {
            foreach {opt type} $opt {break}
            if {[incr i] >= [llength $input]} { error "$opt requires an argument" }
            if {$type != "" && ![string is $type -strict [lindex $input $i]]} { error "$opt requires argument of type $type" }
            set output($opt) [lindex $input $i]
        } else {
            set output($opt) {}
        }
    }
}

proc ::getstring::getStringEnable {w} {
    if {![winfo exists $w.entry]} { return }
    if {[$w.entry get] != ""} {
        $w.ok configure -state normal
    } else {
        $w.ok configure -state disabled
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































Deleted scriptlibs/tklib0.5/history/history.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
# history.tcl --
#
#       Provides a history mechanism for entry widgets
#
# Copyright (c) 2005    Aaron Faupell <afaupell@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: history.tcl,v 1.4 2005/08/25 03:36:58 andreas_kupries Exp $

package require Tk
package provide history 0.1

namespace eval history {
    bind History <Up>   {::history::up %W}
    bind History <Down> {::history::down %W}
}

proc ::history::init {w {len 30}} {
    variable history
    variable prefs
    set bt [bindtags $w]
    if {[lsearch $bt History] > -1} { error "$w already has a history" }
    if {[set i [lsearch $bt $w]] < 0} { error "cant find $w in bindtags" }
    bindtags $w [linsert $bt [expr {$i + 1}] History]
    array set history [list $w,list {} $w,cur -1]
    set prefs(maxlen,$w) $len
    return $w
}

proc ::history::remove {w} {
    variable history
    variable prefs
    set bt [bindtags $w]
    if {[set i [lsearch $bt History]] < 0} { error "$w has no history" }
    bindtags $w [lreplace $bt $i $i]
    unset prefs(maxlen,$w) history($w,list) history($w,cur)
}

proc ::history::add {w line} {
    variable history
    variable prefs
    if {$history($w,cur) > -1 && [lindex $history($w,list) $history($w,cur)] == $line} {
        set history($w,list) [lreplace $history($w,list) $history($w,cur) $history($w,cur)]
    }
    set history($w,list) [linsert $history($w,list) 0 $line]
    set history($w,list) [lrange $history($w,list) 0 $prefs(maxlen,$w)]
    set history($w,cur) -1
}

proc ::history::up {w} {
    variable history
    if {[lindex $history($w,list) [expr {$history($w,cur) + 1}]] != ""} {
        if {$history($w,cur) == -1} {
            set history($w,tmp) [$w get]
        }
        $w delete 0 end
        incr history($w,cur)
        $w insert end [lindex $history($w,list) $history($w,cur)]
    } else {
        alert $w
    }
}

proc ::history::down {w} {
    variable history
    if {$history($w,cur) != -1} {
        $w delete 0 end
        if {$history($w,cur) == 0} {
            $w insert end $history($w,tmp)
            set history($w,cur) -1
        } else {
            incr history($w,cur) -1
            $w insert end [lindex $history($w,list) $history($w,cur)]
        }
    } else {
        alert $w
    }
}

proc ::history::get {w} {
    variable history
    return $history($w,list)
}

proc ::history::clear {w} {
    variable history
    set history($w,cur) -1
    set history($w,list) {}
    unset -nocomplain history($w,tmp)
}

proc ::history::configure {w option {value {}}} {
    variable history
    variable prefs
    switch -exact -- $option {
        length {
            if {$value == ""} { return $prefs(maxlen,$w) }
            if {![string is integer -strict $value]} { error "length must be an integer" }
            set prefs(maxlen,$w) $value
        }
        alert {
            if {$value == ""} { return [info body ::history::alert] }
            proc ::history::alert w $value
        }
        default {
            error "unknown option $option"
        }
    }
}

proc ::history::alert {w} {bell}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































Deleted scriptlibs/tklib0.5/history/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if { ![package vsatisfies [package provide Tcl] 8.4] } { return }
package ifneeded history 0.1 [list source [file join $dir history.tcl]]

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


























Deleted scriptlibs/tklib0.5/ico/ico.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
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
981
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
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
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
1210
1211
1212
1213
1214
1215
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
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
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
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
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
# ico.tcl --
#
# Win32 ico manipulation code
#
# Copyright (c) 2003-2007 Aaron Faupell
# Copyright (c) 2003-2004 ActiveState Corporation
#
# RCS: @(#) $Id: ico.tcl,v 1.28 2008/03/12 07:25:49 hobbs Exp $

# Sample usage:
#	set file bin/wish.exe
#	set icos [::ico::icons $file]
#	set img  [::ico::getIcon $file [lindex $icos 1] -format image -res 32]

package require Tcl 8.4

# Instantiate vars we need for this package
namespace eval ::ico {
    namespace export icons iconMembers getIcon getIconByName writeIcon copyIcon transparentColor clearCache EXEtoICO
    # stores cached indices of icons found
    variable  RES
    array set RES {}

    # used for 4bpp number conversion
    variable BITS
    array set BITS [list {} 0 0000 0 0001 1 0010 2 0011 3 0100 4 \
			0101 5 0110 6 0111 7 1000 8 1001 9 \
			1010 10 1011 11 1100 12 1101 13 1110 14 1111 15 \
			\
			00000 00 00001 0F 00010 17 00011 1F \
			00100 27 00101 2F 00110 37 00111 3F \
			01000 47 01001 4F 01010 57 01011 5F \
			01100 67 01101 6F 01110 77 01111 7F \
			10000 87 10001 8F 10010 97 10011 9F \
			10100 A7 10101 AF 10110 B7 10111 BF \
			11000 C7 11001 CF 11010 D7 11011 DF \
			11100 E7 11101 EF 11110 F7 11111 FF]
}


# icons --
#
# List of icons in a file
#
# ARGS:
#	file	File to extract icon info from.
#	?-type?	Type of file.  If not specified, it is derived from
#		the file extension.  Currently recognized types are
#		EXE, DLL, ICO, ICL, BMP, and ICODATA
#
# RETURNS:
#	list of icon names or numerical IDs
#
proc ::ico::icons {file args} {
    parseOpts type $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getIconList$type]]} {
	return -code error "unsupported file format $type"
    }
    getIconList$type [file normalize $file]
}

# iconMembers --
#
# Get info on images which make up an icon
#
# ARGS:
#	file		File containing icon
#       name		Name of the icon in the file
#	?-type?		Type of file.  If not specified, it is derived from
#			the file extension.  Currently recognized types are
#			EXE, DLL, ICO, ICL, BMP, and ICODATA
#
# RETURNS:
#	list of icons as tuples {name width height bpp}
#
proc ::ico::iconMembers {file name args} {
    parseOpts type $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getIconMembers$type]]} {
	return -code error "unsupported file format $type"
    }
    getIconMembers$type [file normalize $file] $name
}

# getIcon --
#
# Get pixel data or image of icon
#
# ARGS:
#	file		File to extract icon info from.
#	name		Name of image in the file to use.  The name is the first element
#			in the sublists returned by iconMembers.
#	?-res?		Set the preferred resolution.
#	?-bpp?		Set the preferred color depth in bits per pixel.
#	?-exact?	Accept only exact matches for res and bpp. Returns
#			an error if there is no exact match.
#	?-type?		Type of file.  If not specified, it is derived from
#			the file extension.  Currently recognized types are
#			EXE, DLL, ICO, ICL, BMP, and ICODATA
#	?-format?	Output format. Must be one of "image" or "colors"
#			'image' will return the name of a Tk image.
#			'colors' will return a list of pixel values
#	?-image?	If output is image, use this as the name of Tk image
#			created
#
# RETURNS:
#	pixel data as a list that could be passed to 'image create'
#	or the name of a Tk image
#
proc ::ico::getIcon {file name args} {
    set image {}
    set format image
    set exact 0
    set bpp 24
    parseOpts {type format image res bpp exact} $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getRawIconData$type]]} {
        return -code error "unsupported file format $type"
    }
    # ICODATA is a pure data type - not a real file
    if {$type ne "ICODATA"} {
	set file [file normalize $file]
    }

    set mem [getIconMembers$type $file $name]

    if {![info exists res]} {
        set icon [lindex $mem 0 0]
    } elseif {$exact} {
        set icon [lsearch -inline -glob $mem "* $res $bpp"]
        if {$icon == ""} { return -code error "No matching icon" }
    } else {
        set mem [lsort -integer -index 1 $mem]
        set match ""
        foreach x $mem {
            if {[lindex $x 1] == [lindex $res 0]} { lappend match $x }
        }
        if {$match == ""} {
            # todo: resize a larger icon
            #return -code error "No matching icon"
            set match [list [lindex $mem end]]
        }
        set match [lsort -integer -decreasing -index 3 $match]
        foreach x $match {
            if {[lindex $x 3] <= $bpp} { set icon [lindex $x 0]; break }
        }
        if {![info exists icon]} { set icon [lindex $match end 0]}
    }
    if {$format eq "name"} {
        return $icon
    }
    set colors [eval [linsert [getRawIconData$type $file $icon] 0 getIconAsColorList]]
    if {$format eq "image"} {
        return [createImage $colors $image]
    }
    return $colors
}

# getIconByName --
#
# Get pixel data or image of icon name in file. The icon name
# is the first element of the sublist from [iconMembers].
#
# ARGS:
#	file		File to extract icon info from.
#	name		Name of image in the file to use.  The name is the first element
#			in the sublists returned by iconMembers.
#	?-type?		Type of file.  If not specified, it is derived from
#			the file extension.  Currently recognized types are
#			EXE, DLL, ICO, ICL, BMP, and ICODATA
#	?-format?	Output format. Must be one of "image" or "colors"
#			'image' will return the name of a Tk image.
#			'colors' will return a list of pixel values
#	?-image?	If output is image, use this as the name of Tk image
#			created
#
# RETURNS:
#	pixel data as a list that could be passed to 'image create'
#
proc ::ico::getIconByName {file name args} {
    set format image
    set image {}
    parseOpts {type format image} $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getRawIconData$type]]} {
        return -code error "unsupported file format $type"
    }
    # ICODATA is a pure data type - not a real file
    if {$type ne "ICODATA"} {
        set file [file normalize $file]
    }
    set colors [eval [linsert [getRawIconData$type $file $name] 0 getIconAsColorList]]
    if {$format eq "image"} {
        return [createImage $colors $image]
    }
    return $colors
}

# getFileIcon --
#
# Get the registered icon for the file under Windows
#
# ARGS:
#	file	File to get icon for.
#	
#	optional arguments and return values are the same as getIcon
#
proc ::ico::getFileIcon {file args} {
    set icon "%SystemRoot%\\System32\\shell32.dll,0"
    if {[file isdirectory $file] || $file == "Folder"} {
        if {![catch {registry get HKEY_CLASSES_ROOT\\Folder\\DefaultIcon ""} reg]} {
            set icon $reg
        }
    } else {
        set ext [file extension $file]
        if {![catch {registry get HKEY_CLASSES_ROOT\\$ext ""} doctype]} {
            if {![catch {registry get HKEY_CLASSES_ROOT\\$doctype\\CLSID ""} clsid] && \
                ![catch {registry get HKEY_CLASSES_ROOT\\CLSID\\$clsid\\DefaultIcon ""} reg]} {
                set icon $reg
            } elseif {![catch {registry get HKEY_CLASSES_ROOT\\$doctype\\DefaultIcon ""} reg]} {
                set icon $reg
            }
        }
    }
    set index [lindex [split $icon ,] 1]
    set icon [lindex [split $icon ,] 0]
    if {$index == ""} { set index 0 }
    set icon [string trim $icon "@'\" "]
    while {[regexp -nocase {%([a-z]+)%} $icon -> var]} {
        set icon [string map [list %$var% $::env($var)] $icon]
    }
    set icon [string map [list %1 $file] $icon]
    if {$index < 0} {
        if {![catch {eval [list getIcon $icon [string trimleft $index -]] $args} output]} {
            return $output
        }
        set index 0
    }
    return [eval [list getIcon $icon [lindex [icons $icon] $index]] $args]
}

# writeIcon --
#
# Overwrite write image in file with depth/pixel data
#
# ARGS:
#	file	File to extract icon info from.
#	name	Name of image in the file to use.  The name is the first element
#		in the sublists returned by iconMembers.
#	bpp	bit depth of icon we are writing
#	data	Either pixel color data (as returned by getIcon -format color)
#		or the name of a Tk image.
#	?-type?	Type of file.  If not specified, it is derived from
#		the file extension.  Currently recognized types are
#		EXE, DLL, ICO and ICL
#
# RETURNS:
#	nothing
#
proc ::ico::writeIcon {file name bpp data args} {
    parseOpts type $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands writeIcon$type]]} {
	return -code error "unsupported file format $type"
    }
    if {[llength $data] == 1} {
        set data [getColorListFromImage $data]
    } elseif {[lsearch -glob [join $data] #*] > -1} {
        set data [translateColors $data]
    }
    if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} {
	return -code error "invalid color depth"
    }
    set palette {}
    if {$bpp <= 8} {
	set palette [getPaletteFromColors $data]
	if {[lindex $palette 0] > (1 << $bpp)} {
	    return -code error "specified color depth too low"
	}
	set data  [lindex $palette 2]
	set palette [lindex $palette 1]
	append palette [string repeat \000 [expr {(1 << ($bpp + 2)) - [string length $palette]}]]
    }
    set and [getAndMaskFromColors $data]
    set xor [getXORFromColors $bpp $data]
    # writeIcon$type file index w h bpp palette xor and
    writeIcon$type [file normalize $file] $name \
	[llength [lindex $data 0]] [llength $data] $bpp $palette $xor $and
}


# copyIcon --
#
# Copies an icon directly from one file to another
#
# ARGS:
#	file1	        File to extract icon info from.
#	name1		Name of image in the file to use.  The name is the first element
#			in the sublists returned by iconMembers.
#	file2	        File to write icon to.
#	name2		Name of image in the file to use.  The name is the first element
#			in the sublists returned by iconMembers.
#	?-fromtype?	Type of source file.  If not specified, it is derived from
#		        the file extension.  Currently recognized types are
#		        EXE, DLL, ICO, ICL, BMP, and ICODATA
#	?-totype?	Type of destination file.  If not specified, it is derived from
#		        the file extension.  Currently recognized types are
#		        EXE, DLL, ICO, ICL, BMP, and ICODATA
#
# RETURNS:
#	nothing
#
proc ::ico::copyIcon {file1 name1 file2 name2 args} {
    parseOpts {fromtype totype} $args
    if {![info exists fromtype]} {
        # $type wasn't specified - get it from the extension
        set fromtype [fileext $file1]
    }
    if {![info exists totype]} {
        # $type wasn't specified - get it from the extension
        set totype [fileext $file2]
    }
    if {![llength [info commands writeIcon$totype]]} {
	return -code error "unsupported file format $totype"
    }
    if {![llength [info commands getRawIconData$fromtype]]} {
	return -code error "unsupported file format $fromtype"
    }
    set src [getRawIconData$fromtype $file1 $name1]
    writeIcon $file2 $name2 [lindex $src 2] [eval getIconAsColorList $src] -type $totype
}

#
# transparentColor --
#
# Turns on transparency for all pixels in the image that match the color
#
# ARGS:
#	img	        Name of the Tk image to modify, or an image in color list format
#	color	        Color in #hex format which will be made transparent
#
# RETURNS:
#	the data or image after modification
#
proc ::ico::transparentColor {img color} {
    if {[llength $img] == 1} {
        package require Tk
        if {[string match "#*" $color]} {
            set color [scan $color "#%2x%2x%2x"]
        }
        set w [image width $img]
        set h [image height $img]
        for {set y 0} {$y < $h} {incr y} {
            for {set x 0} {$x < $w} {incr x} {
                if {[$img get $x $y] eq $color} {$img transparency set $x $y 1}
            }
        }
    } else {
        set y 0
        foreach row $img {
            set x 0
            foreach px $row {
                if {$px == $color} {lset img $y $x {}}
                incr x
            }
            incr y
        }
    }
    return $img
}

#
# clearCache --
#
# Clears the cache of icon offsets
#
# ARGS:
#	file	optional filename
#
#
# RETURNS:
#	nothing
#
proc ::ico::clearCache {{file {}}} {
    variable RES
    if {$file ne ""} {
	array unset RES $file,*
    } else {
	unset RES
	array set RES {}
    }
}

#
# EXEtoICO --
#
# Convert all icons found in exefile into regular icon files
#
# ARGS:
#	exeFile	        Input EXE filename
#	?icoDir?	Output ICO directory. Default is the
#			same directory exeFile is located in
#
# RETURNS:
#	nothing
#
proc ::ico::EXEtoICO {exeFile {icoDir {}}} {
    variable RES

    set file [file normalize $exeFile]
    FindResources $file

    if {$icoDir == ""} { set icoDir [file dirname $file] }

    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    foreach group $RES($file,group,names) {
        set dir  {}
        set data {}
        foreach icon $RES($file,group,$group,members) {
            seek $fh $RES($file,icon,$icon,offset) start
	    set ico $RES($file,icon,$icon,data)
	    eval [list lappend dir] $ico
	    append data [read $fh [eval calcSize $ico 40]]
        }

        # write them out to a file
        set ifh [open [file join $icoDir [file tail $exeFile]-$group.ico] w+]
        fconfigure $ifh -eofchar {} -encoding binary -translation lf

        bputs $ifh sss 0 1 [llength $RES($file,group,$group,members)]
        set offset [expr {6 + ([llength $RES($file,group,$group,members)] * 16)}]
        foreach {w h bpp} $dir {
            set len [calcSize $w $h $bpp 40]
            lappend fix $offset $len
            bputs $ifh ccccssii $w $h [expr {$bpp <= 8 ? 1 << $bpp : 0}] 0 1 $bpp $len $offset
            set offset [expr {$offset + $len}]
        }
        puts -nonewline $ifh $data
        foreach {offset size} $fix {
            seek $ifh [expr {$offset + 20}] start
            bputs $ifh i $size
        }
        close $ifh
    }
    close $fh
}



##
## Internal helper commands.
## Some may be appropriate for exposing later, but would need docs
## and make sure they "fit" in the API.
##

# gets the file extension as we use it internally (upper case, no '.')
proc ::ico::fileext {file} {
    return [string trimleft [string toupper [file extension $file]] .]
}

# helper proc to parse optional arguments to some of the public procs
proc ::ico::parseOpts {acc opts} {
    foreach {key val} $opts {
        set key [string trimleft $key -]
	if {[lsearch -exact $acc $key] >= 0} {
	    upvar $key $key
	    set $key $val
	} elseif {$key ne ""} {
	    return -code error "unknown option \"$key\": must be one of $acc"
	}
    }
}

# formats a single color from a binary decimal list format to the #hex format
proc ::ico::formatColor {r g b} {
    format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c]
}

# translates a color list from the #hex format to the decimal list format
#                                #0000FF                  {0 0 255}
proc ::ico::translateColors {colors} {
    set new {}
    foreach line $colors {
	set tline {}
	foreach x $line {
	    if {$x eq ""} {lappend tline {}; continue}
	    lappend tline [scan $x "#%2x%2x%2x"]
	}
	set new [linsert $new 0 $tline]
    }
    return $new
}

# reads a 32 bit signed integer from the filehandle
proc ::ico::getdword {fh} {
    binary scan [read $fh 4] i* tmp
    return $tmp
}

proc ::ico::getword {fh} {
    binary scan [read $fh 2] s* tmp
    return $tmp
}

proc ::ico::getulong {fh} {
    binary scan [read $fh 4] i tmp
    return [format %u $tmp]
}

proc ::ico::getushort {fh} {
    binary scan [read $fh 2] s tmp
    return [expr {$tmp & 0x0000FFFF}]
}

proc ::ico::bputs {fh format args} {
    puts -nonewline $fh [eval [list binary format $format] $args]
}

proc ::ico::createImage {colors {name {}}} {
    package require Tk
    set h [llength $colors]
    set w [llength [lindex $colors 0]]
    if {$name ne ""} {
	set img [image create photo $name -width $w -height $h]
    } else {
	set img [image create photo -width $w -height $h]
    }
    if {0} {
	# if image supported "" colors as transparent pixels,
	# we could use this much faster op
	$img put -to 0 0 $colors
    } else {
	for {set x 0} {$x < $w} {incr x} {
	    for {set y 0} {$y < $h} {incr y} {
                set clr [lindex $colors $y $x]
                if {$clr ne ""} {
                    $img put -to $x $y $clr
                }
            }
        }
    }
    return $img
}

# return a list of colors in the #hex format from raw icon data
# returned by readDIB
proc ::ico::getIconAsColorList {w h bpp palette xor and} {
    # Create initial empty color array that we'll set indices in
    set colors {}
    set row    {}
    set empty  {}
    for {set x 0} {$x < $w} {incr x} { lappend row $empty }
    for {set y 0} {$y < $h} {incr y} { lappend colors $row }

    set x 0
    set y [expr {$h-1}]
    if {$bpp == 1} {
	binary scan $xor B* xorBits
	foreach i [split $xorBits {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
                lset colors $y $x [lindex $palette $i]
	    }
	    incr x
	}
    } elseif {$bpp == 4} {
	variable BITS
	binary scan $xor B* xorBits
	set i 0
	foreach a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
                set bits [string range $xorBits $i [expr {$i+3}]]
                lset colors $y $x [lindex $palette $BITS($bits)]
            }
            incr i 4
            incr x
	}
    } elseif {$bpp == 8} {
	foreach i [split $xor {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
                lset colors $y $x [lindex $palette [scan $i %c]]
	    }
	    incr x
	}
    } elseif {$bpp == 16} {
        variable BITS
        binary scan $xor b* xorBits
        set i 0
	foreach a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
                set b1 [string range $xorBits      $i        [expr {$i+4}]]
                set b2 [string range $xorBits [expr {$i+5}]  [expr {$i+9}]]
                set b3 [string range $xorBits [expr {$i+10}] [expr {$i+14}]]
                lset colors $y $x "#$BITS($b3)$BITS($b2)$BITS($b1)"
            }
            incr i 16
            incr x
        }
    } elseif {$bpp == 24} {
        foreach {b g r} [split $xor {}] a [split $and {}] {
            if {$x == $w} { set x 0; incr y -1 }
            if {$a == 0} {
                lset colors $y $x [formatColor $r $g $b]
            }
            incr x
        }
    } elseif {$bpp == 32} {
	foreach {b g r n} [split $xor {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
                lset colors $y $x [formatColor $r $g $b]
	    }
	    incr x
	}
    }
    return $colors
}

# creates a binary formatted AND mask by reading a list of colors in the decimal list format
# and checking for empty colors which designate transparency
proc ::ico::getAndMaskFromColors {colors} {
    set and {}
    foreach line $colors {
	set l {}
	foreach x $line {append l [expr {$x eq ""}]}
	append l [string repeat 0 [expr {[string length $l] % 32}]]
	foreach {a b c d e f g h} [split $l {}] {
	    append and [binary format B8 $a$b$c$d$e$f$g$h]
	}
    }
    return $and
}

# creates a binary formatted XOR mask in the specified depth format from
# a list of colors in the decimal list format
proc ::ico::getXORFromColors {bpp colors} {
    set xor {}
    if {$bpp == 1} {
	foreach line $colors {
	    foreach {a b c d e f g h} $line {
                foreach x {a b c d e f g h} {
                    if {[set $x] == ""} {set $x 0}
		}
		binary scan $a$b$c$d$e$f$g$h bbbbbbbb h g f e d c b a
		append xor [binary format b8 $a$b$c$d$e$f$g$h]
	    }
	}
    } elseif {$bpp == 4} {
	foreach line $colors {
	    foreach {a b} $line {
		if {$a == ""} {set a 0}
		if {$b == ""} {set b 0}
		binary scan $a$b b4b4 b a
		append xor [binary format b8 $a$b]
	    }
	}
    } elseif {$bpp == 8} {
	foreach line $colors {
	    foreach x $line {
		if {$x == ""} {set x 0}
		append xor [binary format c $x]
	    }
	}
    } elseif {$bpp == 24} {
	foreach line $colors {
	    foreach x $line {
		if {![llength $x]} {
		    append xor [binary format ccc 0 0 0]
		} else {
		    foreach {a b c n} $x {
			append xor [binary format ccc $c $b $a]
		    }
		}
	    }
	}
    } elseif {$bpp == 32} {
	foreach line $colors {
	    foreach x $line {
		if {![llength $x]} {
		    append xor [binary format cccc 0 0 0 0]
		} else {
		    foreach {a b c n} $x {
			if {$n == ""} {set n 0}
			append xor [binary format cccc $c $b $a $n]
		    }
		}
	    }
	}
    }
    return $xor
}

# translates a Tk image into a list of colors in the {r g b} format
# one element per pixel and {} designating transparent
# used by writeIcon when writing from a Tk image
proc ::ico::getColorListFromImage {img} {
    package require Tk
    set w [image width $img]
    set h [image height $img]
    set r {}
    for {set y [expr $h - 1]} {$y > -1} {incr y -1} {
	set l {}
	for {set x 0} {$x < $w} {incr x} {
	    if {[$img transparency get $x $y]} {
		lappend l {}
	    } else {
		lappend l [$img get $x $y]
	    }
	}
	lappend r $l
    }
    return $r
}

# creates a palette from a list of colors in the decimal list format
# a palette consists of 3 values, the number of colors, the palette entry itself,
# and the color list transformed to point to palette entries instead of color names
# the palette entry itself is stored as 32bpp in "G B R padding" order
proc ::ico::getPaletteFromColors {colors} {
    set palette "\x00\x00\x00\x00"
    array set tpal {{0 0 0} 0}
    set new {}
    set i 1
    foreach line $colors {
	set tline {}
	foreach x $line {
	    if {$x eq ""} {lappend tline {}; continue}
	    if {![info exists tpal($x)]} {
		foreach {a b c n} $x {
		    append palette [binary format cccc $c $b $a 0]
		}
		set tpal($x) $i
		incr i
	    }
	    lappend tline $tpal($x)
	}
	lappend new $tline
    }
    return [list $i $palette $new]
}

# calculate byte size of an icon.
# often passed $w twice because $h is double $w in the binary data
proc ::ico::calcSize {w h bpp {offset 0}} {
    set s [expr {int(($w*$h) * ($bpp/8.0)) \
		     + ((($w*$h) + ($h*($w%32)))/8) + $offset}]
    if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] }
    return $s
}

# read a Device Independent Bitmap from the current offset, return:
#	{width height depth palette XOR_mask AND_mask}
proc ::ico::readDIB {fh} {
    binary scan [read $fh 16] x4iix2s w h bpp
    set h [expr {$h / 2}]
    seek $fh 24 current

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
	set colors [read $fh [expr {1 << ($bpp + 2)}]]
	foreach {b g r x} [split $colors {}] {
	    lappend palette [formatColor $r $g $b]
	}
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
	# do nothing here
    } else {
	return -code error "unsupported color depth: $bpp"
    }

    set xor  [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]]
    set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]]

    set and {}
    set row [expr {((($w - 1) / 32) * 32 + 32) / 8}]
    set len [expr {$row * $h}]
    for {set i 0} {$i < $len} {incr i $row} {
	binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp
	append and $tmp
    }

    return [list $w $h $bpp $palette $xor $and]
}

# read a Device Independent Bitmap from raw data, return:
#	{width height depth palette XOR_mask AND_mask}
proc ::ico::readDIBFromData {data loc} {
    # Read info from location
    binary scan $data @${loc}x4iix2s w h bpp
    set h [expr {$h / 2}]
    # Move over w/h/bpp info + magic offset to start of DIB
    set cnt [expr {$loc + 16 + 24}]

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
	# Could do: [binary scan $data @${cnt}c$len colors]
	# and iter over colors, but this is more consistent with $fh version
	set len    [expr {1 << ($bpp + 2)}]
	set colors [string range $data $cnt [expr {$cnt + $len - 1}]]
	foreach {b g r x} [split $colors {}] {
	    lappend palette [formatColor $r $g $b]
	}
	incr cnt $len
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
	# do nothing here
    } else {
	return -code error "unsupported color depth: $bpp"
    }

    # Use -1 to account for string range inclusiveness
    set end  [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}]
    set xor  [string range $data $cnt $end]
    set and1 [string range $data [expr {$end + 1}] \
		  [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]]

    set and {}
    set row [expr {((($w - 1) / 32) * 32 + 32) / 8}]
    set len [expr {$row * $h}]
    for {set i 0} {$i < $len} {incr i $row} {
	# Has to be decoded by row, in order
	binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp
	append and $tmp
    }

    return [list $w $h $bpp $palette $xor $and]
}

proc ::ico::getIconListICO {file} {
    set fh [open $file r]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    if {"[getword $fh] [getword $fh]" ne "0 1"} {
	return -code error "not an icon file"
    }
    close $fh
    return 0
}

proc ::ico::getIconListICODATA {data} {
    if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} {
	return -code error "not icon data"
    }
    return 0
}

proc ::ico::getIconListBMP {file} {
    set fh [open $file]
    if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" }
    close $fh
    return 0
}

proc ::ico::getIconListEXE {file} {
    variable RES

    set file [file normalize $file]
    if {[FindResources $file] > -1} {
        return $RES($file,group,names)
    } else {
        return ""
    }
}

# returns a list of images that make up the named icon
# as tuples {name width height bpp}. Called by [iconMembers]
proc ::ico::getIconMembersICO {file name} {
    variable RES

    if {$name ne "0"} { return -code error "no icon \"$name\"" }
    set file [file normalize $file]
    if {[info exists RES($file,group,$name,members)]} {
        set ret ""
        foreach x $RES($file,group,$name,members) {
            lappend ret [linsert $RES($file,icon,$x,data) 0 $x]
        }
        return $ret
    }

    set fh [open $file r]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    # both words must be read to keep in sync with later reads
    if {"[getword $fh] [getword $fh]" ne "0 1"} {
        close $fh
	return -code error "not an icon file"
    }

    set ret ""
    set num [getword $fh]
    for {set i 0} {$i < $num} {incr i} {
        set info ""
        lappend RES($file,group,$name,members) $i
	lappend info [scan [read $fh 1] %c] [scan [read $fh 1] %c]
	set bpp [scan [read $fh 1] %c]
        if {$bpp == 0} {
	    set orig [tell $fh]
	    seek $fh 9 current
	    seek $fh [expr {[getdword $fh] + 14}] start
	    lappend info [getword $fh]
	    seek $fh $orig start
	} else {
	    lappend info [expr {int(sqrt($bpp))}]
	}
	lappend ret [linsert $info 0 $i]
	set RES($file,icon,$i,data) $info
	seek $fh 13 current
    }
    close $fh
    return $ret
}

# returns a list of images that make up the named icon
# as tuples {name width height bpp}. Called by [iconMembers]
proc ::ico::getIconMembersICODATA {data} {
    if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} {
	return -code error "not icon data"
    }
    set r {}
    set cnt 6
    for {set i 0} {$i < $num} {incr i} {
	if {[binary scan $data @${cnt}ccc w h bpp] != 3} {
	    return -code error "error decoding icon data"
	}
	incr cnt 3
	set info [list $i $w $h]
	if {$bpp == 0} {
	    set off [expr {$cnt + 9}]
	    binary scan $data @${off}i off
	    incr off 14
	    binary scan $data @${off}s bpp
	    lappend info $bpp
	} else {
	    lappend info [expr {int(sqrt($bpp))}]
	}
	lappend r $info
	incr cnt 13
    }
    return $r
}

# returns a list of images that make up the named icon
# as tuples {name width height bpp}. Called by [iconMembers]
proc ::ico::getIconMembersBMP {file {name 0}} {
    if {$name ne "0"} { return -code error "no icon \"$name\"" }
    set fh [open $file]
    if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" }
    seek $fh 14 start
    binary scan [read $fh 16] x4iix2s w h bpp
    close $fh
    return [list 1 $w $h $bpp]
}

# returns a list of images that make up the named icon
# as tuples {name width height bpp}. Called by [iconMembers]
proc ::ico::getIconMembersEXE {file name} {
    variable RES
    set file [file normalize $file]
    FindResources $file
    if {![info exists RES($file,group,$name,members)]} { return -code error "no icon \"$name\"" }
    set ret ""
    foreach x $RES($file,group,$name,members) {
        lappend ret [linsert $RES($file,icon,$x,data) 0 $x]
    }
    return $ret
}

# returns an icon in the form:
#       {width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataICO {file name} {
    set fh [open $file r]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    # both words must be read to keep in sync with later reads
    if {"[getword $fh] [getword $fh]" ne "0 1"} {
        close $fh
        return -code error "not an icon file"
    }
    set num [getword $fh]
    if {![string is integer -strict $name] || $name < 0 || $name >= $num} { return -code error "no icon \"$name\"" }

    seek $fh [expr {(16 * $name) + 12}] current
    seek $fh [getdword $fh] start

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIB $fh]

    close $fh
    return $dib
}

# returns an icon in the form:
#       {width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataICODATA {data name} {
    if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} {
	return -code error "not icon data"
    }
    if {![string is integer -strict $name] || $name < 0 || $name >= $num} {
	return -code error "No icon $name"
    }
    # Move to ico location
    set cnt [expr {6 + (16 * $name) + 12}]
    binary scan $data @${cnt}i loc

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIBFromData $data $loc]

    return $dib
}

# returns an icon in the form:
#	{width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataBMP {file {name 1}} {
    if {$name ne "1"} {return -code error "No icon \"$name\""}
    set fh [open $file]
    if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" }
    seek $fh 14 start
    binary scan [read $fh 16] x4iix2s w h bpp
    seek $fh 24 current

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
        set colors [read $fh [expr {1 << ($bpp + 2)}]]
        foreach {b g r x} [split $colors {}] {
            lappend palette [formatColor $r $g $b]
        }
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
        # do nothing here
    } else {
        return -code error "unsupported color depth: $bpp"
    }

    set xor  [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]]
    set and [string repeat 0 [expr {$w * $h}]]
    close $fh

    return [list $w $h $bpp $palette $xor $and]
}

# returns an icon in the form:
#	{width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataEXE {file name} {
    variable RES

    set file [file normalize $file]
    FindResources $file

    if {![info exists RES($file,icon,$name,offset)]} { error "No icon \"$name\"" }
    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    seek $fh $RES($file,icon,$name,offset) start

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIB $fh]
    close $fh
    return $dib
}

proc ::ico::writeIconICO {file name w h bpp palette xor and} {
    if {![file exists $file]} {
	set fh [open $file w+]
	fconfigure $fh -eofchar {} -encoding binary -translation lf
	set num 0
    } else {
	set fh [open $file r+]
	fconfigure $fh -eofchar {} -encoding binary -translation lf
	if {"[getword $fh] [getword $fh]" ne "0 1"} {
	    close $fh
	    return -code error "not an icon file"
	}
	set num [getword $fh]
	seek $fh [expr {6 + (16 * $num)}] start
    }

    set size [expr {[string length $palette] + [string length $xor] + [string length $and]}]
    set newicon [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0]$palette$xor$and

    set data {}
    for {set i 0} {$i < $num} {incr i} {
        binary scan [read $fh 24] ix16i a b
        seek $fh -24 current
        lappend data [read $fh [expr {$a + $b}]]
    }

    if {![string is integer -strict $name] || $name < 0 || $name >= $num} {
        set name [llength $data]
        lappend data $newicon
    } else {
        set data [lreplace $data $name $name $newicon]
    }
    set num [llength $data]

    seek $fh 0 start
    bputs $fh sss 0 1 $num
    set offset [expr {6 + (16 * $num)}]
    foreach x $data {
        binary scan $x x4iix2s w h bpp
        set len [string length $x]
	# use original height in icon table header
        bputs $fh ccccssii $w [expr {$h / 2}] [expr {$bpp <= 8 ? 1 << $bpp : 0}] 0 0 $bpp $len $offset
        incr offset $len
    }
    puts -nonewline $fh [join $data {}]
    close $fh

    return $name
}

proc ::ico::writeIconICODATA {file name w h bpp palette xor and} {
    upvar 2 [file tail $file] input
    if {![info exists input] || ([binary scan $input sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1)} {
	set num 0
    }

    set size [expr {[string length $palette] + [string length $xor] + [string length $and]}]
    set newicon [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0]$palette$xor$and

    set readpos [expr {6 + (16 * $num)}]
    set data {}
    for {set i 0} {$i < $num} {incr i} {
        binary scan $input @{$readpos}ix16i a b
        lappend data [string range $data $readpos [expr {$readpos + $a + $b}]]
        incr readpos [expr {$readpos + $a + $b}]
    }

    if {![string is integer -strict $name] || $name < 0 || $name >= $num} {
        set name [llength $data]
        lappend data $newicon
    } else {
        set data [lreplace $data $name $name $newicon]
    }
    set num [llength $data]

    set new [binary format sss 0 1 $num]
    set offset [expr {6 + (16 * $num)}]
    foreach x $data {
        binary scan $x x4iix2s w h bpp
        set len [string length $x]
	# use original height in icon table header
        append new [binary format ccccssii $w [expr {$h / 2}] [expr {$bpp <= 8 ? 1 << $bpp : 0}] 0 0 $bpp $len $offset]
        incr offset $len
    }
    set input $new
    append input [join $data {}]

    return $name
}

proc ::ico::writeIconBMP {file name w h bpp palette xor and} {
    set fh [open $file w+]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    set size [expr {[string length $palette] + [string length $xor]}]
    # bitmap header: magic, file size, reserved, reserved, offset of bitmap data
    bputs $fh a2issi BM [expr {14 + 40 + $size}] 0 0 54
    bputs $fh iiissiiiiii 40 $w $h 1 $bpp 0 $size 0 0 0 0
    puts -nonewline $fh $palette$xor
    close $fh
}

proc ::ico::writeIconEXE {file name w h bpp palette xor and} {
    variable RES

    set file [file normalize $file]
    set members [getIconMembersEXE $file $name]

    if {![info exists RES($file,icon,$name,data)]} {
        return -code error "no icon \"$name\""
    }
    if {![string match "* $w $h $bpp" $RES($file,icon,$name,data)]} {
	return -code error "icon format differs from original"
    }
    
    set fh [open $file r+]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    seek $fh [expr {$RES($file,icon,$name,offset) + 40}] start

    puts -nonewline $fh $palette$xor$and
    close $fh
}

proc ::ico::FindResources {file} {
    variable RES

    if {[info exists RES($file,group,names)]} {
        return [llength $RES($file,group,names)]
    }

    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    if {[read $fh 2] ne "MZ"} {
	close $fh
	return -code error "unknown file format"
    }
    seek $fh 60 start
    seek $fh [getword $fh] start
    set sig [read $fh 4]
    seek $fh -4 current
    if {$sig eq "PE\000\000"} {
        return [FindResourcesPE $fh $file]
    } elseif {[string match NE* $sig]} {
        return [FindResourcesNE $fh $file]
    } else {
        return -code error "unknown file format"
    }
}

# parse the resource table of 16 bit windows files for icons
proc ::ico::FindResourcesNE {fh file} {
    variable RES

    seek $fh 36 current
    seek $fh [expr {[getword $fh] - 38}] current
    set base [tell $fh]
    set shift [expr {int(pow(2, [getushort $fh]))}]
    while {[set type [expr {[getushort $fh] & 0x7fff}]] != 0} {
        set num [getushort $fh]
        if {$type != 3 && $type != 14} {
            seek $fh [expr {($num * 12) + 4}] current
            continue
        }
        set type [string map {3 icon 14 group} $type]
        seek $fh 4 current
        for {set i 0} {$i < $num} {incr i} {
            set offset [expr {[getushort $fh] * $shift}]
            seek $fh 4 current
            set name [getNEResName $fh $base [getushort $fh]]
            set RES($file,$type,$name,offset) $offset
            lappend RES($file,$type,names) $name
            seek $fh 4 current
        }
    }
    if {[array names RES $file,*] == ""} {
        close $fh
        return -1
    }
    foreach x [array names RES $file,group,*,offset] {
        seek $fh [expr {$RES($x) + 4}] start
        binary scan [read $fh 2] s a
        set x [lindex [split $x ,] 2]
        for {set i 0} {$i < $a} {incr i} {
            binary scan [read $fh 14] x12s n
            lappend RES($file,group,$x,members) $n
        }
    }
    foreach x [array names RES $file,icon,*,offset] {
        seek $fh [expr {$RES($x)}] start
        set x [lindex [split $x ,] 2]
        binary scan [read $fh 16] x4iix2s w h bpp
        set RES($file,icon,$x,data) [list $w [expr {$h / 2}] $bpp]
    }
    close $fh
    return [llength $RES($file,group,names)]
}

proc ::ico::getNEResName {fh base data} {
    if {$data == 0} {
        return 0
    }
    binary scan $data b* tmp
    if {[string index $tmp 0] == 0} {
        set cur [tell $fh]
        seek $fh [expr {$data + $base}] start
        binary scan [read $fh 1] c len
        set name [read $fh $len]
        seek $fh $cur start
        return $name
    } else {
        return [expr {$data & 0x7fff}]
    }
}

# parse the resource tree of 32 bit windows files for icons
proc ::ico::FindResourcesPE {fh file} {
    variable RES

    # find the .rsrc section by reading the coff header
    binary scan [read $fh 24] x6sx12s sections headersize
    seek $fh $headersize current
    for {set i 0} {$i < $sections} {incr i} {
        binary scan [read $fh 40] a8x4ix4i type baserva base
        if {[string match .rsrc* $type]} {break}
    }
    # no resource section found = no icons
    if {![string match .rsrc* $type]} {
        close $fh
        return -1
    }
    seek $fh $base start

    seek $fh 12 current
    # number of entries in the resource table. each one is a different resource type
    set entries [expr {[getushort $fh] + [getushort $fh]}]
    for {set i 0} {$i < $entries} {incr i} {
        set type [getulong $fh]
        set offset [expr {[getulong $fh] & 0x7fffffff}]
        if {$type != 3 && $type != 14} {continue}
        set type [string map {3 icon 14 group} $type]

        set cur [tell $fh]
        seek $fh [expr {$base + $offset + 12}] start
        set entries2 [expr {[getushort $fh] + [getushort $fh]}]
        for {set i2 0} {$i2 < $entries2} {incr i2} {
            set name [getPEResName $fh $base [getulong $fh]]
            lappend RES($file,$type,names) $name
            set offset [expr {[getulong $fh] & 0x7fffffff}]

            set cur2 [tell $fh]
            seek $fh [expr {$offset + $base + 12}] start
            set entries3 [expr {[getushort $fh] + [getushort $fh]}]
            for {set i3 0} {$i3 < $entries3} {incr i3} {
                seek $fh 4 current
                set offset [expr {[getulong $fh] & 0x7fffffff}]
                set cur3 [tell $fh]

                seek $fh [expr {$offset + $base}] start
                set rva [getulong $fh]
                set RES($file,$type,$name,offset) [expr {$rva - $baserva + $base}]

                seek $fh $cur3 start
            }

            seek $fh $cur2 start
        }
        seek $fh $cur start
    }
    if {[array names RES $file,*] == ""} {
        close $fh
        return -1
    }
    foreach x [array names RES $file,group,*,offset] {
        seek $fh [expr {$RES($x) + 4}] start
        binary scan [read $fh 2] s a
        set x [lindex [split $x ,] 2]
        for {set i 0} {$i < $a} {incr i} {
            binary scan [read $fh 14] x12s n
            lappend RES($file,group,$x,members) $n
        }
    }
    foreach x [array names RES $file,icon,*,offset] {
        seek $fh [expr {$RES($x)}] start
        set x [lindex [split $x ,] 2]
        binary scan [read $fh 16] x4iix2s w h bpp
        set RES($file,icon,$x,data) [list $w [expr {$h / 2}] $bpp]
    }

    close $fh
    return [llength $RES($file,group,names)]
}

proc ::ico::getPEResName {fh start data} {
    if {($data & 0x80000000) != 0} {
        set cur [tell $fh]
        seek $fh [expr {($data & 0x7fffffff) + $start}] start
        set len [getushort $fh]
        set name [read $fh [expr {$len * 2}]]
        seek $fh $cur start
        return [encoding convertfrom unicode $name]
    } else {
        return $data
    }
}

interp alias {} ::ico::getIconListDLL    {} ::ico::getIconListEXE
interp alias {} ::ico::getIconMembersDLL {} ::ico::getIconMembersEXE
interp alias {} ::ico::getRawIconDataDLL {} ::ico::getRawIconDataEXE
interp alias {} ::ico::writeIconDLL      {} ::ico::writeIconEXE
interp alias {} ::ico::getIconListICL    {} ::ico::getIconListEXE
interp alias {} ::ico::getIconMembersICL {} ::ico::getIconMembersEXE
interp alias {} ::ico::getRawIconDataICL {} ::ico::getRawIconDataEXE
interp alias {} ::ico::writeIconICL      {} ::ico::writeIconEXE

package provide ico 1.0.3
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/ico/ico0.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
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
981
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
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
# ico.tcl --
#
# Win32 ico manipulation code
#
# Copyright (c) 2003 Aaron Faupell
# Copyright (c) 2003-2004 ActiveState Corporation
#
# RCS: @(#) $Id: ico0.tcl,v 1.2 2007/02/23 23:28:33 hobbs Exp $

# JH: speed has been considered in these routines, although they
# may not be fully optimized.  Running EXEtoICO on explorer.exe,
# which has nearly 100 icons, takes .2 secs on a P4/2.4ghz machine.
#

# Sample usage:
#	set file bin/wish.exe
#	set icos [::ico::getIconList $file]
#	set img  [::ico::getIcon $file 1 -format image]

package require Tcl 8.4

# Instantiate vars we need for this package
namespace eval ::ico {
    namespace export getIconList getIcon writeIcon copyIcon transparentColor clearCache EXEtoICO
    # stores cached indices of icons found
    variable  ICONS
    array set ICONS {}

    # used for 4bpp number conversion
    variable BITS
    array set BITS [list {} 0 0000 0 0001 1 0010 2 0011 3 0100 4 \
			0101 5 0110 6 0111 7 1000 8 1001 9 \
			1010 10 1011 11 1100 12 1101 13 1110 14 1111 15 \
			\
			00000 00 00001 0F 00010 17 00011 1F \
			00100 27 00101 2F 00110 37 00111 3F \
			01000 47 01001 4F 01010 57 01011 5F \
			01100 67 01101 6F 01110 77 01111 7F \
			10000 87 10001 8F 10010 97 10011 9F \
			10100 A7 10101 AF 10110 B7 10111 BF \
			11000 C7 11001 CF 11010 D7 11011 DF \
			11100 E7 11101 EF 11110 F7 11111 FF]
}


# getIconList --
#
# List of icons in the file (each element a list of w h and bpp)
#
# ARGS:
#	file	File to extra icon info from.
#	?-type?	Type of file.  If not specified, it is derived from
#		the file extension.  Currently recognized types are
#		EXE, DLL, ICO and ICL
#
# RETURNS:
#	list of icons' dimensions as tuples {width height bpp}
#
proc ::ico::getIconList {file args} {
    parseOpts type $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getIconList$type]]} {
	return -code error "unsupported file format $type"
    }
    getIconList$type [file normalize $file]
}

# getIcon --
#
# Get pixel data or image of icon @ index in file
#
# ARGS:
#	file		File to extra icon info from.
#	index		Index of icon in the file to use.  The ordering is the
#			same as returned by getIconList.  (0-based)
#	?-type?		Type of file.  If not specified, it is derived from
#			the file extension.  Currently recognized types are
#			EXE, DLL, ICO and ICL
#	?-format?	Output format. Must be one of "image" or "colors"
#			'image' will return the name of a Tk image.
#			'colors' will return a list of pixel values
#	?-name?		If output is image, use this as the name of Tk image
#			created
#
# RETURNS:
#	pixel data as a list that could be passed to 'image create'
#
proc ::ico::getIcon {file index args} {
    set name {}
    set format image
    parseOpts {type format name} $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getRawIconData$type]]} {
        return -code error "unsupported file format $type"
    }
    # ICODATA is a pure data type - not a real file
    if {$type ne "ICODATA"} {
	set file [file normalize $file]
    }
    set colors [eval [linsert [getRawIconData$type $file $index] 0 getIconAsColorList]]
    if {$format eq "image"} {
        return [createImage $colors $name]
    }
    return $colors
}

# writeIcon --
#
# Overwrite write icon @ index in file of specific type with depth/pixel data
#
# ARGS:
#	file	File to extra icon info from.
#	index	Index of icon in the file to use.  The ordering is the
#		same as returned by getIconList.  (0-based)
#	bpp	bit depth of icon we are writing
#	data	Either pixel color data (as returned by getIcon -format color)
#		or the name of a Tk image.
#	?-type?	Type of file.  If not specified, it is derived from
#		the file extension.  Currently recognized types are
#		EXE, DLL, ICO and ICL
#
# RETURNS:
#	Tk image based on the specified icon
#
proc ::ico::writeIcon {file index bpp data args} {
    parseOpts type $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands writeIcon$type]]} {
	return -code error "unsupported file format $type"
    }
    if {[llength $data] == 1} {
        set data [getColorListFromImage $data]
    } elseif {[lsearch -glob [join $data] #*] > -1} {
        set data [translateColors $data]
    }
    if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} {
	return -code error "invalid color depth"
    }
    set palette {}
    if {$bpp <= 8} {
	set palette [getPaletteFromColors $data]
	if {[lindex $palette 0] > (1 << $bpp)} {
	    return -code error "specified color depth too low"
	}
	set data  [lindex $palette 2]
	set palette [lindex $palette 1]
	append palette [string repeat \000 [expr {(1 << ($bpp + 2)) - [string length $palette]}]]
    }
    set and [getAndMaskFromColors $data]
    set xor [getXORFromColors $bpp $data]
    # writeIcon$type file index w h bpp palette xor and
    writeIcon$type [file normalize $file] $index \
	[llength [lindex $data 0]] [llength $data] $bpp $palette $xor $and
}


# copyIcon --
#
# Copies an icon directly from one file to another
#
# ARGS:
#	file	        File to extract icon info from.
#	index	        Index of icon in the file to use.  The ordering is the
#		        same as returned by getIconList.  (0-based)
#	?-fromtype?	Type of source file.  If not specified, it is derived from
#		        the file extension.  Currently recognized types are
#		        EXE, DLL, ICO and ICL
#	?-totype?	Type of destination file.  If not specified, it is derived from
#		        the file extension.  Currently recognized types are
#		        EXE, DLL, ICO and ICL
#
# RETURNS:
#	nothing
#
proc ::ico::copyIcon {f1 i1 f2 i2 args} {
    parseOpts {fromtype totype} $args
    if {![info exists fromtype]} {
        # $type wasn't specified - get it from the extension
        set fromtype [fileext $f1]
    }
    if {![info exists totype]} {
        # $type wasn't specified - get it from the extension
        set totype [fileext $f2]
    }
    if {![llength [info commands writeIcon$totype]]} {
	return -code error "unsupported file format $totype"
    }
    if {![llength [info commands getRawIconData$fromtype]]} {
	return -code error "unsupported file format $fromtype"
    }
    set src [getRawIconData$fromtype $f1 $i1]
    writeIcon $f2 $i2 [lindex $src 2] [eval getIconAsColorList $src] -type $totype
}

#
# transparentColor --
#
# Turns on transparency for all pixels in the image that match the color
#
# ARGS:
#	img	        Name of the Tk image to modify, or an image in color list format
#	color	        Color in #hex format which will be made transparent
#
# RETURNS:
#	the data or image after modification
#
proc ::ico::transparentColor {img color} {
    if {[llength $img] == 1} {
        package require Tk
        if {[string match "#*" $color]} {
            set color [scan $color "#%2x%2x%2x"]
        }
        set w [image width $img]
        set h [image height $img]
        for {set y 0} {$y < $h} {incr y} {
            for {set x 0} {$x < $w} {incr x} {
                if {[$img get $x $y] eq $color} {$img transparency set $x $y 1}
            }
        }
    } else {
        set y 0
        foreach row $img {
            set x 0
            foreach px $row {
                if {$px == $color} {lset img $y $x {}}
                incr x
            }
            incr y
        }
    }
    return $img
}

#
# clearCache --
#
# Clears the cache of icon offsets
#
# ARGS:
#	file	optional filename
#
#
# RETURNS:
#	nothing
#
proc ::ico::clearCache {{file {}}} {
    variable ICONS
    if {$file ne ""} {
	array unset ICONS $file,*
    } else {
	unset ICONS
	array set ICONS {}
    }
}

#
# EXEtoICO --
#
# Convert all icons found in exefile into a regular icon file
#
# ARGS:
#	exeFile	        Input EXE filename
#	icoFile	        Output ICO filename
#
# RETURNS:
#	nothing
#
proc ::ico::EXEtoICO {exeFile icoFile} {
    variable ICONS

    set file [file normalize $exeFile]
    set cnt  [SearchForIcos $file]
    set dir  {}
    set data {}
    
    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    for {set i 0} {$i <= $cnt} {incr i} {
        seek $fh $ICONS($file,$i) start
	set ico $ICONS($file,$i,data)
	eval [list lappend dir] $ico
	append data [read $fh [eval calcSize $ico 40]]
    }
    close $fh

    # write them out to a file
    set ifh [open $icoFile w+]
    fconfigure $ifh -eofchar {} -encoding binary -translation lf

    bputs $ifh sss 0 1 [expr {$cnt + 1}]
    set offset [expr {6 + (($cnt + 1) * 16)}]
    foreach {w h bpp} $dir {
	set colors 0
	if {$bpp <= 8} {set colors [expr {1 << $bpp}]}
	set s [calcSize $w $h $bpp 40]
	lappend fix $offset $s
	bputs $ifh ccccssii $w $h $colors 0 1 $bpp $s $offset
	set offset [expr {$offset + $s}]
    }
    puts -nonewline $ifh $data
    foreach {offset size} $fix {
	seek $ifh [expr {$offset + 20}] start
	bputs $ifh i $size
    }
    close $ifh
}

##
## Internal helper commands.
## Some may be appropriate for exposing later, but would need docs
## and make sure they "fit" in the API.
##

# gets the file extension as we use it internally (upper case, no '.')
proc ::ico::fileext {file} {
    return [string trimleft [string toupper [file extension $file]] .]
}

# helper proc to parse optional arguments to some of the public procs
proc ::ico::parseOpts {acc opts} {
    foreach {key val} $opts {
        set key [string trimleft $key -]
	if {[lsearch -exact $acc $key] >= 0} {
	    upvar $key $key
	    set $key $val
	} elseif {$key ne ""} {
	    return -code error "unknown option \"$key\": must be one of $acc"
	}
    }
}

# formats a single color from a binary decimal list format to the #hex format
proc ::ico::formatColor {r g b} {
    format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c]
}

# translates a color list from the #hex format to the decimal list format
#                                #0000FF                  {0 0 255}
proc ::ico::translateColors {colors} {
    set new {}
    foreach line $colors {
	set tline {}
	foreach x $line {
	    if {$x eq ""} {lappend tline {}; continue}
	    lappend tline [scan $x "#%2x%2x%2x"]
	}
	set new [linsert $new 0 $tline]
    }
    return $new
}

proc ::ico::getdword {fh} {
    binary scan [read $fh 4] i* tmp
    return $tmp
}

proc ::ico::getword {fh} {
    binary scan [read $fh 2] s* tmp
    return $tmp
}

proc ::ico::getulong {fh} {
    binary scan [read $fh 4] i tmp
    return [format %u $tmp]
}

proc ::ico::getushort {fh} {
    binary scan [read $fh 2] s tmp
    return [expr {$tmp & 0x0000FFFF}]
}

# binary puts
proc ::ico::bputs {fh format args} {
    puts -nonewline $fh [eval [list binary format $format] $args]
}

# creates a Tk image from a list of colors in the #hex format
proc ::ico::createImage {colors {name {}}} {
    package require Tk
    set h [llength $colors]
    set w [llength [lindex $colors 0]]
    if {$name ne ""} {
	set img [image create photo $name -width $w -height $h]
    } else {
	set img [image create photo -width $w -height $h]
    }
    if {0} {
	# if image supported "" colors as transparent pixels,
	# we could use this much faster op
	$img put -to 0 0 $colors
    } else {
	for {set x 0} {$x < $w} {incr x} {
	    for {set y 0} {$y < $h} {incr y} {
		set clr [lindex $colors $y $x]
		if {$clr ne ""} {
		    $img put -to $x $y $clr
		}
	    }
	}
    }
    return $img
}

# return a list of colors in the #hex format from raw icon data
# returned by readDIB
proc ::ico::getIconAsColorList {w h bpp palette xor and} {
    # Create initial empty color array that we'll set indices in
    set colors {}
    set row    {}
    set empty  {}
    for {set x 0} {$x < $w} {incr x} { lappend row $empty }
    for {set y 0} {$y < $h} {incr y} { lappend colors $row }

    set x 0
    set y [expr {$h-1}]
    if {$bpp == 1} {
	binary scan $xor B* xorBits
	foreach i [split $xorBits {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		lset colors $y $x [lindex $palette $i]
	    }
	    incr x
	}
    } elseif {$bpp == 4} {
	variable BITS
	binary scan $xor B* xorBits
	set i 0
	foreach a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		set bits [string range $xorBits $i [expr {$i+3}]]
		lset colors $y $x [lindex $palette $BITS($bits)]
	    }
	    incr i 4
	    incr x
	}
    } elseif {$bpp == 8} {
	foreach i [split $xor {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		lset colors $y $x [lindex $palette [scan $i %c]]
	    }
	    incr x
	}
    } elseif {$bpp == 16} {
        variable BITS
        binary scan $xor b* xorBits
        set i 0
	foreach a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		set b1 [string range $xorBits      $i        [expr {$i+4}]]
		set b2 [string range $xorBits [expr {$i+5}]  [expr {$i+9}]]
		set b3 [string range $xorBits [expr {$i+10}] [expr {$i+14}]]
		lset colors $y $x "#$BITS($b3)$BITS($b2)$BITS($b1)"
	    }
	    incr i 16
	    incr x
	}
    } elseif {$bpp == 24} {
	foreach {b g r} [split $xor {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		lset colors $y $x [formatColor $r $g $b]
	    }
	    incr x
	}
    } elseif {$bpp == 32} {
	foreach {b g r n} [split $xor {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		lset colors $y $x [formatColor $r $g $b]
	    }
	    incr x
	}
    }
    return $colors
}

# creates a binary formatted AND mask by reading a list of colors in the decimal list format
# and checking for empty colors which designate transparency
proc ::ico::getAndMaskFromColors {colors} {
    set and {}
    foreach line $colors {
	set l {}
	foreach x $line {append l [expr {$x eq ""}]}
	append l [string repeat 0 [expr {[string length $l] % 32}]]
	foreach {a b c d e f g h} [split $l {}] {
	    append and [binary format B8 $a$b$c$d$e$f$g$h]
	}
    }
    return $and
}

# creates a binary formatted XOR mask in the specified depth format from
# a list of colors in the decimal list format
proc ::ico::getXORFromColors {bpp colors} {
    set xor {}
    if {$bpp == 1} {
	foreach line $colors {
	    foreach {a b c d e f g h} $line {
		foreach x {a b c d e f g h} {
		    if {[set $x] == ""} {set $x 0}
		}
		binary scan $a$b$c$d$e$f$g$h bbbbbbbb h g f e d c b a
		append xor [binary format b8 $a$b$c$d$e$f$g$h]
	    }
	}
    } elseif {$bpp == 4} {
	foreach line $colors {
	    foreach {a b} $line {
		if {$a == ""} {set a 0}
		if {$b == ""} {set b 0}
		binary scan $a$b b4b4 b a
		append xor [binary format b8 $a$b]
	    }
	}
    } elseif {$bpp == 8} {
	foreach line $colors {
	    foreach x $line {
		if {$x == ""} {set x 0}
		append xor [binary format c $x]
	    }
	}
    } elseif {$bpp == 24} {
	foreach line $colors {
	    foreach x $line {
		if {![llength $x]} {
		    append xor [binary format ccc 0 0 0]
		} else {
		    foreach {a b c n} $x {
			append xor [binary format ccc $c $b $a]
		    }
		}
	    }
	}
    } elseif {$bpp == 32} {
	foreach line $colors {
	    foreach x $line {
		if {![llength $x]} {
		    append xor [binary format cccc 0 0 0 0]
		} else {
		    foreach {a b c n} $x {
			if {$n == ""} {set n 0}
			append xor [binary format cccc $c $b $a $n]
		    }
		}
	    }
	}
    }
    return $xor
}

# translates a Tk image into a list of colors in the {r g b} format
# one element per pixel and {} designating transparent
# used by writeIcon when writing from a Tk image
proc ::ico::getColorListFromImage {img} {
    package require Tk
    set w [image width $img]
    set h [image height $img]
    set r {}
    for {set y [expr $h - 1]} {$y > -1} {incr y -1} {
	set l {}
	for {set x 0} {$x < $w} {incr x} {
	    if {[$img transparency get $x $y]} {
		lappend l {}
	    } else {
		lappend l [$img get $x $y]
	    }
	}
	lappend r $l
    }
    return $r
}

# creates a palette from a list of colors in the decimal list format
# a palette consists of 3 values, the number of colors, the palette entry itself,
# and the color list transformed to point to palette entries instead of color names
# the palette entry itself is stored as 32bpp in "G B R padding" order
proc ::ico::getPaletteFromColors {colors} {
    set palette "\x00\x00\x00\x00"
    array set tpal {{0 0 0} 0}
    set new {}
    set i 1
    foreach line $colors {
	set tline {}
	foreach x $line {
	    if {$x eq ""} {lappend tline {}; continue}
	    if {![info exists tpal($x)]} {
		foreach {a b c n} $x {
		    append palette [binary format cccc $c $b $a 0]
		}
		set tpal($x) $i
		incr i
	    }
	    lappend tline $tpal($x)
	}
	lappend new $tline
    }
    return [list $i $palette $new]
}

# calculate byte size of an icon.
# often passed $w twice because $h is double $w in the binary data
proc ::ico::calcSize {w h bpp {offset 0}} {
    set s [expr {int(($w*$h) * ($bpp/8.0)) \
		     + ((($w*$h) + ($h*($w%32)))/8) + $offset}]
    if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] }
    return $s
}

# read a Device Independent Bitmap from the current offset, return:
#	{width height depth palette XOR_mask AND_mask}
proc ::ico::readDIB {fh} {
    binary scan [read $fh 16] x4iix2s w h bpp
    set h [expr {$h / 2}]
    seek $fh 24 current

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
	set colors [read $fh [expr {1 << ($bpp + 2)}]]
	foreach {b g r x} [split $colors {}] {
	    lappend palette [formatColor $r $g $b]
	}
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
	# do nothing here
    } else {
	return -code error "unsupported color depth: $bpp"
    }

    set xor  [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]]
    set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]]

    set and {}
    set row [expr {((($w - 1) / 32) * 32 + 32) / 8}]
    set len [expr {$row * $h}]
    for {set i 0} {$i < $len} {incr i $row} {
	binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp
	append and $tmp
    }

    return [list $w $h $bpp $palette $xor $and]
}

# read a Device Independent Bitmap from raw data, return:
#	{width height depth palette XOR_mask AND_mask}
proc ::ico::readDIBFromData {data loc} {
    # Read info from location
    binary scan $data @${loc}x4iix2s w h bpp
    set h [expr {$h / 2}]
    # Move over w/h/bpp info + magic offset to start of DIB
    set cnt [expr {$loc + 16 + 24}]

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
	# Could do: [binary scan $data @${cnt}c$len colors]
	# and iter over colors, but this is more consistent with $fh version
	set len    [expr {1 << ($bpp + 2)}]
	set colors [string range $data $cnt [expr {$cnt + $len - 1}]]
	foreach {b g r x} [split $colors {}] {
	    lappend palette [formatColor $r $g $b]
	}
	incr cnt $len
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
	# do nothing here
    } else {
	return -code error "unsupported color depth: $bpp"
    }

    # Use -1 to account for string range inclusiveness
    set end  [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}]
    set xor  [string range $data $cnt $end]
    set and1 [string range $data [expr {$end + 1}] \
		  [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]]

    set and {}
    set row [expr {((($w - 1) / 32) * 32 + 32) / 8}]
    set len [expr {$row * $h}]
    for {set i 0} {$i < $len} {incr i $row} {
	# Has to be decoded by row, in order
	binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp
	append and $tmp
    }

    return [list $w $h $bpp $palette $xor $and]
}

proc ::ico::getIconListICO {file} {
    set fh [open $file r]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    # both words must be read to keep in sync with later reads
    if {"[getword $fh] [getword $fh]" ne "0 1"} {
	return -code error "not an icon file"
    }
    set num [getword $fh]
    set r {}
    for {set i 0} {$i < $num} {incr i} {
	set info {}
	lappend info [scan [read $fh 1] %c] [scan [read $fh 1] %c]
	set bpp [scan [read $fh 1] %c]
	if {$bpp == 0} {
	    set orig [tell $fh]
	    seek $fh 9 current
	    seek $fh [expr {[getdword $fh] + 14}] start
	    lappend info [getword $fh]
	    seek $fh $orig start
	} else {
	    lappend info [expr {int(sqrt($bpp))}]
	}
	lappend r $info
	seek $fh 13 current
    }
    close $fh
    return $r
}

proc ::ico::getIconListICODATA {data} {
    if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} {
	return -code error "not icon data"
    }
    set r {}
    set cnt 6
    for {set i 0} {$i < $num} {incr i} {
	if {[binary scan $data @${cnt}ccc w h bpp] != 3} {
	    return -code error "error decoding icon data"
	}
	incr cnt 3
	set info [list $w $h]
	if {$bpp == 0} {
	    set off [expr {$cnt + 9}]
	    binary scan $data @${off}i off
	    incr off 14
	    binary scan $data @${off}s bpp
	    lappend info $bpp
	} else {
	    lappend info [expr {int(sqrt($bpp))}]
	}
	lappend r $info
	incr cnt 13
    }
    return $r
}

proc ::ico::getIconListBMP {file} {
    set fh [open $file]
    if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" }
    seek $fh 14 start
    binary scan [read $fh 16] x4iix2s w h bpp
    close $fh
    return [list $w $h $bpp]
}

proc ::ico::getIconListEXE {file} {
    variable ICONS

    set file [file normalize $file]
    set cnt  [SearchForIcos $file]

    set icons [list]
    for {set i 0} {$i <= $cnt} {incr i} {
	lappend icons $ICONS($file,$i,data)
    }

    return $icons
}

# returns an icon in the form:
#	{width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataICO {file index} {
    set fh [open $file r]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    # both words must be read to keep in sync with later reads
    if {"[getword $fh] [getword $fh]" ne "0 1"} {
        close $fh
	return -code error "not an icon file"
    }
    if {$index < 0 || $index >= [getword $fh]} {
	return -code error "index out of range"
    }

    seek $fh [expr {(16 * $index) + 12}] current
    seek $fh [getdword $fh] start

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIB $fh]

    close $fh
    return $dib
}

proc ::ico::getRawIconDataICODATA {data index} {
    if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} {
	return -code error "not icon data"
    }
    if {$index < 0 || $index >= $num} {
	return -code error "index out of range: must be between 0 and $num"
    }
    # Move to ico location
    set cnt [expr {6 + (16 * $index) + 12}]
    binary scan $data @${cnt}i loc

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIBFromData $data $loc]

    return $dib
}

# returns an icon in the form:
#	{width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataBMP {file {index 0}} {
    if {$index != 0} {return -code error "index out of range"}
    set fh [open $file]
    if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" }
    seek $fh 14 start
    binary scan [read $fh 16] x4iix2s w h bpp
    seek $fh 24 current

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
	set colors [read $fh [expr {1 << ($bpp + 2)}]]
	foreach {b g r x} [split $colors {}] {
	    lappend palette [formatColor $r $g $b]
	}
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
	# do nothing here
    } else {
	return -code error "unsupported color depth: $bpp"
    }

    set xor  [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]]
    set and [string repeat 0 [expr {$w * $h}]]
    close $fh

    return [list $w $h $bpp $palette $xor $and]
}

# returns an icon in the form:
#	{width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataEXE {file index} {
    variable ICONS

    set file [file normalize $file]
    set cnt  [SearchForIcos $file $index]

    if {$cnt < $index} { return -code error "index out of range" }

    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    seek $fh $ICONS($file,$index) start

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIB $fh]
    close $fh
    return $dib
}

proc ::ico::writeIconICO {file index w h bpp palette xor and} {
    if {![file exists $file]} {
	set fh [open $file w+]
	fconfigure $fh -eofchar {} -encoding binary -translation lf
	bputs $fh sss 0 1 0
	seek $fh 0 start
    } else {
	set fh [open $file r+]
	fconfigure $fh -eofchar {} -encoding binary -translation lf
    }
    if {[file size $file] > 4 && "[getword $fh] [getword $fh]" ne "0 1"} {
	close $fh
	return -code error "not an icon file"
    }
    set num [getword $fh]
    if {$index eq "end"} { set index $num }
    if {$index < 0 || $index > $num} {
	close $fh
	return -code error "index out of range"
    }
    set colors 0
    if {$bpp <= 8} {set colors [expr {1 << $bpp}]}
    set size [expr {[string length $palette] + [string length $xor] + [string length $and]}]

    # if we are adding a new icon at the end
    if {$index == $num} {
        # increment the icon count
	seek $fh -2 current
	bputs $fh s [expr {$num + 1}]
	# save all the data past the icon dir entries
	seek $fh [expr {$num * 16}] current
	set olddata [read $fh]
	# increment all the offsets in the existing dir entries by 16 to account for our new entry
	set cur 0
	while {$cur < $num} {
	    seek $fh [expr {($cur * 16) + 18}] start
	    set toff [getdword $fh]
	    seek $fh -4 current
	    bputs $fh i [expr {$toff + 16}]
	    incr cur
	}
	# insert new icon dir entry
	bputs $fh ccccss $w $h $colors 0 0 $bpp
	bputs $fh ii [expr {$size + 40}] [expr {[string length $olddata] + [tell $fh] + 8}]
	# put all the icon data back
	puts -nonewline $fh $olddata
	# put our new icon at the end
	bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0
	puts -nonewline $fh $palette
	puts -nonewline $fh $xor
	puts -nonewline $fh $and
    } else {
        # we are overwriting an icon - not necesarily the same size
        # get existing icon offset and length
	seek $fh [expr {($index * 16) + 8}] current
	set len [getdword $fh]
	set offset [getdword $fh]
	# adjust offset in existing icon dir entries higher than our new icon to account
	# for new icon length
	set cur [expr {$index + 1}]
	while {$cur < $num} {
	    seek $fh [expr {($cur * 16) + 18}] start
	    set toff [getdword $fh]
	    seek $fh -4 current
	    bputs $fh i [expr {$toff + (($size + 40) - $len)}]
	    incr cur
	}
	# save all data after new icon
	seek $fh [expr {$offset + $len}] start
	set olddata [read $fh]
	# overwrite icon dir entry
	seek $fh [expr {($index * 16) + 6}] start
	bputs $fh ccccssi $w $h $colors 0 0 $bpp [expr {$size + 40}]
	# insert new icon and saved data
	seek $fh $offset start
	bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0
	puts -nonewline $fh $palette
	puts -nonewline $fh $xor
	puts -nonewline $fh $and
	puts -nonewline $fh $olddata
    }
    close $fh
}

proc ::ico::writeIconICODATA {file index w h bpp palette xor and} {
    if {$index != 0} {return -code error "index out of range"}
    upvar 2 [file tail $file] data
    set data [binary format sss 0 1 1]
    set colors 0
    if {$bpp <= 8} {set colors [expr {1 << $bpp}]}
    set size [expr {[string length $palette] + [string length $xor] + [string length $and]}]
    append data [binary format ccccssii $w $h $colors 0 0 $bpp [expr {$size + 40}] 22]
    append data [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0]
    append data $palette $xor $and
}

proc ::ico::writeIconBMP {file index w h bpp palette xor and} {
    if {$index != 0} {return -code error "index out of range"}
    set fh [open $file w+]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    set size [expr {[string length $palette] + [string length $xor]}]
    # bitmap header: magic, file size, reserved, reserved, offset of bitmap data
    bputs $fh a2issi BM [expr {14 + 40 + $size}] 0 0 54
    bputs $fh iiissiiiiii 40 $w $h 1 $bpp 0 $size 0 0 0 0
    puts -nonewline $fh $palette$xor
    close $fh
}

proc ::ico::writeIconEXE {file index w h bpp palette xor and} {
    variable ICONS

    set file [file normalize $file]
    set cnt  [SearchForIcos $file $index]

    if {$index eq "end"} {set index $cnt}
    if {$cnt < $index} { return -code error "index out of range" }

    if {[list $w $h $bpp] != $ICONS($file,$index,data)} {
	return -code error "icon format differs from original"
    }
    
    set fh [open $file r+]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    seek $fh [expr {$ICONS($file,$index) + 40}] start

    puts -nonewline $fh $palette$xor$and
    close $fh
}

proc ::ico::SearchForIcos {file {index -1}} {
    variable ICONS	  ; # stores icos offsets by index, and [list w h bpp]

    if {[info exists ICONS($file,$index)]} {
	return $ICONS($file,$index)
    }
    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    if {[read $fh 2] ne "MZ"} {
	close $fh
	return -code error "unknown file format"
    }
    seek $fh 60 start
    seek $fh [getword $fh] start
    set sig [read $fh 4]
    seek $fh -4 current
    if {$sig eq "PE\000\000"} {
        return [SearchForIcosPE $fh $file $index]
    } elseif {[string match NE* $sig]} {
        return [SearchForIcosNE $fh $file $index]
    } else {
        return -code error "unknown file format"
    }
}

# parse the resource table of 16 bit windows files for icons
proc ::ico::SearchForIcosNE {fh file index} {
    variable ICONS ; # stores icos offsets by index, and [list w h bpp]
    set idx   -1   ; # index of icos found

    seek $fh 36 current
    seek $fh [expr {[getword $fh] - 38}] current
    
    set base [tell $fh]
    set shift [expr {int(pow(2, [getushort $fh]))}]
    while {[set type [expr {[getushort $fh] & 0x7fff}]] != 0} {
        set num [getushort $fh]
        if {$type != 3} {
            seek $fh [expr {($num * 12) + 4}] current
            continue
        }
        seek $fh 4 current
        for {set i 0} {$i < $num} {incr i} {
            incr idx
            set ICONS($file,$idx) [expr {[getushort $fh] * $shift}]
            seek $fh 10 current
            set cur [tell $fh]

            seek $fh $ICONS($file,$idx) start
            binary scan [read $fh 16] x4iix2s w h bpp
            set ICONS($file,$idx,data) [list $w [expr {$h / 2}] $bpp]

            seek $fh $cur start
        }
        close $fh
        return $idx
    }
    close $fh
    return -1
}

# parse the resource tree of 32 bit windows files for icons
proc ::ico::SearchForIcosPE {fh file index} {
    variable ICONS ; # stores icos offsets by index, and [list w h bpp]
    set idx -1     ; # index of icos found

    # find the .rsrc section by reading the coff header
    binary scan [read $fh 24] x6sx12s sections headersize
    seek $fh $headersize current
    for {set i 0} {$i < $sections} {incr i} {
        binary scan [read $fh 40] a8x4ix4i type baserva base
        if {[string match .rsrc* $type]} {break}
    }
    # no resource section found = no icons
    if {![string match .rsrc* $type]} {
        close $fh
        return -1
    }
    seek $fh $base start

    seek $fh 12 current
    set entries [expr {[getushort $fh] + [getushort $fh]}]
    for {set i 0} {$i < $entries} {incr i} {
        set name [getulong $fh]
        set offset [expr {[getulong $fh] & 0x7fffffff}]
        if {$name != 3} {continue}
        seek $fh [expr {$base + $offset + 12}] start

        set entries2 [expr {[getushort $fh] + [getushort $fh]}]
        for {set i2 0} {$i2 < $entries2} {incr i2} {
            seek $fh 4 current
            set offset [expr {[getulong $fh] & 0x7fffffff}]
            set cur2 [tell $fh]
            seek $fh [expr {$offset + $base + 12}] start

            set entries3 [expr {[getushort $fh] + [getushort $fh]}]
            for {set i3 0} {$i3 < $entries3} {incr i3} {
                seek $fh 4 current
                set offset [expr {[getulong $fh] & 0x7fffffff}]
                set cur3 [tell $fh]
                seek $fh [expr {$offset + $base}] start

                set rva [getulong $fh]
                incr idx
                set ICONS($file,$idx) [expr {$rva - $baserva + $base}]
                seek $fh $ICONS($file,$idx) start
                binary scan [read $fh 16] x4iix2s w h bpp
                set ICONS($file,$idx,data) [list $w [expr {$h / 2}] $bpp]

                seek $fh $cur3 start
            }
            seek $fh $cur2 start
        }
        close $fh
        return $idx
    }
    close $fh
    return -1
}

interp alias {} ::ico::getIconListDLL    {} ::ico::getIconListEXE
interp alias {} ::ico::getRawIconDataDLL {} ::ico::getRawIconDataEXE
interp alias {} ::ico::writeIconDLL      {} ::ico::writeIconEXE
interp alias {} ::ico::getIconListICL    {} ::ico::getIconListEXE
interp alias {} ::ico::getRawIconDataICL {} ::ico::getRawIconDataEXE
interp alias {} ::ico::writeIconICL      {} ::ico::writeIconEXE

proc ::ico::showaux {files} {
    if {[llength $files]} {
	set file [lindex $files 0]
	Show $f
	update
	after 50 [list ::ico::showaux [lrange $files 1 end]]
    }
}

# Application level command: Find icons in a file and show them.
proc ::ico::Show {file args} {
    package require BWidget
    
    set parent .
    parseOpts {type parent} $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }

    set file  [file normalize $file]
    set icos  [getIconList $file -type $type]
    set wname [string map {. _ : _} $file]

    if {$parent eq "."} { set w ""} else { set w $parent }

    set mf $w.mainsw
    if {![winfo exists $mf]} {
	set sw [ScrolledWindow $mf]
	set sf [ScrollableFrame $mf.sf -constrainedwidth 1]
	$sw setwidget $sf
	pack $sw -fill both -expand 1
	grid columnconfigure [$mf.sf getframe] 0 -weight 1
    }
    set mf [$mf.sf getframe]

    set lf $mf.f$wname
    if {[winfo exists $lf]} { destroy $lf }
    if {![llength $icos]} {
	label $lf -text "No icons in '$file'" -anchor w
	grid $lf -sticky ew
    } else {
	labelframe $lf -text "[llength $icos] Icons in '$file'"
	grid $lf -sticky news
	set sw [ScrolledWindow $lf.sw$wname]
	set height 48
	set fh [expr {[font metrics [$lf cget -font] -linespace] + 4}]
	set sf [ScrollableFrame $lf.sf$wname -constrainedheight 1 \
		    -height [expr {$height + $fh}]]
	$sw setwidget $sf
	set sf [$sf getframe]
	pack $sw -fill both -expand 1
	set col 0
	for {set x 0} {$x < [llength $icos]} {incr x} {
	    # catch in case theres any icons with unsupported color
	    if {[catch {getIcon $file $x -type $type} img]} {
		set txt "ERROR: $img"
		set lbl [label $sf.lbl$wname-$x -anchor w -text $txt]
		grid $lbl -sticky s -row 0 -column [incr col]
	    } else {
		set txt [eval {format "$x: %sx%s %sbpp"} [lindex $icos $x]]
		set lbl [label $sf.lbl$wname-$x -anchor w -text $txt \
			     -compound top -image $img]
		if {[image height $img] > $height} {
		    set height [image height $img]
		    $lf.sf$wname configure -height [expr {$height + $fh}]
		}
		grid $lbl -sticky s -row 0 -column [incr col]
	    }
	    update idletasks
	}
    }
    grid rowconfigure $parent 0 -weight 1
    grid columnconfigure $parent 0 -weight 1
}

package provide ico 0.3.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/ico/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
# pkgIndex.tcl --
#
# Copyright (c) 2003 ActiveState Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: pkgIndex.tcl,v 1.8 2008/03/12 07:25:49 hobbs Exp $

package ifneeded ico 0.3.1 [list source [file join $dir ico0.tcl]]
package ifneeded ico 1.0.3 [list source [file join $dir ico.tcl]]
<
<
<
<
<
<
<
<
<


















Deleted scriptlibs/tklib0.5/ipentry/ipentry.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
# ipentry.tcl --
#
#       An entry widget for IP addresses.
#
# Copyright (c) 2003-2008 Aaron Faupell <afaupell@users.sourceforge.net>
# Copyright (c) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
#  
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: ipentry.tcl,v 1.19 2009/01/21 07:10:03 afaupell Exp $

package require Tk
package provide ipentry 0.3

namespace eval ::ipentry {
    namespace export ipentry ipentry6
    # copy all the bindings from Entry class to our own IPEntrybindtag class
    foreach x [bind Entry] {
        bind IPEntrybindtag $x [bind Entry $x]
    }
    # then replace certain keys we are interested in with our own
    bind IPEntrybindtag <KeyPress>         {::ipentry::keypress %W %K}
    bind IPEntrybindtag <BackSpace>        {::ipentry::backspace %W}
    bind IPEntrybindtag <period>           {::ipentry::dot %W}
    bind IPEntrybindtag <Key-Right>        {::ipentry::arrow %W %K}
    bind IPEntrybindtag <Key-Left>         {::ipentry::arrow %W %K}
    bind IPEntrybindtag <FocusIn>          {::ipentry::FocusIn %W}
    bind IPEntrybindtag <FocusOut>         {::ipentry::FocusOut %W}
    bind IPEntrybindtag <<Paste>>          {::ipentry::Paste %W CLIPBOARD}
    bind IPEntrybindtag <<PasteSelection>> {::ipentry::Paste %W PRIMARY}
    
    # copy all the bindings from IPEntrybindtag
    foreach x [bind IPEntrybindtag] {
        bind IPEntrybindtag6 $x [bind IPEntrybindtag $x]
    }
    # and replace certain keys with ip6 bindings
    bind IPEntrybindtag6 <KeyPress>         {::ipentry::keypress %W %K 6}
    bind IPEntrybindtag6 <colon>            {::ipentry::dot %W}
    bind IPEntrybindtag6 <period>           {}

    #if {[package vsatisfies [package provide Tk] 8.5]} {
    #     ttk::style layout IPEntryFrame {
    #         Entry.field -sticky news -border 1 -children {
    #             IPEntryFrame.padding -sticky news
    #         }
    #     }
    #     bind [winfo class .] <<ThemeChanged>> \
    #         [list +ttk::style layout IPEntryFrame \
    #              [ttk::style layout IPEntryFrame]]
    # }
}

# ipentry --
#
# main entry point - construct a new ipentry widget
#
# ARGS:
#       w       path name of widget to create
#
#               see ::ipentry::configure for args
#
# RETURNS:
#       the widget path name
#
proc ::ipentry::ipentry {w args} {
    upvar #0 [namespace current]::widget_$w state
    #set state(themed) [package vsatisfies [package provide Tk] 8.5]
    set state(themed) 0
    foreach {name val} $args {
        if {$name eq "-themed"} {
            set state(themed) $val
        }
    }
    if {$state(themed)} {
        ttk::frame $w -style IPEntryFrame -class IPEntry -takefocus 0
    } else {
        frame $w -relief sunken -class IPEntry;#-padx 5
    }
    foreach x {0 1 2 3} y {d1 d2 d3 d4} {
        #if {$state(themed)} {
        #    ttk::entry $w.$x -width 3 -justify center
        #    ttk::label $w.$y -text .
        #}
        entry $w.$x -borderwidth 0 -width 3 -highlightthickness 0 \
            -justify center -takefocus 0
        label $w.$y -borderwidth 0 -font [$w.$x cget -font] -width 1 -text . \
            -justify center -cursor [$w.$x cget -cursor] \
             -background [$w.$x cget -background] \
             -disabledforeground [$w.$x cget -disabledforeground]
        pack $w.$x $w.$y -side left
        bindtags $w.$x [list $w.$x IPEntrybindtag . all]
        bind $w.$y <Button-1> {::ipentry::dotclick %W %x}
    }
    destroy $w.d4
    $w.0 configure -takefocus 1
    if {$state(themed)} {
        pack configure $w.0 -padx {1 0} -pady 1
        pack configure $w.3 -padx {0 1} -pady 1 -fill x -expand 1
        $w.3 configure -justify left
    } else {
        $w configure -borderwidth [lindex [$w.0 configure -bd] 3]
            #-background [$w.0 cget -bg]
    }
    rename ::$w ::ipentry::_$w
    # redirect the widget name command to the widgetCommand dispatcher
    interp alias {} ::$w {} ::ipentry::widgetCommand $w
    bind $w <Destroy> [list ::ipentry::destroyWidget $w]
    if {[llength $args] > 0} {
        eval [list $w configure] $args
    }
    return $w
}

# ipentry --
#
# main entry point - construct a new ipentry6 widget
#
# ARGS:
#       w       path name of widget to create
#
#               see ::ipentry::configure for args
#
# RETURNS:
#       the widget path name
#
proc ::ipentry::ipentry6 {w args} {
    upvar #0 [namespace current]::widget_$w state
    #set state(themed) [package vsatisfies [package provide Tk] 8.5]
    set state(themed) 0
    foreach {name val} $args {
        if {$name eq "-themed"} {
            set state(themed) $val
        }
    }
    if {$state(themed)} {
        ttk::frame $w -style IPEntryFrame -class IPEntry -takefocus 0
    } else {
        frame $w -relief sunken -class IPEntry;#-padx 5
    }
    foreach x {0 1 2 3 4 5 6 7} y {d1 d2 d3 d4 d5 d6 d7 d8} {
        entry $w.$x -borderwidth 0 -width 4 -highlightthickness 0 \
            -justify center -takefocus 0
        label $w.$y -borderwidth 0 -font [$w.$x cget -font] -width 1 -text : \
            -justify center -cursor [$w.$x cget -cursor] \
            -background [$w.$x cget -background] \
            -disabledforeground [$w.$x cget -disabledforeground]
        pack $w.$x $w.$y -side left
        bindtags $w.$x [list $w.$x IPEntrybindtag6 . all]
        bind $w.$y <Button-1> {::ipentry::dotclick %W %x}
    }
    destroy $w.d8
    $w.0 configure -takefocus 1
    if {$state(themed)} {
        pack configure $w.0 -padx {1 0} -pady 1
        pack configure $w.7 -padx {0 1} -pady 1 -fill x -expand 1
        $w.7 configure -justify left
    } else {
        $w configure -borderwidth [lindex [$w.0 configure -bd] 3]
            #-background [$w.0 cget -bg]
    }
    rename ::$w ::ipentry::_$w
    # redirect the widget name command to the widgetCommand dispatcher
    interp alias {} ::$w {} ::ipentry::widgetCommand6 $w
    bind $w <Destroy> [list ::ipentry::destroyWidget $w]
    if {[llength $args] > 0} {
        eval [list $w configure] $args
    }
    return $w
}

# keypress --
#
# called every time a key is pressed in an ipentry widget
# used by both ipentry and ipentry6
#
# ARGS:
#       w       window argument (%W) from the event binding
#       key     the keysym (%K) from the event
#       type    empty string or "6" depending on the type of ipentry
#
# RETURNS:
#       nothing
#
proc ::ipentry::keypress {w key {type {}}} {
    if {![validate$type $w $key]} { return }
    # sel.first and sel.last throw an error if the selection isnt in $w
    catch {
        set insert [$w index insert]
        # if a key is pressed while there is a selection then delete the
        # selected chars
        if {([$w index sel.first] <= $insert) && ([$w index sel.last] >= $insert)} {
            $w delete sel.first sel.last
        }
    }
    $w insert insert $key
    ::ipentry::updateTextvar $w
}

# backspace --
#
# called when the Backspace key is pressed in an ipentry widget
# used by both ipentry and ipentry6
#
# try to act like a normal backspace except if the cursor is at index 0
# of one entry we need to move to the end of the preceding entry
#
# ARGS:
#       w       window argument (%W) from the event binding
#
# RETURNS:
#       nothing
#
proc ::ipentry::backspace {w} {
    if {[$w selection present]} {
        $w delete sel.first sel.last
    } else {
        if {[$w index insert] == 0} {
            set w [skip $w prev]
        }
        $w delete [expr {[$w index insert] - 1}]
    }
    ::ipentry::updateTextvar $w
}

# dot --
#
# called when the dot (Period) key is pressed in an ipentry widget
# used by both ipentry and ipentry6
#
# treat the current entry as done and move to the next entry field
#
# ARGS:
#       w       window argument (%W) from the event binding
#
# RETURNS:
#       nothing
#
proc ::ipentry::dot {w} {
    if {[string length [$w get]] > 0} {
        skip $w next 1
    }
    ::ipentry::updateTextvar $w
}

# FocusIn --
#
# called when the focus enters any of the child widgets of an ipentry
# used by both ipentry and ipentry6
#
# clear the selection of all child widgets other than the one with focus
#
# ARGS:
#       w       window argument (%W) from the event binding
#
# RETURNS:
#       nothing
#
proc ::ipentry::FocusIn {w} {
    set p [winfo parent $w]
    foreach x {0 1 2 3 4 5 6 7} {
        if {![winfo exists $p.$x]} { break }
        if {"$p.$x" != $w} {
            $p.$x selection clear
        }
    }
}

# FocusOut --
#
# called when the focus leaves any of the child widgets of an ipentry
# used by both ipentry and ipentry6
#
# dont allow a 0 in the first quad
#
# ARGS:
#       w       window argument (%W) from the event binding
#
# RETURNS:
#       nothing
#
proc ::ipentry::FocusOut {w} {
    set s [$w get]
    if {[string match {*.0} $w] && $s != "" && $s < 1} {
        $w delete 0 end
        $w insert end 1
        ::ipentry::updateTextvar $w
    }
    # trim off leading zeros
    if {[string length $s] > 1} {
        set n [string trimleft $s 0]
        if {$n eq ""} { set n 0 }
        if {![string equal $n $s]} {
            $w delete 0 end
            $w insert end $n
        }
    }
}

# Paste --
#
# called from the <<Paste>> virtual event
# used by ipentry only
#
# clear the selection of all child widgets other than the one with focus
#
# ARGS:
#       w       window argument (%W) from the event binding
#       sel     one of CLIPBOARD or PRIMARY
#
# RETURNS:
#       nothing
#
proc ::ipentry::Paste {w sel} {
    if {[catch {::tk::GetSelection $w $sel} paste]} { return }
    $w delete 0 end
    foreach char [split $paste {}] {
        # ignore everything except dots and digits
        if {![string match {[0123456789.]} $char]} { continue }
        if {$char != "."} {
            $w insert end $char
        }
        # if value is over 255 truncate it
        if {[$w get] > 255} {
            $w delete 0 end
            $w insert 0 255
        }
        # if char is a . then get the index of the current entry
        # and update $w to point to the next entry
        if {$char == "."} {
            set n [string index $w end]
            if { $n >= 3 } { return }
            set w [string trimright $w "0123"][expr {$n + 1}]
            $w delete 0 end
            continue
        }
    }
    ::ipentry::updateTextvar $w
}

# Paste6 --
#
# called from the <<Paste>> virtual event
# used by both ipentry6 only
#
# clear the selection of all child widgets other than the one with focus
#
# ARGS:
#       w       window argument (%W) from the event binding
#       sel     one of CLIPBOARD or PRIMARY
#
# RETURNS:
#       nothing
#
proc ::ipentry::Paste6 {w sel} {
    if {[catch {::tk::GetSelection $w $sel} paste]} { return }
    $w delete 0 end
    foreach char [split $paste {}] {
        # ignore everything except colons and hex digits
        if {![string match {[0123456789abcdefABCDEF:]} $char]} { continue }
        if {$char != ":"} {
            $w insert end $char
        }
        # if char is a : then get the index of the current entry
        # and update $w to point to the next entry
        if {$char == ":"} {
            set n [string index $w end]
            if { $n >= 7 } { return }
            set w [string trimright $w "01234567"][expr {$n + 1}]
            $w delete 0 end
            continue
        }
    }
    ::ipentry::updateTextvar $w
}

# dotclick --
#
# called when mouse button 1 is clicked on any of the label widgets
# used by both ipentry and ipentry6
#
# decide which side of the dot was clicked and put the focus and cursor
# in the correct entry
#
# ARGS:
#       w       window argument (%W) from the event binding
#
# RETURNS:
#       nothing
#
proc ::ipentry::dotclick {w x} {
    if {$x > ([winfo width $w] / 2)} {
        set w [winfo parent $w].[string index $w end]
        focus $w
        $w icursor 0
    } else {
        set w [winfo parent $w].[expr {[string index $w end] - 1}]
        focus $w
        $w icursor end
    }
}

# arrow --
#
# called when the left or right arrow keys are pressed in an ipentry
# used by both ipentry and ipentry6
#
# ARGS:
#       w       window argument (%W) from the event binding
#       key     one of Left or Right
#
# RETURNS:
#       nothing
#
proc ::ipentry::arrow {w key} {
    set i [$w index insert]
    set l [string length [$w get]]
    # move the icursor +1 or -1 position
    $w icursor [expr $i [string map {Right + Left -} $key] 1]
    $w selection clear
    # if we are moving right and the cursor is at the end, or the entry is empty
    if {$key == "Right" && ($i == $l || $l == 0)} {
        skip $w next
    } elseif {$key == "Left" && $i == 0} {
        skip $w prev
    }
}

# validate --
#
# called by keypress to validate the input
# used by ipentry only
#
# ARGS:
#       w       window argument (%W) from the event binding
#       key     the key pressed
#
# RETURNS:
#       a boolean indicating if the key is valid or not
#
proc ::ipentry::validate {w key} {
    if {![string match {[0123456789]} $key]} { return 0 }
    set curval [$w get]
    set insert [$w index insert]
    # dont allow more than a single 0 to be entered
    if {$curval == "0" && $key == "0"} { return 0 }
    if {[string length $curval] == 2} {
        set curval [join [linsert [split $curval {}] $insert $key] {}]
        if {$curval > 255} {
            $w delete 0 end
            $w insert 0 255
            $w selection range 0 end
            ::ipentry::updateTextvar $w
            return 0
        } elseif {$insert == 2} {
            skip $w next 1
        }
        return 1
    }
    if {[string length $curval] >= 3 && ![$w selection present]} {
        if {$insert == 3} { skip $w next 1 }
        return 0
    }
    return 1
}

# validate6 --
#
# called by keypress to validate the input
# used by ipentry6 only
#
# ARGS:
#       w       window argument (%W) from the event binding
#       key     the key pressed
#
# RETURNS:
#       a boolean indicating if the key is valid or not
#
proc ::ipentry::validate6 {w key} {
    if {![string is xdigit $key]} { return 0 }
    set curval 0x[$w get]
    set insert [$w index insert]
    # dont allow more than a single 0 to be entered
    if {$curval == "0" && $key == "0"} { return 0 }
    if {[string length $curval] == 5} {
        set curval [join [linsert [split $curval {}] $insert $key] {}]
        if {$insert == 3} {
            skip $w next 1
        }
        return 1
    }
    if {[string length $curval] >= 6 && ![$w selection present]} {
        if {$insert == 4} { skip $w next 1 }
        return 0
    }
    return 1
}

# skip --
#
# move the cursor to the previous or next entry widget
# used by both ipentry and ipentry6
#
# ARGS:
#       w       name of the current entry widget 
#       dir     direction to move, one of next or prev
#       sel     boolean indicating whether to select the digits in the next entry
#
# RETURNS:
#       the name of the widget with focus
#
proc ::ipentry::skip {w dir {sel 0}} {
    set n [string index $w end]
    if {$dir == "next"} {
        set next [string trimright $w "012345678"][expr {$n + 1}]
        if { ![winfo exists $next] } { return $w }
        focus $next
        if {$sel} {
            $next icursor 0
            $next selection range 0 end
        }
        return $next
    } else {
        if { $n <= 0 } { return $w }
        set prev [string trimright $w "012345678"][expr {$n - 1}]
        focus $prev
        $prev icursor end
        return $prev
    }
}

# _foreach --
#
# utility for the widget configure command
#
# perform a command on every subwidget of an ipentry frame
#
# ARGS:
#       w       name of the ipentry frame 
#       cmd     command to perform
#       type    one of empty, "entry", or "dot"
#
# RETURNS:
#       nothing
#
proc ::ipentry::_foreach {w cmd {type {}}} {
    if {$type == "" || $type == "entry"} {
        foreach x {0 1 2 3 4 5 6 7} {
            if {![winfo exists $w.$x]} { break }
            eval [list $w.$x] $cmd
        }
    }
    if {$type == "" || $type == "dot"} {
        foreach x {d1 d2 d3 d4 d5 d6 d7} {
            if {![winfo exists $w.$x]} { break }
            eval [list $w.$x] $cmd
        }
     }
}

# cget --
#
# handle the widgetName cget subcommand
# used by both ipentry and ipentry6
#
# ARGS:
#       w       name of the ipentry widget 
#       cmd     name of a configuration option
#
# RETURNS:
#       the value of the requested option
#
proc ::ipentry::cget {w cmd} {
    upvar #0 [namespace current]::widget_$w state
    switch -exact -- $cmd {
        -bd -
        -borderwidth -
        -relief {
            # for bd and relief return the value from the container frame
            if {!$state(themed)} {
                return [::ipentry::_$w cget $cmd]
            }
        }
        -textvariable {
            if {[info exists ::ipentry::textvars($w)]} {
                return $::ipentry::textvars($w)
            }
            return {}
        }
        -themed { return $state(themed) }
        -takefocus { return 0 }
        default {
            # for all other commands return the value from the first entry
            return [$w.0 cget $cmd]
        }
    }
}

# configure --
#
# handle the widgetName configure subcommand
# used by both ipentry and ipentry6
#
# ARGS:
#       w       name of the ipentry widget 
#       args    name/value pairs of configuration options
#
# RETURNS:
#       nothing
#
proc ::ipentry::configure {w args} {
    upvar #0 [namespace current]::widget_$w Priv
    while {[set cmd [lindex $args 0]] != ""} {
        switch -exact -- $cmd {
            -state {
                set state [lindex $args 1]
                if {$state == "disabled"} {
                    _foreach $w [list configure -state disabled]
                    if {[set dbg [$w.0 cget -disabledbackground]] == ""} {
                          set dbg [$w.0 cget -bg]
                    }
                    _foreach $w [list configure -bg $dbg] dot
                    if {$Priv(themed)} {
                        ::ipentry::_$w state disabled
                    } else {
                        ::ipentry::_$w configure -background $dbg
                    }
                } elseif {$state == "normal"} {
                    _foreach $w [list configure -state normal]
                    _foreach $w [list configure -bg [$w.0 cget -bg]] dot
                    if {$Priv(themed)} {
                        ::ipentry::_$w state {!readonly !disabled}
                    } else {
                         ::ipentry::_$w configure -background [$w.0 cget -bg]
                    }
                } elseif {$state == "readonly"} {
                    _foreach $w [list configure -state readonly] entry
                    if {[set robg [$w.0 cget -readonlybackground]] == ""} {
                        set robg [$w.0 cget -bg]
                    }
                    _foreach $w [list configure -bg $robg] dot
                    if {$Priv(themed)} {
                        ::ipentry::_$w state !readonly
                    } else {
                        ::ipentry::_$w configure -background $robg
                    }
                }
                set args [lrange $args 2 end]
            }
            -bg - -background {
                set bg [lindex $args 1]
                _foreach $w [list configure -background $bg]
                if {!$Priv(themed)} {
                    ::ipentry::_$w configure -background $bg
                }
                set args [lrange $args 2 end]
            }
            -disabledforeground {
                _foreach $w [list configure -disabledforeground [lindex $args 1]]
                set args [lrange $args 2 end]
            }
            -font -
            -fg - -foreground {
                _foreach $w [list configure $cmd [lindex $args 1]]
                set args [lrange $args 2 end]
            }
            -bd - -borderwidth -
            -relief -
            -highlightcolor -
            -highlightbackground -
            -highlightthickness {
                _$w configure $cmd [lindex $args 1]
                set args [lrange $args 2 end]
            }
            -readonlybackground -
            -disabledbackground -
            -selectforeground   -
            -selectbackground   -
            -selectborderwidth  -
            -insertbackground {
                _foreach $w [list configure $cmd [lindex $args 1]] entry
                set args [lrange $args 2 end]
            }
            -themed {
                # ignored - only used in widget creation
            }
            -textvariable {
                set name [lindex $args 1]
                upvar #0 $name var
                #if {![string match ::* $name]} { set name ::$name }
                if {[info exists ::ipentry::textvars($w)]} {
                    set trace [trace info variable var]
                    trace remove variable var [lindex $trace 0 0] [lindex $trace 0 1]
                }
                set ::ipentry::textvars($w) $name
                if {![info exists var]} { set var "" }
                ::ipentry::traceFired $w $name {} write
                if {[winfo exists $w.4]} {
                    trace add variable var {write unset} [list ::ipentry::traceFired6 $w]
                } else {
                    trace add variable var {write unset} [list ::ipentry::traceFired $w]
                }
                set args [lrange $args 2 end]
            }
            default {
                error "unknown option \"[lindex $args 0]\""
            }
        }
    }
}

# destroyWidget --
#
# bound to the <Destroy> event
# used by both ipentry and ipentry6
#
# ARGS:
#       w       name of the ipentry widget 
#
# RETURNS:
#       nothing
#
proc ::ipentry::destroyWidget {w} {
    upvar #0 [namespace current]::widget_$w state
    if {[info exists ::ipentry::textvars($w)]} {
        upvar #0 $::ipentry::textvars($w) var
        set trace [trace info variable var]
        trace remove variable var [lindex $trace 0 0] [lindex $trace 0 1]
    }
    rename $w {}
    unset state
}

# traceFired --
#
# called by the variable trace on the ipentry textvariable
# used by ipentry only
#
# ARGS:
#       w       name of the ipentry widget 
#       varname name of the variable being traced
#       key     array index of the variable
#       op      operation performed on the variable, read/write/unset
#
# RETURNS:
#       nothing
#
proc ::ipentry::traceFired {w name key op} {
    upvar #0 $name var
    if {[info level] > 1} {
        set caller [lindex [info level -1] 0]
        if {$caller == "::ipentry::updateTextvar" || $caller == "::ipentry::traceFired"} { return }
    }
    if {$op == "write"} {
        _insert $w [split $var .]
        set val [string trim [join [$w get] .] .]
        # allow a dot at the end, but only if we have less than 3 already
        if {[string index $var end] == "." && [regexp -all {\.+} $var] <= 3} { append val . }
        if {$val eq $var} return
        after 0 [list set $name $val]
        set var $val
    } elseif {$op == "unset"} {
        ::ipentry::updateTextvar $w.0
        trace add variable var {write unset} [list ipentry::traceFired $w]
    }
}

# traceFired6 --
#
# called by the variable trace on the ipentry textvariable
# used by ipentry6 only
#
# ARGS:
#       w       name of the ipentry widget 
#       varname name of the variable being traced
#       key     array index of the variable
#       op      operation performed on the variable, read/write/unset
#
# RETURNS:
#       nothing
#
proc ::ipentry::traceFired6 {w name key op} {
    upvar #0 $name var
    if {[info level] > 1} {
        set caller [lindex [info level -1] 0]
        if {$caller == "::ipentry::updateTextvar" || $caller == "::ipentry::traceFired6"} { return }
    }
    if {$op == "write"} {
        _insert6 $w [split $var :]
        set val [string trim [join [$w get] :] :]
        # allow a dot at the end, but only if we have less than 3 already
        if {[string index $var end] == ":" && [regexp -all {\:+} $var] <= 7} { append val : }
        if {$val eq $var} return
        after 0 [list set $name $val]
        set var $val
    } elseif {$op == "unset"} {
        ::ipentry::updateTextvar $w.0
        trace add variable var {write unset} [list ipentry::traceFired6 $w]
    }
}

# updateTextvar --
#
# called by all procs which change the value of the ipentry
# used by both ipentry and ipentry6
#
# update the textvariable if it exists with the new value
#
# ARGS:
#       w       name of the ipentry widget 
#
# RETURNS:
#       nothing
#
proc ::ipentry::updateTextvar {w} {
    set p [winfo parent $w]
    if {![info exists ::ipentry::textvars($p)]} { return }
    set c [$p.d1 cget -text]
    set val [string trim [join [$p get] $c] $c]
    upvar #0 $::ipentry::textvars($p) var
    if {[info exists var] && $var == $val} { return }
    set var $val
}

# _insert --
#
# called by the variable trace on the ipentry textvariable and widget insert cmd
# used by ipentry only
#
# ARGS:
#       w       name of an ipentry widget 
#       val     a list of 4 values to be inserted into the ipentry
#
# RETURNS:
#       nothing
#
proc ::ipentry::_insert {w val} {
    foreach x {0 1 2 3} {
        set n [lindex $val $x]
        if {$n != ""} {
            if {![string is integer -strict $n]} {
                #error "cannot insert non-numeric arguments"
                return
            }
            if {$n > 255} { set n 255 }
            if {$n <= 0}  { set n 0 }
            if {$x == 0 && $n < 1} { set n 1 }
        }
        $w.$x delete 0 end
        $w.$x insert 0 $n
    }
}

# _insert6 --
#
# called by the variable trace on the ipentry textvariable and widget insert cmd
# used by both ipentry6 only
#
# ARGS:
#       w       name of an ipentry widget 
#       val     a list of 8 values to be inserted into the ipentry
#
# RETURNS:
#       nothing
#
proc ::ipentry::_insert6 {w val} {
    foreach x {0 1 2 3 4 5 6 7} {
        set n [lindex $val $x]
        if {![string is xdigit $n]} {
              #error "cannot insert non-hex arguments"
              return
        }
        if {$n != "" } {
            if "$x == 0 && 0x$n < 1" { set n 1 }
            if "0x$n > 0xffff" { set n ffff }
        }
        $w.$x delete 0 end
        $w.$x insert 0 $n
    }
}

# widgetCommand --
#
# handle the widgetName command
# used by ipentry, with some commands passed through from widgetCommand6
#
# ARGS:
#       w       name of the ipentry widget 
#       cmd     the subcommand
#       args    arguments to the subcommand
#
# RETURNS:
#       the results of the invoked subcommand
#
proc ::ipentry::widgetCommand {w cmd args} {
    upvar #0 [namespace current]::widget_$w state
    switch -exact -- $cmd {
        get {
            # return the 4 entry values as a list
            foreach x {0 1 2 3 4 5 6 7} {
                if {![winfo exists $w.$x]} { break }
                set s [$w.$x get]
                if {[string length $s] > 1} {
                    set s [string trimleft $s 0]
                    if {$s == ""} { set s 0 }
                }
                
                lappend r $s
            }
            return $r
        }
        insert {
            _insert $w [join $args]
            ::ipentry::updateTextvar $w.3
        }
        icursor {
            if {![string match $w.* [focus]]} { return }
            set i [lindex $args 0]
            if {![string is integer -strict $i]} { error "argument must be an integer" }
            set s [expr {$i / 4}]
            focus $w.$s
            $w.$s icursor [expr {$i % 4}]
        }
        complete {
            foreach x {0 1 2 3 4 5 6 7} {
                if {![winfo exists $w.$x]} { break }
                if {[$w.$x get] == ""} { return 0 }
            }
            return 1
        }
        configure {
            eval [list ::ipentry::configure $w] $args
        }
        cget {
            return [::ipentry::cget $w [lindex $args 0]]
        }
        default {
            error "bad option \"$cmd\": must be get, insert, complete, cget, or configure"
        }
    }
}

# widgetCommand6 --
#
# handle the widgetName command for ipentry6 widgets
# most subcommands are passed through to widgetCommand by the default case
#
# ARGS:
#       w       name of the ipentry widget 
#       cmd     the subcommand
#       args    arguments to the subcommand
#
# RETURNS:
#       the results of the invoked subcommand
#
proc ::ipentry::widgetCommand6 {w cmd args} {
    upvar #0 [namespace current]::widget_$w state
    switch -exact -- $cmd {
        insert {
            _insert6 $w [join $args]
            ::ipentry::updateTextvar $w.7
        }
        icursor {
            if {![string match $w.* [focus]]} { return }
            set i [lindex $args 0]
            if {![string is integer -strict $i]} { error "argument must be am integer" }
            set s [expr {$i / 8}]
            focus $w.$s
            $w.$s icursor [expr {$i % 8}]
        }
        default {
            return [eval [list ::ipentry::widgetCommand $w $cmd] $args]
        }
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/ipentry/pkgIndex.tcl.

1
2
3
if { ![package vsatisfies [package provide Tcl] 8.4] } { return }
package ifneeded ipentry 0.3 [list source [file join $dir ipentry.tcl]]

<
<
<






Deleted scriptlibs/tklib0.5/khim/ROOT.msg.

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
# ROOT.msg --
#
#	Default English-language messages for KHIM
#
# Copyright (c) 2006 by Kevin B. Kenny.  All rights reserved.
#
# Refer to the file "license.terms" for the terms and conditions of
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES.
#
# $Id: ROOT.msg,v 1.2 2006/09/05 18:52:22 kennykb Exp $
# $Source: /cvsroot/tcllib/tklib/modules/khim/ROOT.msg,v $
#
#----------------------------------------------------------------------

# Make sure that help text is available in the root locale.

namespace eval ::khim {

    # If you edit this file, also edit the corresponding text in en.msg,
    # which is provided for 8.4 compatibility.

    ::msgcat::mcset {} HELPTEXT {

	Kevin's Hacky Input Method (KHIM)

	KHIM allows you to input international characters from a
	keyboard that doesn't support them.  It works independently of
	any input method that the operating system may supply; it is
	intended for when you don't have control over your keyboard
	mapping and still need to input text in other languages.

	To use KHIM, bring up the KHIM Controls (the way this is done
        depends on your application) and enable KHIM by checking "Use
        KHIM".  You also need to choose a key on your keyboard that is
        seldom used, and designate it as the "Compose" key by pressing
        the button labelled, "Compose key:" then striking the key you
        wish to designate.  Generally speaking, this key should not be
        the key designated as "Compose" on the keyboard; that key will
        continue to invoke whatever input method the local operating
        system supplies.

	Once KHIM is enabled, you can enter international characters
	in any widget that is configured to use KHIM by pressing the
	Compose key followed by a two-character sequence.  The listbox
	in the KHIM controls shows the available sequences.  In
	addition, if you strike the Compose key twice, you get a
	dialog that allows you to input arbitrary symbols from a
	Unicode character map. In the map, you can navigate among the
	characters using either the cursor keys or the mouse, and you
	can select the current character for insertion by
	double-clicking it, pressing the space bar, or pressing the
	Enter (or Return) key.

	To define a new sequence for use with the Compose key, bring
	up the KHIM controls, enter the two characters in the
	"Input key sequence" entry and the desired character to insert
	into the "Character" entry, and press "Change".  (You may copy
	and paste the character from another application, or use the
	"Unicode..." button (or press the Compose key twice) to select
	the character from a map of all available Unicode code
	points.) To remove a sequence, select it in the listbox and
	press "Delete".

    }

    ::msgcat::mcset {} {SELECT COMPOSE KEY} [string map [list \n\t \n] {
	Please press the 
	key that you want 
	to use as the 
	"Compose" key.
    }]

}

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




















































































































































Deleted scriptlibs/tklib0.5/khim/cs.msg.

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
# cs.msg --
#
#	Czech-language messages for KHIM
#
# Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
# Translation by Michal Mestan <mestan@dix.cz>
#
# Refer to the file "license.terms" for the terms and conditions of
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES.
#
# $Id: cs.msg,v 1.1 2006/12/06 17:28:12 kennykb Exp $
# $Source: /cvsroot/tcllib/tklib/modules/khim/cs.msg,v $
#
#----------------------------------------------------------------------

namespace eval ::khim {

    ::msgcat::mcset cs HELPTEXT {

	Kevin's Hacky Input Method (KHIM)

	KHIM vám umožňuje zadávat mezinárodní znaky vÄetnÄ› tÄ›ch,
	které na vaší klávesnici nejspou. Pracuje nezávisle na
	požité vstupní metodÄ› kterou váš operaÄní systém může
	poskytovat. Je hlavnÄ› urÄen pro případy, kdy nemáte možnost
	měnit mapování klávesnice a přesto potřebujete zapsat
	cizojazyÄný text.

	K nastavení KHIM slouží "Ovládací panel KHIM" (jeho vyvolání
	je závaislé na konkrétní aplikaci), zde povolte KHIM zaškrtnutím
	políÄka "Používat KHIM". Mužete si zde též vybrat klávesu na
	vaší klávesnici, kterou bude KHIM používat jako "mrtvá"
	stisknutím talÄítka "Mrtvá klávesa" a poté stisktnutím
	patÅ™iÄné klávesy. ObecnÄ› lze říci, nemůže to být jakákoliv
	"mrtvá" klávasa vaší klávesové mapy, jelikož při stisknutí
	je volána vstupní metoda operaÄního systému.

	Když je KHIM povolen, můžete vkládat mezinárodní znaky
	v jakémkoliv přípravku, který je nastaven tak, aby používal
	KHIM stiknutním "mrtvé" klávesy následované posloupností
	dvou znaků. Seznam v "Ovládacím panelu KHIM" zobrazuje
	dostupné posloupnosti. Pokud stisknete "mrtvou" klávesu
	dvakrát, zobrazí se vám dialog, ve kterém můžete vybrat
	žádaný symbol z unokódové mapy. V mapě se můžete pohybovat
	kursorovými klávesami, dvojklikem myší, mezerníkem Äi klávesou
	enter vybraný znak vložíte do textu.

	Chcete-li další znaky vkládat pomocí mrtvé klávesy, otevřete
	"Ovládací panel KHIM" vložte dva znaky do pole "Posloupnost 
	kláves" a požadovaný znak, který chcete vložit do pole 
	"Vkládaný znak" a stisknÄ›tÄ› talÄítko "ZmÄ›nit" (vkládaný
	znak můžete nakopírovat z jiné aplikace nebo pouÄít talÄítko
	"Unikód..." (nebo stisknout dvakrát "mrtvou" klávesu) a vybrat
	znak z unikódové mapy). K odstranění klávesové posloupnosti
	slouží tlaÄítko "Smazat".

    }

    ::msgcat::mcset cs {SELECT COMPOSE KEY} [string map [list \n\t \n] {
	Stiskněte klávesu 
	kterou chcete používat 
	jako "mrtvou" klávesu.
    }]

    ::msgcat::mcset cs {Apply} "Použít"

    ::msgcat::mcset cs {Cancel} "Zrušit"

    ::msgcat::mcset cs {Change} "Změnit"

    ::msgcat::mcset cs {Character} "Znak"

    ::msgcat::mcset cs {Compose Key} "Mrtvá klávesa"

    ::msgcat::mcset cs {Compose key:} "Mrtvá klávesa:"

    ::msgcat::mcset cs {Composed sequence must be two characters long} \
	"Vkládaný znak je vždy šložen z posloupnosti zdvou nzaků"

    ::msgcat::mcset cs {Delete} "Smazat"

    ::msgcat::mcset cs {Help...} "Nápověda..."

    ::msgcat::mcset cs {Input key sequence} "Zadajete posloupnost kláves"

    ::msgcat::mcset cs {Insert Character} "Vkládaný znak"

    ::msgcat::mcset cs {Invalid sequence} "Chybná posloupnost"

    ::msgcat::mcset cs {Key sequences} "Posloupnosti kláves"

    ::msgcat::mcset cs {KHIM Controls} "Ovládací panel KHIM"

    ::msgcat::mcset cs {OK} {OK}

    ::msgcat::mcset cs {Select code page:} "Výběr kódové stránky:"

    ::msgcat::mcset cs {Unicode...} "Unikód..."

    ::msgcat::mcset cs {Use KHIM} "Používat KHIM"

}

# Local Variables:
# mode: tcl
# End:


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
























































































































































































































Deleted scriptlibs/tklib0.5/khim/da.msg.

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
# da.msg --
#
#	Danish-language messages for KHIM
#
# Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
# Translation by Torsten Berg
#
# Refer to the file "license.terms" for the terms and conditions of
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES.
#
# $Id: da.msg,v 1.1 2006/09/05 13:48:49 kennykb Exp $
# $Source: /cvsroot/tcllib/tklib/modules/khim/da.msg,v $
#
#----------------------------------------------------------------------

namespace eval ::khim {

    ::msgcat::mcset da {Apply} {Anvend}

    ::msgcat::mcset da {Cancel} {Annuller}

    ::msgcat::mcset da {Change} {Ændre}

    ::msgcat::mcset da {Character} {Tegn}

    ::msgcat::mcset da {Compose Key} {Compose taste}

    ::msgcat::mcset da {Compose key:} {Compose taste:}

    ::msgcat::mcset da {Composed sequence must be two characters long} \
	{Compose tegnfølgen skal bestå af to tegn}

    ::msgcat::mcset da {Delete} {Slet}

    ::msgcat::mcset da {Help...} {Hjælp...}

    ::msgcat::mcset da HELPTEXT {

	Kevin's Hacky Input Method (KHIM)

	KHIM gør det muligt at indtaste internationale tegn med et tastatur
	som ikke understøtter disse. Dette fungerer uafhængigt af en
	bestående indtast metode som styresystemet måtte understøtte.
	Det er tænkt til at hjælpe, hvis du ikke har kontrol over tilordningen
	på dit tastatur og dog har brug for at indtaste tekst i andre sprog.
	
	For at benytte KHIM, vis kontrolpanelet (hvordan det gøres, afhænger af
	dit program) og aktiver KHIM ved at afkrydse "Benyt KHIM". Du skal vælge
	en taste	der kun sjældent benyttes på dit tastatur og fastlægge denne som
	"Compose" taste for at sætte tegn sammen med. Tryk dertil på knappen
	markeret med "Compose taste:" og tryk derefter på den taste du ønsker at
	fastlægge. Generellt skulle det ikke være den taste som normalt benyttes
	til at konstruere tegn med; denne taste vil fortsat opråbe din lokale
	systems indtast metode.

	Når KHIM er aktiveret kan du indtaste internationale tegn i enhver
	kontrol der er konfigureret til at bruge KHIM ved at trykke på den valgte
	"Compose" taste fulgt af to bestemte tegn. Rullelisten til venstre
	på KHIM kontrolpanelet viser de tegnfølger der står til rådighed. Hvis
	du trykker "Compose" tasten to gange kommer der et vindue frem hvor
	du kan vælge vilkårlige symboler fra en unicode tabel. Du kan navigere
	rundt i selve tabellen ved enten at benytte markøren eller markørtasterne.
	Du kan udvælge det markerede tegn ved at doppelt-klikke på symbolet eller
	ved at trykke på mellemrums-, enter- eller returtasten.

	Ny tegnfølger kan defineres ved at indtaste en følge af to tegn i feltet
	markeret med "Indtast tegnfølge" og det ønskede symbol i feltet markeret
	med "Tegn" og derefter trykke på "Ændre". Du kan også kopiere og indsætte
	et symbol fra et andet program eller benytte "Unicode..." knappen
	(eller trykke "Compose" tasten to gange) for at hente et symbol fra
	tabellen med alle unicode koder. Tryk på "Slet" knappen for at fjerne
	en tegnfølge.

    }

    ::msgcat::mcset da {Input key sequence} {Indtast tegnfølge}

    ::msgcat::mcset da {Insert Character} {Indtast et tegn}

    ::msgcat::mcset da {Invalid sequence} {Ugyldig tegnfølge}

    ::msgcat::mcset da {Key sequences} {Tegnfølger}

    ::msgcat::mcset da {KHIM Controls} {KHIM kontrolpanel}

    ::msgcat::mcset da {OK} {O.k.}

    ::msgcat::mcset da {Select code page:} {Vælg kode side:}

    ::msgcat::mcset da {SELECT COMPOSE KEY} [string map [list \n\t \n] {
	Tryk på den taske
	du ønsker at bruge  
	som "Compose" taste.
    }]

    ::msgcat::mcset da {Unicode...} {Unicode...}

    ::msgcat::mcset da {Use KHIM} {Benyt KHIM}

}

# Local Variables:
# mode: tcl
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































Deleted scriptlibs/tklib0.5/khim/de.msg.

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
# de.msg --
#
#	German-language messages for KHIM
#
# Copyright (c) 2006 by Andreas Kupries.  All rights reserved.
#
# Refer to the file "license.terms" for the terms and conditions of
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES.
#
# $Id: de.msg,v 1.2 2006/09/07 13:18:13 kennykb Exp $
# $Source: /cvsroot/tcllib/tklib/modules/khim/de.msg,v $
#
#----------------------------------------------------------------------

namespace eval ::khim {

    ::msgcat::mcset de HELPTEXT {

	Kevin's Hacky Input Method (KHIM)

	KHIM ermöglicht die Eingabe von internationalen Zeichen
	mittels einer Tastatur, welches diese nicht direkt
	unterstützt. Es ist unabhängig von allen Eingabemethoden,
	welche vom Betriebssystem bereitgestellt werden (könnten),
	und für den Fall gedacht, wenn der Anwender keine Kontrolle
	über die Tastatur hat und dennoch Text in anderen Sprachen
	eingeben muß.

	Um KHIM zu benutzen, ist es notwendig, den KHIM Steuer-Dialog zu
	öffnen (dies ist abhängig von der Anwendung) und dann KHIM
	durch 'ticken' der 'Benutze KHIM'-Checkbox zu aktivieren. Es
	ist weiterhin notwendig, eine Taste als die Kombinier-Taste zu
	wählen. Die gewählte Taste sollte im Normalgebrauch selten
	genutzt werden. Die Auswahl selbst besteht aus zwei Schritten.
	Zuerst muß der Knopf "Kombinier-Taste:" gedrückt werden,
	dann die gewünschte Taste.

	Allgemein gesprochen, wenn die benutzte Tastatur eine Taste
	"Compose" besitzt, dann sollte diese _nicht_ als die
	Kombinier-Taste für KHIM gewählt werden. Dies stellt sicher,
	das diese Taste weiterhin vom Betriebssystem genutzt werden
	kann, um dessen eventuelle Eingabemethoden zu aktivieren.

	Sobald KHIM aktiviert wurde, können in jedem Widget, welches
	für die Benutzung von KHIM konfiguriert wurde, internationale
	Zeichen eingegeben werden. Dies geschieht durch Drücken der
	gewählten Kombinier-Taste, gefolgt von zwei weiteren Zeichen,
	welche das gewünschte Zeichen identifizieren. Der KHIM
	Steuer-Dialog stellt eine Liste der bekannten Zeichenfolgen
	zur Verfügung. Zusätzlich ist es möglich einen Dialog zu
	öffnen, welcher die Auswahl beliebiger Zeichen in einer Tabelle
	erlaubt. Dies geschieht durch zweimaliges Drücken der
	Kombinier-Taste. Navigation in der Tabelle geschieht mit der
	Maus oder den Kursor-Tasten. Das einzufügende Zeichen kann
	mit Doppel-Klick gewählt werden, durch Drücken der
	Leer-Taste, oder durch Drücken der Enter- (oder Return-)Taste.

	Es ist auch möglich, die Liste der direkt anwählbären Zeichen
	zu erweitern. Dies geschieht im KHIM Steuer-Dialog durch Eingabe
	der zwei Zeichen für den Kode im Eingabefeld
	"Eingabezeichenfolge", des gewünschten Zeichens im Feld
	"Zeichen", gefolgt vom Drücken des Knopfes "Ändern".

	(Bezüglich der Herkunft des gewünschten Zeichens: Es kann aus
	einer anderen Anwendung kopiert werden, oder man benutze den Knopf
	"Unicode..." (oder drücke die Kombinier-Taste zweimal), um es
	aus der Tabelle aller Zeichen auszuwählen.)

	Eine Zeichenfolge wird gelöscht durch Auswahl der Folge in
	der Liste aller Zeichenfolgen, gefolgt von der
	Lösch/Entferne-Taste.
    }

    ::msgcat::mcset de {SELECT COMPOSE KEY} [string map [list \n\t \n] {
	Bitte drücken Sie
	die Taste, welche Sie
	als Kombinier-Taste
	verwenden wollen.
    }]

    ::msgcat::mcset de {Apply} {Anwenden}

    ::msgcat::mcset de {Cancel} {Abbrechen}

    ::msgcat::mcset de {Change} {Ändern}

    ::msgcat::mcset de {Character} {Zeichen}

    ::msgcat::mcset de {Compose Key} {Kombinier-Taste}

    ::msgcat::mcset de {Compose key:} {Kombinier-Taste:}

    ::msgcat::mcset de {Composed sequence must be two characters long} \
	{Die Eingabezeichenfolge muß aus zwei Zeichen bestehen}

    ::msgcat::mcset de {Delete} {Löschen}

    ::msgcat::mcset de {Help...} {Hilfe...}

    ::msgcat::mcset de {Input key sequence} {Eingabezeichenfolge}

    ::msgcat::mcset de {Insert Character} {Zeichen einfügen}

    ::msgcat::mcset de {Invalid sequence} {Ungültige Zeichenfolge}

    ::msgcat::mcset de {Key sequences} {Zeichenfolgen}

    ::msgcat::mcset de {KHIM Controls} {KHIM Steuerung}

    ::msgcat::mcset de {OK} {OK}

    ::msgcat::mcset de {Select code page:} {Wähle Code-Seite:}

    ::msgcat::mcset de {Unicode...} {Unicode...}

    ::msgcat::mcset de {Use KHIM} {Benutze KHIM}

}

# Local Variables:
# mode: tcl
# End:

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






















































































































































































































































Deleted scriptlibs/tklib0.5/khim/en.msg.

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
# en.msg --
#
#	English-language messages for KHIM
#
# Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
#
# Refer to the file "license.terms" for the terms and conditions of
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES.
#
# $Id: en.msg,v 1.3 2007/06/08 19:24:31 kennykb Exp $
# $Source: /cvsroot/tcllib/tklib/modules/khim/en.msg,v $
#
#----------------------------------------------------------------------

namespace eval ::khim {

    # If you edit HELPTEXT or {SELECT COMPOSE KEY}, also edit the corresponding
    # messages in ROOT.msg

    ::msgcat::mcset en HELPTEXT {

	Kevin's Hacky Input Method (KHIM)

	KHIM allows you to input international characters from a
	keyboard that doesn't support them.  It works independently of
	any input method that the operating system may supply; it is
	intended for when you don't have control over your keyboard
	mapping and still need to input text in other languages.

	To use KHIM, bring up the KHIM Controls (the way this is done
        depends on your application) and enable KHIM by checking "Use
        KHIM".  You also need to choose a key on your keyboard that is
        seldom used, and designate it as the "Compose" key by pressing
        the button labelled, "Compose key:" then striking the key you
        wish to designate.  Generally speaking, this key should not be
        the key designated as "Compose" on the keyboard; that key will
        continue to invoke whatever input method the local operating
        system supplies.

	Once KHIM is enabled, you can enter international characters
	in any widget that is configured to use KHIM by pressing the
	Compose key followed by a two-character sequence.  The listbox
	in the KHIM controls shows the available sequences.  In
	addition, if you strike the Compose key twice, you get a
	dialog that allows you to input arbitrary symbols from a
	Unicode character map. In the map, you can navigate among the
	characters using either the cursor keys or the mouse, and you
	can select the current character for insertion by
	double-clicking it, pressing the space bar, or pressing the
	Enter (or Return) key.

	To define a new sequence for use with the Compose key, bring
	up the KHIM controls, enter the two characters in the
	"Input key sequence" entry and the desired character to insert
	into the "Character" entry, and press "Change".  (You may copy
	and paste the character from another application, or use the
	"Unicode..." button (or press the Compose key twice) to select
	the character from a map of all available Unicode code
	points.) To remove a sequence, select it in the listbox and
	press "Delete".

    }

    ::msgcat::mcset en {SELECT COMPOSE KEY} [string map [list \n\t \n] {
	Please press the 
	key that you want 
	to use as the 
	"Compose" key.
    }]

    ::msgcat::mcset en {Apply} {Apply}

    ::msgcat::mcset en {Cancel} {Cancel}

    ::msgcat::mcset en {Change} {Change}

    ::msgcat::mcset en {Character} {Character}

    ::msgcat::mcset en {Compose Key} {Compose Key}

    ::msgcat::mcset en {Compose key:} {Compose key:}

    ::msgcat::mcset en {Composed sequence must be two characters long} \
	{Composed sequence must be two characters long}

    ::msgcat::mcset en {Delete} {Delete}

    ::msgcat::mcset en {KHIM Help} {KHIM Help}

    ::msgcat::mcset en {Help...} {Help...}

    ::msgcat::mcset en {Input key sequence} {Input key sequence}

    ::msgcat::mcset en {Insert Character} {Insert Character}

    ::msgcat::mcset en {Invalid sequence} {Invalid sequence}

    ::msgcat::mcset en {Key sequences} {Key sequences}

    ::msgcat::mcset en {KHIM Controls} {KHIM Controls}

    ::msgcat::mcset en {OK} {OK}

    ::msgcat::mcset en {Select code page:} {Select code page:}

    ::msgcat::mcset en {Unicode...} {Unicode...}

    ::msgcat::mcset en {Use KHIM} {Use KHIM}

}

# Local Variables:
# mode: tcl
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































Deleted scriptlibs/tklib0.5/khim/es.msg.

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
# es.msg --
#
#	Spanish-language messages for KHIM
#
# Copyright (c) 2008 by Emiliano Gavilán.
# Proofreading and corrections by Miguel Sofer.
#
# Refer to the file "license.terms" for the terms and conditions of
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES.
#
# $Id: es.msg,v 1.3 2008/05/30 02:00:19 kennykb Exp $
# $Source: /cvsroot/tcllib/tklib/modules/khim/es.msg,v $
#
#----------------------------------------------------------------------

namespace eval ::khim {

    ::msgcat::mcset es HELPTEXT {

	Kevin's Hacky Input Method (KHIM)

	KHIM permite ingresar caracteres internacionales desde un teclado
	que no soporta esta funcionalidad. Funciona independientemente de
	cualquier método de entrada que su sistema operativo pueda proveer;
	su finalidad es permitirle ingresar caracteres en otros lenguajes,
	aun cuando no tenga control del mapeo de su teclado.

	Para usar KHIM, seleccione el diálogo de control de KHIM
	(la forma de lograr esto depende de su aplicación) y habilite
	el uso de KHIM seleccionando "Usar KHIM". También necesitará
	seleccionar una tecla que sea raramente usada y designarla como
	tecla "Componer" presionando el botón con la leyenda "Tecla Componer:"
	y luego la tecla que quiere asignar a esta función. Ésta tecla no
	debe ser la tecla designada como la tecla de composición de su
	teclado; dicha tecla seguirá invocando cualquier método de entrada
	que su sistema operativo provea.

	Una vez que KHIM esté habilitado, podrá ingresar caracteres
	internacionales en cualquier widget que este configurado para
	usar KHIM presionando la tecla designada como Componer seguida
	de una secuencia de dos teclas. La lista en el control de KHIM
	muestra todas las secuencias disponibles. Además, si presiona
	la tecla "Componer" dos veces, se mostrará un diálogo que le
	permitirá ingresar cualquier carácter arbitrario desde un mapa
	de caracteres Unicode. Dicho mapa puede navegarse utilizando
	el ratón o las teclas de dirección, y se puede seleccionar el
	carácter deseado con un doble click, la barra espaciadora o la
	tecla Return (Enter).

	Para definir una nueva secuencia para utilizar con la tecla
	"Componer", seleccione el control de KHIM, ingrese dos	teclas en
	secuencia en la entrada "Secuencia de teclas", el carácter deseado
	en la entrada "Carácter", y luego presione la tecla "Cambiar".
	(Usted puede copiar y pegar dicho carácter desde otra aplicación,
	o presionar el botón "Unicode..." (o presione la tecla "Componer"
	dos veces) para seleccionar el carácter desde el mapa de los
	caracteres Unicode disponibles). Para borrar una secuencia,
	selecciónela de la lista y presione "Borrar".

    }

    ::msgcat::mcset es {SELECT COMPOSE KEY} [string map [list \n\t \n] {
	Por favor presione 
	la tecla que desee
	usar como tecla
	"Componer".
    }]

    ::msgcat::mcset es {Apply} {Aplicar}

    ::msgcat::mcset es {Cancel} {Cancelar}

    ::msgcat::mcset es {Change} {Cambiar}

    ::msgcat::mcset es {Character} {Carácter}

    ::msgcat::mcset es {Compose Key} {Tecla Componer}

    ::msgcat::mcset es {Compose key:} {Tecla Componer:}

    ::msgcat::mcset es {Composed sequence must be two characters long} \
	{La secuencia de composición debe ser de dos teclas}

    ::msgcat::mcset es {Delete} {Borrar}

    ::msgcat::mcset es {KHIM Help} {Ayuda de KHIM}

    ::msgcat::mcset es {Help...} {Ayuda...}

    ::msgcat::mcset es {Input key sequence} {Secuencia de teclas de entrada}

    ::msgcat::mcset es {Insert Character} {Insertar carácter}

    ::msgcat::mcset es {Invalid sequence} {Secuencia inválida}

    ::msgcat::mcset es {Key sequences} {Secuencias de teclas}

    ::msgcat::mcset es {KHIM Controls} {Controles de KHIM}

    ::msgcat::mcset es {OK} {Aceptar}

    ::msgcat::mcset es {Select code page:} {Seleccionar página de código:}

    ::msgcat::mcset es {Unicode...} {Unicode...}

    ::msgcat::mcset es {Use KHIM} {Usar KHIM}

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































Deleted scriptlibs/tklib0.5/khim/khim.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
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
981
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
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
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
1210
1211
1212
1213
1214
1215
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
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
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
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
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
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
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
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
# khim.tcl --
#
#	Kevin's Hacky Input Method
#
# The 'khim' package defines a KHIM bindtag that can be applied to
# entry or text widgets (after widget-specific bindings but before
# Entry or Text bindings) to allow entry of international characters
# from a US keyboard without any input method other than Tk.
#
# It works by defining a "Compose" key (default is <Pause>).  When
# the "Compose" key is pressed, followed by a two-character sequence,
# those two characters are looked up in a user-configurable table and
# replaced with a Unicode character, which is inserted into the widget.
#
# Copyright (c) 2006 by Kevin B. Kenny.  All rights reserved.
#
# Refer to the file "license.terms" for the terms and conditions of
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES.
#
# $Id: khim.tcl,v 1.10 2007/06/08 19:24:31 kennykb Exp $
# $Source: /cvsroot/tcllib/tklib/modules/khim/khim.tcl,v $
#
#----------------------------------------------------------------------

package require Tcl 8.4
package require Tk 8.4
package require msgcat 1.2
package require autoscroll 1.0

package provide khim 1.0.1

namespace eval khim [list variable KHIMDir [file dirname [info script]]]

namespace eval khim {

    namespace import ::msgcat::mc

    namespace export getOptions getConfig setConfig showHelp

    variable composeKey;		# Keysym of the key used for the
					# Compose function
    variable map;			# Dictionary whose keys are two-
					# character sequences and whose
					# values are the characters to
					# insert when those sequences
					# are composed
    variable UniOK;			# Table of code-point ranges that
					# conform to printable chars
    variable use;			# 1 if KHIM is enabled, 0 if not.

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

    variable CMapFont;			# Font to use to display Unicode
					# characters in the character map

    variable CMapBadCharFont;		# Font in which to display the hex
					# values of bad code points

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

    variable CMapCodePage;		# Array whose keys are the
					# path names of KHIM character map
					# dialogs and whose values are
					# the code pages on display in
					# those dialogs

    variable CMapFocus;			# Array whose keys are the path names
					# of KHIM character map dialogs and
					# whose values are the focus windows
					# where characters selected in the
					# dialogs will be inserted.

    variable CMapInputCodePage;		# Array whose keys are the path names
					# of KHIM character map dialogs and
					# whose values are variables used
					# to hold the value of the spinbox
					# that selects the code page.

    variable CMapSelectedCharacter;	# Array whose keys are the path names
					# of KHIM character map dialogs and
					# whose values are the characters
					# currently selected in the dialogs
					
    variable CMapXL;			# Array whose keys are the path names
					# of KHIM character map dialogs and
					# whose values are the
					# X co-ordinates of the columns in
					# the character map

    variable CMapYL;			# Array whose keys are the path names
					# of KHIM character map dialogs and
					# whose values are the
					# Y co-ordinates of the rows in the
					# character map.
}

# Load up message catalogs for the locale

namespace eval khim [list ::msgcat::mcload [file dirname [info script]]]

# Compressed table of which Unicode code points in the BMP are printable
# characters. The table is read, "0x0000-0x001f are not printable,
# 0x0020-0x007e are printable, 0x007f-0x009f are not printable,
# 0x00a0-0x00ac are printable, 0x00ad is not, 0x00ae-0x0241 are, etc."

set khim::UniOK {
    0x0000 0x0020 0x007f 0x00a0 0x00ad 0x00ae 0x0242 0x0250 0x0370 0x0374
    0x0376 0x037a 0x037b 0x037e 0x037f 0x0384 0x038b 0x038c 0x038d 0x038e
    0x03a2 0x03a3 0x03cf 0x03d0 0x0487 0x0488 0x04cf 0x04d0 0x04fa 0x0500
    0x0510 0x0531 0x0557 0x0559 0x0560 0x0561 0x0588 0x0589 0x058b 0x0591
    0x05ba 0x05bb 0x05c8 0x05d0 0x05eb 0x05f0 0x0600 0x060b 0x0616 0x061b
    0x061c 0x061e 0x0620 0x0621 0x063b 0x0640 0x065f 0x0660 0x06dd 0x06de
    0x070f 0x0710 0x074b 0x074d 0x076e 0x0780 0x07b2 0x0901 0x093a 0x093c
    0x094e 0x0950 0x0955 0x0958 0x0971 0x097d 0x097e 0x0981 0x0984 0x0985
    0x098d 0x098f 0x0991 0x0993 0x09a9 0x09aa 0x09b1 0x09b2 0x09b3 0x09b6
    0x09ba 0x09bc 0x09c5 0x09c7 0x09c9 0x09cb 0x09cf 0x09d7 0x09d8 0x09dc
    0x09de 0x09df 0x09e4 0x09e6 0x09fb 0x0a01 0x0a04 0x0a05 0x0a0b 0x0a0f
    0x0a11 0x0a13 0x0a29 0x0a2a 0x0a31 0x0a32 0x0a34 0x0a35 0x0a37 0x0a38
    0x0a3a 0x0a3c 0x0a3d 0x0a3e 0x0a43 0x0a47 0x0a49 0x0a4b 0x0a4e 0x0a59
    0x0a5d 0x0a5e 0x0a5f 0x0a66 0x0a75 0x0a81 0x0a84 0x0a85 0x0a8e 0x0a8f
    0x0a92 0x0a93 0x0aa9 0x0aaa 0x0ab1 0x0ab2 0x0ab4 0x0ab5 0x0aba 0x0abc
    0x0ac6 0x0ac7 0x0aca 0x0acb 0x0ace 0x0ad0 0x0ad1 0x0ae0 0x0ae4 0x0ae6
    0x0af0 0x0af1 0x0af2 0x0b01 0x0b04 0x0b05 0x0b0d 0x0b0f 0x0b11 0x0b13
    0x0b29 0x0b2a 0x0b31 0x0b32 0x0b34 0x0b35 0x0b3a 0x0b3c 0x0b44 0x0b47
    0x0b49 0x0b4b 0x0b4e 0x0b56 0x0b58 0x0b5c 0x0b5e 0x0b5f 0x0b62 0x0b66
    0x0b72 0x0b82 0x0b84 0x0b85 0x0b8b 0x0b8e 0x0b91 0x0b92 0x0b96 0x0b99
    0x0b9b 0x0b9c 0x0b9d 0x0b9e 0x0ba0 0x0ba3 0x0ba5 0x0ba8 0x0bab 0x0bae
    0x0bba 0x0bbe 0x0bc3 0x0bc6 0x0bc9 0x0bca 0x0bce 0x0bd7 0x0bd8 0x0be6
    0x0bfb 0x0c01 0x0c04 0x0c05 0x0c0d 0x0c0e 0x0c11 0x0c12 0x0c29 0x0c2a
    0x0c34 0x0c35 0x0c3a 0x0c3e 0x0c45 0x0c46 0x0c49 0x0c4a 0x0c4e 0x0c55
    0x0c57 0x0c60 0x0c62 0x0c66 0x0c70 0x0c82 0x0c84 0x0c85 0x0c8d 0x0c8e
    0x0c91 0x0c92 0x0ca9 0x0caa 0x0cb4 0x0cb5 0x0cba 0x0cbc 0x0cc5 0x0cc6
    0x0cc9 0x0cca 0x0cce 0x0cd5 0x0cd7 0x0cde 0x0cdf 0x0ce0 0x0ce2 0x0ce6
    0x0cf0 0x0d02 0x0d04 0x0d05 0x0d0d 0x0d0e 0x0d11 0x0d12 0x0d29 0x0d2a
    0x0d3a 0x0d3e 0x0d44 0x0d46 0x0d49 0x0d4a 0x0d4e 0x0d57 0x0d58 0x0d60
    0x0d62 0x0d66 0x0d70 0x0d82 0x0d84 0x0d85 0x0d97 0x0d9a 0x0db2 0x0db3
    0x0dbc 0x0dbd 0x0dbe 0x0dc0 0x0dc7 0x0dca 0x0dcb 0x0dcf 0x0dd5 0x0dd6
    0x0dd7 0x0dd8 0x0de0 0x0df2 0x0df5 0x0e01 0x0e3b 0x0e3f 0x0e5c 0x0e81
    0x0e83 0x0e84 0x0e85 0x0e87 0x0e89 0x0e8a 0x0e8b 0x0e8d 0x0e8e 0x0e94
    0x0e98 0x0e99 0x0ea0 0x0ea1 0x0ea4 0x0ea5 0x0ea6 0x0ea7 0x0ea8 0x0eaa
    0x0eac 0x0ead 0x0eba 0x0ebb 0x0ebe 0x0ec0 0x0ec5 0x0ec6 0x0ec7 0x0ec8
    0x0ece 0x0ed0 0x0eda 0x0edc 0x0ede 0x0f00 0x0f48 0x0f49 0x0f6b 0x0f71
    0x0f8c 0x0f90 0x0f98 0x0f99 0x0fbd 0x0fbe 0x0fcd 0x0fcf 0x0fd2 0x1000
    0x1022 0x1023 0x1028 0x1029 0x102b 0x102c 0x1033 0x1036 0x103a 0x1040
    0x105a 0x10a0 0x10c6 0x10d0 0x10fd 0x1100 0x115a 0x115f 0x11a3 0x11a8
    0x11fa 0x1200 0x1249 0x124a 0x124e 0x1250 0x1257 0x1258 0x1259 0x125a
    0x125e 0x1260 0x1289 0x128a 0x128e 0x1290 0x12b1 0x12b2 0x12b6 0x12b8
    0x12bf 0x12c0 0x12c1 0x12c2 0x12c6 0x12c8 0x12d7 0x12d8 0x1311 0x1312
    0x1316 0x1318 0x135b 0x135f 0x137d 0x1380 0x139a 0x13a0 0x13f5 0x1401
    0x1677 0x1680 0x169d 0x16a0 0x16f1 0x1700 0x170d 0x170e 0x1715 0x1720
    0x1737 0x1740 0x1754 0x1760 0x176d 0x176e 0x1771 0x1772 0x1774 0x1780
    0x17b4 0x17b6 0x17de 0x17e0 0x17ea 0x17f0 0x17fa 0x1800 0x180f 0x1810
    0x181a 0x1820 0x1878 0x1880 0x18aa 0x1900 0x191d 0x1920 0x192c 0x1930
    0x193c 0x1940 0x1941 0x1944 0x196e 0x1970 0x1975 0x1980 0x19aa 0x19b0
    0x19ca 0x19d0 0x19da 0x19de 0x1a1c 0x1a1e 0x1a20 0x1d00 0x1dc4 0x1e00
    0x1e9c 0x1ea0 0x1efa 0x1f00 0x1f16 0x1f18 0x1f1e 0x1f20 0x1f46 0x1f48
    0x1f4e 0x1f50 0x1f58 0x1f59 0x1f5a 0x1f5b 0x1f5c 0x1f5d 0x1f5e 0x1f5f
    0x1f7e 0x1f80 0x1fb5 0x1fb6 0x1fc5 0x1fc6 0x1fd4 0x1fd6 0x1fdc 0x1fdd
    0x1ff0 0x1ff2 0x1ff5 0x1ff6 0x1fff 0x2000 0x200b 0x2010 0x202a 0x202f
    0x2060 0x2070 0x2072 0x2074 0x208f 0x2090 0x2095 0x20a0 0x20b6 0x20d0
    0x20ec 0x2100 0x214d 0x2153 0x2184 0x2190 0x23dc 0x2400 0x2427 0x2440
    0x244b 0x2460 0x269d 0x26a0 0x26b2 0x2701 0x2705 0x2706 0x270a 0x270c
    0x2728 0x2729 0x274c 0x274d 0x274e 0x274f 0x2753 0x2756 0x2757 0x2758
    0x275f 0x2761 0x2795 0x2798 0x27b0 0x27b1 0x27bf 0x27c0 0x27c7 0x27d0
    0x27ec 0x27f0 0x2b14 0x2c00 0x2c2f 0x2c30 0x2c5f 0x2c80 0x2ceb 0x2cf9
    0x2d26 0x2d30 0x2d66 0x2d6f 0x2d70 0x2d80 0x2d97 0x2da0 0x2da7 0x2da8
    0x2daf 0x2db0 0x2db7 0x2db8 0x2dbf 0x2dc0 0x2dc7 0x2dc8 0x2dcf 0x2dd0
    0x2dd7 0x2dd8 0x2ddf 0x2e00 0x2e18 0x2e1c 0x2e1e 0x2e80 0x2e9a 0x2e9b
    0x2ef4 0x2f00 0x2fd6 0x2ff0 0x2ffc 0x3000 0x3040 0x3041 0x3097 0x3099
    0x3100 0x3105 0x312d 0x3131 0x318f 0x3190 0x31b8 0x31c0 0x31d0 0x31f0
    0x321f 0x3220 0x3244 0x3250 0x32ff 0x3300 0x4db6 0x4dc0 0x9fbc 0xa000
    0xa48d 0xa490 0xa4c7 0xa700 0xa717 0xa800 0xa82c 0xac00 0xd7a4 0xe000
    0xfa2e 0xfa30 0xfa6b 0xfa70 0xfada 0xfb00 0xfb07 0xfb13 0xfb18 0xfb1d
    0xfb37 0xfb38 0xfb3d 0xfb3e 0xfb3f 0xfb40 0xfb42 0xfb43 0xfb45 0xfb46
    0xfbb2 0xfbd3 0xfd40 0xfd50 0xfd90 0xfd92 0xfdc8 0xfdf0 0xfdfe 0xfe00
    0xfe1a 0xfe20 0xfe24 0xfe30 0xfe53 0xfe54 0xfe67 0xfe68 0xfe6c 0xfe70
    0xfe75 0xfe76 0xfeff 0xff01 0xffbf 0xffc2 0xffc8 0xffca 0xffd0 0xffd2
    0xffd8 0xffda 0xffdd 0xffe0 0xffe7 0xffe8 0xfff9 0xfffc 0xfffe
}

#----------------------------------------------------------------------
#
# BSearch --
#
#	Service procedure that does binary search in several places.
#
# Parameters:
#	list - List of lists, sorted in ascending order by the
#	       first elements
#	key - Value to search for
#
# Results:
#	Returns the index of the greatest element in $list that is less
#	than or equal to $key.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc ::khim::BSearch { list key } {

    if { $key < [lindex $list 0 0] } {
	return -1
    }

    set l 0
    set u [expr { [llength $list] - 1 }]

    while { $l < $u } {

	# At this point, we know that
	#   $k >= [lindex $list $l 0]
	#   Either $u == [llength $list] or else $k < [lindex $list $u+1 0]
	# We find the midpoint of the interval {l,u} rounded UP, compare
	# against it, and set l or u to maintain the invariant.  Note
	# that the interval shrinks at each step, guaranteeing convergence.

	set m [expr { ( $l + $u + 1 ) / 2 }]
	if { $key >= [lindex $list $m 0] } {
	    set l $m
	} else {
	    set u [expr { $m - 1 }]
	}
    }

    return $l
}

#----------------------------------------------------------------------
#
# khim::ValidChar --
#
#	Test whether a number is the index of a valid character.
#
# Parameters:
#	c - Number of the character.
#
# Results:
#	Returns 1 if the character is a printable Unicode characte
#	in the BMP, and 0 otherwise.
#
#----------------------------------------------------------------------

proc ::khim::ValidChar { c } {
    variable UniOK
    return [expr {( [BSearch $UniOK $c] & 1 )}]
}

#----------------------------------------------------------------------
#
# khim::getOptions --
#
#	Displays a dialog that allows the user to enable/disable KHIM,
#	change key mappings, and change the Compose key.
#
# Parameters:
#	w -- Window path name of the dialog box.
#
# Results:
#	None.
#
# Side effects:
#	Changes options to whatever the user selects.
#
#----------------------------------------------------------------------

proc khim::getOptions {w} {

    variable use
    variable composeKey
    variable map
    variable inputUse
    variable inputComposeKey
    variable inputMap

    # Set temporary options for the use of the dialog

    set inputUse $use
    set inputComposeKey $composeKey
    array set inputMap $map

    # Create a modal dialog

    toplevel $w -class dialog
    wm withdraw $w
    set p [winfo toplevel [winfo parent $w]]
    set g [wm transient $p]
    if { ![string compare {} $g] } {
	set g $p
    }
    wm transient $w $g
    catch {wm attributes $w -toolwindow 1}
    wm title $w [mc "KHIM Controls"]
    bind $w <Destroy> [list ::khim::HandleDestroy $w %W]

    # Create GUI and manage geometry

    checkbutton $w.v -variable ::khim::inputUse -text [mc "Use KHIM"]
    label $w.l1 -text [mc "Compose key:"]
    button $w.b1 -textvariable khim::inputComposeKey \
	-command [list ::khim::GetComposeKey $w.b1]
    labelframe $w.lf1 -text [mc "Key sequences"] -padx 5 -pady 5 -width 400
    listbox $w.lf1.lb -height 20 -yscroll [list $w.lf1.y set] \
	-font {Courier 12} -width 8 -height 10 \
	-exportselection 0
    bind $w.lf1.lb <<ListboxSelect>> [list ::khim::Select %W]
    scrollbar $w.lf1.y -orient vertical -command [list $w.lf1.lb yview]
    frame $w.lf1.f1
    label $w.lf1.f1.l1 -text [mc "Input key sequence"]
    entry $w.lf1.f1.e1 -textvariable ::khim::inputSequence -width 2 \
	-font {Courier 12}
    bind $w.lf1.f1.e1 <FocusIn> {
	%W selection from 0
	%W selection to end
    }
    grid $w.lf1.f1.l1 $w.lf1.f1.e1
    grid columnconfigure $w.lf1.f1 2 -weight 1
    frame $w.lf1.f2
    label $w.lf1.f2.l1 -text [mc "Character"]
    entry $w.lf1.f2.e1 -textvariable ::khim::inputCharacter -width 2 \
	-font {Courier 12}
    bind $w.lf1.f2.e1 <FocusIn> {
	%W selection from 0
	%W selection to end
    }
    button $w.lf1.f2.b1 -text [mc "Unicode..."] \
	-command [list ::khim::FocusAndInsertSymbol $w.lf1.f2.e1]

    grid $w.lf1.f2.l1 $w.lf1.f2.e1
    grid $w.lf1.f2.b1 -row 0 -column 2 -sticky w -padx {20 0}
    grid columnconfigure $w.lf1.f2 3 -weight 1
    grid $w.lf1.lb -row 0 -column 0 -sticky nsew -rowspan 5
    grid $w.lf1.y -row 0 -column 1 -sticky ns -rowspan 5
    frame $w.lf1.f3
    button $w.lf1.f3.b1 -text [mc Change] \
	-command [list ::khim::ChangeSequence $w]
    button $w.lf1.f3.b2 -text [mc Delete] \
	-command [list ::khim::DeleteSequence $w]
    grid $w.lf1.f1 -row 0 -column 2 -sticky e -padx {20 0}
    grid $w.lf1.f2 -row 1 -column 2 -sticky e -padx {20 0}
    grid $w.lf1.f3.b1 $w.lf1.f3.b2 -padx 5 -sticky ew
    grid columnconfigure $w.lf1.f3 {0 1} -weight 1 -uniform A
    grid $w.lf1.f3 -row 3 -column 2 -sticky e -padx 20
    
    grid rowconfigure $w.lf1 2 -weight 1
    grid columnconfigure $w.lf1 3 -weight 1
    ::autoscroll::autoscroll $w.lf1.y
    frame $w.bf
    button $w.bf.ok -text [mc OK] -command [list ::khim::OK $w]
    button $w.bf.apply -text [mc Apply] -command [list ::khim::Apply $w]
    button $w.bf.cancel -text [mc Cancel] -command [list destroy $w]
    button $w.bf.help -text [mc Help...] \
	-command [list ::khim::showHelp $w.help]
    grid $w.bf.ok -row 0 -column 0 -padx 5 -sticky ew
    grid $w.bf.apply -row 0 -column 1 -padx 5 -sticky ew
    grid $w.bf.cancel -row 0 -column 2 -padx 5 -sticky ew
    grid $w.bf.help -row 0 -column 4 -padx 5
    grid columnconfigure $w.bf 3 -weight 1
    grid columnconfigure $w.bf {0 1 2 4} -uniform A
    grid $w.v -columnspan 2 -sticky w
    grid $w.l1 $w.b1 -sticky w
    grid $w.lf1 -columnspan 2 -sticky nsew -padx 5 -pady 5
    grid $w.bf -pady 5 -sticky ew -columnspan 2
    grid columnconfigure $w 1 -weight 1

    # Initialize the listbox content

    ShowSequences $w

    # Pop up the dialog

    wm deiconify $w
    tkwait window $w
    return
}

#----------------------------------------------------------------------
#
# khim::FocusAndInsertSymbol --
#
#	Shift focus to a given window and call the character map
#	interactor on it.
#
# Parameters:
#	w - Window to focus
#
# Results:
#	None.
#
# Side effects:
#	Whatever the user requests from the character map.
#
#----------------------------------------------------------------------

proc khim::FocusAndInsertSymbol {w} {
    focus $w
    CMapInteractor $w
    return
}

#----------------------------------------------------------------------
#
# khim::showHelp --
#
#	Display a help dialog for KHIM
#
# Parameters:
#	w -- Path name of the dialog
#
# Results:
#	None.
#
# Side effects:
#	Pops up the dialog.
#
# The help text is in the HELPTEXT entry in the message catalog of the
# current locale.
#
#----------------------------------------------------------------------

proc khim::showHelp {w} {

    variable KHIMDir

    # Create dialog to display help

    catch {destroy $w}
    toplevel $w
    wm withdraw $w
    set p [winfo toplevel [winfo parent $w]]
    set g [wm transient $p]
    if { ![string compare {} $g] } {
	set g $p
    }
    wm transient $w $g
    wm title $w [mc {KHIM Help}]
    catch {wm attributes $w -toolwindow 1}

    # Create and manage GUI components

    text $w.t -width 60 -yscrollcommand [list $w.y set] -wrap word
    set text [string trim [mc HELPTEXT]]
    if {$text eq "HELPTEXT"} {
	# This must be a version of Tcl that doesn't support the root
	# locale.  Do The Right Thing anyway
	set locale [::msgcat::mclocale]
	::msgcat::mclocale en
	set text [string trim [mc HELPTEXT]]
	if {$text eq "HELPTEXT"} {
	    ::msgcat::mcload $KHIMDir
	    set text [string trim [mc HELPTEXT]]
	}
	::msgcat::mclocale $locale
    }
    regsub -all -line {^[ \t]+} $text {} text
    regsub -all -line {[ \t]+$} $text {} text
    regsub -all {\n\n} $text <p> text
    regsub -all {\n} $text { } text
    regsub -all <p> $text \n\n text
    $w.t insert insert $text
    $w.t see 1.0
    $w.t configure -state disabled
    scrollbar $w.y -command [list $w.t yview] -orient vertical
    button $w.ok -text [mc OK] -command [list destroy $w]
    grid $w.t -row 0 -column 0 -sticky nsew
    grid $w.y -row 0 -column 1 -sticky ns
    grid $w.ok -pady 5 -row 1 -column 0 -columnspan 2
    grid rowconfigure $w 0 -weight 1
    grid columnconfigure $w 0 -weight 1

    # Determine whether we have a grab in effect

    set gr [grab current $w]
    if {$gr ne {}} {
	bind $w <Map> "focus $w.ok; grab set $w"
    } else {
	bind $w <Map> [list focus $w.ok]
    }

    # Pop up the dialog

    wm deiconify $w

    # Restore the grab if there was one

    if {$gr ne {}} {
	tkwait window $w
	grab set $gr
    }

    return
}

#----------------------------------------------------------------------
#
# khim::GetComposeKey --
#
#	Prompt the user for what key to use for the "Compose" function.
#
# Parameters:
#	parent -- Path name of the parent widget of the dialog
#
# Side effects:
#	Stores the user's selection in 'inputComposeKey'
#
#----------------------------------------------------------------------

proc khim::GetComposeKey {parent} {
    variable KHIMDir
    variable inputComposeKey
    set w [winfo parent $parent].composeKey
    toplevel $w -class dialog
    wm withdraw $w
    wm geometry $w +[winfo rootx $parent]+[winfo rooty $parent]
    set p [winfo toplevel [winfo parent $w]]
    set g [wm transient $p]
    if { ![string compare {} $g] } {
	set g $p
    }
    wm transient $w $g
    catch {wm attributes $w -toolwindow 1}
    wm title $w [mc "Compose Key"]
    set text [mc "SELECT COMPOSE KEY"]
    if {$text eq "SELECT COMPOSE KEY"} {
	# This must be a version of Tcl that doesn't support the root
	# locale.  Do The Right Thing anyway
	set locale [::msgcat::mclocale]
	::msgcat::mclocale en
	set text [string trim [mc "SELECT COMPOSE KEY"]]
	if {$text eq "SELECT COMPOSE KEY"} {
	    ::msgcat::mcload $KHIMDir
	    set text [string trim [mc "SELECT COMPOSE KEY"]]
	}
	::msgcat::mclocale $locale
    }
    grid [label $w.l -text $text]
    bind $w.l <Any-Key> [list set ::khim::inputComposeKey %K]
    bind $w.l <Map> [list focus %W]
    wm resizable $w 0 0
    bind $w <Map> [list grab $w]
    wm deiconify $w
    bind $w <Destroy> {set ::khim::inputComposeKey DESTROYED}
    set holdInputComposeKey $inputComposeKey
    while {1} {
	vwait ::khim::inputComposeKey
	if { $inputComposeKey eq {DESTROYED} } {
	    set inputComposeKey $holdInputComposeKey
	    break
	} elseif {$inputComposeKey ne {}} {
	    bind $w <Destroy> {}
	    after idle [list destroy $w]
	    break
	}
    }
    return
}

#----------------------------------------------------------------------
#
# khim::Select --
#
#	Handles selection in the listbox containing KHIM input
#	character sequences.
#
# Parameters:
#	lb -- Path name of the listbox.
#
# Results:
#	None.
#
# Side effects:
#	Stores the currently selected sequence, and its mapping,
#	in "inputSequence" and "inputCharacter."
#
#----------------------------------------------------------------------

proc khim::Select {lb} {
    variable inputSequence
    variable inputCharacter
    foreach item [$lb curselection] {
	if { [regexp "^(..) \u2192 (.)" [$lb get $item] \
		  -> inputSequence inputCharacter] } {
	    break
	}
    }
    return
}

#----------------------------------------------------------------------
#
# khim::DeleteSequence --
#
#	Deletes the currently selected input sequence from the set.
#
# Parameters:
#	w - Path name of the active dialog box.
#
# Results:
#	None.
#
# Side effects:
#	Removes the currently selected sequence from 'inputMap'
#	and redisplays the sequences in the listbox
#
#----------------------------------------------------------------------

proc khim::DeleteSequence {w} {
    khim::SetSequence $w {}
    return
}

#----------------------------------------------------------------------
#
# khim::ChangeSequence --
#
#	Changes the currently selected input sequence from the set.
#
# Parameters:
#	w - Path name of the active dialog box.
#
# Results:
#	None.
#
# Side effects:
#	Changes the currently selected sequence from 'inputMap'
#	to request the character stored in 'inputCharacter'
#	and redisplays the sequences in the listbox
#
#----------------------------------------------------------------------

proc khim::ChangeSequence {w} {
    variable inputCharacter
    khim::SetSequence $w $inputCharacter
    return
}

#----------------------------------------------------------------------
#
# khim::SetSequence --
#
#	Deletes or changes a character sequence in the input map
#
# Parameters:
#	w - Path name of the active dialog box
#	inputCharacter - Character that the active sequence should
#		         map to.  An empty string deletes the sequence.
#
# Results:
#	None.
#
# Side effects:
#	Changes the currently selected sequence from 'inputMap'
#	to request the character stored in 'inputCharacter'
#	and redisplays the sequences in the listbox
#
#----------------------------------------------------------------------

proc khim::SetSequence {w inputCharacter} {
    variable inputSequence
    variable inputMap
    if { [string length $inputSequence] != 2 } {
	tk_messageBox \
	    -message [mc {Composed sequence must be two characters long}] \
	    -type ok \
	    -icon error \
	    -parent $w \
	    -title [mc {Invalid sequence}]
    } elseif { [string length $inputCharacter] == 0 } {
	catch { unset inputMap($inputSequence) }
	ShowSequences $w
    } else {
	set inputMap($inputSequence) $inputCharacter
	ShowSequences $w $inputSequence
    }
    return
}

#----------------------------------------------------------------------
#
# khim::ShowSequences --
#
#	Updates the listbox in the KHIM configuration dialog with
#	the currently defined input sequences.
#
# Parameters:
#	w -- Path name of the active dialog
#	inputSequence -- Input sequence that has been changed, if any.
#
# Results:
#	None.
#
# Side effects:
#	Listbox is updated to reflect change, and the active sequence
#	is selected.
#
#----------------------------------------------------------------------

proc khim::ShowSequences {w {inputSequence {}}} {
    variable inputMap

    # Remember the scroll position

    foreach {top bottom} [$w.lf1.lb yview] break
    
    # Clear the listbox

    $w.lf1.lb delete 0 end

    # Put all the items back in the listbox, in order.
    # Remember the index of any item that matches the current sequence.

    foreach key [lsort -dictionary [array names inputMap]] {
	if { ![string compare $key $inputSequence] } {
	    set idx [$w.lf1.lb index end]
	}
	$w.lf1.lb insert end "$key \u2192 $inputMap($key)"
    }

    # Select the just-changed item, if any.  If there is nothing to select,
    # simply restore the scroll position.

    if { [info exists idx] } {
	$w.lf1.lb selection set $idx
	$w.lf1.lb see $idx
    } else {
	$w.lf1.lb yview moveto $top
    }
    return
}

#----------------------------------------------------------------------
#
# khim::Apply --
#
#	Apply changes from the KHIM configuration dialog.
#
# Parameters:
#	w - Path name of the dialog
#
# Results:
#	None.
#
# Side effects:
#	Current configuration is stored, and bindings to the KHIM
#	bindtag are applied.
#
#----------------------------------------------------------------------

proc khim::Apply { w } {
    variable use
    variable composeKey
    variable map
    variable inputUse
    variable inputComposeKey
    variable inputMap

    set use $inputUse
    set composeKey $inputComposeKey
    set map [array get inputMap]
    RedoBindings

    return
}

#----------------------------------------------------------------------
#
# khim::OK --
#
#	Apply changes and dismiss the KHIM configuration dialog.
#
# Parameters:
#	w - Path name of the dialog
#
# Results:
#	None.
#
# Side effects:
#	Current configuration is stored, and bindings to the KHIM
#	bindtag are applied.  The dialog is dismissed.
#
#----------------------------------------------------------------------

proc khim::OK { w } {
    Apply $w
    destroy $w
}

#----------------------------------------------------------------------
#
# khim::HandleDestroy --
#
#	Clean up from destruction of the KHIM input dialog.
#
# Parameters:
#	w - Path name of the destroyed window
#	t - Path name of the toplevel of the active dialog.
#
# Results:
#	None.
#
# Side effects:
#	Unsets variables that are used only when the dialog is active.
#
#----------------------------------------------------------------------

proc khim::HandleDestroy { w t } {
    if { [string compare $w $t] } return
    variable inputComposeKey
    variable inputMap
    variable inputUse
    unset inputUse
    unset inputComposeKey
    unset inputMap
    return
}

#----------------------------------------------------------------------
#
# khim::RedoBindings --
#
#	Establish bindings on the KHIM bindtag according to the current
#	settings.
#
# Parameters:
#	None.
#
# Results:
#	None.
#
# Side effects:
#	Binds the Compose key to a {break}, the leading character
#	of each two-character sequence to a break as well, and
#	the second character of each two character sequence to
#	insert the mapped character. Arranges so that unrecognized
#	two-character sequences insert the two individual characters.
#
#----------------------------------------------------------------------

proc khim::RedoBindings {} {
    variable use
    variable composeKey
    variable map
    foreach b [bind KHIM] {
	bind KHIM $b {}
    }
    if { $use } {
	bind KHIM <Key-$composeKey> break
	bind KHIM <Key-$composeKey><Key-$composeKey> {
	    khim::CMapInteractor %W
	}
	foreach {seq char} $map {
	    set c0 [string map {{ } <space> < <less>} [string index $seq 0]]
	    set c1 [string map {{ } <space> < <less>} [string index $seq 1]]
	    bind KHIM <Key-$composeKey>$c0 break
	    bind KHIM <Key-$composeKey>$c0<Key> \
		[list khim::BadCompose %W [string index $seq 0] %A]
	    bind KHIM <Key-$composeKey>$c0$c1 \
		[list khim::Insert %W $char]\;break
	}
    }
    return
}

#----------------------------------------------------------------------
#
# khim::BadCompose --
#
#	Handle an unrecognized key sequence
#
# Parameters:
#	w - Focus window
#	c0 - First character in the sequence
#	c1 - Second character in the sequence, or an empty string if
#	     there is no second character
#
# Results:
#	None
#
# Side effects:
#	Inserts the two individual characters into the focus window.
#
#----------------------------------------------------------------------

proc khim::BadCompose {w c0 c1} {
    if {$c1 ne {}} {
	khim::Insert $w $c0
	khim::Insert $w $c1
    }
    return -code break
}

#----------------------------------------------------------------------
#
# khim::Insert --
#
#	Inserts a character into a text or entry.
#
# Parameters:
#	w - Window in which to insert
#	c - Character to insert
#
# Results:
#	None.
#
# Side effects:
#	Character is inserted.
#
#----------------------------------------------------------------------

proc khim::Insert {w c} {
    $w insert insert $c
    switch -exact [winfo class $w] {
	Entry - TEntry {
	    set c [$w index insert]
	    if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} {
		$w xview $c
	    }
	}
	Text {
	    $w see insert
	}
    }
}

#----------------------------------------------------------------------
#
# khim::getConfig --
#
#	Returns a script that will restore the current KHIM configuration.
#
# Results:
#	Returns the script.
#
#----------------------------------------------------------------------

proc khim::getConfig {} {
    variable use
    variable composeKey
    variable map
    array set x $map
    set retval [list khim::setConfig 1.0 $use $composeKey]
    append retval { } \{
    foreach key [lsort -dictionary [array names x]] {
	append retval \n {    } [list $key] { } [ReplaceU $x($key)]
    }
    append retval \n\}
}

#----------------------------------------------------------------------
#
# khim::setConfig --
#
#	Restores the saved configuration from "khim::getConfig"
#
# Parameters:
#	version - Version of the configuration command
#	u - Flag for whether KHIM is enabled
#	c - Compose key selected
#	m - Map from compose sequences to characters.
#
# Results:
#	None
#
# Side effects:
#	Configuration is set.
#
#----------------------------------------------------------------------

proc khim::setConfig {v u c m args} {
    variable use
    variable composeKey
    variable map
    switch -exact $v {
	1.0 {
	    set use $u
	    set composeKey $c
	    set map $m
	}
	default {
	    return -code error "Unknown KHIM version $v"
	}
    }
    RedoBindings
    return
}

#----------------------------------------------------------------------
#
# khim::ReplaceU --
#
#	Replaces non-ASCII characters in a Unicode string with \u escapes.
#
# Parameters:
#	s - String to clean up
#
# Results:
#	Returns the cleaned string.
#
#----------------------------------------------------------------------

proc khim::ReplaceU {string} {
    set retval {}
    foreach char [split $string {}] {
	scan $char %c ccode
	if { $ccode >= 0x0020 && $ccode < 0x007f
	     && $char ne "\{" && $char ne "\}" && $char ne "\["
	     && $char ne "\]" && $char ne "\\" && $char ne "\$" } {
	    append retval $char
	} else {
	    append retval \\u [format %04x $ccode]
	}
    }
    return $retval
}

#----------------------------------------------------------------------
#
# khim::CMapUpdateSpinbox --
#
#	Variable trace callback that manages the state of the
#	code page selection spinbox when the code page changes.
#
# Parameters:
#	w - Window path name of the character map dialog
#	args - Extra args from the 'trace' mechanism are not used here.
#
# Results:
#	None.
#
# Side effects:
#	If the CMapInputCodePage variable contains an invalid code
#	page number, the background of the spinbox changes to red.
#	Otherwise, the background of the spinbox changes to white.
#       The values list of the spinbox is updated to be a list of
#	the decimal or hexadecimal code page numbers according to
#	whether the variable's string representation contains
#	'0x'. 
#
#----------------------------------------------------------------------

proc khim::CMapUpdateSpinbox {w args} {
    variable CMapInputCodePage
    variable CMapCodePage
    variable CMapSavedColors

    set spin $w.spin

    # Test validity of the code page number

    if { ![string is integer -strict $CMapInputCodePage($w)]
	 || $CMapInputCodePage($w) < 0
	 || $CMapInputCodePage($w) >= 0x100 } {
	if {![info exists CMapSavedColors($w)]} {
	    set CMapSavedColors($w) \
		[list [$spin cget -background] [$spin cget -foreground]]
	}
	$spin configure -background \#ff6666 -foreground \#000000
    } else {

	# Valid code page - generate the values list. Make sure that
	# the current value is in the list, even if it's formatted
	# eccentrically (e.g., 0x000012).

	if {[info exists CMapSavedColors($w)]} {
	    foreach {bg fg} $CMapSavedColors($w) break
	    $spin configure -background $bg -foreground $fg
	    unset CMapSavedColors($w)
	}
	if { [string match *0x* $CMapInputCodePage($w)] } {
	    set format 0x%02X
	} else {
	    set format %d
	}
	for { set i 0 } { $i < $CMapInputCodePage($w) } { incr i } {
	    lappend values [format $format $i]
	}
	lappend values $CMapInputCodePage($w)
	for { incr i } { $i < 0x100 } { incr i } {
	    lappend values [format $format $i]
	}

	# When we change the values list, the content of the spinbox
	# appears to be lost; deal with this by saving and restoring it.

	set cp $CMapInputCodePage($w)
	set i [$spin index insert]
	$spin configure -values $values
	$spin set $cp
	$spin icursor $i
	set CMapCodePage($w) $CMapInputCodePage($w)
    }
    return
}

#----------------------------------------------------------------------
#
# khim::CMapDrawCanvas --
#
#	Puts a map of a single Unicode code page into a canvas.
#
# Parameters:
#	w -- Path name of the character map dialog
#	args -- Additional arguments resulting from a 'trace' callback
#
# Results:
#	None.
#
# Side effects:
#	The given canvas is redrawn with a 16x16 grid of characters.
#
#----------------------------------------------------------------------

proc khim::CMapDrawCanvas {w args} {
    variable CMapCodePage
    variable CMapInputCodePage
    variable CMapFont
    variable CMapBadCharFont
    variable CMapXL
    variable CMapYL
    variable CMapSelectedCharacter
    variable CMapAfter
    variable CMapBackground
    variable CMapForeground

    if {[info exists CMapAfter($w)]} {
	after cancel $CMapAfter($w)
	unset CMapAfter($w)
    }

    set c $w.c

    set pad 2

    # Clear the canvas

    $c delete all

    set minsize [CMapCellSize $c]

    # Drop glyphs for all the characters onto the canvas, stacking them
    # all at (0,0).  We'll be sliding them by rows and columns to make the
    # grid.

    set rem [expr { $CMapSelectedCharacter($w) % 0x0100 }]
    set srow [expr { $rem / 16 }]
    set scol [expr { $rem % 16 }]
    set tick [clock clicks -milliseconds]
    set ok 1
    for { set row 0 } { $row < 16 } { incr row } {
	for { set col 0 } { $col < 16 } { incr col } {
	    set point [expr { 256 * $CMapCodePage($w) + 16 * $row + $col }]
	    if { ($ok || ($row == $srow && $col == $scol))
		 && [ValidChar $point] } {
		set t [format %c $point]
		set f $CMapFont
	    } else {
		set t [format %02X\n%02X \
			   [expr { $point / 0x100 }] [expr { $point % 0x100 }]]
		set f $CMapBadCharFont
	    }
	    set tags [list text row$row col$col]
	    $c create text 0 0 -text $t -font $f -fill $CMapForeground($w)\
		-anchor center -justify center -tags $tags
	    set tock [clock clicks -milliseconds]
	    if {$ok && $tock-$tick > 1500} {
		set CMapAfter($w) [after 500 [list khim::CMapDrawCanvas $w]]
		set ok 0
	    }
	}
    }

    # Spread out the columns and generate a list of the X co-ordinates
    # of the spacer lines

    set xmin [expr {$pad + 1}]
    set x $xmin
    set CMapXL($w) [list $x]
    for { set col 0 } { $col < 16 } { incr col } {
	foreach { x0 - x1 - } [$c bbox col$col] break
	set cw [expr { $x1 - $x0 + 5 }]
	if { $cw < $minsize } {
	    set cw $minsize
	}
	set xt [expr { $x + $cw/2 }]
	set dx [expr { $xt - ( $x0 + $x1 ) / 2 }]
	$c move col$col $dx 0
	incr x $cw
	lappend CMapXL($w) $x
    }
    set xmax $x

    # Now do the same with the rows

    set ymin [expr {$pad + 1}]
    set y $ymin
    set CMapYL($w) [list $y]
    for { set row 0 } { $row < 16 } { incr row } {
	foreach {  - y0 - y1 } [$c bbox row$row] break
	set rh [expr { $y1 - $y0 + 5 }]
	if { $rh < $minsize } {
	    set rh $minsize
	}
	set yt [expr { $y + $rh/2 }]
	set dy [expr { $yt - ( $y0 + $y1 ) / 2 }]
	$c move row$row 0 $dy
	incr y $rh
	lappend CMapYL($w) $y
    }
    set ymax $y

    # Now that the characters on the grid are properly positioned, draw
    # the separator lines and configure the canvas size

    # We interpolate between foreground and background to draw the lines,
    # so that they appear "finer" visually than a 0-pixel line
    
    set linecolor \#
    foreach \
	c1 [winfo rgb $c $CMapForeground($w)] \
	c2 [winfo rgb $c $CMapBackground($w)] {
	    set c3 [expr {(3 * $c2 + $c1) / 4}]
	    append linecolor [format %04x $c3]
	}
    foreach x $CMapXL($w) {
	$c create line $x $ymin $x $ymax -width 0 -fill $linecolor
    }
    foreach y $CMapYL($w) {
	$c create line $xmin $y $xmax $y -width 0 -fill $linecolor
    }
    $c configure -width [expr { $xmax + $pad }] \
	-height [expr { $ymax + $pad }] \
	-scrollregion [list 0 0 [expr {$xmax + $pad}] [expr {$ymax + $pad}]]

    # Change the codepage in the spinbox

    if { $CMapCodePage($w) != $CMapInputCodePage($w) } {
	set CMapInputCodePage($w) $CMapCodePage($w)
    }

    # Display a selection box

    ShowSelectedCell $w
}

#----------------------------------------------------------------------
#
# khim::CMapCellSize --
#
#	Computes the size of one cell in the character map
#
# Parameters:
#	c - canvas in which the map will be drawn.
#
# Results:
#	Returns the size in pixels of one square cell in the canvas.
#
#----------------------------------------------------------------------

proc khim::CMapCellSize {c} {

    variable CMapFont
    variable CMapBadCharFont

    # Compute the minimum linear dimension of one box in the grid.
    # It is at least 5 pxl greater than
    #   - the linespace of the display font
    #   - 2-line space in the "bad character" font
    #   - one em in the display font
    #   - two digit widths in the "bad character" font

    set minsize \
	[expr { [font metrics $CMapFont -displayof $c -linespace] + 5 }]
    set minsize2 [expr { 2 * [font metrics $CMapBadCharFont \
				  -displayof $c -linespace] + 5 }]
    if { $minsize2 > $minsize } {
	set minsize $minsize2
    }
    set minsize2 [expr { [font measure $CMapFont -displayof $c M] + 5 }]
    if { $minsize2 > $minsize } {
	set minsize $minsize2
    }
    set minsize2 [expr { [font measure $CMapBadCharFont -displayof $c 00] + 5 }]
    if { $minsize2 > $minsize } {
	set minsize $minsize2
    }
    return $minsize
}

#----------------------------------------------------------------------
#
# khim::ShowSelectedCell --
#
#	Paints a border around the cell in the KHIM character map
#	corresponding to the selected character
#
# Parameters:
#	w - Path name of the character map
#
# Results:
#	None.
#
#----------------------------------------------------------------------

proc khim::ShowSelectedCell {w} {
    variable CMapCodePage
    variable CMapSelectedCharacter
    variable CMapXL
    variable CMapYL
    variable CMapBackground
    variable CMapForeground
    variable CMapSelectBackground
    variable CMapSelectForeground
    if { $CMapSelectedCharacter($w) < $CMapCodePage($w) * 0x0100
	 || $CMapSelectedCharacter($w) >= ($CMapCodePage($w) + 1) * 0x100 } {
	set CMapSelectedCharacter($w) \
	    [expr { ($CMapSelectedCharacter($w) % 0x100)
		    + (0x100 * $CMapCodePage($w)) }]
    }
    set c $w.c
    set rem [expr { $CMapSelectedCharacter($w) % 0x0100 }]
    set row [expr { $rem / 16 }]
    set col [expr { $rem % 16 }]

    $c itemconfigure text -fill $CMapForeground($w)
    $c itemconfigure text&&row$row&&col$col -fill $CMapSelectForeground($w)

    set xmin [lindex $CMapXL($w) $col]
    incr col
    set xmax [lindex $CMapXL($w) $col]

    set ymin [lindex $CMapYL($w) $row]
    incr row
    set ymax [lindex $CMapYL($w) $row]
    catch { $c delete selectrect }
    $c create rectangle $xmin $ymin $xmax $ymax \
	-width 2 -fill $CMapSelectBackground($w) \
	-outline $CMapSelectForeground($w) -tags selectrect
    $c lower selectrect text
    return
}

#----------------------------------------------------------------------
#
# khim::CMapSelectedCharacter --
#
#	Given X and Y co-ordinates in the character map, determines
#	what character is selected.
#
# Parameters:
#	c - The canvas displaying the map.
#
# Results:
#	Returns the character, or an empty string if the co-ordinates
#	do not designate a cell.
#
#----------------------------------------------------------------------

proc khim::CMapSelectedCharacter {w x y} {
    variable CMapCodePage
    variable CMapXL
    variable CMapYL
    set row [BSearch $CMapYL($w) $y]
    set col [BSearch $CMapXL($w) $x]
    if { $row >= 0 && $row <= 15 && $col >= 0 && $col <= 15 } {
	return [format %c [expr { 0x100 * $CMapCodePage($w) 
				  + 0x10 * $row 
				  + $col }]]
    } else {
	return {}
    }
}

#----------------------------------------------------------------------
#
# khim::CMapSelect --
#
#	Handles mouse selection in the KHIM color map
#
# Parameters:
#	c - Path name of the canvas
#	x, y - Mouse coordinates relative to the canvas
#
# Results:
#	None
#
# Side effects:
#	Character in the cell containing the pointer is selected, and
#	the display of the selection is updated.
#
#----------------------------------------------------------------------

proc khim::CMapSelect {c x y} {
    variable CMapSelectedCharacter
    set w [khim::CMapCanvToDialog $c]
    set ch [khim::CMapSelectedCharacter $w $x $y]
    if { $ch ne {} } {
	scan $ch %c CMapSelectedCharacter($w)
    }
    ShowSelectedCell $w
    return
}

#----------------------------------------------------------------------
#
# khim::CMapActivate --
#
#	Activates the KHIM character map after a mouse selection.
#
# Parameters:
#	c - Path name of the canvas
#	x, y - Mouse coordinates relative to the canvas
#
# Results:
#	None
#
# Side effects:
#	Directs focus to the canvas, and selects the character designated
#	by the pointer.
#
#----------------------------------------------------------------------

proc khim::CMapActivate {c x y} {
    focus $c
    khim::CMapSelect $c $x $y
    return
}

#----------------------------------------------------------------------
#
# khim::CMapHomeEnd --
#
#	Handles the Home and End keys in the KHIM character map
#
# Parameters:
#	c - Path name of the canvas
#	unit - Unit being homed (word, page, file)
#	key - 1 for End, 0 for Home
#
# Results:
#	None.
#
# Side effects:
#	Moves the selection according to the key pressed.
#
#----------------------------------------------------------------------

proc khim::CMapHome {c unit key} {
    variable CMapSelectedCharacter
    set w [khim::CMapCanvToDialog $c]
    set sc [expr { $unit * ($CMapSelectedCharacter($w) / $unit)
		   + $key * ($unit - 1) }]
    khim::CMapMoveTo $c $sc
    return
}

#----------------------------------------------------------------------
#
# khim::CMapMove --
#
#	Handles several cursor keys (Left, Right, Up, Down, PgUp,
#	PgDn) in the KHIM character map.
#
# Parameters:
#	c - Path name of the canvas
#	delta - Number of code points to move
#
# Results:
#	None.
#
# Side effects;
#	Moves the selection by the designated number of codepoints.
#
#----------------------------------------------------------------------

proc khim::CMapMove {c delta} {
    variable CMapSelectedCharacter
    set w [khim::CMapCanvToDialog $c]
    set sc [expr { $CMapSelectedCharacter($w) + $delta }]
    if { $sc < 0 } {
	set sc 0
    } elseif { $sc > 0xffff } {
	set sc 0xffff
    }
    khim::CMapMoveTo $c $sc
    return
}

#----------------------------------------------------------------------
#
# khim:CMapMoveTo --
#
#	Changes the selection in the KHIM character map to a specified
#	codepoint.
#
# Parameters:
#	c - Path name of the canvas
#	sc - Code point to select, expressed as an integer
#
# Results:
#	None
#
# Side effects:
#	Moves the selection to the given character.
#
#----------------------------------------------------------------------

proc khim::CMapMoveTo { c sc } {
    variable CMapSelectedCharacter
    variable CMapCodePage
    set w [khim::CMapCanvToDialog $c]
    set cp [expr { $sc / 0x0100 }]
    set CMapSelectedCharacter($w) $sc
    if { $cp != $CMapCodePage($w) } {
	set CMapCodePage($w) $cp
    } else {
	ShowSelectedCell $w
    }
    return
}

#----------------------------------------------------------------------
#
# CMapKey --
#
#	Handles non-cursor keypresses in the KHIM character map
#
# Parameters:
#	c - Path name of the canvas
#	char - Character sent by the key
#
# Results:
#	None.
#
# Side effects:
#	Selects the given character
#
#----------------------------------------------------------------------

proc khim::CMapKey {c char} {
    if {$char eq {}} return;		# If the key doesn't generate a char,
					# ignore it.
    scan $char %c sc
    CMapMoveTo $c $sc
    return
}

#----------------------------------------------------------------------
#
# khim::CMapWheel --
#
#	Handles the mousewheel in the KHIM character map
#
# Parameters:
#	c - Path name of the canvas
#	delta - Amount by which the canvas is to move.
#
# Return value:
#	None.
#
# Side effects:
#	Adjusts the selection by an appropriately scaled version of 'delta'
#	
#----------------------------------------------------------------------

proc khim::CMapWheel { c delta shifted } {
    # the delta will vary for OS X and X11/Win32, but we only check
    # + or - and move accordingly
    if {$delta > 0} {
	khim::CMapMove $c [expr {$shifted ? -1 : -16}]
    } else {
	khim::CMapMove $c [expr {$shifted ? 1 : 16}]
    }
    return
}

#----------------------------------------------------------------------
#
# khim::CMapCanvToDialog --
#
#	Locates the KHIM character map dialog given the widget path
#	name of the canvas.
#
# Parameters:
#	c - Path name of the canvas
#
# Results:
#	Returns the path name of the dialog.
#
#----------------------------------------------------------------------

proc khim::CMapCanvToDialog {c} {
    return [winfo parent $c]
}

#----------------------------------------------------------------------
#
# khim::CMapInteractor --
#
#	Posts the KHIM character map for interacting with the user.
#
# Parameters:
#	w - Path name of the text or canvas widget to which the
#	    interactor applies.
#
# Results:
#	None.
#
# Side effects:
#	Interactor is posted, and the event loop is entered recursively
#	to handle it.  On return, any requested symbol insertion has
#	already been done.
#
#----------------------------------------------------------------------

proc khim::CMapInteractor {w} {
    variable CMapSelectedCharacter
    variable CMapInputCodePage
    variable CMapCodePage
    variable CMapFocus
    variable CMapBackground
    variable CMapForeground
    variable CMapSelectBackground
    variable CMapSelectForeground
    set t [winfo toplevel $w]
    if { $t eq "." } {
	set t {}
    }
    set map $t.khimcmap
    if {[winfo exists $map]} {
	wm deiconify $map
	return
    }
    toplevel $map
    wm withdraw $map
    wm title $map [mc {Insert Character}]

    if { ![info exists CMapInputCodePage($map)] } {
	set CMapInputCodePage($map) 0
	set CMapCodePage($map) 0
    }
    grid [label $map.l1 -text [mc {Select code page:}]] \
	-row 0 -column 0 -sticky e
    grid [spinbox $map.spin -textvariable khim::CMapInputCodePage($map) \
	      -width 4] \
	-row 0 -column 1 -sticky w

    # Get canvas background from the background that a text widget would
    # have had.
    text $map.text
    set CMapBackground($map) [$map.text cget -background]
    set CMapForeground($map) [$map.text cget -foreground]
    set CMapSelectBackground($map) [$map.text cget -selectbackground]
    set CMapSelectForeground($map) [$map.text cget -selectforeground]
    destroy $map.text

    # Create the dialog
    set c $map.c
    grid [canvas $c -width 400 -height 400 \
	      -bg $CMapBackground($map) -takefocus 1] \
	-columnspan 2 -padx 3 -pady 3
    grid [frame $map.f] -row 2 -column 0 -columnspan 2 -sticky ew -pady 3
    button $map.f.b1 -text [mc OK] -command [list khim::CMapOK $map]
    button $map.f.b2 -text [mc Cancel] -command [list khim::CMapCancel $map]
    button $map.f.b3 -text [mc Help...] \
	-command [list khim::showHelp $map.help]
    grid $map.f.b1 -row 0 -column 0 -sticky ew -padx 5
    grid $map.f.b2 -row 0 -column 1 -sticky ew -padx 5
    grid $map.f.b3 -row 0 -column 3 -sticky ew -padx 5
    grid columnconfigure $map.f 2 -weight 1
    grid columnconfigure $map.f {0 1 3} -uniform A
    grid columnconfigure $map 1 -weight 1

    bindtags $c [list $c khim::cmap Canvas [winfo toplevel $c] all]
    trace add variable ::khim::CMapInputCodePage($map) write \
	[list khim::CMapUpdateSpinbox $map]
    after idle [list khim::CMapUpdateSpinbox $map]
    trace add variable ::khim::CMapCodePage($map) write \
	[list khim::CMapDrawCanvas $map]
    if { ![info exists CMapSelectedCharacter($map)] } {
	set CMapSelectedCharacter($map) 0x0000
    }
    set CMapFocus($map) $w

    # Draw the character map in the canvas
    CMapDrawCanvas $map

    wm deiconify $map
    bind $map <Map> [list grab $map]
    bind $map.c <Map> [list focus %W]

    # eeew, tkwait... make this interaction modal
    tkwait window $map
    catch {
	destroy $map
    }
    focus $w
    return
}    

#----------------------------------------------------------------------
#
# khim::CMapCopypastedismiss --
#
#	Handles double-click in the KHIM character map.
#
# Parameters:
#	c - Path name of the canvas
#	x,y - Mouse co-ordinates of the double click
#
# Results:
#	None.
#
# Side effects:
#	Copies the designated character into the text or entry
#	that KHIM is using, and dismisses the widget.
#
#----------------------------------------------------------------------

proc khim::CMapCopypastedismiss {c x y} {
    CMapSelect $c $x $y
    CMapOK $c
    return
}

#----------------------------------------------------------------------
#
# khim::CMapOK
#
#	Handles the 'OK' button in the KHIM character map.
#
# Parameters:
#	w - Path name of the dialog
#
# Results:
#	None.
#
# Side effects:
#	Copies the selected character into the text or entry
#	that KHIM is using, and dismisses the widget.
#
#----------------------------------------------------------------------

proc khim::CMapOK {w} {
    CMapCopy $w
    CMapPasteToFocus $w
    CMapCancel $w
    return
}

#----------------------------------------------------------------------
#
# khim::CMapCopy --
#
#	Copies a character from the KHIM character map onto the
#	clipboard.
#
# Parameters:
#	w - Path name of the dialog.
#
# Results:
#	None.
#
# Side efffects:
#	Copies the selected character to the clipboard.
#
#----------------------------------------------------------------------

proc khim::CMapCopy {w} {
    variable CMapSelectedCharacter
    clipboard clear -displayof $w
    upvar 0 CMapSelectedCharacter([winfo toplevel $w]) ch
    if { [info exists ch] && $ch ne {} } {
	clipboard append -displayof $w -- [format %c $ch]
    }
    return
}

#----------------------------------------------------------------------
#
# khim::CMapPasteToFocus --
#
#	Sends a <<Paste>> event into the window on whose behalf
#	the KHIM character map was invoked, to copy a character selection
#	into it.
#
# Parameters:
#	w - Path name of the character map dialog.
#
# Results:
#	None.
#
# Side effects:
#	<<Paste>> is generated.
#
#----------------------------------------------------------------------

proc khim::CMapPasteToFocus {w} {
    variable CMapFocus
    event generate $CMapFocus([winfo toplevel $w]) <<Paste>>
    return
}

#----------------------------------------------------------------------
#
# khim::CMapCancel --
#
#	Handles the 'Cancel' button in the KHIM character map.
#
# Parameters:
#	w - Path name of the character map dialog.
#
# Results:
#	None.
#
# Side effects:
#	Destroys the dialog without taking further action.
#
#----------------------------------------------------------------------

proc khim::CMapCancel {w} {
    destroy [winfo toplevel $w]
}

#----------------------------------------------------------------------
#
# khim::CMapDestroy --
#
#	Handles the <Destroy> notification in the KHIM character map
#
# Parameters:
#	c - Path name of the character map canvas
#
# Results:
#	None.
#
# Side effects:
#	Cleans up memory for the destroyed widget.
#
#----------------------------------------------------------------------

proc khim::CMapDestroy {c} {
    variable CMapFocus
    variable CMapAfter
    variable CMapXL
    variable CMapYL
    variable CMapSavedColors
    variable CMapForeground
    variable CMapBackground
    variable CMapSelectForeground
    variable CMapSelectBackground
    set w [winfo toplevel $c]
    if {[info exists CMapAfter($w)]} {
	after cancel $CMapAfter($w)
	unset CMapAfter($w)
    }
    catch {unset CMapFocus($w)}
    catch {unset CMapXL($w)}
    catch {unset CMapYL($w)}
    catch {unset CMapSavedColors($w)}
    catch {unset CMapForeground($w)}
    catch {unset CMapSelectForeground($w)}
    catch {unset CMapBackground($w)}
    catch {unset CMapSelectBackground($w)}
    return
}
    
# Bindings for the "khim::cmap" bindtag that is used in the character map
# dialog

bind khim::cmap <1> {khim::CMapSelect %W %x %y}
bind khim::cmap <Double-1> {khim::CMapCopypastedismiss %W %x %y}
bind khim::cmap <B1-Motion> {khim::CMapSelect %W %x %y}
bind khim::cmap <ButtonRelease-1> {khim::CMapActivate %W %x %y}
bind khim::cmap <Up> {khim::CMapMove %W -16; break}
bind khim::cmap <Left> {khim::CMapMove %W -1; break}
bind khim::cmap <Right> {khim::CMapMove %W 1; break}
bind khim::cmap <Down> {khim::CMapMove %W 16; break}
bind khim::cmap <Next> {khim::CMapMove %W 0x100; break}
bind khim::cmap <Prior> {khim::CMapMove %W -0x100; break}
bind khim::cmap <Control-Home> {khim::CMapMoveTo %W 0x0000; break}
bind khim::cmap <Control-End> {khim::CMapMoveTo %W 0xffff; break}
bind khim::cmap <Shift-Home> {khim::CMapHome %W 0x0100 0; break}
bind khim::cmap <Shift-End> {khim::CMapHome %W 0x0100 1; break}
bind khim::cmap <Home> {khim::CMapHome %W 0x010 0; break}
bind khim::cmap <End> {khim::CMapHome %W 0x010 1; break}
bind khim::cmap <Key> {khim::CMapKey %W %A}
bind khim::cmap <<Cut>> {khim::CMapCopy %W}
bind khim::cmap <<Copy>> {khim::CMapCopy %W}
bind khim::cmap <space> {khim::CMapOK %W}
bind khim::cmap <Return> {khim::CMapOK %W}
bind khim::cmap <Escape> {khim::CMapCancel %W}
bind khim::cmap <MouseWheel> {khim::CMapWheel %W %D 0; break}
bind khim::cmap <Shift-MouseWheel> {khim::CMapWheel %W %D 1; break}
bind khim::cmap <Tab> {tk::TabToWindow [tk_focusNext %W]; break}
bind khim::cmap <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]; break}
if { [string equal "x11" [tk windowingsystem]] } {
    bind khim::cmap <4> {khim::CMapWheel %W 120 0; break}
    bind khim::cmap <5> {khim::CMapWheel %W -120 0; break}
    bind khim::cmap <Shift-4> {khim::CMapWheel %W 120 1; break}
    bind khim::cmap <Shift-5> {khim::CMapWheel %W -120 1; break}
}
bind khim::cmap <Destroy> {khim::CMapDestroy %W}

# Set initial default configuration

khim::setConfig 1.0 1 Pause {
    !! \u00a1
    {"A} \u00c4
    {"a} \u00e4
    {"E} \u00cb
    {"e} \u00eb
    {"I} \u00cf
    {"i} \u00ef
    {"O} \u00d6
    {"o} \u00f6
    {"U} \u00dc
    {"u} \u00fc
    'A \u00c1
    'a \u00e1
    'E \u00c9
    'e \u00e9
    'I \u00cd
    'i \u00ed
    'O \u00d3
    'o \u00f3
    'U \u00da
    'u \u00fa
    'Y \u00dd
    'y \u00fd
    *A \u00c5
    *a \u00e5
    ,C \u00c7
    ,c \u00e7
    -> \u2192
    -L \u0141
    -l \u0142
    /O \u00d8
    /o \u00f8
    12 \u00bd
    13 \u2153
    14 \u00bc
    18 \u215b
    23 \u2154
    34 \u00be
    38 \u215c
    58 \u215d
    78 \u215e
    :( \u2639
    :) \u263a
    <- \u2190
    << \u00ab
    >> \u00bb
    ?? \u00bf
    ^A \u00c2
    ^a \u00e2
    ^E \u00ca
    ^e \u00ea
    ^I \u00ce
    ^i \u00ee
    ^O \u00d4
    ^o \u00f4
    ^U \u00db
    ^u \u00fb
    `A \u00c0
    `a \u00e0
    `E \u00c8
    `e \u00e8
    `I \u00cc
    `i \u00ec
    `O \u00d2
    `o \u00f2
    `U \u00d9
    `u \u00f9
    AA \u00c5
    aa \u00e5
    AE \u00c6
    ae \u00e6
    bu \u2022
    de \u00b0
    eu \u20ac
    LP \u2615
    mu \u00b5
    OE \u0152
    oe \u0153
    OC \u00a9
    OR \u00ae
    ss \u00df
    |c \u00a2
    ~A \u00c3
    ~a \u00e3
    ~N \u00d1
    ~n \u00f1
    ~O \u00d5
    ~o \u00f5
}

# Set initial bindings on the KHIM bind tag.

khim::RedoBindings

set khim::CMapFont [font create -family helvetica -size 15]
set khim::CMapBadCharFont [font create -family courier -size 8]

# Test program

if {[info exists ::argv0] && ![string compare $::argv0 [info script]]} {

    grid [entry .e -font {Courier 18}] -columnspan 5 -sticky ew
    .e insert end {Type here}
    bindtags .e {.e KHIM Entry . all}
    grid [button .test -text "Test" -command "khim::getOptions .khim"] \
	[button .bload -text "Load config" -command "testLoadConfig"] \
	[button .bsave -text "Save config" -command "testSaveConfig"] \
	[button .bhelp -text "Help" -command "khim::showHelp .help"] \
	[button .bquit -text "Quit" -command "exit"] \
	-padx 5 -pady 5
    
    proc testLoadConfig {} {
	source ~/.khimrc
    }
    proc testSaveConfig {} {
	set f [open ~/.khimrc w]
	puts $f [khim::getConfig]
	close $f
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/khim/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded khim 1.0.1 [list source [file join $dir khim.tcl]]
<
<
<
<
<
<
<
<
<
<
<






















Deleted scriptlibs/tklib0.5/khim/pl.msg.

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
# pl.msg --
#
#	Polish-language messages for KHIM
# Contributed by Irek Chmielowiec <irek.ch (at) gmail.com>
# Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
#
# Refer to the file "license.terms" for the terms and conditions of
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES.
#
#----------------------------------------------------------------------

namespace eval ::khim {

    # If you edit HELPTEXT or {SELECT COMPOSE KEY}, also edit the corresponding
    # messages in ROOT.msg

    ::msgcat::mcset pl HELPTEXT {

	Kevin's Hacky Input Method (KHIM)

	KHIM pozwala na wprowadzanie znaków narodowych i symboli z
	klawiatury która tego nie obsługuje. Działa niezależnie od
	metody wprowadzania znaków jaką może oferować system operacyjny;
	jest przewidziany do sytuacji kiedy nie ma siÄ™ kontroli nad
	odwzorowaniem klawiszy a istnieje potrzeba wprowadzania tekstu w
	różnych językach.

	Aby móc używać KHIM, uruchom okno Ustawień KHIM (sposób jego
	uruchomienia zależy od używanej aplikacji) i włącz KHIM
	zaznaczając opcję "Włącz KHIM". Należy także wybrać klawisz
	który jest rzadko używany i przypisać mu funkcję klawisza
	"sterujÄ…cego" naciskajÄ…c przycisk "Klawisz sterujÄ…cy:",
	a następnie naciskając klawisz któremu chcemy tę funkcję
	przypisać. Mówiąc ogólnie, nie powinien to być klawisz
	ustawiony jako sterujący dla używanego układu klawiatury (np.
	Alt); klawisz ten będzie działał niezależnie od metody
	wprowadzania znaków oferowanej przez lokalny system operacyjny.

	Kiedy KHIM jest już uruchomiony, można wprowadzać znaki narodowe
	i symbole w każdym elemencie interfejsu użytkownika, który
	został ustawiony do korzystania z KHIM, naciskając klawisz
	sterujący razem z sekwencją dwóch znaków. Lista wyboru w
	ustawieniach KHIM pokazuje dostępne kombinacje. Dodatkowo, po
	dwukrotnym naciśnięciu klawisza sterującego pojawi się okno
	pozwalające na bezpośrednie wstawienie wybranego znaku z tablicy
	symboli Unicode. W oknie tablicy można nawigować pomiędzy
	znakami używając klawiszy kursorów lub za pomocą myszy a wybór
	znaku następuje przez dwukrotne kliknięcie, naciśnięcie spacji
	lub naciśnięcie klawisza Enter (Return).

	Aby zdefiniować nową sekwencję do użycia z klawiszem sterującym
	należy uruchomić ustawienia KHIM, wprowadzić dwa znaki w polu 
	"Sekwencja znaków" i znak jaki chcemy uzyskać w polu "Wynik"
	oraz nacisnąć przycisk "Zmień". (Można także skopiować i
	wkleić znak z innej aplikacji lub użyć przycisku "Tablica
	Unicode..." (także przez dwukrotne naciśnięcie klawisza
	sterującego) do wyboru znaku z tablicy wszystkich dostępnych
	kodów Unicode.) Aby usunąć sekwencję znaków, należy wybrać ją z
	listy i nacisnąć "Usuń".

    }

    ::msgcat::mcset pl {SELECT COMPOSE KEY} [string map [list \n\t \n] {
	Proszę nacisnąć klawisz 
	który ma być używany 
	jako sterujÄ…cy.
    }]

    ::msgcat::mcset pl {Apply} {Zastosuj}

    ::msgcat::mcset pl {Cancel} {Anuluj}

    ::msgcat::mcset pl {Change} {Zmień}

    ::msgcat::mcset pl {Character} {Wynik}

    ::msgcat::mcset pl {Compose Key} {Klawisz sterujÄ…cy}

    ::msgcat::mcset pl {Compose key:} {Klawisz sterujÄ…cy:}

    ::msgcat::mcset pl {Composed sequence must be two characters long} \
	{Sekwecja znaków musi być dwuelementowa}

    ::msgcat::mcset pl {Delete} {Usuń}

    ::msgcat::mcset pl {KHIM Help} {Pomoc KHIM}

    ::msgcat::mcset pl {Help...} {Pomoc...}

    ::msgcat::mcset pl {Input key sequence} {Sekwencja znaków}

    ::msgcat::mcset pl {Insert Character} {Wstaw znak}

    ::msgcat::mcset pl {Invalid sequence} {Nieprawidłowa sekwencja}

    ::msgcat::mcset pl {Key sequences} {Sekwencje znaków}

    ::msgcat::mcset pl {KHIM Controls} {Ustawienia KHIM}

    ::msgcat::mcset pl {OK} {OK}

    ::msgcat::mcset pl {Select code page:} {Wybierz kodowanie:}

    ::msgcat::mcset pl {Unicode...} {Tablica Unicode...}

    ::msgcat::mcset pl {Use KHIM} {Włącz KHIM}

}

# vim:ft=tcl:ts=8:sw=4:sts=4:noet
# Local Variables:
# mode: tcl
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































Deleted scriptlibs/tklib0.5/khim/ru.msg.

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
# ru.msg --
#
#	Russian-language messages for KHIM
#
# Contributed by Konstantin Khomoutov <flatworm@users.sourceforge.net>.
# Proof-read and edited by Serge Yudin <talking_zero@mail.ru>.
#
# Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
#
# Refer to the file "license.terms" for the terms and conditions of
# use and redistribution of this file, and a DISCLAIMER OF ALL WARRANTEES.
#
# $Id: ru.msg,v 1.1 2007/06/08 19:24:31 kennykb Exp $
# $Source: /cvsroot/tcllib/tklib/modules/khim/ru.msg,v $
#
#----------------------------------------------------------------------

namespace eval ::khim {

    # If you edit HELPTEXT or {SELECT COMPOSE KEY}, also edit the corresponding
    # messages in ROOT.msg

    ::msgcat::mcset ru HELPTEXT {

	Kevin's Hacky Input Method (KHIM) --
	Ðетривиальный Метод Кевина Ð´Ð»Ñ Ð’Ð²Ð¾Ð´Ð° Символов

	KHIM делает возможным ввод Ñимволов национальных алфавитов
	Ñ ÐºÐ»Ð°Ð²Ð¸Ð°Ñ‚ÑƒÑ€Ñ‹, ÐºÐ¾Ñ‚Ð¾Ñ€Ð°Ñ Ð½Ðµ позволÑÑŽÑ‚ Ñтого делать. Он работает
	незавиÑимо от любых ÑпоÑобов ввода, которые поддерживает ОС;
	его задача -- позволить оÑущеÑтвлÑть ввод таких Ñимволов,
	которые невозможно ввеÑти Ñ Ñ‚ÐµÐºÑƒÑ‰Ð¸Ð¼Ð¸ наÑтройками ОС данного
	компьютера, а менÑть их нет возможноÑти или желаниÑ.

	Ð”Ð»Ñ Ñ‚Ð¾Ð³Ð¾, чтобы иÑпользовать KHIM, Ñледует вызвать диалог
	"ÐаÑтройки KHIM" (как Ñто Ñделать, завиÑит от приложениÑ,
	иÑпользующего KHIM) и разрешить работу KHIM, включив переключатель
	"ИÑпользовать KHIM". Также Вам понадобитÑÑ Ð²Ñ‹Ð±Ñ€Ð°Ñ‚ÑŒ редко
	иÑпользуемую клавишу на Вашей клавиатуре и назначить её
	"клавишей композиции". Ð”Ð»Ñ Ñтого нужно нажать кнопку, подпиÑанную
	"Клавиша композиции:", в диалоге наÑтроек KHIM и затем нажать
	выбранную клавишу на клавиатуре. Имейте в виду, что еÑли на Вашей
	клавиатуре еÑть клавиша, Ð½Ð°Ð·Ñ‹Ð²Ð°ÐµÐ¼Ð°Ñ "Compose", то её не Ñледует
	выбирать в качеÑтве клавиши композиции Ð´Ð»Ñ KHIM -- пуÑть она
	продолжает вызывать тот метод ввода,
	который назначен ей операционной ÑиÑтемой.

	ПоÑле того как KHIM активирован, Ð’Ñ‹ можете вÑтавлÑть Ñимволы
	национальных алфавитов в любое поле ввода, наÑтроенное на
	иÑпользование KHIM, таким образом: нажать и отпуÑтить клавишу
	композиции, затем ввеÑти два Ñимвола -- "входную поÑледовательноÑть".
	Ð’ диалоге наÑтроек KHIM еÑть окно Ñо ÑпиÑком доÑтупных
	поÑледовательноÑтей. Кроме того, двойное нажатие клавиши
	композиции вызывает окно диалога, позволÑющее выбрать произвольный
	Ñимвол Unicode. Выбор нужного Ñимвола в Ñтом диалоге
	оÑущеÑтвлÑетÑÑ Ð¼Ñ‹ÑˆÑŒÑŽ либо клавишами ÑƒÐ¿Ñ€Ð°Ð²Ð»ÐµÐ½Ð¸Ñ ÐºÑƒÑ€Ñором,
	а вÑтавка выбранного Ñимвола -- двойным щелчком левой кнопки
	мыши на нём, либо нажатием клавиши Пробел или Ввод.

	Чтобы Ñоздать новую входную поÑледовательноÑть Ð´Ð»Ñ Ð¸ÑпользованиÑ
	ÑовмеÑтно Ñ ÐºÐ»Ð°Ð²Ð¸ÑˆÐµÐ¹ композиции окройте диалог наÑтроек KHIM,
	введите два Ñимвола в поле "Ð’Ñ…Ð¾Ð´Ð½Ð°Ñ Ð¿Ð¾ÑледовательноÑть" и
	ÑоответÑтвующий ей Ñимвол в поле "Символ", затем нажмите
	кнопку "Изменить". (Ð’Ñ‹ можете копировать и вÑтавлÑть целевой
	Ñимвол из другого приложениÑ. Также можно воÑпользоватьÑÑ
	вÑтроенным в KHIM диалогом выбора Ñимволов Unicode, нажав
	кнопку "Unicode..." или дважды нажав клавишу композиции.)
	Ð”Ð»Ñ ÑƒÐ´Ð°Ð»ÐµÐ½Ð¸Ñ Ð²Ñ…Ð¾Ð´Ð½Ð¾Ð¹ поÑледовательноÑти выберите её в ÑпиÑке
	и дажмите "Удалить".

    }

    ::msgcat::mcset ru {SELECT COMPOSE KEY} [string map [list \n\t \n] {
	Ðажмите клавишу,
	которую вы хотите
	иÑпользовать в качеÑтве
	"Клавиши композиции"
    }]

    ::msgcat::mcset ru {Apply} {Применить}

    ::msgcat::mcset ru {Cancel} {Отменить}

    ::msgcat::mcset ru {Change} {Изменить}

    ::msgcat::mcset ru {Character} {Символ}

    ::msgcat::mcset ru {Compose Key} {Клавиша композиции}

    ::msgcat::mcset ru {Compose key:} {Клавиша композиции:}

    ::msgcat::mcset ru {Composed sequence must be two characters long} \
	{Ð’Ñ…Ð¾Ð´Ð½Ð°Ñ Ð¿Ð¾ÑледовательноÑть должна ÑоÑтоÑть из двух Ñимволов}

    ::msgcat::mcset ru {Delete} {Удалить}

    ::msgcat::mcset ru {KHIM Help} {Справка по KHIM}

    ::msgcat::mcset ru {Help...} {Справка...}

    ::msgcat::mcset ru {Input key sequence} {Ð’Ñ…Ð¾Ð´Ð½Ð°Ñ Ð¿Ð¾ÑледовательноÑть}

    ::msgcat::mcset ru {Insert Character} {Выберите Ñимвол}

    ::msgcat::mcset ru {Invalid sequence} {ÐÐµÐ¿Ñ€Ð°Ð²Ð¸Ð»ÑŒÐ½Ð°Ñ ÐºÐ¾Ð¼Ð±Ð¸Ð½Ð°Ñ†Ð¸Ñ}

    ::msgcat::mcset ru {Key sequences} {Комбинации клавиш}

    ::msgcat::mcset ru {KHIM Controls} {ÐаÑтройки KHIM}

    ::msgcat::mcset ru {OK} {OK}

    ::msgcat::mcset ru {Select code page:} {Выберите Ñтраницу кодов:}

    ::msgcat::mcset ru {Unicode...} {Unicode...}

    ::msgcat::mcset ru {Use KHIM} {ИÑпользовать KHIM}

}

# vim:ft=tcl:ts=8:sw=4:sts=4:noet
# Local Variables:
# mode: tcl
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































Deleted scriptlibs/tklib0.5/khim/uk.msg.

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
# uk.msg --
#
#	Ukrainian-language messages for KHIM
#
# Contributed by Fixer jabber:<uzver@jabber.kiev.ua>, email:<artem_brz@mail.ru>.
#
# Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
#
#----------------------------------------------------------------------

namespace eval ::khim {

    # If you edit HELPTEXT or {SELECT COMPOSE KEY}, also edit the corresponding
    # messages in ROOT.msg

    ::msgcat::mcset uk HELPTEXT {

	Kevin's Hacky Input Method (KHIM) --
	Ðетривіальний Метод Кевіна Ð´Ð»Ñ Ð’Ð²ÐµÐ´ÐµÐ½Ð½Ñ Ð¡Ð¸Ð¼Ð²Ð¾Ð»Ñ–Ð²

	KHIM дає можливіÑть вводити Ñимволи національних алфавітів
	з клавіатури, Ñка не дозволÑÑ” цього робити. Він працює
	незалежно від інших ÑпоÑобів вводу, котрі підтримує ОС;
	його Ð·Ð°Ð²Ð´Ð°Ð½Ð½Ñ -- дати змогу здійÑнювати Ð²Ð²ÐµÐ´ÐµÐ½Ð½Ñ Ñ‚Ð°ÐºÐ¸Ñ… Ñимволів,
	котрі неможливо ввеÑти з теперішніми налаштуваннÑми ОС даного
	компьютера, а помінÑти Ñ—Ñ… немає ні можливоÑті, ні бажаннÑ.

	Ð”Ð»Ñ Ñ‚Ð¾Ð³Ð¾, щоб кориÑтуватиÑÑ KHIM, треба відкрити діалог
	"ÐÐ°Ð»Ð°ÑˆÑ‚ÑƒÐ²Ð°Ð½Ð½Ñ KHIM" (Ñк це зробити, залежить від програми,
	Ñка викориÑтовує KHIM) Ñ– дозволити роботу KHIM, увімкнувши перемикач
	"ВикориÑтовувати KHIM". Також Вам необхідно обрати рідко
	викориÑтовувану клавішу на Вашій клавіатурі Ñ– призначити Ñ—Ñ—
	"клавішою композиції". Ð”Ð»Ñ Ñ†ÑŒÐ¾Ð³Ð¾ потрібно натиÑнути кнопку, підпиÑану Ñк
	"Клавіша композиції:", у діалозі налаштувань KHIM, а потім натиÑнути
	обрану клавішу на клавіатурі. Майте на увазі, що Ñкшо на Вашій
	клавіатурі Ñ” клавіша, що зветьÑÑ "Compose", то Ñ—Ñ— не треба
	обирати в ÑкоÑті клавіши композиції Ð´Ð»Ñ KHIM -- хай вона
	продовжує викликати той метод вводу,
	котрий призначений їй операційною ÑиÑтемою.

	ПіÑÐ»Ñ Ñ‚Ð¾Ð³Ð¾ Ñк KHIM активувавÑÑ, Ви можете вÑтавлÑти Ñимволи
	національних алфавітів в будь-Ñке поле Ð´Ð»Ñ Ð²Ð²Ð¾Ð´Ñƒ, налаштоване на
	викориÑÑ‚Ð°Ð½Ð½Ñ KHIM, таким чином: натиÑнути Ñ– відпуÑтити клавішу
	композиції, а потім ввеÑти два Ñимволи -- "вхідну поÑлідовніÑть".
	У діалозі налаштувань KHIM Ñ” вікно з переліком доÑтупних
	поÑлідовноÑтей. Крім того, подвійне натиÑÐºÐ°Ð½Ð½Ñ ÐºÐ»Ð°Ð²Ñ–ÑˆÑ–
	композиції викликає вікно діалогу, що дозволÑÑ” обрати довільний
	Ñимвол Unicode. Вибір потрібного Ñимволу в цьому діалозі
	здійÑнюєтьÑÑ Ð¼Ð¸ÑˆÐ¾ÑŽ чи клавішами ÑƒÐ¿Ñ€Ð°Ð²Ð»Ñ–Ð½Ð½Ñ ÐºÑƒÑ€Ñором,
	а вÑтавлÑÐ½Ð½Ñ Ð¾Ð±Ñ€Ð°Ð½Ð¾Ð³Ð¾ Ñимолу -- подвійним клацаннÑм лівої кнопки
	миші на ньому, або натиÑканнÑм клавіши Пробіл чи Ввід.

	Щоб Ñтворити нову вхідну поÑлідовніÑть Ð´Ð»Ñ Ð²Ð¸ÐºÐ¾Ñ€Ð¸ÑтаннÑ
	ÑуміÑно з клавішою композиції відкрийте діалог налаштувань KHIM,
	введіть два Ñимволи в поле "Вхідна поÑлідовніÑть" Ñ–
	відповідний їй Ñимвол у полі "Символ", а потім натиÑніть
	клавішу "Змінити". (Ви можете копіювати Ñ– вÑтавлÑти цільовий
	Ñимвол з іншої програми. Також можна ÑкориÑтатиÑÑ
	вбудованим у KHIM діалогом вибору Ñимволів Unicode, натиÑнувши
	кнопку "Unicode...", або подвійно клацнувши клавішу композиції.)
	Ð”Ð»Ñ Ð²Ð¸Ð´Ð°Ð»ÐµÐ½Ð½Ñ Ð²Ñ…Ñ–Ð´Ð½Ð¾Ñ— поÑлідовноÑті оберіть Ñ—Ñ— у переліку
	Ñ– натиÑніть "Видалити."

    }

    ::msgcat::mcset uk {SELECT COMPOSE KEY} [string map [list \n\t \n] {
	ÐатиÑніть клавішу,
	котру ви бажаєте
	викориÑтовувати в ÑкоÑті
	"Клавіші композиції"
    }]

    ::msgcat::mcset uk {Apply} {ПрийнÑти}

    ::msgcat::mcset uk {Cancel} {Відмінити}

    ::msgcat::mcset uk {Change} {Змінити}

    ::msgcat::mcset uk {Character} {Символ}

    ::msgcat::mcset uk {Compose Key} {Клавіша композиції}

    ::msgcat::mcset uk {Compose key:} {Клавіша композиції:}

    ::msgcat::mcset uk {Composed sequence must be two characters long} \
	{Вхідна поÑлідовніÑть повинна ÑкладатиÑÑ Ð· двох Ñимволів}

    ::msgcat::mcset uk {Delete} {Видалити}

    ::msgcat::mcset uk {KHIM Help} {Допомога по KHIM}

    ::msgcat::mcset uk {Help...} {Допомога...}

    ::msgcat::mcset uk {Input key sequence} {Вхідна поÑлідовніÑть}

    ::msgcat::mcset uk {Insert Character} {Оберіть Ñимвол}

    ::msgcat::mcset uk {Invalid sequence} {Ðеправильна комбінаціÑ}

    ::msgcat::mcset uk {Key sequences} {Комбінації клавіш}

    ::msgcat::mcset uk {KHIM Controls} {ÐÐ°Ð»Ð°ÑˆÑ‚ÑƒÐ²Ð°Ð½Ð½Ñ KHIM}

    ::msgcat::mcset uk {OK} {OK}

    ::msgcat::mcset uk {Select code page:} {Оберіть кодову Ñторінку:}

    ::msgcat::mcset uk {Unicode...} {Unicode...}

    ::msgcat::mcset uk {Use KHIM} {ВикориÑтовувати KHIM}

}

# vim:ft=tcl:ts=8:sw=4:sts=4:noet
# Local Variables:
# mode: tcl
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































Deleted scriptlibs/tklib0.5/ntext/ntext.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
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
981
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
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
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
1210
1211
1212
1213
1214
1215
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
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
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
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
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
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
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
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
# ntext.tcl --
# derived from text.tcl
#
# This file defines the Ntext bindings for Tk text widgets and provides
# procedures that help in implementing the bindings.
#
# $Id: ntext.tcl,v 1.1 2007/06/21 21:05:27 hobbs Exp $
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998 by Scriptics Corporation.
# Copyright (c) 2005-2007 additions by Keith Nash.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

##### START OF CODE THAT IS MODIFIED text.tcl, Tk 8.5a5 = ActiveTcl 8.5beta6

#-------------------------------------------------------------------------
# Elements of ::tk::Priv that are used in this file:
#
# afterId -		If non-null, it means that auto-scanning is underway
#			and it gives the "after" id for the next auto-scan
#			command to be executed.
# char -		Character position on the line;  kept in order
#			to allow moving up or down past short lines while
#			still remembering the desired position.
# mouseMoved -		Non-zero means the mouse has moved a significant
#			amount since the button went down (so, for example,
#			start dragging out a selection).
# prevPos -		Used when moving up or down lines via the keyboard.
#			Keeps track of the previous insert position, so
#			we can distinguish a series of ups and downs, all
#			in a row, from a new up or down.
# selectMode -		The style of selection currently underway:
#			char, word, or line.
# x, y -		Last known mouse coordinates for scanning
#			and auto-scanning.
#-------------------------------------------------------------------------

#-------------------------------------------------------------------------
# The code below creates the Ntext class bindings for text widgets.
#-------------------------------------------------------------------------

package require Tk 8.5

# Mouse bindings: use ::ntext::Bcount to deal with out-of-order multiple
# clicks. This permits the bindings to be simplified

bind Ntext <1> {
    set ::ntext::Bcount 1
    ntext::TextButton1 %W %x %y
    %W tag remove sel 0.0 end
}
bind Ntext <B1-Motion> {
    set tk::Priv(x) %x
    set tk::Priv(y) %y
    ntext::TextSelectTo %W %x %y
}
# Inside the if:
#   The previous Button-1 event was not a single-click, but a double, triple,
#   or quadruple.
#   We can simplify the bindings if we ensure that a double-click is
#   *always* preceded by a single-click.
#   So in this case run the same code as <1> before doing <Double-1>
bind Ntext <Double-1> {
    if {$::ntext::Bcount != 1} {
	set ::ntext::Bcount 1
	ntext::TextButton1 %W %x %y
	%W tag remove sel 0.0 end
    }
    set ::ntext::Bcount 2
    set tk::Priv(selectMode) word
    ntext::TextSelectTo %W %x %y
    catch {%W mark set insert sel.first}
}
# ignore an out-of-order triple click.  This has no adverse consequences.
bind Ntext <Triple-1> {
    if {$::ntext::Bcount != 2} {
	continue
    }
    set ::ntext::Bcount 3
    set tk::Priv(selectMode) line
    ntext::TextSelectTo %W %x %y
    catch {%W mark set insert sel.first}
}
# don't care if a quadruple click is out-of-order (i.e. follows a quadruple
# click, not a triple click).
bind Ntext <Quadruple-1> {
    set ::ntext::Bcount 4
}
bind Ntext <Shift-1> {
    set ::ntext::Bcount 1
    if {(!$::ntext::classicMouseSelect) && ([%W tag ranges sel] eq "")} {
	# Move the selection anchor mark to the old insert mark
	# Should the mark's gravity be set?
	%W mark set tk::anchor%W insert
    }
    if {$::ntext::classicAnchor} {
	tk::TextResetAnchor %W @%x,%y
	# if sel exists, sets anchor to end furthest from x,y
	# changes anchor only, not insert
    }
    set tk::Priv(selectMode) char
    ntext::TextSelectTo %W %x %y
}
# Inside the outer if:
#   The previous Button-1 event was not a single-click, but a double, triple,
#   or quadruple.
#   We can simplify the bindings if we ensure that a double-click is
#   *always* preceded by a single-click.
#   So in this case run the same code as <Shift-1> before doing <Double-Shift-1>
bind Ntext <Double-Shift-1>	{
    if {$::ntext::Bcount != 1} {
	set ::ntext::Bcount 1
	if {(!$::ntext::classicMouseSelect) && ([%W tag ranges sel] eq "")} {
	    # Move the selection anchor mark to the old insert mark
	    # Should the mark's gravity be set?
	    %W mark set tk::anchor%W insert
	}
	if {$::ntext::classicAnchor} {
	    tk::TextResetAnchor %W @%x,%y
	    # if sel exists, sets anchor to end furthest from x,y
	    # changes anchor only, not insert
	}
	set tk::Priv(selectMode) char
	ntext::TextSelectTo %W %x %y
    }
    set ::ntext::Bcount 2
    set tk::Priv(selectMode) word
    ntext::TextSelectTo %W %x %y 1
}
# ignore an out-of-order triple click.  This has no adverse consequences.
bind Ntext <Triple-Shift-1>	{
    if {$::ntext::Bcount != 2} {
	continue
    }
    set ::ntext::Bcount 3
    set tk::Priv(selectMode) line
    ntext::TextSelectTo %W %x %y
}
# don't care if a quadruple click is out-of-order (i.e. follows a quadruple
# click, not a triple click).
bind Ntext <Quadruple-Shift-1> {
    set ::ntext::Bcount 4
}
bind Ntext <B1-Leave> {
    set tk::Priv(x) %x
    set tk::Priv(y) %y
    ntext::TextAutoScan %W
}
bind Ntext <B1-Enter> {
    tk::CancelRepeat
}
bind Ntext <ButtonRelease-1> {
    tk::CancelRepeat
}
bind Ntext <Control-1> {
    %W mark set insert @%x,%y
    if {[%W cget -autoseparators]} {
	%W edit separator
    }
}
bind Ntext <Double-Control-1> { # nothing }
bind Ntext <Control-B1-Motion> { # nothing }
bind Ntext <Left> {
    tk::TextSetCursor %W insert-1displayindices
}
bind Ntext <Right> {
    tk::TextSetCursor %W insert+1displayindices
}
bind Ntext <Up> {
    tk::TextSetCursor %W [tk::TextUpDownLine %W -1]
}
bind Ntext <Down> {
    tk::TextSetCursor %W [tk::TextUpDownLine %W 1]
}
bind Ntext <Shift-Left> {
    tk::TextKeySelect %W [%W index {insert - 1displayindices}]
}
bind Ntext <Shift-Right> {
    tk::TextKeySelect %W [%W index {insert + 1displayindices}]
}
bind Ntext <Shift-Up> {
    tk::TextKeySelect %W [tk::TextUpDownLine %W -1]
}
bind Ntext <Shift-Down> {
    tk::TextKeySelect %W [tk::TextUpDownLine %W 1]
}
bind Ntext <Control-Left> {
    tk::TextSetCursor %W \
	[tk::TextPrevPos %W insert ntext::new_startOfPreviousWord]
}
bind Ntext <Control-Right> {
    tk::TextSetCursor %W [ntext::TextNextWord %W insert]
}
bind Ntext <Control-Up> {
    tk::TextSetCursor %W [tk::TextPrevPara %W insert]
}
bind Ntext <Control-Down> {
    tk::TextSetCursor %W [tk::TextNextPara %W insert]
}
bind Ntext <Shift-Control-Left> {
    tk::TextKeySelect %W \
	[tk::TextPrevPos %W insert ntext::new_startOfPreviousWord]
}
bind Ntext <Shift-Control-Right> {
    tk::TextKeySelect %W [ntext::TextNextWord %W insert]
}
bind Ntext <Shift-Control-Up> {
    tk::TextKeySelect %W [tk::TextPrevPara %W insert]
}
bind Ntext <Shift-Control-Down> {
    tk::TextKeySelect %W [tk::TextNextPara %W insert]
}
bind Ntext <Prior> {
    tk::TextSetCursor %W [ntext::TextScrollPages %W -1 preScroll]
}
bind Ntext <Shift-Prior> {
    tk::TextKeySelect %W [ntext::TextScrollPages %W -1 preScroll]
}
bind Ntext <Next> {
    tk::TextSetCursor %W [ntext::TextScrollPages %W 1 preScroll]
}
bind Ntext <Shift-Next> {
    tk::TextKeySelect %W [ntext::TextScrollPages %W 1 preScroll]
}
bind Ntext <Control-Prior> {
    %W xview scroll -1 page
}
bind Ntext <Control-Next> {
    %W xview scroll 1 page
}

bind Ntext <Home> {
    tk::TextSetCursor %W  [::ntext::HomeIndex %W insert]
}
bind Ntext <Shift-Home> {
    tk::TextKeySelect %W [::ntext::HomeIndex %W insert]
}
bind Ntext <End> {
    tk::TextSetCursor %W  [::ntext::EndIndex %W insert]
}
bind Ntext <Shift-End> {
    tk::TextKeySelect %W [::ntext::EndIndex %W insert]
}
bind Ntext <Control-Home> {
    tk::TextSetCursor %W 1.0
}
bind Ntext <Control-Shift-Home> {
    tk::TextKeySelect %W 1.0
}
bind Ntext <Control-End> {
    tk::TextSetCursor %W {end - 1 indices}
}
bind Ntext <Control-Shift-End> {
    tk::TextKeySelect %W {end - 1 indices}
}

bind Ntext <Tab> {
    if {[%W cget -state] eq "normal"} {
	ntext::TextInsert %W \t
	focus %W
	break
    }
}
bind Ntext <Shift-Tab> {
    # Needed only to keep <Tab> binding from triggering;  doesn't
    # have to actually do anything.
    break
}
bind Ntext <Control-Tab> {
    focus [tk_focusNext %W]
}
bind Ntext <Control-Shift-Tab> {
    focus [tk_focusPrev %W]
}
bind Ntext <Control-i> {
    if {$::ntext::classicExtras} {
	ntext::TextInsert %W \t
    }
}
bind Ntext <Return> {
    ntext::TextInsert %W \n
    if {[%W cget -autoseparators]} {
	%W edit separator
    }
}
bind Ntext <Delete> {
    if {[%W tag nextrange sel 1.0 end] ne ""} {
	set ::ntext::OldFirst [%W index sel.first]
	%W delete sel.first sel.last
	ntext::AdjustIndentOneLine %W $::ntext::OldFirst
    } else {
	%W delete insert
	ntext::AdjustIndentOneLine %W insert
	%W see insert
    }
}
bind Ntext <BackSpace> {
    if {[%W tag nextrange sel 1.0 end] ne ""} {
	set ::ntext::OldFirst [%W index sel.first]
	%W delete sel.first sel.last
	ntext::AdjustIndentOneLine %W $::ntext::OldFirst
    } elseif {[%W compare insert != 1.0]} {
	%W delete insert-1c
	ntext::AdjustIndentOneLine %W insert
	%W see insert
    }
}

bind Ntext <Control-space> {
    if {$::ntext::classicExtras} {
	%W mark set tk::anchor%W insert
    }
}
bind Ntext <Select> {
    %W mark set tk::anchor%W insert
}
bind Ntext <Control-Shift-space> {
    if {$::ntext::classicExtras} {
	set tk::Priv(selectMode) char
	tk::TextKeyExtend %W insert
    }
}
bind Ntext <Shift-Select> {
    set tk::Priv(selectMode) char
    tk::TextKeyExtend %W insert
}
bind Ntext <Control-slash> {
    %W tag add sel 1.0 end
}
bind Ntext <Control-backslash> {
    %W tag remove sel 1.0 end
    if {[%W cget -autoseparators]} {
	%W edit separator
    }
}
bind Ntext <<Cut>> {
    ntext::new_textCut %W
}
bind Ntext <<Copy>> {
    tk_textCopy %W
}
bind Ntext <<Paste>> {
    ntext::new_textPaste %W
}
bind Ntext <<Clear>> {
    if {[%W tag nextrange sel 1.0 end] ne ""} {
	set ::ntext::OldFirst [%W index sel.first]
	%W delete sel.first sel.last
	ntext::AdjustIndentOneLine %W $::ntext::OldFirst
    }
}
bind Ntext <<PasteSelection>> {
    if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)]
	    || !$tk::Priv(mouseMoved)} {
	ntext::TextPasteSelection %W %x %y
    }
}
# Implement Insert/Overwrite modes
bind Ntext <Insert> {
    set ntext::overwrite [expr !$ntext::overwrite]
#    This behaves strangely on a newline or tab:
#    %W configure -blockcursor $ntext::overwrite
    if {$ntext::overwrite} {
	%W configure -insertbackground red
    } else {
	%W configure -insertbackground black
    }
}
bind Ntext <KeyPress> {
    ntext::TextInsert %W %A
}

# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
# <KeyPress> class binding will also fire and insert the character,
# which is wrong.

bind Ntext <Alt-KeyPress> {# nothing }
bind Ntext <Meta-KeyPress> {# nothing}
bind Ntext <Control-KeyPress> {# nothing}
# Make Escape clear the selection
bind Ntext <Escape> {
    %W tag remove sel 0.0 end
    if {[%W cget -autoseparators]} {
	%W edit separator
    }
}
bind Ntext <KP_Enter> {# nothing}
if {[tk windowingsystem] eq "aqua"} {
    bind Ntext <Command-KeyPress> {# nothing}
}

# Additional emacs-like bindings:

bind Ntext <Control-a> {
    if {$::ntext::classicExtras && !$tk_strictMotif} {
	tk::TextSetCursor %W {insert display linestart}
    }
}
bind Ntext <Control-b> {
    if {$::ntext::classicExtras && !$tk_strictMotif} {
	tk::TextSetCursor %W insert-1displayindices
    }
}
bind Ntext <Control-d> {
    if {$::ntext::classicExtras && !$tk_strictMotif} {
	%W delete insert
	ntext::AdjustIndentOneLine %W insert
    }
}
bind Ntext <Control-e> {
    if {$::ntext::classicExtras && !$tk_strictMotif} {
	tk::TextSetCursor %W {insert display lineend}
    }
}
bind Ntext <Control-f> {
    if {$::ntext::classicExtras && !$tk_strictMotif} {
	tk::TextSetCursor %W insert+1displayindices
    }
}
bind Ntext <Control-k> {
    if {$::ntext::classicExtras && !$tk_strictMotif} {
	if {[%W compare insert == {insert lineend}]} {
	    %W delete insert
	} else {
	    %W delete insert {insert lineend}
	}
	ntext::AdjustIndentOneLine %W insert
    }
}
bind Ntext <Control-n> {
    if {$::ntext::classicExtras && !$tk_strictMotif} {
	tk::TextSetCursor %W [tk::TextUpDownLine %W 1]
    }
}
bind Ntext <Control-o> {
    if {$::ntext::classicExtras && !$tk_strictMotif} {
	%W insert insert \n
	%W mark set insert insert-1c
	ntext::AdjustIndentOneLine %W "insert + 1 line"
    }
}
bind Ntext <Control-p> {
    if {$::ntext::classicExtras && !$tk_strictMotif} {
	tk::TextSetCursor %W [tk::TextUpDownLine %W -1]
    }
}
bind Ntext <Control-t> {
    if {$::ntext::classicExtras && !$tk_strictMotif} {
	ntext::TextTranspose %W
    }
}

bind Ntext <<Undo>> {
    # An Undo operation may remove the separator at the top of the Undo stack.
    # Then the item at the top of the stack gets merged with the subsequent changes.
    # Place separators before and after Undo to prevent this.
    if {[%W cget -autoseparators]} {
	%W edit separator
    }
    if {![catch { %W edit undo }]} {
	# the undo stack does not record tags - so we need to reapply them
	ntext::AdjustIndentMultipleLines %W 1.0 end
    }
    if {[%W cget -autoseparators]} {
	%W edit separator
    }
}

bind Ntext <<Redo>> {
    if {![catch { %W edit redo }]} {
	# the redo stack does not record tags - so we need to reapply them
	ntext::AdjustIndentMultipleLines %W 1.0 end
    }
}

bind Ntext <Meta-b> {
    if {!$tk_strictMotif} {
	tk::TextSetCursor %W \
	    [tk::TextPrevPos %W insert ntext::new_startOfPreviousWord]
    }
}
bind Ntext <Meta-d> {
    if {!$tk_strictMotif} {
	%W delete insert [ntext::TextNextWord %W insert]
    }
    ntext::AdjustIndentOneLine %W insert
}
bind Ntext <Meta-f> {
    if {!$tk_strictMotif} {
	tk::TextSetCursor %W [ntext::TextNextWord %W insert]
    }
}
bind Ntext <Meta-less> {
    if {!$tk_strictMotif} {
	tk::TextSetCursor %W 1.0
    }
}
bind Ntext <Meta-greater> {
    if {!$tk_strictMotif} {
	tk::TextSetCursor %W end-1c
    }
}
bind Ntext <Meta-BackSpace> {
    if {!$tk_strictMotif} {
	%W delete \
	    [tk::TextPrevPos %W insert ntext::new_startOfPreviousWord] insert
    }
    ntext::AdjustIndentOneLine %W insert
}
bind Ntext <Meta-Delete> {
    if {!$tk_strictMotif} {
	%W delete \
	    [tk::TextPrevPos %W insert ntext::new_startOfPreviousWord] insert
    }
    ntext::AdjustIndentOneLine %W insert
}

# Macintosh only bindings:

if {[tk windowingsystem] eq "aqua"} {
bind Ntext <Option-Left> {
    tk::TextSetCursor %W \
	[tk::TextPrevPos %W insert ntext::new_startOfPreviousWord]
}
bind Ntext <Option-Right> {
    tk::TextSetCursor %W [ntext::TextNextWord %W insert]
}
bind Ntext <Option-Up> {
    tk::TextSetCursor %W [tk::TextPrevPara %W insert]
}
bind Ntext <Option-Down> {
    tk::TextSetCursor %W [tk::TextNextPara %W insert]
}
bind Ntext <Shift-Option-Left> {
    tk::TextKeySelect %W \
	[tk::TextPrevPos %W insert ntext::new_startOfPreviousWord]
}
bind Ntext <Shift-Option-Right> {
    tk::TextKeySelect %W [ntext::TextNextWord %W insert]
}
bind Ntext <Shift-Option-Up> {
    tk::TextKeySelect %W [tk::TextPrevPara %W insert]
}
bind Ntext <Shift-Option-Down> {
    tk::TextKeySelect %W [tk::TextNextPara %W insert]
}
# ntext::TextScrollPages is probably not what is needed here, because
# tk::TextScrollPages only scrolls, and relies on the calling code to set the
# insert mark.  Keep the old functionality.
# Don't Mac users need to scroll up as well as down?
# Feedback from Mac users please.
bind Ntext <Control-v> {
#    tk::TextScrollPages %W 1
    %W yview scroll 1 pages
}

# End of Mac only bindings
}

# A few additional bindings of my own.

bind Ntext <Control-h> {
    if {$::ntext::classicExtras && (!$tk_strictMotif)
	    && [%W compare insert != 1.0]} {
	%W delete insert-1c
	%W see insert
	ntext::AdjustIndentOneLine %W insert
    }
}
bind Ntext <2> {
    if {!$tk_strictMotif} {
	tk::TextScanMark %W %x %y
    }
}
bind Ntext <B2-Motion> {
    if {!$tk_strictMotif} {
	tk::TextScanDrag %W %x %y
    }
}
set ::tk::Priv(prevPos) {}

# The MouseWheel will typically only fire on Windows and MacOS X.
# However, someone could use the "event generate" command to produce one
# on other platforms.  We must be careful not to round -ve values of %D
# down to zero.

if {[tk windowingsystem] eq "aqua"} {
    bind Ntext <MouseWheel> {
        %W yview scroll [expr {-15 * (%D)}] pixels
    }
    bind Ntext <Option-MouseWheel> {
        %W yview scroll [expr {-150 * (%D)}] pixels
    }
    bind Ntext <Shift-MouseWheel> {
        %W xview scroll [expr {-15 * (%D)}] pixels
    }
    bind Ntext <Shift-Option-MouseWheel> {
        %W xview scroll [expr {-150 * (%D)}] pixels
    }
} else {
    # We must make sure that positive and negative movements are rounded
    # equally to integers, avoiding the problem that
    #     (int)1/3 = 0,
    # but
    #     (int)-1/3 = -1
    # The following code ensure equal +/- behaviour.
    bind Ntext <MouseWheel> {
	if {%D >= 0} {
	    %W yview scroll [expr {-%D/3}] pixels
	} else {
	    %W yview scroll [expr {(2-%D)/3}] pixels
	}
    }
}

if {"x11" eq [tk windowingsystem]} {
    # Support for mousewheels on Linux/Unix commonly comes through mapping
    # the wheel to the extended buttons.  If you have a mousewheel, find
    # Linux configuration info at:
    #	http://www.inria.fr/koala/colas/mouse-wheel-scroll/
    bind Ntext <4> {
	if {!$tk_strictMotif} {
	    %W yview scroll -50 pixels
	}
    }
    bind Ntext <5> {
	if {!$tk_strictMotif} {
	    %W yview scroll 50 pixels
	}
    }
}

bind Ntext <Configure> {
    ::ntext::AdjustIndentMultipleLines %W 1.0 end
}


##### End of bindings. Now define the namespace and its variables.


namespace eval ::ntext {

# Variables that control the behaviour of certain bindings and may be changed
# by the user's script
# Set to 1 for "classic Text" style (the Tcl/Tk defaults), 0 for "Ntext" style

# Whether Shift-Button-1 has a variable or fixed anchor
variable classicAnchor      0

# Whether to activate certain traditional "extra" bindings
variable classicExtras      0

# Whether Shift-Button-1 ignores changes made by the keyboard to the insert
# mark
variable classicMouseSelect 0

# Type of word-boundary search
variable classicWordBreak   0

# Whether to use -lmargin2 to align the wrapped display lines with their
# own first display line
variable classicWrap        1

# Advanced use (see man page): align to this character on the first display
# line
variable newWrapRegexp   {[^[:space:]]}

# Variable that sets overwrite/insert mode: may be changed by the user's script
# but is normally controlled by a binding to <KeyPress-Insert>
variable overwrite          0

# Debugging aid for developers: sets the background color for each logical line
# according to the magnitude of its hanging (-lmargin2) indent.
variable lm2IndentDebug     0

# Variables that will hold regexp's for word boundary detection

variable tcl_match_wordBreakAfter
variable tcl_match_wordBreakBefore
variable tcl_match_endOfWord
variable tcl_match_startOfNextWord
variable tcl_match_startOfPreviousWord


# These variables are for internal use by ntext only. They should not be
# modified by the user's script.
variable Bcount             0
variable OldFirst          {}


}

##### End of namespace definition.  Now define the procs.

# ::tk::TextClosestGap --
# Given x and y coordinates, this procedure finds the closest boundary
# between characters to the given coordinates and returns the index
# of the character just after the boundary.
#
# Arguments:
# w -		The text window.
# x -		X-coordinate within the window.
# y -		Y-coordinate within the window.

# ::ntext::TextClosestGap is copied from ::tk with modifications:
# modified to fix the jump-to-next-line issue.

proc ::ntext::TextClosestGap {w x y} {
    set pos [$w index @$x,$y]
    set bbox [$w bbox $pos]
    if {$bbox eq ""} {
	return $pos
    }
    if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {
	return $pos
    }
    # Never return a position that will place the cursor on the next display
    # line. This used to happen if $x is closer to the end of the display line
    # than to its last character.
    if {[$w cget -wrap] eq "word"} {
	set lineType displaylines
    } else {
	set lineType lines
    }
    if {[$w count -$lineType $pos "$pos + 1 char"] != 0} {
	return $pos
    } else {
    }
    $w index "$pos + 1 char"
}

# ::tk::TextButton1 --
# This procedure is invoked to handle button-1 presses in text
# widgets.  It moves the insertion cursor, sets the selection anchor,
# and claims the input focus.
#
# Arguments:
# w -		The text window in which the button was pressed.
# x -		The x-coordinate of the button press.
# y -		The x-coordinate of the button press.

# ::ntext::TextButton1 is copied from ::tk with no modifications:
# so it calls functions in ::ntext, not ::tk

proc ::ntext::TextButton1 {w x y} {
    variable ::tk::Priv

    set Priv(selectMode) char
    set Priv(mouseMoved) 0
    set Priv(pressX) $x
    $w mark set insert [TextClosestGap $w $x $y]
    $w mark set tk::anchor$w insert
    # Set the anchor mark's gravity depending on the click position
    # relative to the gap
    set bbox [$w bbox [$w index tk::anchor$w]]
    if {$x > [lindex $bbox 0]} {
	$w mark gravity tk::anchor$w right
    } else {
	$w mark gravity tk::anchor$w left
    }
    # Allow focus in any case on Windows, because that will let the
    # selection be displayed even for state disabled text widgets.
    if {$::tcl_platform(platform) eq "windows" \
	    || [$w cget -state] eq "normal"} {
	focus $w
    }
    if {[$w cget -autoseparators]} {
	$w edit separator
    }
}

# ::tk::TextSelectTo --
# This procedure is invoked to extend the selection, typically when
# dragging it with the mouse.  Depending on the selection mode (character,
# word, line) it selects in different-sized units.  This procedure
# ignores mouse motions initially until the mouse has moved from
# one character to another or until there have been multiple clicks.
#
# Note that the 'anchor' is implemented programmatically using
# a text widget mark, and uses a name that will be unique for each
# text widget (even when there are multiple peers).  Currently the
# anchor is considered private to Tk, hence the name 'tk::anchor$w'.
#
# Arguments:
# w -		The text window in which the button was pressed.
# x -		Mouse x position.
# y - 		Mouse y position.

# ::ntext::TextSelectTo is copied from ::tk with modifications:
# modified to prevent word selection from crossing a line end.

proc ::ntext::TextSelectTo {w x y {extend 0}} {
    global tcl_platform
    variable ::tk::Priv

    set cur [TextClosestGap $w $x $y]
    if {[catch {$w index tk::anchor$w}]} {
	$w mark set tk::anchor$w $cur
    }
    set anchor [$w index tk::anchor$w]
    if {[$w compare $cur != $anchor] || (abs($Priv(pressX) - $x) >= 3)} {
	set Priv(mouseMoved) 1
    }
    switch -- $Priv(selectMode) {
	char {
	    if {[$w compare $cur < tk::anchor$w]} {
		set first $cur
		set last tk::anchor$w
	    } else {
		set first tk::anchor$w
		set last $cur
	    }
	}
	word {
	    # Set initial range based only on the anchor (1 char min width -
	    # MOD - unless this straddles a display line end)
	    if {[$w cget -wrap] eq "word"} {
		set lineType displaylines
	    } else {
		set lineType lines
	    }
	    if {[$w mark gravity tk::anchor$w] eq "right"} {
		set first "tk::anchor$w"
		set last "tk::anchor$w + 1c"
		if {[$w count -$lineType $first $last] != 0} {
			set last $first
		} else {
		}
	    } else {
		set first "tk::anchor$w - 1c"
		set last "tk::anchor$w"
		if {[$w count -$lineType $first $last] != 0} {
			set first $last
		} else {
		}
	    }
	    if {($last eq $first) && ([$w index $first] eq $cur)} {
		# Use $first and $last as above; further extension will straddle
		# a display line. Better to have no selection than a bad one.
	    } else {
		# Extend range (if necessary) based on the current point
		if {[$w compare $cur < $first]} {
		    set first $cur
		} elseif {[$w compare $cur > $last]} {
		    set last $cur
		}

		# Now find word boundaries
		set first1 [$w index "$first + 1c"]
		set last1  [$w index "$last - 1c"]
		if {[$w count -$lineType $first $first1] != 0} {
		    set first1 [$w index $first]
		} else {
		}
		if {[$w count -$lineType $last $last1] != 0} {
		    set last1 [$w index $last]
		} else {
		}
		set first2 [::tk::TextPrevPos $w "$first1" \
		    ntext::new_wordBreakBefore]
		set last2  [::tk::TextNextPos $w "$last1"  \
		    ntext::new_wordBreakAfter]
		# Don't allow a "word" to straddle a display line boundary (or,
		# in -wrap char mode, a logical line boundary). This is not the
		# right result if -wrap word has been forced into -wrap char
		# because a word is too long.
		if {[$w count -$lineType $first2 $first] != 0} {
		    set first [$w index "$first display linestart"]
		} else {
		    set first $first2
		}
		if {[$w count -$lineType $last2 $last] != 0} {
		    set last [$w index "$last display lineend"]
		} else {
		    set last $last2
		}
	    }
	}
	line {
	    # Set initial range based only on the anchor
	    set first "tk::anchor$w linestart"
	    set last "tk::anchor$w lineend"

	    # Extend range (if necessary) based on the current point
	    if {[$w compare $cur < $first]} {
		set first "$cur linestart"
	    } elseif {[$w compare $cur > $last]} {
		set last "$cur lineend"
	    }
	    set first [$w index $first]
	    set last [$w index "$last + 1c"]
	}
    }
    if {$Priv(mouseMoved) || ($Priv(selectMode) ne "char")} {
	$w tag remove sel 0.0 end
	$w mark set insert $cur
	$w tag add sel $first $last
	$w tag remove sel $last end
	update idletasks
    }
}


# ::tk::TextKeyExtend -- called without modification

# ::tk::TextPasteSelection --
# This procedure sets the insertion cursor to the mouse position,
# inserts the selection, and sets the focus to the window.
#
# Arguments:
# w -		The text window.
# x, y - 	Position of the mouse.

# ::ntext::TextPasteSelection is copied from ::tk with modifications:
# modified to set oldInsert and call AdjustIndentMultipleLines.

proc ::ntext::TextPasteSelection {w x y} {
    $w mark set insert [TextClosestGap $w $x $y]
    set oldInsert [$w index insert]
    if {![catch {::tk::GetSelection $w PRIMARY} sel]} {
	set oldSeparator [$w cget -autoseparators]
	if {$oldSeparator} {
	    $w configure -autoseparators 0
	    $w edit separator
	}
	$w insert insert $sel
	AdjustIndentMultipleLines $w $oldInsert insert
	if {$oldSeparator} {
	    $w edit separator
	    $w configure -autoseparators 1
	}
    }
    if {[$w cget -state] eq "normal"} {
	focus $w
    }
}


# ::tk::TextAutoScan --
# This procedure is invoked when the mouse leaves a text window
# with button 1 down.  It scrolls the window up, down, left, or right,
# depending on where the mouse is (this information was saved in
# ::tk::Priv(x) and ::tk::Priv(y)), and reschedules itself as an "after"
# command so that the window continues to scroll until the mouse
# moves back into the window or the mouse button is released.
#
# Arguments:
# w -		The text window.

# ::ntext::TextAutoScan is copied from ::tk with modifications:
# chiefly so it calls ::ntext::TextSelectTo not ::tk::TextSelectTo
# modified so it calls itself and not ::tk::TextAutoScan

proc ::ntext::TextAutoScan {w} {
    variable ::tk::Priv
    if {![winfo exists $w]} {
	return
    }
    if {$Priv(y) >= [winfo height $w]} {
	$w yview scroll [expr {1 + $Priv(y) - [winfo height $w]}] pixels
    } elseif {$Priv(y) < 0} {
	$w yview scroll [expr {-1 + $Priv(y)}] pixels
    } elseif {$Priv(x) >= [winfo width $w]} {
	$w xview scroll 2 units
    } elseif {$Priv(x) < 0} {
	$w xview scroll -2 units
    } else {
	return
    }
    TextSelectTo $w $Priv(x) $Priv(y)
    set Priv(afterId) [after 50 [list ntext::TextAutoScan $w]]
}

# ::tk::TextSetCursor -- called without modification

# ::tk::TextKeySelect -- called without modification

# ::tk::TextResetAnchor -- called without modification

# ::tk::TextInsert --
# Insert a string into a text at the point of the insertion cursor.
# If there is a selection in the text, and it covers the point of the
# insertion cursor, then delete the selection before inserting.
#
# Arguments:
# w -		The text window in which to insert the string
# s -		The string to insert (usually just a single character)

# ::ntext::TextInsert is copied from ::tk with modifications:
# modified to implement Insert/Overwrite and to call AdjustIndentOneLine
# combine nested 'if' statements to avoid repetition of 'else' code

proc ::ntext::TextInsert {w s} {
    if {($s eq "") || ([$w cget -state] eq "disabled")} {
	return
    }
    set compound 0
    if {[llength [set range [$w tag ranges sel]]] &&
	[$w compare [lindex $range 0] <= insert]  &&
	[$w compare [lindex $range end] >= insert]} {

	set oldSeparator [$w cget -autoseparators]
	if {$oldSeparator} {
	    $w configure -autoseparators 0
	    $w edit separator
	    set compound 1
	}
	$w delete [lindex $range 0] [lindex $range end]
    } elseif {$::ntext::overwrite && ($s ne "\n") && ($s ne "\t") &&
		([$w get insert] ne "\n")} {
	set oldSeparator [$w cget -autoseparators]
	if {$oldSeparator} {
	    $w configure -autoseparators 0
	    $w edit separator
	    set compound 1
	    # When undoing an overwrite, the insert mark is left
	    # in the "wrong" place - after and not before the change.
	    # Some non-Tk editors do this too.
	}
	$w delete insert
    }
    $w insert insert $s
    AdjustIndentOneLine $w insert
    $w see insert
    if {$compound && $oldSeparator} {
	$w edit separator
	$w configure -autoseparators 1
    }
}

# ::tk::TextUpDownLine -- called without modification

# ::tk::TextPrevPara -- called without modification

# ::tk::TextNextPara -- called without modification

# ::tk::TextScrollPages --
# This is a utility procedure used in bindings for moving up and down
# pages and possibly extending the selection along the way.  It scrolls
# the view in the widget by the number of pages, and it returns the
# index of the character that is at the same position in the new view
# as the insertion cursor used to be in the old view.
#
# Arguments:
# w -		The text window in which the cursor is to move.
# count -	Number of pages forward to scroll;  may be negative
#		to scroll backwards.

# ::ntext::TextScrollPages is called like ::tk::TextScrollPages, but is
# completely rewritten, and behaves differently.
#
# ::tk::TextScrollPages scrolls the widget, and returns an index (a new value
# for the insert mark); if the mark was on-screen before the scroll,
# ::tk::TextScrollPages tries to return an index that keeps it in the same
# screen position.
#
# ::ntext::TextScrollPages takes a slightly different approach:
# like ::tk::TextScrollPages, it returns an index (a new value for the insert
# mark), and lets the calling code decide whether to move the mark.
# Unlike ::tk::TextScrollPages, when called with two arguments it does no
# scrolling - it relies on the calling code to do the scrolling, which in
# practice is usually when it tries to 'see' the returned index value.
#
# By focussing on the insert mark, ::ntext::TextScrollPages has the
# following useful features:
#  - When the slack is less than one page, it "moves" the insert mark as far
#    as possible.
#  - When there is no slack, it "moves" the insert mark to the start/end of
#    the widget.
#  - It uses ::tk::TextUpDownLine to remember the initial x-value.
#
# When called with three arguments, 3rd argument = "preScroll", then, if the
# new position of the insert mark is off-screen, ::ntext::TextScrollPages
# will scroll the widget, to try to make the calling code's "see" move the
# returned index value to the middle, not the edge, of the widget.  This
# feature is most useful in widgets with only a few visible lines, where it
# prevents successive calls from moving the insert mark between the middle and
# the edge of the widget.

proc ::ntext::TextScrollPages {w count {help ""}} {
    set spareLines 1 ;# adjustable

    set oldInsert [$w index insert]
    set count [expr {int($count)}]
    if {$count == 0} {
	return $oldInsert
    }
    set visibleLines [$w count -displaylines @0,0 @0,20000]
    if {$visibleLines > $spareLines} {
	set pageLines [expr {$visibleLines - $spareLines}]
    } else {
	set pageLines 1
    }
    set newInsert  [::tk::TextUpDownLine $w [expr {$pageLines * $count}]]
    if {[$w compare $oldInsert != $newInsert]} {
	set finalInsert $newInsert
    } elseif {$count < 0} {
	set finalInsert 1.0
    } else {
	set finalInsert [$w index "end -1 char"]
    }
    if {($help eq "preScroll") && ([$w bbox $finalInsert] eq "")} {
	# If $finalInsert is offscreen, try to put it in the middle
	if {    [$w count -displaylines 1.0 $finalInsert] > \
		[$w count -displaylines $finalInsert end]} {
	    $w see 1.0
	} else {
	    $w see end
	}
	$w see $finalInsert
    }
    return $finalInsert
}

# ::tk::TextTranspose --
# This procedure implements the "transpose" function for text widgets.
# It tranposes the characters on either side of the insertion cursor,
# unless the cursor is at the end of the line.  In this case it
# transposes the two characters to the left of the cursor.  In either
# case, the cursor ends up to the right of the transposed characters.
#
# Arguments:
# w -		Text window in which to transpose.

# ::ntext::TextTranspose is copied from ::tk::TextTranspose with modifications:
# modified to call AdjustIndentOneLine.
# rename local variable autosep to oldSeparator for uniformity with other procs

proc ::ntext::TextTranspose w {
    set pos insert
    if {[$w compare $pos != "$pos lineend"]} {
	set pos [$w index "$pos + 1 char"]
    }
    set new [$w get "$pos - 1 char"][$w get  "$pos - 2 char"]
    if {[$w compare "$pos - 1 char" == 1.0]} {
	return
    }
    # ensure this is seen as an atomic op to undo
    set oldSeparator [$w cget -autoseparators]
    if {$oldSeparator} {
	$w configure -autoseparators 0
	$w edit separator
    }
    $w delete "$pos - 2 char" $pos
    $w insert insert $new

    if {[$w compare insert == "insert linestart"]} {
	AdjustIndentOneLine $w "insert - 1 line"
    }
    AdjustIndentOneLine $w insert

    $w see insert
    if {$oldSeparator} {
	$w edit separator
	$w configure -autoseparators 1
    }
}

# ::tk_textCopy -- called without modification

# ::tk_textCut --
# This procedure copies the selection from a text widget into the
# clipboard, then deletes the selection (if it exists in the given
# widget).
#
# Arguments:
# w -		Name of a text widget.

# ::ntext::new_textCut is copied from ::tk_textCut with modifications:
# modified to set LocalOldFirst, call AdjustIndentOneLine, and add autoseparators

# LocalOldFirst is never off by one: the final newline of the widget cannot
# be deleted.

proc ::ntext::new_textCut w {
    if {![catch {set data [$w get sel.first sel.last]}]} {
	set oldSeparator [$w cget -autoseparators]
	if {$oldSeparator} {
	    $w configure -autoseparators 0
	    $w edit separator
	}
	set LocalOldFirst [$w index sel.first]
	clipboard clear -displayof $w
	clipboard append -displayof $w $data
	$w delete sel.first sel.last
	AdjustIndentOneLine $w $LocalOldFirst
	if {$oldSeparator} {
	    $w edit separator
	    $w configure -autoseparators 1
	}
    }
    return
}

# ::tk_textPaste --
# This procedure pastes the contents of the clipboard to the insertion
# point in a text widget.
#
# Arguments:
# w -		Name of a text widget.

# ::ntext::new_textPaste is copied from ::tk_textPaste with modifications:
# - modified to set oldInsert, LocalOldFirst and ntextIndentMark, and call
#   AdjustIndentMultipleLines.
# - modified to behave the same way for X11 as for other windowing systems
# - modified to overwrite the selection (if it exists), even if the insert mark
#   is elsewhere

proc ::ntext::new_textPaste w {
    set oldInsert [$w index insert]
    global tcl_platform
    if {![catch {::tk::GetSelection $w CLIPBOARD} sel]} {
	set oldSeparator [$w cget -autoseparators]
	if {$oldSeparator} {
	    $w configure -autoseparators 0
	    $w edit separator
	}
	if {([tk windowingsystem] ne "x11TheOldFashionedWay") && \
		([$w tag nextrange sel 1.0 end] ne "")} {
	    set LocalOldFirst [$w index sel.first]
	    $w mark set ntextIndentMark sel.last
	    # right gravity mark, survives deletion
	    $w delete sel.first sel.last
	    $w insert $LocalOldFirst $sel
	    AdjustIndentMultipleLines $w $LocalOldFirst ntextIndentMark
	} else {
	    $w insert insert $sel
	    AdjustIndentMultipleLines $w $oldInsert insert
	}
	if {$oldSeparator} {
	    $w edit separator
	    $w configure -autoseparators 1
	}
    }
    return
}

# ::tk::TextNextWord --
# Returns the index of the next word position after a given position in the
# text.  The next word is platform dependent and may be either the next
# end-of-word position or the next start-of-word position after the next
# end-of-word position.
#
# Arguments:
# w -		The text window in which the cursor is to move.
# start -	Position at which to start search.

# ::ntext::TextNextWord is copied from ::tk::TextNextWord with modifications:
# modified to use a platform-independent definition: always goes to the start
# of the next word.

proc ::ntext::TextNextWord {w start} {
    ::tk::TextNextPos $w $start ntext::new_startOfNextWord
}

# ::tk::TextNextPos  -- called without modification
# ::tk::TextPrevPos  -- called without modification
# ::tk::TextScanMark -- called without modification
# ::tk::TextScanDrag -- called without modification


# Two new functions, HomeIndex and EndIndex, that can be used for "smart" Home
# and End operations

# ::ntext::HomeIndex --
#
# Return the index to jump to (from $index) as "Smart Home"
# Some corner cases (e.g. lots of leading whitespace, wrapped around)
# probably have a better solution; but there's no consensus on how a
# text editor should behave in such cases.
#
# Arguments:
# w -    		Name of a text widget.
# index -		an index in the widget

proc ::ntext::HomeIndex {w index} {
    set index   [$w index $index]
    set dls     [$w index "$index display linestart"]

    # Set firstNonSpace to the index of the first non-space character on the
    # logical line.
    set dlsList [split $dls .]
    set dlsLine [lindex $dlsList 0]
    set lls     $dlsLine.0
    set firstNonSpace \
	[$w search -regexp -- {[^[:space:]]} \
	     $dlsLine.0 [expr {$dlsLine + 1}].0]

    # Now massage $firstNonSpace so it contains the "usual" home position on
    # the first display line
    if {$firstNonSpace eq {}} {
	# No non-whitespace characters on the line
	set firstNonSpace $dlsLine.0
    } elseif {[$w count -displaylines $lls $firstNonSpace] != 0} {
	# Either lots of whitespace, or whitespace with character wrap forces
	# $firstNonSpace onto the next.
	# display line
	set firstNonSpace $dlsLine.0
    } else {
	# The usual case: the first non-whitespace $firstNonSpace is on the
	# first display line
    }

    if {$dls eq $lls} {
	# We're on the first display line
	if {$index eq $firstNonSpace} {
	    # we're at the first non-whitespace of the first display line
	    set home $lls
	} else {
	    # we're on the first display line, but not at the first
	    # non-whitespace
	    set home $firstNonSpace
	}
    } else {
	if {$dls eq $index} {
	    # we're at the start of a display line other than the first
	    set home $firstNonSpace
	} else {
	    # we're not on the first display line, and we're not at our display
	    # line's start
	    set home $dls
	}
    }
    return $home
}

# ::ntext::EndIndex --
#
# Return the index to jump to (from $index) as "Smart End"
#
# Arguments:
# w -    		Name of a text widget.
# index -		an index in the widget

proc ::ntext::EndIndex {w index} {
    set index    [$w index $index]
    set dle      [$w index "$index display lineend"]

    if {$dle eq $index} {
	# we're at the end of a display line: return the logical line end
	return [$w index "$index lineend"]
    } else {
	# return the display line end
	return $dle
    }
}

##### END OF CODE THAT IS MODIFIED text.tcl
##### THE CODE ABOVE DEPENDS ON THE PROCS DEFINED BELOW

##### START OF CODE FOR WORD BOUNDARY DETECTION

# We define ::ntext counterparts for the functions in lib/tcl8.5/word.tcl
# such as ::tcl_wordBreakAfter
# See man page for discussion of the variables ::tcl_wordchars
# and ::tcl_nonwordchars defined in word.tcl

# This code block defines the seven namespace procs
#   createMatchPatterns
#   initializeMatchPatterns
#   new_wordBreakAfter
#   new_wordBreakBefore
#   new_endOfWord
#   new_startOfNextWord
#   new_startOfPreviousWord


# ::ntext::createMatchPatterns --
#
# This procedure defines the regexp patterns that are used in text
# searches, and saves them in namespace variables ::ntext::tcl_match_*
#
# Each argument should be a regexp expression defining a class of
# characters (usually a bracket expression, a class-shorthand escape,
# or a single character); the third argument may be omitted, or supplied
# as the empty string, in which case it is unused.
#
# The arguments are analogous to lib/tcl8.5/word.tcl's global variables
# tcl_wordchars and tcl_nonwordchars, but are not exposed as global or
# namespace variables: instead, the regexp patterns that are used for
# the searches are exposed as namespace variables.
#
# Usually this procedure is called by ::ntext::initializeMatchPatterns
# with machine-generated arguments.
#
# Arguments:
# new_nonwordchars -		regexp expression for non-word characters
#                   		(e.g. whitespace)
# new_word1chars -		regexp expression for first set of word
#                 		characters (e.g. alphanumerics)
# new_word2chars -		(optional) regexp expression for second set
#                 		of word characters (e.g. punctuation)

proc ::ntext::createMatchPatterns {new_nonwordchars new_word1chars {new_word2chars {}}} {

    variable tcl_match_wordBreakAfter
    variable tcl_match_wordBreakBefore
    variable tcl_match_endOfWord
    variable tcl_match_startOfNextWord
    variable tcl_match_startOfPreviousWord

    if {$new_word2chars eq {}} {
	# With one "non-word" character class, and one "word" class, generate
	# the same regexp patterns as Tcl's default search functions:
	# The shorthand is based on ntext's default definitions for the
	# function arguments:
	# "s" $new_nonwordchars (space)
	# "w" $new_word1chars   (word)
	# "p" $new_word2chars   (punctuation)
	set wordBreakAfter      "ws|sw"
	set wordBreakBefore     "^.*($wordBreakAfter)"
	set endOfWord           "s*w+s"
	set startOfNextWord     "w*s+w"
	set startOfPreviousWord "s*(w+)s*\$"
    } else {
	# Generalise to one "non-word" character class, and two "word" classes
	set wordBreakAfter      "ps|pw|sp|sw|wp|ws"
	set wordBreakBefore     "^.*($wordBreakAfter)"
	set endOfWord           "s*w+s|s*w+p|s*p+s|s*p+w"
	set startOfNextWord     "w*s+w|p*s+w|p+w|w*s+p|p*s+p|w+p"
	set startOfPreviousWord "s*(w+)s*\$|p*(w+)s*\$|w*(p+)s*\$|s*(p+)s*\$"
	# all tested, the first two with Double-1
	# in the last three, note that whitespace is not considered a "word"
	# - in endOfWord, note that leading space is acceptable, but not leading
	#   anything else
	# - in startOfNextWord, note that leading characters are acceptable only
	#   before a space
	# - in startOfPreviousWord, note that trailing space is acceptable, but
	# - not trailing anything else
	# With these rules, generalisation to more classes of characters is
	# straightforward.
    }

    foreach pattern {wordBreakAfter wordBreakBefore endOfWord \
	    startOfNextWord startOfPreviousWord} {
	# Define the search pattern
	set tcl_match_$pattern [string map [list w $new_word1chars p \
		$new_word2chars s $new_nonwordchars] [set $pattern]]
    }
    return
}

# ::ntext::initializeMatchPatterns --
#
# This procedure calls createMatchPatterns with arguments appropriate for
# the values of ::ntext::classicWordBreak and ::tcl_platform(platform).

proc ::ntext::initializeMatchPatterns {} {
    variable classicWordBreak
    if {!$classicWordBreak} {
	# ntext style: two classes of word character
	set punct {]`|.,:;/~!%&*_+='~[{}^"?()}     ;#" keep \ as a word char
	set space {[:space:]}
	set tcl_punctchars "\[${punct}-\]"
	set tcl_spacechars "\[${space}\]"
	set tcl_word1chars "\[^${punct}${space}-\]"
    } elseif {$::tcl_platform(platform) eq "windows"} {
	# Windows style - any but a unicode space char
	set tcl_word1chars "\\S"
	set tcl_spacechars "\\s"
	set tcl_punctchars {}
    } else {
	# Motif style - any unicode word char (number, letter, or underscore)
	set tcl_word1chars "\\w"
	set tcl_spacechars "\\W"
	set tcl_punctchars {}
    }

    createMatchPatterns $tcl_spacechars $tcl_word1chars $tcl_punctchars
    return
}


# Now procs derived from those in lib/tcl8.5/word.tcl, Tcl 8.5a5
# = ActiveTcl 8.5beta6

# tcl_wordBreakAfter --
#
# This procedure returns the index of the first word boundary
# after the starting point in the given string, or -1 if there
# are no more boundaries in the given string.  The index returned refers
# to the first character of the pair that comprises a boundary.
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

# ::ntext::new_wordBreakAfter is copied from ::tcl_wordBreakAfter with
# modifications: new word-boundary detection rules

proc ::ntext::new_wordBreakAfter {str start} {
    variable tcl_match_wordBreakAfter
    set str [string range $str $start end]
    if {[regexp -indices $tcl_match_wordBreakAfter $str result]} {
	return [expr {[lindex $result 1] + $start}]
    }
    return -1
}

# tcl_wordBreakBefore --
#
# This procedure returns the index of the first word boundary
# before the starting point in the given string, or -1 if there
# are no more boundaries in the given string.  The index returned
# refers to the second character of the pair that comprises a boundary.
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

# ::ntext::new_wordBreakBefore is copied from ::tcl_wordBreakBefore with
# modifications: new word-boundary detection rules

proc ::ntext::new_wordBreakBefore {str start} {
    variable tcl_match_wordBreakBefore
    if {$start eq "end"} {
	set start [string length $str]
    }
    if {[regexp -indices $tcl_match_wordBreakBefore \
	    [string range $str 0 $start] result]} {
	return [lindex $result 1]
    }
    return -1
}

# tcl_endOfWord --
#
# This procedure returns the index of the first end-of-word location
# after a starting index in the given string.  An end-of-word location
# is defined to be the first whitespace character following the first
# non-whitespace character after the starting point.  Returns -1 if
# there are no more words after the starting point.
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

# ::ntext::new_endOfWord is copied from ::tcl_endOfWord with
# modifications:
# new word-boundary detection rules

proc ::ntext::new_endOfWord {str start} {
    variable tcl_match_endOfWord
    if {[regexp -indices $tcl_match_endOfWord \
	    [string range $str $start end] result]} {
	return [expr {[lindex $result 1] + $start}]
    }
    return -1
}

# tcl_startOfNextWord --
#
# This procedure returns the index of the first start-of-word location
# after a starting index in the given string.  A start-of-word
# location is defined to be a non-whitespace character following a
# whitespace character.  Returns -1 if there are no more start-of-word
# locations after the starting point.
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

# ::ntext::new_startOfNextWord is copied from ::tcl_startOfNextWord with
# modifications: new word-boundary detection rules

proc ::ntext::new_startOfNextWord {str start} {
    variable tcl_match_startOfNextWord
    if {[regexp -indices $tcl_match_startOfNextWord \
	    [string range $str $start end] result]} {
	return [expr {[lindex $result 1] + $start}]
    }
    return -1
}

# tcl_startOfPreviousWord --
#
# This procedure returns the index of the first start-of-word location
# before a starting index in the given string.
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

# ::ntext::new_startOfPreviousWord is copied from ::tcl_startOfPreviousWord
# with modifications: new word-boundary detection rules

proc ::ntext::new_startOfPreviousWord {str start} {
    variable tcl_match_startOfPreviousWord
    if {$start eq "end"} {
	set start [string length $str]
    }
    if {[regexp -indices \
	    $tcl_match_startOfPreviousWord \
	    [string range $str 0 [expr {$start - 1}]] result words(1) \
	    words(2) words(3) words(4) words(5) words(6) words(7) words(8) \
	    words(9) words(10) words(11) words(12) words(13) words(14) \
	    words(15) words(16)]} {
	set result -1
	foreach name [array names words] {
	    set val [lindex $words($name) 0]
	    if {$val != -1} {
		set result $val
		break
	    }
	}
	return $result
    }
    return -1
}

##### END OF CODE FOR WORD BOUNDARY DETECTION

##### START OF CODE TO HANDLE (OPTIONAL) INDENTATION USING -lmargin2

# ::ntext::wrapIndent --
#
# Procedure to adjust the hanging indent of a text widget.
# If indentation is active, i.e. if
# ::ntext::classicWrap == 0 and the widget has "-wrap word",
# the logical lines specified by the arguments will be indented so that for
# each logical line, the start of every wrapped display line is aligned with
# the first display line.
# If indentation is inactive, the procedure removes any existing indentation.
#
# This procedure is the only indentation procedure that should be called
# by user scripts.  It uses -lmargin2 to adjust the hanging indent of lines
# in a text widget.
#
# Call with one argument to adjust the indentation of the entire widget;
# with two arguments, to adjust the indentation of a single logical line;
# with three arguments, to adjust the indentation of a range of logical lines.
#
# Arguments:
# textWidget -		text widget to be indented
# index1 -		(optional) index in the first logical line to be
#         		indented
# index2 -		(optional) index in the last logical line to be indented

proc ::ntext::wrapIndent {textWidget args} {
    variable classicWrap
    if {([$textWidget cget -wrap] eq "word") && !$classicWrap} {
	if {[llength $args] == 0} {
	    AdjustIndentMultipleLines $textWidget 1.0 end
	} elseif {[llength $args] == 1} {
	    AdjustIndentOneLine $textWidget [lindex $args 0]
	} else {
	    AdjustIndentMultipleLines $textWidget \
		[lindex $args 0] [lindex $args 1]
	}
    } else {
	if {[llength $args] == 0} {
	    RemoveIndentMultipleLines $textWidget 1.0 end
	} elseif {[llength $args] == 1} {
	    RemoveIndentOneLine $textWidget [lindex $args 0]
	} else {
	    RemoveIndentMultipleLines $textWidget \
		[lindex $args 0] [lindex $args 1]
	}
    }
    return
}

# ::ntext::AdjustIndentMultipleLines --
#
# Procedure to adjust the hanging indent of multiple logical lines
# of a text widget - but only if indentation is active,
# i.e. if ::ntext::classicWrap == 0 and the widget has "-wrap word";
# otherwise the procedure does nothing.
#
# User scripts should call ::ntext::wrapIndent instead.
#
# Arguments:
# textWidget -		text widget to be indented
# index1 -		index in the first logical line to be indented
# index2 -		index in the last logical line to be indented

proc ::ntext::AdjustIndentMultipleLines {textWidget index1 index2} {
    # Ensure that each line has precisely one tag whose name begins
    # "ntextAlignLM2Indent=", and that this tag covers the whole line; set
    # its -lmargin2 value so that for each line, the start of every wrapped
    # display line is aligned with the first display line.
    variable classicWrap
    if {([$textWidget cget -wrap] eq "word") && !$classicWrap} {
	if {[$textWidget count -lines $index1 $index2] < 0} {
	    set index3 $index1
	    set index1 $index2
	    set index2 $index3
	}
	set index1 [$textWidget index "$index1 linestart"]
	set index2 [$textWidget index "$index2 linestart"]
	for     {set index $index1} \
		{$index <= $index2 && [$textWidget compare $index != end]} \
		{set index [$textWidget index "$index + 1 line"]} {
	    AdjustIndentOneLine $textWidget $index
	    set oldIndex $index
	}
    } else {
	# indentation not active
    }
    return
}

# ::ntext::AdjustIndentOneLine --
#
# Procedure to adjust the hanging indent of a single logical line
# of a text widget - but only if indentation is active,
# i.e. if ::ntext::classicWrap == 0 and the widget has "-wrap word";
# otherwise the procedure does nothing.
#
# User scripts should call ::ntext::wrapIndent instead.
#
# Arguments:
# textWidget -		text widget to be indented
# index -		index in the logical line to be indented

proc ::ntext::AdjustIndentOneLine {textWidget index} {
    # Ensure that the line has precisely one tag whose name begins
    # "ntextAlignLM2Indent=", and that this tag covers the whole line; set
    # its -lmargin2 value so that the start of every wrapped display line
    # is aligned with the first display line.
    variable classicWrap
    if {([$textWidget cget -wrap] eq "word") && !$classicWrap} {
	RemoveIndentOneLine $textWidget $index
	set pix [HowMuchIndent $textWidget $index]
	AddIndent $textWidget $index $pix
    } else {
	# indentation not active
    }
    return
}

# ::ntext::AddIndent --
#
# Procedure to set the hanging indent of a single logical line
# of a text widget.  The line must not already have indentation.
#
# User scripts should call ::ntext::wrapIndent instead.
#
# Arguments:
# textWidget -		text widget to be indented
# index -		index in the logical line to be indented
# pix -  		number of pixels of indentation

proc ::ntext::AddIndent {textWidget index pix} {
    # Add a tag with properties "-lmargin2 $pix" to the entire logical line
    variable lm2IndentDebug
    set lineStart     [$textWidget index "$index linestart"]
    set nextLineStart [$textWidget index "$lineStart + 1 line"]
    set tagName ntextAlignLM2Indent=${pix}
    $textWidget tag add $tagName $lineStart $nextLineStart
    $textWidget tag configure $tagName -lmargin2 ${pix}
    if {$lm2IndentDebug} {
	$textWidget tag configure $tagName -background [IntToColor $pix 100]
    }
    $textWidget tag lower $tagName
    return $tagName
}

# ::ntext::HowMuchIndent --
#
# Procedure to measure and return the number of pixels of hanging
# indent required by a single logical line of a text widget;
# i.e. how many pixels of -lmargin2 indentation does the logical line
# need, for alignment with its own first display line?
#
# User scripts should call ::ntext::wrapIndent instead.
#
# N.B. This procedure cannot be used before the widget is drawn: it uses
# display lines, which the widget calculates only when it is drawn.
#
# Arguments:
# textWidget -		text widget to be examined
# index -		index in the logical line to be examined

proc ::ntext::HowMuchIndent {textWidget index} {
    variable newWrapRegexp
    set lineStart [$textWidget index "$index linestart"]
    set secondDispLineStart [$textWidget index "$lineStart + 1 display line"]
    # checked that this gives the start of the next display line in
    # the *updated* display
    set indentTo  [$textWidget search -regexp -count matchLen -- \
	    $newWrapRegexp $lineStart $secondDispLineStart]
    if {$indentTo eq {}} {
	set pix 0
    } else {
	set indentTo [$textWidget index "$indentTo + $matchLen chars - 1 char"]
	set pix [$textWidget count -xpixels $lineStart $indentTo]
	# -update doesn't work yet for -xpixels: so this line appears to
	# assume a fixed-width font: yet it gets the correct result (with or
	# without -update) when a tab is inserted.
    }
    return $pix
}

# ::ntext::RemoveIndentOneLine --
#
# Procedure to remove the hanging indent of a single logical line
# of a text widget.  It does this regardless of whether indentation
# is active, i.e. regardless of the value of ::ntext::classicWrap
#
# User scripts should call ::ntext::wrapIndent instead.
#
# Arguments:
# textWidget -		text widget to be dedented
# index -		index in the logical line to be dedented

proc ::ntext::RemoveIndentOneLine {textWidget index} {
    # Remove -lmargin2 indentation, by removing each tag in the
    # line whose name begins "ntextAlignLM2Indent="

    set lineStart     [$textWidget index "$index linestart"]
    set nextLineStart [$textWidget index "$lineStart + 1 line"]

    set tagNames [$textWidget tag names $lineStart]

    foreach {dum1 tag dum2} [$textWidget dump -tag $lineStart $nextLineStart] {
	lappend tagNames $tag
    }

    # tagNames now holds all tags on this logical line
    # Remove the ones that ntext has previously used to set -lmargin2
    # These tags' names all begin with the same string.

    foreach tag $tagNames {
	if {[string range $tag 0 19] eq "ntextAlignLM2Indent="} {
	    #### puts $tag
	    $textWidget tag remove $tag $lineStart $nextLineStart
	}
    }
    return
}

# ::ntext::RemoveIndentMultipleLines --
#
# Procedure to remove the hanging indent of multiple logical lines
# of a text widget.  It does this regardless of whether indentation
# is active, i.e. regardless of the value of ::ntext::classicWrap
#
# User scripts should call ::ntext::wrapIndent instead.
#
# Arguments:
# textWidget -		text widget to be dedented
# index1 -		index in the first logical line to be dedented
# index2 -		index in the last logical line to be dedented

proc ::ntext::RemoveIndentMultipleLines {textWidget index1 index2} {
    # Remove -lmargin2 indentation, by removing each tag in these
    # lines whose name begins "ntextAlignLM2Indent="

    if {[$textWidget count -lines $index1 $index2] < 0} {
	set index3 $index1
	set index1 $index2
	set index2 $index3
    } else {
    }
    if {    [$textWidget compare $index1 == 1.0] && \
	    [$textWidget compare $index2 == end]} {
	# shortcut if whole widget needs processing

	# Remove -lmargin2 indentation, by removing each tag in the
	# widget whose name begins "ntextAlignLM2Indent="

	set tagNames [$textWidget tag names]

	# tagNames now holds all tags in the widget
	# Remove the ones that ntext has previously used to set -lmargin2
	# These tags' names all begin with the same string.

	foreach tag $tagNames {
	    if {[string range $tag 0 19] eq  "ntextAlignLM2Indent="} {
		#### puts $tag
		$textWidget tag remove $tag 1.0 end
	    }
	}
    } else {
	# go through the widget line-by-line
	set index1 [$textWidget index "$index1 linestart"]
	set index2 [$textWidget index "$index2 linestart"]
	for     {set index $index1} \
		{$index <= $index2 && [$textWidget compare $index != end]} \
		{set index [$textWidget index "$index + 1 line"]} {
	    RemoveIndentOneLine $textWidget $index
	    set oldIndex $index
	}
    }
    return
}

# ::ntext::IntToColor --
#
# Return a color in 24-bit hexadecimal format (e.g. "#FF8080") whose
# value is a periodic function of the number $pix, with period $range.
# Nothing too dark: each of R, G and B is in the range 156 to 255.
# Return value is white if $pix == 0
#
# Arguments:
# pix -  		real or integer number
# range -		real or integer number, non-zero

proc ::ntext::IntToColor {pix range} {
    set val [expr {int(99.9 - $pix * 100.0 / $range) % 100 + 156}]
    set r $val
    set g $val
    set b 255
    set color [format "#%02x%02x%02x" $r $g $b]
    return $color
}

##### END OF CODE TO HANDLE (OPTIONAL) INDENTATION USING -lmargin2

##### End of procs.

# Initialize match patterns for word boundary detection -

::ntext::initializeMatchPatterns

package provide ntext 0.81
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/ntext/pkgIndex.tcl.

1
package ifneeded ntext 0.81 [list source [file join $dir ntext.tcl]]
<


Deleted scriptlibs/tklib0.5/pkgIndex.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
# Tcl package index file, version 1.1
# Do NOT edit by hand.  Let tklib install generate this file.
# Generated by tklib installer for version 0.5

# All tklib packages need Tcl 8 (use [namespace])
if {![package vsatisfies [package provide Tcl] 8]} {return}

# Extend the auto_path to make tklib packages available
if {[lsearch -exact $::auto_path $dir] == -1} {
    lappend ::auto_path $dir
}

# For Tcl 8.3.1 and later, that's all we need
if {[package vsatisfies [package provide Tcl] 8.4]} {return}
if {(0 == [catch {
    package vcompare [info patchlevel] [info patchlevel]
}]) && (
    [package vcompare [info patchlevel] 8.3.1] >= 0
)} {return}

# For older Tcl releases, here are equivalent contents
# of the pkgIndex.tcl files of all the modules

if {![package vsatisfies [package provide Tcl] 8.0]} {return}


set maindir $dir
set dir [file join $maindir autoscroll] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir canvas] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir chatwidget] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir crosshair] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir ctext] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir cursor] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir datefield] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir diagrams] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir getstring] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir history] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir ico] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir ipentry] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir khim] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir ntext] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir plotchart] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir style] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir swaplist] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir tablelist] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir tkpiechart] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir tooltip] ;	 source [file join $dir pkgIndex.tcl]
set dir [file join $maindir widget] ;	 source [file join $dir pkgIndex.tcl]
unset maindir

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




































































































Deleted scriptlibs/tklib0.5/plotchart/pkgIndex.tcl.

1
2
3
4
5
if {![package vsatisfies [package provide Tcl] 8.4]} {
    # PRAGMA: returnok
    return
}
package ifneeded Plotchart 1.6.1 [list source [file join $dir plotchart.tcl]]
<
<
<
<
<










Deleted scriptlibs/tklib0.5/plotchart/plot3d.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
# plot3d.tcl --
#    Facilities to draw simple 3D plots in a dedicated canvas
#
# Note:
#    This source file contains the private functions for 3D plotting.
#    It is the companion of "plotchart.tcl"
#

# Draw3DAxes --
#    Draw the axes in a 3D plot
# Arguments:
#    w           Name of the canvas
#    xmin        Minimum x coordinate
#    xmax        Maximum x coordinate
#    xstep       Step size
#    ymin        Minimum y coordinate
#    ymax        Maximum y coordinate
#    ystep       Step size
#    zmin        Minimum z coordinate
#    zmax        Maximum z coordinate
#    zstep       Step size
#    names       List of labels for the x-axis (optional)
# Result:
#    None
# Note:
#    To keep the axes in positive orientation, the x-axis appears
#    on the right-hand side and the y-axis appears in front.
#    This may not be the most "intuitive" presentation though.
# Side effects:
#    Axes drawn in canvas
#
proc ::Plotchart::Draw3DAxes { w xmin  ymin  zmin
                                 xmax  ymax  zmax
                                 xstep ystep zstep
                                 {names {}}        } {
   variable scaling

   $w delete axis3d

   #
   # Create the support lines first
   #
   foreach {pxxmin pyxmin} [coords3DToPixel $w $scaling($w,xmin) $scaling($w,ymin) $scaling($w,zmin)] {break}
   foreach {pxxmax pyxmax} [coords3DToPixel $w $scaling($w,xmax) $scaling($w,ymin) $scaling($w,zmin)] {break}
   foreach {pxymax pyymax} [coords3DToPixel $w $scaling($w,xmax) $scaling($w,ymax) $scaling($w,zmin)] {break}
   foreach {pxzmax pyzmax} [coords3DToPixel $w $scaling($w,xmax) $scaling($w,ymin) $scaling($w,zmax)] {break}
   foreach {pxzmx2 pyzmx2} [coords3DToPixel $w $scaling($w,xmin) $scaling($w,ymin) $scaling($w,zmax)] {break}
   foreach {pxymx2 pyymx2} [coords3DToPixel $w $scaling($w,xmin) $scaling($w,ymax) $scaling($w,zmin)] {break}
   foreach {pxzymx pyzymx} [coords3DToPixel $w $scaling($w,xmax) $scaling($w,ymax) $scaling($w,zmax)] {break}

   $w create line $pxxmax $pyxmax $pxxmin $pyxmin \
                  -fill black -tag axis3d
   $w create line $pxxmax $pyxmax $pxymax $pyymax \
                  -fill black -tag axis3d
   $w create line $pxxmin $pyxmin $pxymx2 $pyymx2 \
                  -fill black -tag axis3d
   $w create line $pxymax $pyymax $pxymx2 $pyymx2 \
                  -fill black -tag axis3d
   $w create line $pxzmax $pyzmax $pxzymx $pyzymx \
                  -fill black -tag axis3d
   $w create line $pxxmax $pyxmax $pxzmax $pyzmax \
                  -fill black -tag axis3d
   $w create line $pxxmin $pyxmin $pxzmx2 $pyzmx2 \
                  -fill black -tag axis3d
   $w create line $pxzmax $pyzmax $pxzmx2 $pyzmx2 \
                  -fill black -tag axis3d
   $w create line $pxymax $pyymax $pxzymx $pyzymx \
                  -fill black -tag axis3d

   #
   # Numbers to the z-axis
   #
   set z $zmin
   while { $z < $zmax+0.5*$zstep } {
      foreach {xcrd ycrd} [coords3DToPixel $w $xmin $ymin $z] {break}
      set xcrd2 [expr {$xcrd-3}]
      set xcrd3 [expr {$xcrd-5}]

      $w create line $xcrd2 $ycrd $xcrd $ycrd -tag axis3d
      $w create text $xcrd3 $ycrd -text $z -tag axis3d -anchor e
      set z [expr {$z+$zstep}]
   }

   #
   # Numbers or labels to the x-axis (shown on the right!)
   #
   if { $names eq "" } {
       set x $xmin
       while { $x < $xmax+0.5*$xstep } {
           foreach {xcrd ycrd} [coords3DToPixel $w $x $ymax $zmin] {break}
           set xcrd2 [expr {$xcrd+4}]
           set xcrd3 [expr {$xcrd+6}]

           $w create line $xcrd2 $ycrd $xcrd $ycrd -tag axis3d
           $w create text $xcrd3 $ycrd -text $x -tag axis3d -anchor w
           set x [expr {$x+$xstep}]
       }
   } else {
       set x [expr {$xmin+0.5*$xstep}]
       foreach label $names {
           foreach {xcrd ycrd} [coords3DToPixel $w $x $ymax $zmin] {break}
           set xcrd2 [expr {$xcrd+6}]

           $w create text $xcrd2 $ycrd -text $label -tag axis3d -anchor w
           set x [expr {$x+$xstep}]
       }
   }

   #
   # Numbers to the y-axis (shown in front!)
   #
   set y $ymin
   while { $y < $ymax+0.5*$ystep } {
      foreach {xcrd ycrd} [coords3DToPixel $w $xmin $y $zmin] {break}
      set ycrd2 [expr {$ycrd+3}]
      set ycrd3 [expr {$ycrd+5}]

      $w create line $xcrd $ycrd2 $xcrd $ycrd -tag axis3d
      $w create text $xcrd $ycrd3 -text $y -tag axis3d -anchor n
      set y [expr {$y+$ystep}]
   }

   set scaling($w,xstep) $xstep
   set scaling($w,ystep) $ystep
   set scaling($w,zstep) $zstep

   #
   # Set the default grid size
   #
   GridSize3D $w 10 10
}

# GridSize3D --
#    Set the grid size for a 3D function plot
# Arguments:
#    w           Name of the canvas
#    nxcells     Number of cells in x-direction
#    nycells     Number of cells in y-direction
# Result:
#    None
# Side effect:
#    Store the grid sizes in the private array
#
proc ::Plotchart::GridSize3D { w nxcells nycells } {
   variable scaling

   set scaling($w,nxcells) $nxcells
   set scaling($w,nycells) $nycells
}

# Draw3DFunction --
#    Plot a function of x and y
# Arguments:
#    w           Name of the canvas
#    function    Name of a procedure implementing the function
# Result:
#    None
# Side effect:
#    The plot of the function - given the grid
#
proc ::Plotchart::Draw3DFunction { w function } {
   variable scaling

   set nxcells $scaling($w,nxcells)
   set nycells $scaling($w,nycells)
   set xmin    $scaling($w,xmin)
   set xmax    $scaling($w,xmax)
   set ymin    $scaling($w,ymin)
   set ymax    $scaling($w,ymax)
   set dx      [expr {($xmax-$xmin)/double($nxcells)}]
   set dy      [expr {($ymax-$ymin)/double($nycells)}]

   foreach {fill border} $scaling($w,colours) {break}

   #
   # Draw the quadrangles making up the plot in the right order:
   # first y from minimum to maximum
   # then x from maximum to minimum
   #
   for { set j 0 } { $j < $nycells } { incr j } {
      set y1 [expr {$ymin + $dy*$j}]
      set y2 [expr {$y1   + $dy}]
      for { set i $nxcells } { $i > 0 } { incr i -1 } {
         set x2 [expr {$xmin + $dx*$i}]
         set x1 [expr {$x2   - $dx}]

         set z11 [$function $x1 $y1]
         set z12 [$function $x1 $y2]
         set z21 [$function $x2 $y1]
         set z22 [$function $x2 $y2]

         foreach {px11 py11} [coords3DToPixel $w $x1 $y1 $z11] {break}
         foreach {px12 py12} [coords3DToPixel $w $x1 $y2 $z12] {break}
         foreach {px21 py21} [coords3DToPixel $w $x2 $y1 $z21] {break}
         foreach {px22 py22} [coords3DToPixel $w $x2 $y2 $z22] {break}

         $w create polygon $px11 $py11 $px21 $py21 $px22 $py22 \
                           $px12 $py12 $px11 $py11 \
                           -fill $fill -outline $border
      }
   }
}

# Draw3DData --
#    Plot a matrix of data as a function of x and y
# Arguments:
#    w           Name of the canvas
#    data        Nested list of data in the form of a matrix
# Result:
#    None
# Side effect:
#    The plot of the data
#
proc ::Plotchart::Draw3DData { w data } {
   variable scaling

   set  nxcells [llength [lindex $data 0]]
   set  nycells [llength $data]
   incr nxcells -1
   incr nycells -1

   set xmin    $scaling($w,xmin)
   set xmax    $scaling($w,xmax)
   set ymin    $scaling($w,ymin)
   set ymax    $scaling($w,ymax)
   set dx      [expr {($xmax-$xmin)/double($nxcells)}]
   set dy      [expr {($ymax-$ymin)/double($nycells)}]

   foreach {fill border} $scaling($w,colours) {break}

   #
   # Draw the quadrangles making up the data in the right order:
   # first y from minimum to maximum
   # then x from maximum to minimum
   #
   for { set j 0 } { $j < $nycells } { incr j } {
      set z1data [lindex $data $j]
      set z2data [lindex $data [expr {$j+1}]]
      set y1 [expr {$ymin + $dy*$j}]
      set y2 [expr {$y1   + $dy}]
      for { set i $nxcells } { $i > 0 } { incr i -1 } {
         set x2 [expr {$xmin + $dx*$i}]
         set x1 [expr {$x2   - $dx}]

         set z11 [lindex $z1data [expr {$i-1}]]
         set z21 [lindex $z1data $i           ]
         set z12 [lindex $z2data [expr {$i-1}]]
         set z22 [lindex $z2data $i           ]

         foreach {px11 py11} [coords3DToPixel $w $x1 $y1 $z11] {break}
         foreach {px12 py12} [coords3DToPixel $w $x1 $y2 $z12] {break}
         foreach {px21 py21} [coords3DToPixel $w $x2 $y1 $z21] {break}
         foreach {px22 py22} [coords3DToPixel $w $x2 $y2 $z22] {break}

         $w create polygon $px11 $py11 $px21 $py21 $px22 $py22 \
                           $px12 $py12 $px11 $py11 \
                           -fill $fill -outline $border
      }
   }
}

# Draw3DLineFrom3Dcoordinates --
#    Plot a line in the three-dimensional axis system
# Arguments:
#    w           Name of the canvas
#    data        List of xyz-coordinates
#    colour      The colour to use
# Result:
#    None
# Side effect:
#    The projected line
#
proc ::Plotchart::Draw3DLineFrom3Dcoordinates { w data colour } {
   variable scaling

   set xmin    $scaling($w,xmin)
   set xmax    $scaling($w,xmax)
   set xprev   {}

   set coords  {}
   set colours {}
   foreach {x y z} $data {
       foreach {px py} [coords3DToPixel $w $x $y $z] {break}

       lappend coords $px $py

       if { $xprev == {} } {
           set xprev $x
       }
       set factor [expr {0.5*(2.0*$xmax-$xprev-$x)/($xmax-$xmin)}]

       lappend colours [GreyColour $colour $factor]
       set xprev $x
   }

   foreach {xb yb} [lrange $coords 0 end-2] {xe ye} [lrange $coords 2 end] c [lrange $colours 0 end-1] {
       $w create line $xb $yb $xe $ye -fill $c
   }
}

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
























































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/plotchart/plotannot.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
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
# plotannot.tcl --
#    Facilities for annotating charts
#
# Note:
#    This source file contains such functions as to draw a
#    balloon text in an xy-graph.
#    It is the companion of "plotchart.tcl"
#

#
# Static data
#
namespace eval ::Plotchart {
    # Index, three pairs of scale factors to determine xy-coordinates
    set BalloonDir(north-west) {0  0  1 -2 -2  1  0}
    set BalloonDir(north)      {1 -1  0  0 -3  1  0}
    set BalloonDir(north-east) {2 -1  0  2 -2  0  1}
    set BalloonDir(east)       {3  0 -1  3  0  0  1}
    set BalloonDir(south-east) {4  0 -1  2  2 -1  0}
    set BalloonDir(south)      {5  1  0  0  3 -1  0}
    set BalloonDir(south-west) {6  1  0 -2  2  0 -1}
    set BalloonDir(west)       {7  0  1 -3  0  0 -1}

    set TextDir(centre)     c
    set TextDir(center)     c
    set TextDir(c)          c
    set TextDir(north-west) nw
    set TextDir(nw)         nw
    set TextDir(north)      n
    set TextDir(n)          n
    set TextDir(north-east) ew
    set TextDir(ne)         ew
    set TextDir(east)       e
    set TextDir(e)          e
    set TextDir(south-west) nw
    set TextDir(sw)         sw
    set TextDir(south)      s
    set TextDir(s)          s
    set TextDir(south-east) ew
    set TextDir(east)       e
}

# DefaultBalloon --
#    Set the default properties of balloon text and other types of annotation
# Arguments:
#    w           Name of the canvas
# Result:
#    None
# Side effects:
#    Stores the default settings
#
proc ::Plotchart::DefaultBalloon { w } {
    variable settings

    foreach {option value} {font       fixed
                            margin     5
                            textcolour black
                            justify    left
                            arrowsize  5
                            background white
                            outline    black
                            rimwidth   1} {
        set settings($w,balloon$option) $value
    }
    foreach {option value} {font       fixed
                            colour     black
                            justify    left} {
        set settings($w,text$option) $value
    }
}

# ConfigBalloon --
#    Configure the properties of balloon text
# Arguments:
#    w           Name of the canvas
#    args        List of arguments
# Result:
#    None
# Side effects:
#    Stores the new settings for the next balloon text
#
proc ::Plotchart::ConfigBalloon { w args } {
    variable settings

    foreach {option value} $args {
        set option [string range $option 1 end]
        switch -- $option {
            "font" -
            "margin" -
            "textcolour" -
            "justify" -
            "arrowsize" -
            "background" -
            "outline" -
            "rimwidth" {
                set settings($w,balloon$option) $value
            }
            "textcolor" {
                set settings($w,balloontextcolour) $value
            }
        }
    }
}

# DrawBalloon --
#    Plot a balloon text in a chart
# Arguments:
#    w           Name of the canvas
#    x           X-coordinate of the point the arrow points to
#    y           Y-coordinate of the point the arrow points to
#    text        Text in the balloon
#    dir         Direction of the arrow (north, north-east, ...)
# Result:
#    None
# Side effects:
#    Text and polygon drawn in the chart
#
proc ::Plotchart::DrawBalloon { w x y text dir } {
    variable settings
    variable BalloonDir

    #
    # Create the item and then determine the coordinates
    # of the frame around the text
    #
    set item [$w create text 0 0 -text $text -tag BalloonText \
                 -font $settings($w,balloonfont) -fill $settings($w,balloontextcolour) \
                 -justify $settings($w,balloonjustify)]

    if { ![info exists BalloonDir($dir)] } {
        set dir south-east
    }

    foreach {xmin ymin xmax ymax} [$w bbox $item] {break}

    set xmin   [expr {$xmin-$settings($w,balloonmargin)}]
    set xmax   [expr {$xmax+$settings($w,balloonmargin)}]
    set ymin   [expr {$ymin-$settings($w,balloonmargin)}]
    set ymax   [expr {$ymax+$settings($w,balloonmargin)}]

    set xcentr [expr {($xmin+$xmax)/2}]
    set ycentr [expr {($ymin+$ymax)/2}]
    set coords [list $xmin   $ymin   \
                     $xcentr $ymin   \
                     $xmax   $ymin   \
                     $xmax   $ycentr \
                     $xmax   $ymax   \
                     $xcentr $ymax   \
                     $xmin   $ymax   \
                     $xmin   $ycentr ]

    set idx    [lindex $BalloonDir($dir) 0]
    set scales [lrange $BalloonDir($dir) 1 end]

    set factor $settings($w,balloonarrowsize)
    set extraCoords {}

    set xbase  [lindex $coords [expr {2*$idx}]]
    set ybase  [lindex $coords [expr {2*$idx+1}]]

    foreach {xscale yscale} $scales {
        set xnew [expr {$xbase+$xscale*$factor}]
        set ynew [expr {$ybase+$yscale*$factor}]
        lappend extraCoords $xnew $ynew
    }

    #
    # Insert the extra coordinates
    #
    set coords [eval lreplace [list $coords] [expr {2*$idx}] [expr {2*$idx+1}] \
                          $extraCoords]

    set xpoint [lindex $coords [expr {2*$idx+2}]]
    set ypoint [lindex $coords [expr {2*$idx+3}]]

    set poly [$w create polygon $coords -tag BalloonFrame \
                  -fill $settings($w,balloonbackground) \
                  -width $settings($w,balloonrimwidth)  \
                  -outline $settings($w,balloonoutline)]

    #
    # Position the two items
    #
    foreach {xtarget ytarget} [coordsToPixel $w $x $y] {break}
    set dx [expr {$xtarget-$xpoint}]
    set dy [expr {$ytarget-$ypoint}]
    $w move $item  $dx $dy
    $w move $poly  $dx $dy
    $w raise BalloonFrame
    $w raise BalloonText
}

# DrawPlainText --
#    Plot plain text in a chart
# Arguments:
#    w           Name of the canvas
#    x           X-coordinate of the point the arrow points to
#    y           Y-coordinate of the point the arrow points to
#    text        Text to be drawn
#    anchor      Anchor position (north, north-east, ..., defaults to centre)
# Result:
#    None
# Side effects:
#    Text drawn in the chart
#
proc ::Plotchart::DrawPlainText { w x y text {anchor centre} } {
    variable settings
    variable TextDir

    foreach {xtext ytext} [coordsToPixel $w $x $y] {break}

    if { [info exists TextDir($anchor)] } {
        set anchor $TextDir($anchor)
    } else {
        set anchor c
    }

    $w create text $xtext $ytext -text $text -tag PlainText \
         -font $settings($w,textfont) -fill $settings($w,textcolour) \
         -justify $settings($w,textjustify) -anchor $anchor

    $w raise PlainText
}

# BrightenColour --
#    Compute a brighter colour
# Arguments:
#    color       Original colour
#    factor      Factor by which to brighten the colour
# Result:
#    New colour
# Note:
#    Adapted from R. Suchenwirths Wiki page on 3D bars
#
proc ::Plotchart::BrightenColour {color factor} {
   foreach i {r g b} n [winfo rgb . $color] d [winfo rgb . white] {
       set $i [expr {int(255.*($n+($d-$n)*$factor)/$d)}]
   }
   format #%02x%02x%02x $r $g $b
}

# DrawGradientBackground --
#    Add a gradient background to the plot
# Arguments:
#    w           Name of the canvas
#    colour      Main colour
#    dir         Direction of the gradient (left-right, top-down,
#                bottom-up, right-left)
#    rect        (Optional) coordinates of the rectangle to be filled
# Result:
#    None
# Side effects:
#    Gradient background drawn in the chart
#
proc ::Plotchart::DrawGradientBackground { w colour dir {rect {}} } {
    variable scaling

    set pxmin $scaling($w,pxmin)
    set pxmax $scaling($w,pxmax)
    set pymin $scaling($w,pymin)
    set pymax $scaling($w,pymax)

    if { $rect != {} } {
        foreach {rxmin rymin rxmax rymax} $rect {break}
    } else {
        set rxmin $pxmin
        set rxmax $pxmax
        set rymin $pymin
        set rymax $pymax
    }

    switch -- $dir {
        "left-right" {
            set dir   h
            set first 0.0
            set last  1.0
            set fac   [expr {($pxmax-$pxmin)/50.0}]
        }
        "right-left" {
            set dir   h
            set first 1.0
            set last  0.0
            set fac   [expr {($pxmax-$pxmin)/50.0}]
        }
        "top-down" {
            set dir   v
            set first 0.0
            set last  1.0
            set fac   [expr {($pymin-$pymax)/50.0}]
        }
        "bottom-up" {
            set dir   v
            set first 1.0
            set last  0.0
            set fac   [expr {($pymin-$pymax)/50.0}]
        }
        default {
            set dir   v
            set first 0.0
            set last  1.0
            set fac   [expr {($pymin-$pymax)/50.0}]
        }
    }

    if { $dir == "h" } {
        set x2 $rxmin
        set y1 $rymin
        set y2 $rymax
    } else {
        set y2 $rymax
        set x1 $rxmin
        set x2 $rxmax
    }

    set n 50
    if { $dir == "h" } {
        set nmax [expr {ceil($n*($rxmax-$rxmin)/double($pxmax-$pxmin))}]
    } else {
        set nmax [expr {ceil($n*($rymin-$rymax)/double($pymin-$pymax))}]
    }
    for { set i 0 } { $i < $nmax } { incr i } {
        set factor [expr {($first*$i+$last*($n-$i-1))/double($n)}]
        set gcolour [BrightenColour $colour $factor]

        if { $dir == "h" } {
            set x1     $x2
            set x2     [expr {$rxmin+($i+1)*$fac}]
            if { $i == $nmax-1 } {
                set x2 $rxmax
            }
        } else {
            set y1     $y2
            set y2     [expr {$rymax+($i+1)*$fac}]
            if { $i == $nmax-1 } {
                set y2 $rymin
            }
        }

        $w create rectangle $x1 $y1 $x2 $y2 -fill $gcolour -outline $gcolour -tag {data background}
    }

    $w lower data
    $w lower background
}

# DrawImageBackground --
#    Add an image (tilde) to the background to the plot
# Arguments:
#    w           Name of the canvas
#    colour      Main colour
#    image       Name of the image
# Result:
#    None
# Side effects:
#    Image appears in the plot area, tiled if needed
#
proc ::Plotchart::DrawImageBackground { w image } {
    variable scaling

    set pxmin $scaling($w,pxmin)
    set pxmax $scaling($w,pxmax)
    set pymin $scaling($w,pymin)
    set pymax $scaling($w,pymax)

    set iwidth  [image width $image]
    set iheight [image height $image]

    for { set y $pymax } { $y > $pymin } { set y [expr {$y-$iheight}] } {
        for { set x $pxmin } { $x < $pxmax } { incr x $iwidth } {
            $w create image $x $y -image $image -anchor sw -tags {data background}
        }
    }

    $w lower data
    $w lower background
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/plotchart/plotaxis.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
# plotaxis.tcl --
#    Facilities to draw simple plots in a dedicated canvas
#
# Note:
#    This source file contains the functions for drawing the axes
#    and the legend. It is the companion of "plotchart.tcl"
#

# DrawYaxis --
#    Draw the y-axis
# Arguments:
#    w           Name of the canvas
#    ymin        Minimum y coordinate
#    ymax        Maximum y coordinate
#    ystep       Step size
# Result:
#    None
# Side effects:
#    Axis drawn in canvas
#
proc ::Plotchart::DrawYaxis { w ymin ymax ydelt } {
    variable scaling
    variable config

    set scaling($w,ydelt) $ydelt

    $w delete yaxis

    set linecolor  $config($w,leftaxis,color)
    set textcolor  $config($w,leftaxis,textcolor)
    set textfont   $config($w,leftaxis,font)
    set ticklength $config($w,leftaxis,ticklength)
    set thickness  $config($w,leftaxis,thickness)
    set offtick    [expr {($ticklength > 0)? $ticklength+2 : 2}]

    $w create line $scaling($w,pxmin) $scaling($w,pymin) \
                   $scaling($w,pxmin) $scaling($w,pymax) \
                   -fill $linecolor -tag yaxis -width $thickness

    set format $config($w,leftaxis,format)
    if { [info exists scaling($w,-format,y)] } {
        set format $scaling($w,-format,y)
    }

    if { $ymax > $ymin } {
        set y [expr {$ymin+0.0}]  ;# Make sure we have the number in the right format
        set ym $ymax
    } else {
        set y [expr {$ymax+0.0}]
        set ym $ymin
    }
    set yt [expr {$ymin+0.0}]

    set scaling($w,yaxis) {}

    while { $y < $ym+0.5*abs($ydelt) } {

        foreach {xcrd ycrd} [coordsToPixel $w $scaling($w,xmin) $yt] {break}
        set xcrd2 [expr {$xcrd-$ticklength}]
        set xcrd3 [expr {$xcrd-$offtick}]

        lappend scaling($w,yaxis) $ycrd

        set ylabel $yt
        if { $format != "" } {
            set ylabel [format $format $y]
        }
        $w create line $xcrd2 $ycrd $xcrd $ycrd -tag yaxis -fill $linecolor
        $w create text $xcrd3 $ycrd -text $ylabel -tag yaxis -anchor e \
            -fill $textcolor -font $textfont
        set y  [expr {$y+abs($ydelt)}]
        set yt [expr {$yt+$ydelt}]
        if { abs($yt) < 0.5*abs($ydelt) } {
            set yt 0.0
        }
    }
}

# DrawRightaxis --
#    Draw the y-axis on the right-hand side
# Arguments:
#    w           Name of the canvas
#    ymin        Minimum y coordinate
#    ymax        Maximum y coordinate
#    ystep       Step size
# Result:
#    None
# Side effects:
#    Axis drawn in canvas
#
proc ::Plotchart::DrawRightaxis { w ymin ymax ydelt } {
    variable scaling
    variable config

    set scaling($w,ydelt) $ydelt

    $w delete raxis

    set linecolor  $config($w,rightaxis,color)
    set textcolor  $config($w,rightaxis,textcolor)
    set textfont   $config($w,rightaxis,font)
    set thickness  $config($w,rightaxis,thickness)
    set ticklength $config($w,rightaxis,ticklength)
    set offtick    [expr {($ticklength > 0)? $ticklength+2 : 2}]

    $w create line $scaling($w,pxmax) $scaling($w,pymin) \
                   $scaling($w,pxmax) $scaling($w,pymax) \
                   -fill $linecolor -tag raxis -width $thickness

    set format $config($w,rightaxis,format)
    if { [info exists scaling($w,-format,y)] } {
        set format $scaling($w,-format,y)
    }

    if { $ymax > $ymin } {
        set y [expr {$ymin+0.0}]  ;# Make sure we have the number in the right format
        set ym $ymax
    } else {
        set y [expr {$ymax+0.0}]
        set ym $ymin
    }
    set yt [expr {$ymin+0.0}]

    set scaling($w,yaxis) {}

    while { $y < $ym+0.5*abs($ydelt) } {

        foreach {xcrd ycrd} [coordsToPixel $w $scaling($w,xmax) $yt] {break}
        set xcrd2 [expr {$xcrd+$ticklength}]
        set xcrd3 [expr {$xcrd+$offtick}]

        lappend scaling($w,yaxis) $ycrd

        set ylabel $yt
        if { $format != "" } {
            set ylabel [format $format $yt]
        }
        $w create line $xcrd2 $ycrd $xcrd $ycrd -tag raxis -fill $linecolor
        $w create text $xcrd3 $ycrd -text $ylabel -tag raxis -anchor w \
            -fill $textcolor -font $textfont
        set y  [expr {$y+abs($ydelt)}]
        set yt [expr {$yt+$ydelt}]
        if { abs($yt) < 0.5*abs($ydelt) } {
            set yt 0.0
        }
    }
}

# DrawLogYaxis --
#    Draw the logarithmic y-axis
# Arguments:
#    w           Name of the canvas
#    ymin        Minimum y coordinate
#    ymax        Maximum y coordinate
#    ystep       Step size
# Result:
#    None
# Side effects:
#    Axis drawn in canvas
#
proc ::Plotchart::DrawLogYaxis { w ymin ymax ydelt } {
    variable scaling
    variable config

    set scaling($w,ydelt) $ydelt

    $w delete yaxis

    set linecolor  $config($w,leftaxis,color)
    set textcolor  $config($w,leftaxis,textcolor)
    set textfont   $config($w,leftaxis,font)
    set thickness  $config($w,leftaxis,thickness)
    set ticklength $config($w,leftaxis,ticklength)
    set offtick    [expr {($ticklength > 0)? $ticklength+2 : 2}]

    $w create line $scaling($w,pxmin) $scaling($w,pymin) \
                   $scaling($w,pxmin) $scaling($w,pymax) \
                   -fill $linecolor -tag yaxis -width $thickness

    set format $config($w,bottomaxis,format)
    set format $config($w,leftaxis,format)
    if { [info exists scaling($w,-format,y)] } {
        set format $scaling($w,-format,y)
    }

    set scaling($w,yaxis) {}

    set y       [expr {pow(10.0,floor(log10($ymin)))}]
    set ylogmax [expr {pow(10.0,ceil(log10($ymax)))+0.1}]

    while { $y < $ylogmax } {

        #
        # Labels and tickmarks
        #
        foreach factor {1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0} {
            set yt [expr {$y*$factor}]
            if { $yt < $ymin } continue
            if { $yt > $ymax } break

            foreach {xcrd ycrd} [coordsToPixel $w $scaling($w,xmin) [expr {log10($yt)}]] {break}
            set xcrd2 [expr {$xcrd-$ticklength}]
            set xcrd3 [expr {$xcrd-$offtick}]

            lappend scaling($w,yaxis) $ycrd

            set ylabel $y
            if { $format != "" } {
                set ylabel [format $format $y]
            }
            $w create line $xcrd2 $ycrd $xcrd $ycrd -tag yaxis -fill $linecolor
            if { $factor == 1.0 } {
                $w create text $xcrd3 $ycrd -text $ylabel -tag yaxis -anchor e \
                    -fill $textcolor -font $textfont
            }
        }
        set y [expr {10.0*$y}]
    }
}

# DrawXaxis --
#    Draw the x-axis
# Arguments:
#    w           Name of the canvas
#    xmin        Minimum x coordinate
#    xmax        Maximum x coordinate
#    xstep       Step size
# Result:
#    None
# Side effects:
#    Axis drawn in canvas
#
proc ::Plotchart::DrawXaxis { w xmin xmax xdelt } {
    variable scaling
    variable config

    set scaling($w,xdelt) $xdelt

    $w delete xaxis

    set linecolor  $config($w,bottomaxis,color)
    set textcolor  $config($w,bottomaxis,textcolor)
    set textfont   $config($w,bottomaxis,font)
    set thickness  $config($w,bottomaxis,thickness)
    set ticklength $config($w,bottomaxis,ticklength)
    set offtick    [expr {($ticklength > 0)? $ticklength+2 : 2}]

    $w create line $scaling($w,pxmin) $scaling($w,pymax) \
                   $scaling($w,pxmax) $scaling($w,pymax) \
                   -fill black -tag xaxis

    set format $config($w,bottomaxis,format)
    if { [info exists scaling($w,-format,x)] } {
        set format $scaling($w,-format,x)
    }

    if { $xmax > $xmin } {
        set x [expr {$xmin+0.0}]  ;# Make sure we have the number in the right format
        set xm $xmax
    } else {
        set x [expr {$xmax+0.0}]
        set xm $xmin
    }
    set xt [expr {$xmin+0.0}]
    set scaling($w,xaxis) {}

    while { $x < $xm+0.5*abs($xdelt) } {

        foreach {xcrd ycrd} [coordsToPixel $w $xt $scaling($w,ymin)] {break}
        set ycrd2 [expr {$ycrd+$ticklength}]
        set ycrd3 [expr {$ycrd+$offtick}]

        lappend scaling($w,xaxis) $xcrd

        set xlabel $xt
        if { $format != "" } {
            set xlabel [format $format $xt]
        }

        $w create line $xcrd $ycrd2 $xcrd $ycrd -tag xaxis -fill $linecolor
        $w create text $xcrd $ycrd3 -text $xlabel -tag xaxis -anchor n \
            -fill $textcolor -font $textfont
        set x  [expr {$x+abs($xdelt)}]
        set xt [expr {$xt+$xdelt}]
        if { abs($x) < 0.5*abs($xdelt) } {
            set xt 0.0
        }
    }

    set scaling($w,xdelt) $xdelt
}

# DrawXtext --
#    Draw text to the x-axis
# Arguments:
#    w           Name of the canvas
#    text        Text to be drawn
# Result:
#    None
# Side effects:
#    Text drawn in canvas
#
proc ::Plotchart::DrawXtext { w text } {
    variable scaling
    variable config

    set textcolor  $config($w,bottomaxis,textcolor)
    set textfont   $config($w,bottomaxis,font)

    set xt [expr {($scaling($w,pxmin)+$scaling($w,pxmax))/2}]
    set yt [expr {$scaling($w,pymax)+18}]

    $w create text $xt $yt -text $text -fill $textcolor -anchor n -font $textfont
}

# DrawYtext --
#    Draw text to the y-axis
# Arguments:
#    w           Name of the canvas
#    text        Text to be drawn
# Result:
#    None
# Side effects:
#    Text drawn in canvas
#
proc ::Plotchart::DrawYtext { w text } {
    variable scaling
    variable config


    if { [string match "r*" $w] == 0 } {
        set textcolor  $config($w,leftaxis,textcolor)
        set textfont   $config($w,leftaxis,font)
        set xt         $scaling($w,pxmin)
        set anchor     se
    } else {
        set textcolor  $config($w,rightaxis,textcolor)
        set textfont   $config($w,rightaxis,font)
        set xt $scaling($w,pxmax)
        set anchor     sw
    }
    set yt [expr {$scaling($w,pymin)-8}]

    $w create text $xt $yt -text $text -fill $textcolor -anchor $anchor -font $textfont
}

# DrawPolarAxes --
#    Draw thw two polar axes
# Arguments:
#    w           Name of the canvas
#    rad_max     Maximum radius
#    rad_step    Step in radius
# Result:
#    None
# Side effects:
#    Axes drawn in canvas
#
proc ::Plotchart::DrawPolarAxes { w rad_max rad_step } {
    variable config

    set linecolor  $config($w,axis,color)
    set textcolor  $config($w,axis,textcolor)
    set textfont   $config($w,axis,font)
    set thickness  $config($w,axis,thickness)
    set bgcolor    $config($w,background,innercolor)

    #
    # Draw the spikes
    #
    set angle 0.0

    foreach {xcentre ycentre} [polarToPixel $w 0.0 0.0] {break}

    while { $angle < 360.0 } {
        foreach {xcrd ycrd} [polarToPixel $w $rad_max $angle] {break}
        foreach {xtxt ytxt} [polarToPixel $w [expr {1.05*$rad_max}] $angle] {break}
        $w create line $xcentre $ycentre $xcrd $ycrd -fill $linecolor -width $thickness
        if { $xcrd > $xcentre } {
            set dir w
        } else {
            set dir e
        }
        $w create text $xtxt $ytxt -text $angle -anchor $dir -fill $textcolor -font $textfont

        set angle [expr {$angle+30}]
    }

    #
    # Draw the concentric circles
    #
    set rad $rad_step

    while { $rad < $rad_max+0.5*$rad_step } {
        foreach {xright ytxt}    [polarToPixel $w $rad    0.0] {break}
        foreach {xleft  ycrd}    [polarToPixel $w $rad  180.0] {break}
        foreach {xcrd   ytop}    [polarToPixel $w $rad   90.0] {break}
        foreach {xcrd   ybottom} [polarToPixel $w $rad  270.0] {break}

        set oval [$w create oval $xleft $ytop $xright $ybottom -outline $linecolor -width $thickness -fill {}]
        $w lower $oval

        $w create text $xright [expr {$ytxt+3}] -text $rad -anchor n -fill $textcolor -font $textfont

        set rad [expr {$rad+$rad_step}]
    }
}

# DrawXlabels --
#    Draw the labels to an x-axis (barchart)
# Arguments:
#    w           Name of the canvas
#    xlabels     List of labels
#    noseries    Number of series or "stacked"
# Result:
#    None
# Side effects:
#    Axis drawn in canvas
#
proc ::Plotchart::DrawXlabels { w xlabels noseries } {
    variable scaling
    variable config

    set linecolor  $config($w,bottomaxis,color)
    set textcolor  $config($w,bottomaxis,textcolor)
    set textfont   $config($w,bottomaxis,font)
    set thickness  $config($w,bottomaxis,thickness)

    $w delete xaxis

    $w create line $scaling($w,pxmin) $scaling($w,pymax) \
                   $scaling($w,pxmax) $scaling($w,pymax) \
                   -fill $linecolor -width $thickness -tag xaxis

    set x 0.5
    set scaling($w,ybase) {}
    foreach label $xlabels {
        foreach {xcrd ycrd} [coordsToPixel $w $x $scaling($w,ymin)] {break}
        set ycrd [expr {$ycrd+2}]
        $w create text $xcrd $ycrd -text $label -tag xaxis -anchor n \
            -fill $textcolor -font $textfont
        set x [expr {$x+1.0}]

        lappend scaling($w,ybase) 0.0
    }

    set scaling($w,xbase) 0.0

    if { $noseries != "stacked" } {
        set scaling($w,stacked)  0
        set scaling($w,xshift)   [expr {1.0/$noseries}]
        set scaling($w,barwidth) [expr {1.0/$noseries}]
    } else {
        set scaling($w,stacked)  1
        set scaling($w,xshift)   0.0
        set scaling($w,barwidth) 0.8
        set scaling($w,xbase)    0.1
    }
}

# DrawYlabels --
#    Draw the labels to a y-axis (barchart)
# Arguments:
#    w           Name of the canvas
#    ylabels     List of labels
#    noseries    Number of series or "stacked"
# Result:
#    None
# Side effects:
#    Axis drawn in canvas
#
proc ::Plotchart::DrawYlabels { w ylabels noseries } {
    variable scaling
    variable config

    set linecolor  $config($w,leftaxis,color)
    set textcolor  $config($w,leftaxis,textcolor)
    set textfont   $config($w,leftaxis,font)
    set thickness  $config($w,leftaxis,thickness)

    $w delete yaxis

    $w create line $scaling($w,pxmin) $scaling($w,pymin) \
                   $scaling($w,pxmin) $scaling($w,pymax) \
                   -fill $linecolor -width $thickness -tag yaxis

    set y 0.5
    set scaling($w,xbase) {}
    foreach label $ylabels {
        foreach {xcrd ycrd} [coordsToPixel $w $scaling($w,xmin) $y] {break}
        set xcrd [expr {$xcrd-2}]
        $w create text $xcrd $ycrd -text $label -tag yaxis -anchor e \
            -fill $textcolor -font $textfont
        set y [expr {$y+1.0}]

        lappend scaling($w,xbase) 0.0
    }

    set scaling($w,ybase) 0.0

    if { $noseries != "stacked" } {
        set scaling($w,stacked)  0
        set scaling($w,yshift)   [expr {1.0/$noseries}]
        set scaling($w,barwidth) [expr {1.0/$noseries}]
    } else {
        set scaling($w,stacked)  1
        set scaling($w,yshift)   0.0
        set scaling($w,barwidth) 0.8
        set scaling($w,ybase)    0.1
    }
}

# XConfig --
#    Configure the x-axis for an XY plot
# Arguments:
#    w           Name of the canvas
#    args        Option and value pairs
# Result:
#    None
#
proc ::Plotchart::XConfig { w args } {
    AxisConfig xyplot $w x DrawXaxis $args
}

# YConfig --
#    Configure the y-axis for an XY plot
# Arguments:
#    w           Name of the canvas
#    args        Option and value pairs
# Result:
#    None
#
proc ::Plotchart::YConfig { w args } {
    AxisConfig xyplot $w y DrawYaxis $args
}

# AxisConfig --
#    Configure an axis and redraw it if necessary
# Arguments:
#    plottype       Type of plot
#    w              Name of the canvas
#    orient         Orientation of the axis
#    drawmethod     Drawing method
#    option_values  Option/value pairs
# Result:
#    None
#
proc ::Plotchart::AxisConfig { plottype w orient drawmethod option_values } {
    variable scaling
    variable axis_options
    variable axis_option_clear
    variable axis_option_values

    set clear_data 0

    foreach {option value} $option_values {
        set idx [lsearch $axis_options $option]
        if { $idx < 0 } {
            return -code error "Unknown or invalid option: $option (value: $value)"
        } else {
            set clear_data [lindex  $axis_option_clear  $idx]
            set values     [lindex  $axis_option_values [expr {2*$idx+1}]]
            if { $values != "..." } {
                if { [lsearch $values $value] < 0 } {
                    return -code error "Unknown or invalid value: $value for option $option - $values"
                }
            }
            set scaling($w,$option,$orient) $value
            if { $option == "-scale" } {
                set min  ${orient}min
                set max  ${orient}max
                set delt ${orient}delt
                foreach [list $min $max $delt] $value {break}
                set scaling($w,$min)  [set $min]
                set scaling($w,$max)  [set $max]
                set scaling($w,$delt) [set $delt]
            }
        }
    }

    if { $clear_data }  {
        $w delete data
    }

    if { $orient == "x" } {
        $drawmethod $w $scaling($w,xmin) $scaling($w,xmax) $scaling($w,xdelt)
    }
    if { $orient == "y" } {
        $drawmethod $w $scaling($w,ymin) $scaling($w,ymax) $scaling($w,ydelt)
    }
    if { $orient == "z" } {
        $drawmethod $w $scaling($w,zmin) $scaling($w,zmax) $scaling($w,zdelt)
    }
}

# DrawXTicklines --
#    Draw the ticklines for the x-axis
# Arguments:
#    w           Name of the canvas
#    colour      Colour of the ticklines
# Result:
#    None
#
proc ::Plotchart::DrawXTicklines { w {colour black} } {
    DrawTicklines $w x $colour
}

# DrawYTicklines --
#    Draw the ticklines for the y-axis
# Arguments:
#    w           Name of the canvas
#    colour      Colour of the ticklines
# Result:
#    None
#
proc ::Plotchart::DrawYTicklines { w {colour black} } {
    DrawTicklines $w y $colour
}

# DrawTicklines --
#    Draw the ticklines
# Arguments:
#    w           Name of the canvas
#    axis        Which axis (x or y)
#    colour      Colour of the ticklines
# Result:
#    None
#
proc ::Plotchart::DrawTicklines { w axis {colour black} } {
    variable scaling

    if { $axis == "x" } {
        #
        # Cater for both regular x-axes and time-axes
        #
        if { [info exists scaling($w,xaxis)] } {
            set botaxis xaxis
        } else {
            set botaxis taxis
        }
        if { $colour != {} } {
            foreach x $scaling($w,$botaxis) {
                $w create line $x $scaling($w,pymin) \
                               $x $scaling($w,pymax) \
                               -fill $colour -tag xtickline
            }
        } else {
            $w delete xtickline
        }
    } else {
        if { $colour != {} } {
            foreach y $scaling($w,yaxis) {
                $w create line $scaling($w,pxmin) $y \
                               $scaling($w,pxmax) $y \
                               -fill $colour -tag ytickline
            }
        } else {
            $w delete ytickline
        }
    }
}

# DefaultLegend --
#    Set all legend options to default
# Arguments:
#    w              Name of the canvas
# Result:
#    None
#
proc ::Plotchart::DefaultLegend { w } {
    variable legend
    variable config

    set legend($w,background) $config($w,legend,background)
    set legend($w,border)     $config($w,legend,border)
    set legend($w,canvas)     $w
    set legend($w,position)   $config($w,legend,position)
    set legend($w,series)     ""
    set legend($w,text)       ""
}

# LegendConfigure --
#    Configure the legend
# Arguments:
#    w              Name of the canvas
#    args           Key-value pairs
# Result:
#    None
#
proc ::Plotchart::LegendConfigure { w args } {
    variable legend

    foreach {option value} $args {
        switch -- $option {
            "-background" {
                 set legend($w,background) $value
            }
            "-border" {
                 set legend($w,border) $value
            }
            "-canvas" {
                 set legend($w,canvas) $value
            }
            "-position" {
                 if { [lsearch {top-left top-right bottom-left bottom-right} $value] >= 0 } {
                     set legend($w,position) $value
                 } else {
                     return -code error "Unknown or invalid position: $value"
                 }
            }
            default {
                return -code error "Unknown or invalid option: $option (value: $value)"
            }
        }
    }
}

# DrawLegend --
#    Draw or extend the legend
# Arguments:
#    w              Name of the canvas
#    series         For which series?
#    text           Text to be shown
# Result:
#    None
#
proc ::Plotchart::DrawLegend { w series text } {
    variable legend
    variable scaling
    variable data_series

    if { [string match r* $w] } {
        set w [string range $w 1 end]
    }

    lappend legend($w,series) $series
    lappend legend($w,text)   $text
    set legendw               $legend($w,canvas)

    $legendw delete legend
    $legendw delete legendbg

    set y 0
    foreach series $legend($w,series) text $legend($w,text) {

        set colour "black"
        if { [info exists data_series($w,$series,-colour)] } {
            set colour $data_series($w,$series,-colour)
        }
        set type "line"
        if { [info exists data_series($w,$series,-type)] } {
            set type $data_series($w,$series,-type)
        }
        if { [info exists data_series($w,legendtype)] } {
            set type $data_series($w,legendtype)
        }

        # TODO: line or rectangle!

        if { $type != "rectangle" } {
            $legendw create line 0 $y 15 $y -fill $colour -tag legend

            if { $type == "symbol" || $type == "both" } {
                set symbol "dot"
                if { [info exists data_series($w,$series,-symbol)] } {
                    set symbol $data_series($w,$series,-symbol)
                }
                DrawSymbolPixel $legendw $series 7 $y $symbol $colour [list legend legend_$series]
            }
        } else {
            $legendw create rectangle 0 [expr {$y-3}] 15 [expr {$y+3}] \
                -fill $colour -tag [list legend legend_$series]
        }

        $legendw create text 25 $y -text $text -anchor w -tag [list legend legend_$series]

        incr y 10   ;# TODO: size of font!
    }

    #
    # Now the frame and the background
    #
    foreach {xl yt xr yb} [$legendw bbox legend] {break}

    set xl [expr {$xl-2}]
    set xr [expr {$xr+2}]
    set yt [expr {$yt-2}]
    set yb [expr {$yb+2}]

    $legendw create rectangle $xl $yt $xr $yb -fill $legend($w,background) \
        -outline $legend($w,border) -tag legendbg

    $legendw raise legend

    if { $w == $legendw } {
        switch -- $legend($w,position) {
            "top-left" {
                 set dx [expr { 10+$scaling($w,pxmin)-$xl}]
                 set dy [expr { 10+$scaling($w,pymin)-$yt}]
            }
            "top-right" {
                 set dx [expr {-10+$scaling($w,pxmax)-$xr}]
                 set dy [expr { 10+$scaling($w,pymin)-$yt}]
            }
            "bottom-left" {
                 set dx [expr { 10+$scaling($w,pxmin)-$xl}]
                 set dy [expr {-10+$scaling($w,pymax)-$yb}]
            }
            "bottom-right" {
                 set dx [expr {-10+$scaling($w,pxmax)-$xr}]
                 set dy [expr {-10+$scaling($w,pymax)-$yb}]
            }
        }
    } else {
        set dx 10
        set dy 10
    }

    $legendw move legend   $dx $dy
    $legendw move legendbg $dx $dy
}

# DrawTimeaxis --
#    Draw the date/time-axis
# Arguments:
#    w           Name of the canvas
#    tmin        Minimum date/time
#    tmax        Maximum date/time
#    tstep       Step size in days
# Result:
#    None
# Side effects:
#    Axis drawn in canvas
#
proc ::Plotchart::DrawTimeaxis { w tmin tmax tdelt } {
    variable scaling
    variable config

    set linecolor  $config($w,bottomaxis,color)
    set textcolor  $config($w,bottomaxis,textcolor)
    set textfont   $config($w,bottomaxis,font)
    set thickness  $config($w,bottomaxis,thickness)
    set ticklength $config($w,bottomaxis,ticklength)
    set offtick    [expr {($ticklength > 0)? $ticklength+2 : 2}]


    set scaling($w,tdelt) $tdelt

    $w delete taxis

    $w create line $scaling($w,pxmin) $scaling($w,pymax) \
                   $scaling($w,pxmax) $scaling($w,pymax) \
                   -fill $linecolor -width $thickness -tag taxis

    set format $config($w,bottomaxis,format)
    if { [info exists scaling($w,-format,x)] } {
        set format $scaling($w,-format,x)
    }

    set ttmin  [clock scan $tmin]
    set ttmax  [clock scan $tmax]
    set t      [expr {int($ttmin)}]
    set ttdelt [expr {$tdelt*86400.0}]

    set scaling($w,taxis) {}

    while { $t < $ttmax+0.5*$ttdelt } {

        foreach {xcrd ycrd} [coordsToPixel $w $t $scaling($w,ymin)] {break}
        set ycrd2 [expr {$ycrd+$ticklength}]
        set ycrd3 [expr {$ycrd+$offtick}]

        lappend scaling($w,taxis) $xcrd

        if { $format != "" } {
            set tlabel [clock format $t -format $format]
        } else {
            set tlabel [clock format $t -format "%Y-%m-%d"]
        }
        $w create line $xcrd $ycrd2 $xcrd $ycrd -tag taxis -fill $linecolor
        $w create text $xcrd $ycrd3 -text $tlabel -tag taxis -anchor n \
            -fill $textcolor -font $textfont
        set t [expr {int($t+$ttdelt)}]
    }

    set scaling($w,tdelt) $tdelt
}

# RescalePlot --
#    Partly redraw the XY plot to allow for new axes
# Arguments:
#    w           Name of the canvas
#    xscale      New minimum, maximum and step for x-axis
#    yscale      New minimum, maximum and step for y-axis
# Result:
#    None
# Side effects:
#    Axes redrawn in canvas, data scaled and moved
# Note:
#    Symbols will be scaled as well!
#
proc ::Plotchart::RescalePlot { w xscale yscale } {
    variable scaling

   foreach {xmin xmax xdelt} $xscale {break}
   foreach {ymin ymax ydelt} $yscale {break}

   if { $xdelt == 0.0 || $ydelt == 0.0 } {
      return -code error "Step size can not be zero"
   }

   if { ($xmax-$xmin)*$xdelt < 0.0 } {
      set xdelt [expr {-$xdelt}]
   }
   if { ($ymax-$ymin)*$ydelt < 0.0 } {
      set ydelt [expr {-$ydelt}]
   }

   $w delete xaxis
   $w delete yaxis

   #
   # Zoom in to the new scaling: move and scale the existing data
   #

   foreach {xb  yb}  [coordsToPixel $w  $scaling($w,xmin) $scaling($w,ymin)] {break} ;# Extreme pixels
   foreach {xe  ye}  [coordsToPixel $w  $scaling($w,xmax) $scaling($w,ymax)] {break} ;# Extreme pixels
   foreach {xnb ynb} [coordsToPixel $w  $xmin $ymin] {break} ;# Current pixels of new rectangle
   foreach {xne yne} [coordsToPixel $w  $xmax $ymax] {break}

   set fx [expr {($xe-$xb)/double($xne-$xnb)}]
   set fy [expr {($ye-$yb)/double($yne-$ynb)}]

   $w scale data $xnb $ynb $fx $fy
   $w move  data [expr {$xb-$xnb}] [expr {$yb-$ynb}]

   worldCoordinates $w $xmin  $ymin  $xmax  $ymax

   DrawYaxis        $w $ymin  $ymax  $ydelt
   DrawXaxis        $w $xmin  $xmax  $xdelt
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/plotchart/plotbusiness.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
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
# plotbusiness.tcl --
#    Facilities aimed at business type charts
#
# Note:
#    This source file contains the private functions for various
#    business type charts.
#    It is the companion of "plotchart.tcl"
#

# Config3DBar --
#    Configuration options for the 3D barchart
# Arguments:
#    w           Name of the canvas
#    args        List of arguments
# Result:
#    None
# Side effects:
#    Items that are already visible will be changed to the new look
#
proc ::Plotchart::Config3DBar { w args } {
    variable settings

    foreach {option value} $args {
        set option [string range $option 1 end]
        set settings($w,$option) $value

        switch -- $option {
            "usebackground" {
                if { $value } {
                    $w itemconfigure background -fill grey65 -outline black
                } else {
                    $w itemconfigure background -fill {} -outline {}
                }
            }
            "useticklines" {
                if { $value } {
                    $w itemconfigure ticklines -fill black
                } else {
                    $w itemconfigure ticklines -fill {}
                }
            }
            "showvalues" {
                if { $value } {
                    $w itemconfigure values -fill $settings($w,valuecolour)
                } else {
                    $w itemconfigure values -fill {}
                }
            }
            "valuecolour" - "valuecolor" {
                set settings($w,valuecolour) $value
                set settings($w,valuecolor)  $value
                $w itemconfigure values -fill $settings($w,valuecolour)
            }
            "valuefont" {
                set settings($w,valuefont) $value
                $w itemconfigure labels -font $settings($w,valuefont)
            }
            "labelcolour" - "labelcolor" {
                set settings($w,labelcolour) $value
                set settings($w,labelcolor)  $value
                $w itemconfigure labels -fill $settings($w,labelcolour)
            }
            "labelfont" {
                set settings($w,labelfont) $value
                $w itemconfigure labels -font $settings($w,labelfont)
            }
        }
    }
}

# Draw3DBarchart --
#    Draw the basic elements of the 3D barchart
# Arguments:
#    w           Name of the canvas
#    yscale      Minimum, maximum and step for the y-axis
#    nobars      Number of bars
# Result:
#    None
# Side effects:
#    Default settings are introduced
#
proc ::Plotchart::Draw3DBarchart { w yscale nobars } {
    variable settings
    variable scaling

    #
    # Default settings
    #
    set settings($w,labelfont)     "fixed"
    set settings($w,valuefont)     "fixed"
    set settings($w,labelcolour)   "black"
    set settings($w,valuecolour)   "black"
    set settings($w,usebackground) 0
    set settings($w,useticklines)  0
    set settings($w,showvalues)    1

    #
    # Horizontal positioning parameters
    #
    set scaling($w,xbase)    0.0
    set scaling($w,xshift)   0.2
    set scaling($w,barwidth) 0.6

    #
    # Shift the vertical axis a bit
    #
    $w move yaxis -10 0
    #
    # Draw the platform and the walls
    #
    set x1 $scaling($w,pxmin)
    set x2 $scaling($w,pxmax)
    foreach {dummy y1} [coordsToPixel $w $scaling($w,xmin) 0.0] {break}

    set x1 [expr {$x1-10}]
    set x2 [expr {$x2+10}]
    set y1 [expr {$y1+10}]

    set y2 [expr {$y1-30}]
    set x3 [expr {$x1+30}]
    set y3 [expr {$y1-30}]
    set x4 [expr {$x2-30}]
    set y4 $y1

    $w create polygon $x1 $y1 $x3 $y3 $x2 $y2 $x4 $y4 -fill gray65 -tag platform \
         -outline black

    set xw1 $x1
    foreach {dummy yw1} [coordsToPixel $w 0.0 $scaling($w,ymin)] {break}
    set xw2 $x1
    foreach {dummy yw2} [coordsToPixel $w 0.0 $scaling($w,ymax)] {break}

    set xw3 $x3
    set yw3 [expr {$yw2-30}]
    set xw4 $x3
    set yw4 [expr {$yw1-30}]

    $w create polygon $xw1 $yw1 $xw2 $yw2 $xw3 $yw3 $xw4 $yw4 \
        -outline black -fill gray65 -tag background

    set xw5 $x2
    $w create polygon $xw3 $yw3 $xw5 $yw3 $xw5 $yw4 $xw3 $yw4 \
        -outline black -fill gray65 -tag background

    #
    # Draw the ticlines (NOTE: Something is wrong here!)
    #
#   foreach {ymin ymax ystep} $yscale {break}
#   if { $ymin > $ymax } {
#       foreach {ymax ymin ystep} $yscale {break}
#       set ystep [expr {abs($ystep)}]
#   }
#   set yv $ymin
#   while { $yv < ($ymax-0.5*$ystep) } {
#       foreach {dummy pyv} [coordsToPixel $w $scaling($w,xmin) $yv] {break}
#       set pyv1 [expr {$pyv-5}]
#       set pyv2 [expr {$pyv-35}]
#       $w create line $xw1 $pyv1 $xw3 $pyv2 $xw5 $pyv2 -fill black -tag ticklines
#       set yv [expr {$yv+$ystep}]
#   }

    Config3DBar $w -usebackground 0 -useticklines 0
}

# Draw3DBar --
#    Draw a 3D bar in a barchart
# Arguments:
#    w           Name of the canvas
#    label       Label for the bar
#    yvalue      The height of the bar
#    fill        The colour of the bar
# Result:
#    None
# Side effects:
#    The bar is drawn, the display order is adjusted
#
proc ::Plotchart::Draw3DBar { w label yvalue fill } {
    variable settings
    variable scaling

    set xv1 [expr {$scaling($w,xbase)+$scaling($w,xshift)}]
    set xv2 [expr {$xv1+$scaling($w,barwidth)}]

    foreach {x0 y0} [coordsToPixel $w $xv1 0.0]     {break}
    foreach {x1 y1} [coordsToPixel $w $xv2 $yvalue] {break}

    if { $yvalue < 0.0 } {
        foreach {y0 y1} [list $y1 $y0] {break}
        set tag d
    } else {
        set tag u
    }

    set d [expr {($x1-$x0)/3}]
    set x2 [expr {$x0+$d+1}]
    set x3 [expr {$x1+$d}]
    set y2 [expr {$y0-$d+1}]
    set y3 [expr {$y1-$d-1}]
    set y4 [expr {$y1-$d-1}]
    $w create rect $x0 $y0 $x1 $y1 -fill $fill -tag $tag
    $w create poly $x0 $y1 $x2 $y4 $x3 $y4 $x1 $y1 -fill [DimColour $fill 0.8] -outline black -tag u
    $w create poly $x1 $y1 $x3 $y3 $x3 $y2 $x1 $y0 -fill [DimColour $fill 0.6] -outline black -tag $tag

    #
    # Add the text
    #
    if { $settings($w,showvalues) } {
        $w create text [expr {($x0+$x3)/2}] [expr {$y3-5}] -text $yvalue \
            -font $settings($w,valuefont) -fill $settings($w,valuecolour) \
            -anchor s
    }
    $w create text [expr {($x0+$x3)/2}] [expr {$y0+8}] -text $label \
        -font $settings($w,labelfont) -fill $settings($w,labelcolour) \
        -anchor n

    #
    # Reorder the various bits
    #
    $w lower u
    $w lower platform
    $w lower d
    $w lower ticklines
    $w lower background

    #
    # Move to the next bar
    #
    set scaling($w,xbase) [expr {$scaling($w,xbase)+1.0}]
}

# DimColour --
#    Compute a dimmer colour
# Arguments:
#    color       Original colour
#    factor      Factor by which to reduce the colour
# Result:
#    New colour
# Note:
#    Shamelessly copied from R. Suchenwirths Wiki page on 3D bars
#
proc ::Plotchart::DimColour {color factor} {
   foreach i {r g b} n [winfo rgb . $color] d [winfo rgb . white] {
       set $i [expr int(255.*$n/$d*$factor)]
   }
   format #%02x%02x%02x $r $g $b
}

# GreyColour --
#    Compute a greyer colour
# Arguments:
#    color       Original colour
#    factor      Factor by which to mix in grey
# Result:
#    New colour
# Note:
#    Shamelessly adapted from R. Suchenwirths Wiki page on 3D bars
#
proc ::Plotchart::GreyColour {color factor} {
   foreach i {r g b} n [winfo rgb . $color] d [winfo rgb . white] e [winfo rgb . lightgrey] {
       set $i [expr int(255.*($n*$factor+$e*(1.0-$factor))/$d)]
   }
   format #%02x%02x%02x $r $g $b
}

# Draw3DLine --
#    Plot a ribbon of z-data as a function of y
# Arguments:
#    w           Name of the canvas
#    data        List of coordinate pairs y, z
#    colour      Colour to use
# Result:
#    None
# Side effect:
#    The plot of the data
#
proc ::Plotchart::Draw3DLine { w data colour } {
    variable data_series
    variable scaling

    set bright $colour
    set dim    [DimColour $colour 0.6]

    #
    # Draw the ribbon as a series of quadrangles
    #
    set xe $data_series($w,xbase)
    set xb [expr {$xe-$data_series($w,xwidth)}]

    set data_series($w,xbase) [expr {$xe-$data_series($w,xstep)}]

    foreach {yb zb} [lrange $data 0 end-2] {ye ze} [lrange $data 2 end] {

        foreach {px11 py11} [coords3DToPixel $w $xb $yb $zb] {break}
        foreach {px12 py12} [coords3DToPixel $w $xe $yb $zb] {break}
        foreach {px21 py21} [coords3DToPixel $w $xb $ye $ze] {break}
        foreach {px22 py22} [coords3DToPixel $w $xe $ye $ze] {break}

        #
        # Use the angle of the line to determine if the top or the
        # bottom side is visible
        #
        if { $px21 == $px11 ||
             ($py21-$py11)/($px21-$px11) < ($py12-$py11)/($px12-$px11) } {
            set colour $dim
        } else {
            set colour $bright
        }

        $w create polygon $px11 $py11 $px21 $py21 $px22 $py22 \
                          $px12 $py12 $px11 $py11 \
                          -fill $colour -outline black
    }
}

# Draw3DArea --
#    Plot a ribbon of z-data as a function of y with a "facade"
# Arguments:
#    w           Name of the canvas
#    data        List of coordinate pairs y, z
#    colour      Colour to use
# Result:
#    None
# Side effect:
#    The plot of the data
#
proc ::Plotchart::Draw3DArea { w data colour } {
    variable data_series
    variable scaling

    set bright $colour
    set dimmer [DimColour $colour 0.8]
    set dim    [DimColour $colour 0.6]

    #
    # Draw the ribbon as a series of quadrangles
    #
    set xe $data_series($w,xbase)
    set xb [expr {$xe-$data_series($w,xwidth)}]

    set data_series($w,xbase) [expr {$xe-$data_series($w,xstep)}]

    set facade {}

    foreach {yb zb} [lrange $data 0 end-2] {ye ze} [lrange $data 2 end] {

        foreach {px11 py11} [coords3DToPixel $w $xb $yb $zb] {break}
        foreach {px12 py12} [coords3DToPixel $w $xe $yb $zb] {break}
        foreach {px21 py21} [coords3DToPixel $w $xb $ye $ze] {break}
        foreach {px22 py22} [coords3DToPixel $w $xe $ye $ze] {break}

        $w create polygon $px11 $py11 $px21 $py21 $px22 $py22 \
                          $px12 $py12 $px11 $py11 \
                          -fill $dimmer -outline black

        lappend facade $px11 $py11
    }

    #
    # Add the last point
    #
    lappend facade $px21 $py21

    #
    # Add the polygon at the right
    #
    set zmin $scaling($w,zmin)
    foreach {px2z py2z} [coords3DToPixel $w $xe $ye $zmin] {break}
    foreach {px1z py1z} [coords3DToPixel $w $xb $ye $zmin] {break}

    $w create polygon $px21 $py21 $px22 $py22 \
                      $px2z $py2z $px1z $py1z \
                      -fill $dim -outline black

    foreach {pxb pyb} [coords3DToPixel $w $xb $ye $zmin] {break}

    set yb [lindex $data 0]
    foreach {pxe pye} [coords3DToPixel $w $xb $yb $zmin] {break}

    lappend facade $px21 $py21 $pxb $pyb $pxe $pye

    $w create polygon $facade -fill $colour -outline black
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/plotchart/plotchart.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
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
981
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
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
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
1210
1211
1212
1213
1214
1215
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
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
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
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
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
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
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
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
# plotchart.tcl --
#    Facilities to draw simple plots in a dedicated canvas
#
# Note:
#    This source file contains the public functions.
#    The private functions are contained in the files "sourced"
#    at the end.
#
package require Tcl 8.4
package require Tk

# Plotchart --
#    Namespace to hold the procedures and the private data
#
namespace eval ::Plotchart {
   variable settings
   variable legend
   variable scaling
   variable methodProc
   variable data_series

   namespace export worldCoordinates viewPort coordsToPixel \
                    polarCoordinates setZoomPan \
                    world3DCoordinates coordsToPixel \
                    coords3DToPixel polarToPixel \
                    pixelToCoords pixelToIndex determineScale \
                    createXYPlot createPolarPlot createPiechart \
                    createBarchart createHorizontalBarchart \
                    createTimechart createStripchart \
                    createIsometricPlot create3DPlot \
                    createGanttChart createHistogram colorMap \
                    create3DBars createRadialchart \
                    createTXPlot createRightAxis \
                    create3DRibbonChart \
                    createXLogYPlot \
                    plotconfig plotpack \

   #
   # Array linking procedures with methods
   #
   set methodProc(xyplot,title)             DrawTitle
   set methodProc(xyplot,xtext)             DrawXtext
   set methodProc(xyplot,ytext)             DrawYtext
   set methodProc(xyplot,plot)              DrawData
   set methodProc(xyplot,dot)               DrawDot
   set methodProc(xyplot,dotconfig)         DotConfigure
   set methodProc(xyplot,interval)          DrawInterval
   set methodProc(xyplot,trend)             DrawTrendLine
   set methodProc(xyplot,vector)            DrawVector
   set methodProc(xyplot,vectorconfig)      VectorConfigure
   set methodProc(xyplot,rchart)            DrawRchart
   set methodProc(xyplot,grid)              DrawGrid
   set methodProc(xyplot,contourlines)      DrawIsolines
   set methodProc(xyplot,contourfill)       DrawShades
   set methodProc(xyplot,contourbox)        DrawBox
   set methodProc(xyplot,saveplot)          SavePlot
   set methodProc(xyplot,dataconfig)        DataConfig
   set methodProc(xyplot,xconfig)           XConfig
   set methodProc(xyplot,yconfig)           YConfig
   set methodProc(xyplot,xticklines)        DrawXTicklines
   set methodProc(xyplot,yticklines)        DrawYTicklines
   set methodProc(xyplot,background)        BackgroundColour
   set methodProc(xyplot,legendconfig)      LegendConfigure
   set methodProc(xyplot,legend)            DrawLegend
   set methodProc(xyplot,balloon)           DrawBalloon
   set methodProc(xyplot,balloonconfig)     ConfigBalloon
   set methodProc(xyplot,plaintext)         DrawPlainText
   set methodProc(xyplot,bindvar)           BindVar
   set methodProc(xyplot,bindcmd)           BindCmd
   set methodProc(xyplot,rescale)           RescalePlot
   set methodProc(xyplot,box-and-whiskers)  DrawBoxWhiskers
   set methodProc(xlogyplot,title)          DrawTitle
   set methodProc(xlogyplot,xtext)          DrawXtext
   set methodProc(xlogyplot,ytext)          DrawYtext
   set methodProc(xlogyplot,plot)           DrawLogData
   set methodProc(xlogyplot,dot)            DrawLogDot
   set methodProc(xlogyplot,dotconfig)      DotConfigure
   set methodProc(xlogyplot,interval)       DrawLogInterval
   set methodProc(xlogyplot,trend)          DrawLogTrendLine
   set methodProc(xlogyplot,saveplot)       SavePlot
   set methodProc(xlogyplot,dataconfig)     DataConfig
   set methodProc(xlogyplot,xconfig)        XConfig
   set methodProc(xlogyplot,yconfig)        YConfig
   set methodProc(xlogyplot,xticklines)     DrawXTicklines
   set methodProc(xlogyplot,yticklines)     DrawYTicklines
   set methodProc(xlogyplot,background)     BackgroundColour
   set methodProc(xlogyplot,legendconfig)   LegendConfigure
   set methodProc(xlogyplot,legend)         DrawLegend
   set methodProc(xlogyplot,balloon)        DrawBalloon
   set methodProc(xlogyplot,balloonconfig)  ConfigBalloon
   set methodProc(xlogyplot,plaintext)      DrawPlainText
   set methodProc(piechart,title)           DrawTitle
   set methodProc(piechart,plot)            DrawPie
   set methodProc(piechart,saveplot)        SavePlot
   set methodProc(piechart,balloon)         DrawBalloon
   set methodProc(piechart,balloonconfig)   ConfigBalloon
   set methodProc(piechart,plaintext)       DrawPlainText
   set methodProc(polarplot,title)          DrawTitle
   set methodProc(polarplot,plot)           DrawPolarData
   set methodProc(polarplot,saveplot)       SavePlot
   set methodProc(polarplot,dataconfig)     DataConfig
   set methodProc(polarplot,background)     BackgroundColour
   set methodProc(polarplot,legendconfig)   LegendConfigure
   set methodProc(polarplot,legend)         DrawLegend
   set methodProc(polarplot,balloon)        DrawBalloon
   set methodProc(polarplot,balloonconfig)  ConfigBalloon
   set methodProc(polarplot,plaintext)      DrawPlainText
   set methodProc(histogram,title)          DrawTitle
   set methodProc(histogram,xtext)          DrawXtext
   set methodProc(histogram,ytext)          DrawYtext
   set methodProc(histogram,plot)           DrawHistogramData
   set methodProc(histogram,saveplot)       SavePlot
   set methodProc(histogram,dataconfig)     DataConfig
   set methodProc(histogram,xconfig)        XConfig
   set methodProc(histogram,yconfig)        YConfig
   set methodProc(histogram,yticklines)     DrawYTicklines
   set methodProc(histogram,background)     BackgroundColour
   set methodProc(histogram,legendconfig)   LegendConfigure
   set methodProc(histogram,legend)         DrawLegend
   set methodProc(histogram,balloon)        DrawBalloon
   set methodProc(histogram,balloonconfig)  ConfigBalloon
   set methodProc(histogram,plaintext)      DrawPlainText
   set methodProc(horizbars,title)          DrawTitle
   set methodProc(horizbars,xtext)          DrawXtext
   set methodProc(horizbars,ytext)          DrawYtext
   set methodProc(horizbars,plot)           DrawHorizBarData
   set methodProc(horizbars,xticklines)     DrawXTicklines
   set methodProc(horizbars,background)     BackgroundColour
   set methodProc(horizbars,saveplot)       SavePlot
   set methodProc(horizbars,colours)        SetColours
   set methodProc(horizbars,colors)         SetColours
   set methodProc(horizbars,xconfig)        XConfig
   set methodProc(horizbars,legendconfig)   LegendConfigure
   set methodProc(horizbars,legend)         DrawLegend
   set methodProc(horizbars,balloon)        DrawBalloon
   set methodProc(horizbars,balloonconfig)  ConfigBalloon
   set methodProc(horizbars,plaintext)      DrawPlainText
   set methodProc(vertbars,title)           DrawTitle
   set methodProc(vertbars,xtext)           DrawXtext
   set methodProc(vertbars,ytext)           DrawYtext
   set methodProc(vertbars,plot)            DrawVertBarData
   set methodProc(vertbars,background)      BackgroundColour
   set methodProc(vertbars,yticklines)      DrawYTicklines
   set methodProc(vertbars,saveplot)        SavePlot
   set methodProc(vertbars,colours)         SetColours
   set methodProc(vertbars,colors)          SetColours
   set methodProc(vertbars,yconfig)         YConfig
   set methodProc(vertbars,legendconfig)    LegendConfigure
   set methodProc(vertbars,legend)          DrawLegend
   set methodProc(vertbars,balloon)         DrawBalloon
   set methodProc(vertbars,balloonconfig)   ConfigBalloon
   set methodProc(vertbars,plaintext)       DrawPlainText
   set methodProc(timechart,title)          DrawTitle
   set methodProc(timechart,period)         DrawTimePeriod
   set methodProc(timechart,milestone)      DrawTimeMilestone
   set methodProc(timechart,vertline)       DrawTimeVertLine
   set methodProc(timechart,saveplot)       SavePlot
   set methodProc(timechart,background)     BackgroundColour
   set methodProc(timechart,balloon)        DrawBalloon
   set methodProc(timechart,balloonconfig)  ConfigBalloon
   set methodProc(timechart,plaintext)      DrawPlainText
   set methodProc(timechart,hscroll)        ConnectHorizScrollbar
   set methodProc(timechart,vscroll)        ConnectVertScrollbar
   set methodProc(ganttchart,title)         DrawTitle
   set methodProc(ganttchart,period)        DrawGanttPeriod
   set methodProc(ganttchart,task)          DrawGanttPeriod
   set methodProc(ganttchart,milestone)     DrawGanttMilestone
   set methodProc(ganttchart,vertline)      DrawGanttVertLine
   set methodProc(ganttchart,saveplot)      SavePlot
   set methodProc(ganttchart,color)         GanttColor
   set methodProc(ganttchart,colour)        GanttColor
   set methodProc(ganttchart,font)          GanttFont
   set methodProc(ganttchart,connect)       DrawGanttConnect
   set methodProc(ganttchart,summary)       DrawGanttSummary
   set methodProc(ganttchart,background)    BackgroundColour
   set methodProc(ganttchart,balloon)       DrawBalloon
   set methodProc(ganttchart,balloonconfig) ConfigBalloon
   set methodProc(ganttchart,plaintext)     DrawPlainText
   set methodProc(ganttchart,hscroll)       ConnectHorizScrollbar
   set methodProc(ganttchart,vscroll)       ConnectVertScrollbar
   set methodProc(stripchart,title)         DrawTitle
   set methodProc(stripchart,xtext)         DrawXtext
   set methodProc(stripchart,ytext)         DrawYtext
   set methodProc(stripchart,plot)          DrawStripData
   set methodProc(stripchart,saveplot)      SavePlot
   set methodProc(stripchart,dataconfig)    DataConfig
   set methodProc(stripchart,xconfig)       XConfig
   set methodProc(stripchart,yconfig)       YConfig
   set methodProc(stripchart,yticklines)    DrawYTicklines
   set methodProc(stripchart,background)    BackgroundColour
   set methodProc(stripchart,legendconfig)  LegendConfigure
   set methodProc(stripchart,legend)        DrawLegend
   set methodProc(stripchart,balloon)       DrawBalloon
   set methodProc(stripchart,balloonconfig) ConfigBalloon
   set methodProc(stripchart,plaintext)     DrawPlainText
   set methodProc(isometric,title)          DrawTitle
   set methodProc(isometric,xtext)          DrawXtext
   set methodProc(isometric,ytext)          DrawYtext
   set methodProc(isometric,plot)           DrawIsometricData
   set methodProc(isometric,saveplot)       SavePlot
   set methodProc(isometric,background)     BackgroundColour
   set methodProc(isometric,balloon)        DrawBalloon
   set methodProc(isometric,balloonconfig)  ConfigBalloon
   set methodProc(isometric,plaintext)      DrawPlainText
   set methodProc(3dplot,title)             DrawTitle
   set methodProc(3dplot,plotfunc)          Draw3DFunction
   set methodProc(3dplot,plotdata)          Draw3DData
   set methodProc(3dplot,plotline)          Draw3DLineFrom3Dcoordinates
   set methodProc(3dplot,gridsize)          GridSize3D
   set methodProc(3dplot,saveplot)          SavePlot
   set methodProc(3dplot,colour)            SetColours
   set methodProc(3dplot,color)             SetColours
   set methodProc(3dplot,xconfig)           XConfig
   set methodProc(3dplot,yconfig)           YConfig
   set methodProc(3dplot,zconfig)           ZConfig
   set methodProc(3dplot,plotfuncont)       Draw3DFunctionContour
   set methodProc(3dplot,background)        BackgroundColour
   set methodProc(3dbars,title)             DrawTitle
   set methodProc(3dbars,plot)              Draw3DBar
   set methodProc(3dbars,yconfig)           YConfig
   set methodProc(3dbars,saveplot)          SavePlot
   set methodProc(3dbars,config)            Config3DBars
   set methodProc(3dbars,balloon)           DrawBalloon
   set methodProc(3dbars,balloonconfig)     ConfigBalloon
   set methodProc(3dbars,plaintext)         DrawPlainText
   set methodProc(radialchart,title)        DrawTitle
   set methodProc(radialchart,plot)         DrawRadial
   set methodProc(radialchart,saveplot)     SavePlot
   set methodProc(radialchart,balloon)      DrawBalloon
   set methodProc(radialchart,plaintext)    DrawPlainText
   set methodProc(txplot,title)             DrawTitle
   set methodProc(txplot,xtext)             DrawXtext
   set methodProc(txplot,ytext)             DrawYtext
   set methodProc(txplot,plot)              DrawTimeData
   set methodProc(txplot,interval)          DrawInterval
   set methodProc(txplot,saveplot)          SavePlot
   set methodProc(txplot,dataconfig)        DataConfig
   set methodProc(txplot,xconfig)           XConfig
   set methodProc(txplot,yconfig)           YConfig
   set methodProc(txplot,xticklines)        DrawXTicklines
   set methodProc(txplot,yticklines)        DrawYTicklines
   set methodProc(txplot,background)        BackgroundColour
   set methodProc(txplot,legendconfig)      LegendConfigure
   set methodProc(txplot,legend)            DrawLegend
   set methodProc(txplot,balloon)           DrawBalloon
   set methodProc(txplot,balloonconfig)     ConfigBalloon
   set methodProc(txplot,plaintext)         DrawPlainText
   set methodProc(3dribbon,title)           DrawTitle
   set methodProc(3dribbon,saveplot)        SavePlot
   set methodProc(3dribbon,line)            Draw3DLine
   set methodProc(3dribbon,area)            Draw3DArea
   set methodProc(3dribbon,background)      BackgroundColour
   set methodProc(boxplot,title)            DrawTitle
   set methodProc(boxplot,xtext)            DrawXtext
   set methodProc(boxplot,ytext)            DrawYtext
   set methodProc(boxplot,plot)             DrawBoxData
   set methodProc(boxplot,saveplot)         SavePlot
   set methodProc(boxplot,dataconfig)       DataConfig
   set methodProc(boxplot,xconfig)          XConfig
   set methodProc(boxplot,yconfig)          YConfig
   set methodProc(boxplot,xticklines)       DrawXTicklines
   set methodProc(boxplot,yticklines)       DrawYTicklines
   set methodProc(boxplot,background)       BackgroundColour
   set methodProc(boxplot,legendconfig)     LegendConfigure
   set methodProc(boxplot,legend)           DrawLegend
   set methodProc(boxplot,balloon)          DrawBalloon
   set methodProc(boxplot,balloonconfig)    ConfigBalloon
   set methodProc(boxplot,plaintext)        DrawPlainText

   #
   # Auxiliary parameters
   #
   variable torad
   set torad [expr {3.1415926/180.0}]

   variable options
   variable option_keys
   variable option_values
   set options       {-colour -color  -symbol -type -filled -fillcolour -boxwidth}
   set option_keys   {-colour -colour -symbol -type -filled -fillcolour -boxwidth}
   set option_values {-colour {...}
                      -symbol {plus cross circle up down dot upfilled downfilled}
                      -type {line symbol both}
                      -filled {no up down}
                      -fillcolour {...}
                      -boxwidth   {...}
                     }

   variable axis_options
   variable axis_option_clear
   variable axis_option_values
   set axis_options       {-format -ticklength -ticklines -scale}
   set axis_option_clear  { 0       0           0          1    }
   set axis_option_values {-format     {...}
                           -ticklength {...}
                           -ticklines  {0 1}
                           -scale      {...}
                          }
   variable contour_options
}

# setZoomPan --
#    Set up the bindings for zooming and panning
# Arguments:
#    w           Name of the canvas window
# Result:
#    None
# Side effect:
#    Bindings set up
#
proc ::Plotchart::setZoomPan { w } {
   set sqrt2  [expr {sqrt(2.0)}]
   set sqrt05 [expr {sqrt(0.5)}]

   bind $w <Control-Button-1> [list ::Plotchart::ScaleItems $w %x %y $sqrt2]
   bind $w <Control-Prior>    [list ::Plotchart::ScaleItems $w %x %y $sqrt2]
   bind $w <Control-Button-2> [list ::Plotchart::ScaleItems $w %x %y $sqrt05]
   bind $w <Control-Button-3> [list ::Plotchart::ScaleItems $w %x %y $sqrt05]
   bind $w <Control-Next>     [list ::Plotchart::ScaleItems $w %x %y $sqrt05]
   bind $w <Control-Up>       [list ::Plotchart::MoveItems  $w   0 -40]
   bind $w <Control-Down>     [list ::Plotchart::MoveItems  $w   0  40]
   bind $w <Control-Left>     [list ::Plotchart::MoveItems  $w -40   0]
   bind $w <Control-Right>    [list ::Plotchart::MoveItems  $w  40   0]
   focus $w
}

# viewPort --
#    Set the pixel extremes for the graph
# Arguments:
#    w           Name of the canvas window
#    pxmin       Minimum X-coordinate
#    pymin       Minimum Y-coordinate
#    pxmax       Maximum X-coordinate
#    pymax       Maximum Y-coordinate
# Result:
#    None
# Side effect:
#    Array scaling filled
#
proc ::Plotchart::viewPort { w pxmin pymin pxmax pymax } {
   variable scaling

   if { $pxmin >= $pxmax || $pymin >= $pymax } {
      return -code error "Inconsistent bounds for viewport"
   }

   set scaling($w,pxmin)    $pxmin
   set scaling($w,pymin)    $pymin
   set scaling($w,pxmax)    $pxmax
   set scaling($w,pymax)    $pymax
   set scaling($w,new)      1
}

# worldCoordinates --
#    Set the extremes for the world coordinates
# Arguments:
#    w           Name of the canvas window
#    xmin        Minimum X-coordinate
#    ymin        Minimum Y-coordinate
#    xmax        Maximum X-coordinate
#    ymax        Maximum Y-coordinate
# Result:
#    None
# Side effect:
#    Array scaling filled
#
proc ::Plotchart::worldCoordinates { w xmin ymin xmax ymax } {
   variable scaling

   if { $xmin == $xmax || $ymin == $ymax } {
      return -code error "Minimum and maximum must differ for world coordinates"
   }

   set scaling($w,xmin)    [expr {double($xmin)}]
   set scaling($w,ymin)    [expr {double($ymin)}]
   set scaling($w,xmax)    [expr {double($xmax)}]
   set scaling($w,ymax)    [expr {double($ymax)}]

   set scaling($w,new)     1
}

# polarCoordinates --
#    Set the extremes for the polar coordinates
# Arguments:
#    w           Name of the canvas window
#    radmax      Maximum radius
# Result:
#    None
# Side effect:
#    Array scaling filled
#
proc ::Plotchart::polarCoordinates { w radmax } {
   variable scaling

   if { $radmax <= 0.0 } {
      return -code error "Maximum radius must be positive"
   }

   set scaling($w,xmin)    [expr {-double($radmax)}]
   set scaling($w,ymin)    [expr {-double($radmax)}]
   set scaling($w,xmax)    [expr {double($radmax)}]
   set scaling($w,ymax)    [expr {double($radmax)}]

   set scaling($w,new)     1
}

# world3DCoordinates --
#    Set the extremes for the world coordinates in 3D plots
# Arguments:
#    w           Name of the canvas window
#    xmin        Minimum X-coordinate
#    ymin        Minimum Y-coordinate
#    zmin        Minimum Z-coordinate
#    xmax        Maximum X-coordinate
#    ymax        Maximum Y-coordinate
#    zmax        Maximum Z-coordinate
# Result:
#    None
# Side effect:
#    Array scaling filled
#
proc ::Plotchart::world3DCoordinates { w xmin ymin zmin xmax ymax zmax } {
   variable scaling

   if { $xmin == $xmax || $ymin == $ymax || $zmin == $zmax } {
      return -code error "Minimum and maximum must differ for world coordinates"
   }

   set scaling($w,xmin)    [expr {double($xmin)}]
   set scaling($w,ymin)    [expr {double($ymin)}]
   set scaling($w,zmin)    [expr {double($zmin)}]
   set scaling($w,xmax)    [expr {double($xmax)}]
   set scaling($w,ymax)    [expr {double($ymax)}]
   set scaling($w,zmax)    [expr {double($zmax)}]

   set scaling($w,new)     1
}

# coordsToPixel --
#    Convert world coordinates to pixel coordinates
# Arguments:
#    w           Name of the canvas
#    xcrd        X-coordinate
#    ycrd        Y-coordinate
# Result:
#    List of two elements, x- and y-coordinates in pixels
#
proc ::Plotchart::coordsToPixel { w xcrd ycrd } {
   variable scaling

   if { $scaling($w,new) == 1 } {
      set scaling($w,new)     0
      set width               [expr {$scaling($w,pxmax)-$scaling($w,pxmin)}]
      set height              [expr {$scaling($w,pymax)-$scaling($w,pymin)}]

      set dx                  [expr {$scaling($w,xmax)-$scaling($w,xmin)}]
      set dy                  [expr {$scaling($w,ymax)-$scaling($w,ymin)}]
      set scaling($w,xfactor) [expr {$width/$dx}]
      set scaling($w,yfactor) [expr {$height/$dy}]
   }

   set xpix [expr {$scaling($w,pxmin)+($xcrd-$scaling($w,xmin))*$scaling($w,xfactor)}]
   set ypix [expr {$scaling($w,pymin)+($scaling($w,ymax)-$ycrd)*$scaling($w,yfactor)}]
   return [list $xpix $ypix]
}

# coords3DToPixel --
#    Convert world coordinates to pixel coordinates (3D plots)
# Arguments:
#    w           Name of the canvas
#    xcrd        X-coordinate
#    ycrd        Y-coordinate
#    zcrd        Z-coordinate
# Result:
#    List of two elements, x- and y-coordinates in pixels
#
proc ::Plotchart::coords3DToPixel { w xcrd ycrd zcrd } {
   variable scaling

   if { $scaling($w,new) == 1 } {
      set scaling($w,new)      0
      set width                [expr {$scaling($w,pxmax)-$scaling($w,pxmin)}]
      set height               [expr {$scaling($w,pymax)-$scaling($w,pymin)}]

      set dx                   [expr {$scaling($w,xmax)-$scaling($w,xmin)}]
      set dy                   [expr {$scaling($w,ymax)-$scaling($w,ymin)}]
      set dz                   [expr {$scaling($w,zmax)-$scaling($w,zmin)}]
      set scaling($w,xyfactor) [expr {$scaling($w,yfract)*$width/$dx}]
      set scaling($w,xzfactor) [expr {$scaling($w,zfract)*$height/$dx}]
      set scaling($w,yfactor)  [expr {$width/$dy}]
      set scaling($w,zfactor)  [expr {$height/$dz}]
   }

   #
   # The values for xcrd = xmax
   #
   set xpix [expr {$scaling($w,pxmin)+($ycrd-$scaling($w,ymin))*$scaling($w,yfactor)}]
   set ypix [expr {$scaling($w,pymin)+($scaling($w,zmax)-$zcrd)*$scaling($w,zfactor)}]

   #
   # Add the shift due to xcrd-xmax
   #
   set xpix [expr {$xpix + $scaling($w,xyfactor)*($xcrd-$scaling($w,xmax))}]
   set ypix [expr {$ypix - $scaling($w,xzfactor)*($xcrd-$scaling($w,xmax))}]

   return [list $xpix $ypix]
}

# pixelToCoords --
#    Convert pixel coordinates to world coordinates
# Arguments:
#    w           Name of the canvas
#    xpix        X-coordinate (pixel)
#    ypix        Y-coordinate (pixel)
# Result:
#    List of two elements, x- and y-coordinates in world coordinate system
#
proc ::Plotchart::pixelToCoords { w xpix ypix } {
   variable scaling

   if { $scaling($w,new) == 1 } {
      set scaling($w,new)     0
      set width               [expr {$scaling($w,pxmax)-$scaling($w,pxmin)}]
      set height              [expr {$scaling($w,pymax)-$scaling($w,pymin)}]

      set dx                  [expr {$scaling($w,xmax)-$scaling($w,xmin)}]
      set dy                  [expr {$scaling($w,ymax)-$scaling($w,ymin)}]
      set scaling($w,xfactor) [expr {$width/$dx}]
      set scaling($w,yfactor) [expr {$height/$dy}]
   }

   set xcrd [expr {$scaling($w,xmin)+($xpix-$scaling($w,pxmin))/$scaling($w,xfactor)}]
   set ycrd [expr {$scaling($w,ymax)-($ypix-$scaling($w,pymin))/$scaling($w,yfactor)}]
   return [list $xcrd $ycrd]
}

# pixelToIndex --
#    Convert pixel coordinates to elements list index
# Arguments:
#    w           Name of the canvas
#    xpix        X-coordinate (pixel)
#    ypix        Y-coordinate (pixel)
# Result:
#    Elements list index
#
proc ::Plotchart::pixelToIndex { w xpix ypix } {
   variable scaling
   variable torad

   set idx -1
   set radius [expr {($scaling(${w},pxmax) - $scaling(${w},pxmin)) / 2}]
   set xrel [expr {${xpix} - $scaling(${w},pxmin) - ${radius}}]
   set yrel [expr {-${ypix} + $scaling(${w},pymin) + ${radius}}]
   if {[expr {pow(${radius},2) < (pow(${xrel},2) + pow(${yrel},2))}]} {
       # do nothing out of pie chart
   } elseif {[info exists scaling(${w},angles)]} {
       set xy_angle [expr {(360 + round(atan2(${yrel},${xrel})/${torad})) % 360}]
       foreach angle $scaling(${w},angles) {
       if {${xy_angle} <= ${angle}} {
           break
       }
       incr idx
       }
   }
   return ${idx}
}

# polarToPixel --
#    Convert polar coordinates to pixel coordinates
# Arguments:
#    w           Name of the canvas
#    rad         Radius of the point
#    phi         Angle of the point (degrees)
# Result:
#    List of two elements, x- and y-coordinates in pixels
#
proc ::Plotchart::polarToPixel { w rad phi } {
   variable torad

   set xcrd [expr {$rad*cos($phi*$torad)}]
   set ycrd [expr {$rad*sin($phi*$torad)}]

   coordsToPixel $w $xcrd $ycrd
}

# createXYPlot --
#    Create a command for drawing an XY plot
# Arguments:
#    w           Name of the canvas
#    xscale      Minimum, maximum and step for x-axis (initial)
#    yscale      Minimum, maximum and step for y-axis
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the XY plot.
#    The plot will be drawn with axes
#
proc ::Plotchart::createXYPlot { w xscale yscale } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "xyplot_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler xyplot $w
   CopyConfig xyplot $w

   foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break}

   foreach {xmin xmax xdelt} $xscale {break}
   foreach {ymin ymax ydelt} $yscale {break}

   if { $xdelt == 0.0 || $ydelt == 0.0 } {
      return -code error "Step size can not be zero"
   }

   if { ($xmax-$xmin)*$xdelt < 0.0 } {
      set xdelt [expr {-$xdelt}]
   }
   if { ($ymax-$ymin)*$ydelt < 0.0 } {
      set ydelt [expr {-$ydelt}]
   }

   viewPort         $w $pxmin $pymin $pxmax $pymax
   worldCoordinates $w $xmin  $ymin  $xmax  $ymax

   DrawYaxis        $w $ymin  $ymax  $ydelt
   DrawXaxis        $w $xmin  $xmax  $xdelt
   DrawMask         $w
   DefaultLegend    $w
   DefaultBalloon   $w

   return $newchart
}

# createStripchart --
#    Create a command for drawing a strip chart
# Arguments:
#    w           Name of the canvas
#    xscale      Minimum, maximum and step for x-axis (initial)
#    yscale      Minimum, maximum and step for y-axis
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the stripchart.
#    The stripchart will be drawn with axes
#
proc ::Plotchart::createStripchart { w xscale yscale } {
   variable data_series

   set newchart [createXYPlot $w $xscale $yscale]

   interp alias {} $newchart {}

   set newchart "stripchart_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler stripchart $w
   CopyConfig stripchart $w

   return $newchart
}

# createIsometricPlot --
#    Create a command for drawing an "isometric" plot
# Arguments:
#    w           Name of the canvas
#    xscale      Minimum and maximum for x-axis
#    yscale      Minimum and maximum for y-axis
#    stepsize    Step size for numbers on the axes or "noaxes"
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the plot
#    The plot will be drawn with or without axes
#
proc ::Plotchart::createIsometricPlot { w xscale yscale stepsize } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "isometric_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler isometric $w
   CopyConfig isometric $w

   if { $stepsize != "noaxes" } {
      foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break}
   } else {
      set pxmin 0
      set pymin 0
      #set pxmax [$w cget -width]
      #set pymax [$w cget -height]
      set pxmax [WidthCanvas $w]
      set pymax [HeightCanvas $w]
   }

   foreach {xmin xmax} $xscale {break}
   foreach {ymin ymax} $yscale {break}

   if { $xmin == $xmax || $ymin == $ymax } {
      return -code error "Extremes for axes must be different"
   }

   viewPort         $w $pxmin $pymin $pxmax $pymax
   ScaleIsometric   $w $xmin  $ymin  $xmax  $ymax

   if { $stepsize != "noaxes" } {
      DrawYaxis        $w $ymin  $ymax  $ydelt
      DrawXaxis        $w $xmin  $xmax  $xdelt
      DrawMask         $w
   }
   DefaultLegend  $w
   DefaultBalloon $w

   return $newchart
}

# createXLogYPlot --
#    Create a command for drawing an XY plot (with a vertical logarithmic axis)
# Arguments:
#    w           Name of the canvas
#    xscale      Minimum, maximum and step for x-axis (initial)
#    yscale      Minimum, maximum and step for y-axis (step is ignored!)
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the XY plot.
#    The plot will be drawn with axes
#
proc ::Plotchart::createXLogYPlot { w xscale yscale } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "xlogyplot_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler xlogyplot $w
   CopyConfig xlogyplot $w

   foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break}

   foreach {xmin xmax xdelt} $xscale {break}
   foreach {ymin ymax ydelt} $yscale {break}

   if { $xdelt == 0.0 || $ydelt == 0.0 } {
      return -code error "Step size can not be zero"
   }

   if { $ymin <= 0.0 || $ymax <= 0.0 } {
      return -code error "Minimum and maximum for y-axis must be positive"
   }

   #
   # TODO: reversed log plot
   #

   viewPort         $w $pxmin $pymin $pxmax $pymax
   worldCoordinates $w $xmin  [expr {log10($ymin)}]  $xmax [expr {log10($ymax)}]

   DrawLogYaxis     $w $ymin  $ymax  $ydelt
   DrawXaxis        $w $xmin  $xmax  $xdelt
   DrawMask         $w
   DefaultLegend    $w
   DefaultBalloon   $w

   return $newchart
}

# createHistogram --
#    Create a command for drawing a histogram
# Arguments:
#    w           Name of the canvas
#    xscale      Minimum, maximum and step for x-axis (initial)
#    yscale      Minimum, maximum and step for y-axis
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the histogram.
#    The plot will be drawn with axes
#    This is almost the same code as for an XY plot
#
proc ::Plotchart::createHistogram { w xscale yscale } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "histogram_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler histogram $w
   CopyConfig histogram $w

   foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break}

   foreach {xmin xmax xdelt} $xscale {break}
   foreach {ymin ymax ydelt} $yscale {break}

   if { $xdelt == 0.0 || $ydelt == 0.0 } {
      return -code error "Step size can not be zero"
   }

   if { ($xmax-$xmin)*$xdelt < 0.0 } {
      set xdelt [expr {-$xdelt}]
   }
   if { ($ymax-$ymin)*$ydelt < 0.0 } {
      set ydelt [expr {-$ydelt}]
   }

   viewPort         $w $pxmin $pymin $pxmax $pymax
   worldCoordinates $w $xmin  $ymin  $xmax  $ymax

   DrawYaxis        $w $ymin  $ymax  $ydelt
   DrawXaxis        $w $xmin  $xmax  $xdelt
   DrawMask         $w
   DefaultLegend    $w
   DefaultBalloon   $w

   return $newchart
}

# createPiechart --
#    Create a command for drawing a pie chart
# Arguments:
#    w           Name of the canvas
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the pie chart.
#
proc ::Plotchart::createPiechart { w } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "piechart_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler piechart $w
   CopyConfig piechart $w

   foreach {pxmin pymin pxmax pymax} [MarginsCircle $w] {break}

   viewPort $w $pxmin $pymin $pxmax $pymax
   $w create oval $pxmin $pymin $pxmax $pymax

   SetColours $w blue lightblue green yellow orange red magenta brown
   DefaultLegend  $w
   DefaultBalloon $w

   return $newchart
}

# createPolarplot --
#    Create a command for drawing a polar plot
# Arguments:
#    w             Name of the canvas
#    radius_data   Maximum radius and step
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the polar plot
#    Possible additional arguments (optional): nautical/mathematical
#    step in phi
#
proc ::Plotchart::createPolarplot { w radius_data } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "polarplot_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler polarplot $w
   CopyConfig polarplot $w

   set rad_max   [lindex $radius_data 0]
   set rad_step  [lindex $radius_data 1]

   if { $rad_step <= 0.0 } {
      return -code error "Step size can not be zero or negative"
   }
   if { $rad_max <= 0.0 } {
      return -code error "Maximum radius can not be zero or negative"
   }

   foreach {pxmin pymin pxmax pymax} [MarginsCircle $w] {break}

   viewPort         $w $pxmin     $pymin     $pxmax   $pymax
   polarCoordinates $w $rad_max
   DrawPolarAxes    $w $rad_max   $rad_step
   DefaultLegend    $w
   DefaultBalloon   $w

   return $newchart
}

# createBarchart --
#    Create a command for drawing a barchart with vertical bars
# Arguments:
#    w           Name of the canvas
#    xlabels     List of labels for x-axis
#    yscale      Minimum, maximum and step for y-axis
#    noseries    Number of series or the keyword "stacked"
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the barchart.
#
proc ::Plotchart::createBarchart { w xlabels yscale noseries } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "barchart_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler vertbars $w
   CopyConfig vertbars $w

   foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break}

   set xmin  0.0
   set xmax  [expr {[llength $xlabels] + 0.1}]

   foreach {ymin ymax ydelt} $yscale {break}

   if { $ydelt == 0.0 } {
      return -code error "Step size can not be zero"
   }

   if { ($ymax-$ymin)*$ydelt < 0.0 } {
      set ydelt [expr {-$ydelt}]
   }

   viewPort         $w $pxmin $pymin $pxmax $pymax
   worldCoordinates $w $xmin  $ymin  $xmax  $ymax

   DrawYaxis        $w $ymin  $ymax  $ydelt
   DrawXlabels      $w $xlabels $noseries
   DrawMask         $w
   DefaultLegend    $w
   set data_series($w,legendtype) "rectangle"
   DefaultBalloon   $w

   SetColours $w blue lightblue green yellow orange red magenta brown

   return $newchart
}

# createHorizontalBarchart --
#    Create a command for drawing a barchart with horizontal bars
# Arguments:
#    w           Name of the canvas
#    xscale      Minimum, maximum and step for x-axis
#    ylabels     List of labels for y-axis
#    noseries    Number of series or the keyword "stacked"
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the barchart.
#
proc ::Plotchart::createHorizontalBarchart { w xscale ylabels noseries } {
   variable data_series
   variable config

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "hbarchart_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler horizbars $w
   CopyConfig horizbars $w

   set font      $config($w,leftaxis,font)
   set xspacemax 0
   foreach ylabel $ylabels {
       set xspace [font measure $font $ylabel]
       if { $xspace > $xspacemax } {
           set xspacemax $xspace
       }
   }
   set config($w,margin,left) [expr {$xspacemax+5}] ;# Slightly more space required!

   foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break}

   set ymin  0.0
   set ymax  [expr {[llength $ylabels] + 0.1}]

   foreach {xmin xmax xdelt} $xscale {break}

   if { $xdelt == 0.0 } {
      return -code error "Step size can not be zero"
   }

   if { ($xmax-$xmin)*$xdelt < 0.0 } {
      set xdelt [expr {-$xdelt}]
   }

   viewPort         $w $pxmin $pymin $pxmax $pymax
   worldCoordinates $w $xmin  $ymin  $xmax  $ymax

   DrawXaxis        $w $xmin  $xmax  $xdelt
   DrawYlabels      $w $ylabels $noseries
   DrawMask         $w
   DefaultLegend    $w
   set data_series($w,legendtype) "rectangle"
   DefaultBalloon   $w

   SetColours $w blue lightblue green yellow orange red magenta brown

   return $newchart
}

# createBoxplot --
#    Create a command for drawing a plot with box-and-whiskers
# Arguments:
#    w           Name of the canvas
#    xscale      Minimum, maximum and step for x-axis
#    ylabels     List of labels for y-axis
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the boxplot.
#
proc ::Plotchart::createBoxplot { w xscale ylabels } {
   variable data_series
   variable config

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "boxplot_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler boxplot $w
   CopyConfig boxplot $w

   set font      $config($w,leftaxis,font)
   set xspacemax 0
   foreach ylabel $ylabels {
       set xspace [font measure $font $ylabel]
       if { $xspace > $xspacemax } {
           set xspacemax $xspace
       }
   }
   set config($w,margin,left) [expr {$xspacemax+5}] ;# Slightly more space required!
   foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break}

   set ymin  0.0
   set ymax  [expr {[llength $ylabels] + 0.1}]

   foreach {xmin xmax xdelt} $xscale {break}

   if { $xdelt == 0.0 } {
      return -code error "Step size can not be zero"
   }

   if { ($xmax-$xmin)*$xdelt < 0.0 } {
      set xdelt [expr {-$xdelt}]
   }

   viewPort         $w $pxmin $pymin $pxmax $pymax
   worldCoordinates $w $xmin  $ymin  $xmax  $ymax

   DrawXaxis        $w $xmin  $xmax  $xdelt
   DrawYlabels      $w $ylabels 1
   DrawMask         $w
   DefaultLegend    $w
   set data_series($w,legendtype) "rectangle"
   DefaultBalloon   $w

   set config($w,axisnames) $ylabels

   return $newchart
}

# createTimechart --
#    Create a command for drawing a simple timechart
# Arguments:
#    w           Name of the canvas
#    time_begin  Start time (in the form of a date/time)
#    time_end    End time (in the form of a date/time)
#    args        Number of items to be shown (determines spacing)
#                or one or more options (-barheight pixels, -ylabelwidth pixels)
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the timechart.
#
proc ::Plotchart::createTimechart { w time_begin time_end args} {
   variable data_series
   variable scaling

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "timechart_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler timechart $w
   CopyConfig timechart $w

   #
   # Handle the arguments
   #
   set barheight    0
   set noitems      [lindex $args 0]
   set ylabelwidth  8

   if { [string is integer -strict $noitems] } {
       set args [lrange $args 1 end]
   }
   foreach {keyword value} $args {
       switch -- $keyword {
           "-barheight" {
                set barheight $value
           }
           "-ylabelwidth" {
                set ylabelwidth [expr {$value/10.0}] ;# Pixels to characters
           }
           default {
                # Ignore
           }
       }
   }

   foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w 3 $ylabelwidth] {break}

   if { $barheight != 0 } {
       set noitems [expr {($pxmax-$pxmin)/double($barheight)}]
   }
   set scaling($w,barheight) $barheight

   set ymin  0.0
   set ymax  $noitems

   set xmin  [expr {1.0*[clock scan $time_begin]}]
   set xmax  [expr {1.0*[clock scan $time_end]}]

   viewPort         $w $pxmin $pymin $pxmax $pymax
   worldCoordinates $w $xmin  $ymin  $xmax  $ymax

   set scaling($w,current) $ymax
   set scaling($w,dy)      -0.7

   DrawScrollMask $w
   set scaling($w,curpos)  0
   set scaling($w,curhpos) 0

   return $newchart
}

# createGanttchart --
#    Create a command for drawing a Gantt (planning) chart
# Arguments:
#    w           Name of the canvas
#    time_begin  Start time (in the form of a date/time)
#    time_end    End time (in the form of a date/time)
#    args        (First integer) Number of items to be shown (determines spacing)
#                (Second integer) Estimated maximum length of text (default: 20)
#                Or keyword-value pairs
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the Gantt chart.
#    Most commands taken from time charts.
#
proc ::Plotchart::createGanttchart { w time_begin time_end args} {

   variable data_series
   variable scaling

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "ganttchart_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler ganttchart $w
   CopyConfig ganttchart $w

   #
   # Handle the arguments
   #
   set barheight    0
   set noitems      [lindex $args 0]

   if { [string is integer -strict $noitems] } {
       set args        [lrange $args 1 end]
       set ylabelwidth [lindex $args 0]
       if { [string is integer -strict $ylabelwidth] } {
           set args [lrange $args 1 end]
       } else {
           set ylabelwidth 20
       }
   } else {
       set ylabelwidth 20
   }

   foreach {keyword value} $args {
       switch -- $keyword {
           "-barheight" {
                set barheight $value
           }
           "-ylabelwidth" {
                set ylabelwidth [expr {$value/10.0}] ;# Pixels to characters
           }
           default {
                # Ignore
           }
       }
   }

   foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w 3 $ylabelwidth] {break}

   if { $barheight != 0 } {
       set noitems [expr {($pxmax-$pxmin)/double($barheight)}]
   }
   set scaling($w,barheight) $barheight

   set ymin  0.0
   set ymax  $noitems

   set xmin  [expr {1.0*[clock scan $time_begin]}]
   set xmax  [expr {1.0*[clock scan $time_end]}]

   viewPort         $w $pxmin $pymin $pxmax $pymax
   worldCoordinates $w $xmin  $ymin  $xmax  $ymax

   set scaling($w,current) $ymax
   set scaling($w,dy)      -0.7

   #
   # Draw the backgrounds (both in the text part and the
   # graphical part; the text part has the "special" tag
   # "Edit" to enable a GUI to change things)
   #
   set yend 0.0
   for { set i 0 } { $i < $noitems } { incr i } {
       set ybegin $yend
       set yend   [expr {$ybegin+1.0}]
       foreach {x1 y1} [coordsToPixel $w $xmin $ybegin] {break}
       foreach {x2 y2} [coordsToPixel $w $xmax $yend  ] {break}

       if { $i%2 == 0 } {
           set tag odd
       } else {
           set tag even
       }
       $w create rectangle 0   $y1 $x1 $y2 -fill white \
           -tag {Edit vertscroll lowest} -outline white
       $w create rectangle $x1 $y1 $x2 $y2 -fill white \
           -tag [list $tag vertscroll lowest] -outline white
   }

   #
   # Default colours and fonts
   #
   GanttColor $w description black
   GanttColor $w completed   lightblue
   GanttColor $w left        white
   GanttColor $w odd         white
   GanttColor $w even        lightgrey
   GanttColor $w summary     black
   GanttColor $w summarybar  black
   GanttFont  $w description "times 10"
   GanttFont  $w summary     "times 10 bold"
   GanttFont  $w scale       "times 7"
   DefaultBalloon $w

   DrawScrollMask $w
   set scaling($w,curpos)  0
   set scaling($w,curhpos) 0

   return $newchart
}

# create3DPlot --
#    Create a simple 3D plot
# Arguments:
#    w           Name of the canvas
#    xscale      Minimum, maximum and step for x-axis (initial)
#    yscale      Minimum, maximum and step for y-axis
#    zscale      Minimum, maximum and step for z-axis
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the 3D plot
#
proc ::Plotchart::create3DPlot { w xscale yscale zscale } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "3dplot_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler 3dplot $w
   CopyConfig 3dplot $w

   foreach {pxmin pymin pxmax pymax} [Margins3DPlot $w] {break}

   foreach {xmin xmax xstep} $xscale {break}
   foreach {ymin ymax ystep} $yscale {break}
   foreach {zmin zmax zstep} $zscale {break}

   viewPort           $w $pxmin $pymin $pxmax $pymax
   world3DCoordinates $w $xmin  $ymin  $zmin  $xmax  $ymax $zmax

   Draw3DAxes         $w $xmin  $ymin  $zmin  $xmax  $ymax $zmax \
                         $xstep $ystep $zstep
   DefaultLegend      $w
   DefaultBalloon     $w

   SetColours $w grey black

   return $newchart
}

# create3DBarchart --
#    Create a command for drawing a barchart with vertical 3D bars
# Arguments:
#    w           Name of the canvas
#    yscale      Minimum, maximum and step for y-axis
#    nobars      Number of bars to be drawn
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the barchart.
#
proc ::Plotchart::create3DBarchart { w yscale nobars } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "3dbarchart_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler 3dbars $w
   CopyConfig 3dbars $w

   foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w 4] {break}

   set xmin  0.0
   set xmax  [expr {$nobars + 0.1}]

   foreach {ymin ymax ydelt} $yscale {break}

   if { $ydelt == 0.0 } {
      return -code error "Step size can not be zero"
   }

   if { ($ymax-$ymin)*$ydelt < 0.0 } {
      set ydelt [expr {-$ydelt}]
   }

   viewPort         $w $pxmin $pymin $pxmax $pymax
   worldCoordinates $w $xmin  $ymin  $xmax  $ymax

   DrawYaxis        $w $ymin  $ymax  $ydelt
  #DrawMask         $w -- none!
   Draw3DBarchart   $w $yscale $nobars
   DefaultLegend    $w
   DefaultBalloon   $w

   return $newchart
}

# createRadialchart --
#    Create a command for drawing a radial chart
# Arguments:
#    w           Name of the canvas
#    names       Names of the spokes
#    scale       Scale factor for the data
#    style       (Optional) style of the chart (lines, cumulative or filled)
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the radial chart.
#
proc ::Plotchart::createRadialchart { w names scale {style lines} } {
   variable settings
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "radialchart_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler radialchart $w
   CopyConfig radialchart $w

   foreach {pxmin pymin pxmax pymax} [MarginsCircle $w] {break}

   viewPort $w $pxmin $pymin $pxmax $pymax
   $w create oval $pxmin $pymin $pxmax $pymax

   set settings($w,scale)  [expr {double($scale)}]
   set settings($w,style)  $style
   set settings($w,number) [llength $names]

   DrawRadialSpokes $w $names
   DefaultLegend  $w
   DefaultBalloon $w

   return $newchart
}

# createTXPlot --
#    Create a command for drawing a TX plot (x versus date/time)
# Arguments:
#    w           Name of the canvas
#    tscale      Minimum, maximum and step for date/time-axis (initial)
#                (values must be valid dates and the step is in days)
#    xscale      Minimum, maximum and step for vertical axis
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the TX plot.
#    The plot will be drawn with axes
#
proc ::Plotchart::createTXPlot { w tscale xscale } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "txplot_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler txplot $w
   CopyConfig txplot $w

   foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break}

   foreach {tmin tmax tdelt} $tscale {break}

   set xmin  [clock scan $tmin]
   set xmax  [clock scan $tmax]
   set xdelt [expr {86400*$tdelt}]

   foreach {ymin ymax ydelt} $xscale {break}

   if { $xdelt == 0.0 || $ydelt == 0.0 } {
      return -code error "Step size can not be zero"
   }

   if { ($xmax-$xmin)*$xdelt < 0.0 } {
      set xdelt [expr {-$xdelt}]
   }
   if { ($ymax-$ymin)*$ydelt < 0.0 } {
      set ydelt [expr {-$ydelt}]
   }

   viewPort         $w $pxmin $pymin $pxmax $pymax
   worldCoordinates $w $xmin  $ymin  $xmax  $ymax

   DrawYaxis        $w $ymin  $ymax  $ydelt
   DrawTimeaxis     $w $tmin  $tmax  $tdelt
   DrawMask         $w
   DefaultLegend    $w
   DefaultBalloon   $w

   return $newchart
}

# createRightAxis --
#    Create a command for drawing a plot with a right axis
# Arguments:
#    w           Name of the canvas
#    yscale      Minimum, maximum and step for vertical axis
# Result:
#    Name of a new command
# Note:
#    This command requires that another plot command has been
#    created prior to this one. Some of the properties from that
#    command serve for this one too.
#
proc ::Plotchart::createRightAxis { w yscale } {
   variable data_series
   variable scaling

   set newchart "right_$w"

   #
   # Check if there is an appropriate plot already defined - there
   # should be only one!
   #
   if { [llength [info command "*_$w" ]] == 0 } {
       return -code error "There should be a plot with a left axis already defined"
   }
   if { [llength [info command "*_$w" ]] >= 2 } {
       if { [llength [info command "right_$w"]] == 0 } {
           return -code error "There should be only one plot command for this widget ($w)"
       } else {
           catch {
               interp alias {} $newchart {}
           }
       }
   }

   foreach s [array names data_series "r$w,*"] {
      unset data_series($s)
   }

   set type [lindex [interp alias {} [info command "*_$w"]] 1]

   interp alias {} $newchart {} ::Plotchart::PlotHandler $type r$w
   interp alias {} r$w       {} $w
   CopyConfig $type r$w

   set xmin $scaling($w,xmin)
   set xmax $scaling($w,xmax)

   set pxmin $scaling($w,pxmin)
   set pxmax $scaling($w,pxmax)
   set pymin $scaling($w,pymin)
   set pymax $scaling($w,pymax)

   foreach {ymin ymax ydelt} $yscale {break}

   if { $ydelt == 0.0 } {
      return -code error "Step size can not be zero"
   }

   if { ($ymax-$ymin)*$ydelt < 0.0 } {
      set ydelt [expr {-$ydelt}]
   }

   viewPort         r$w $pxmin $pymin $pxmax $pymax
   worldCoordinates r$w $xmin  $ymin  $xmax  $ymax

   DrawRightaxis    r$w $ymin  $ymax  $ydelt

   #DefaultLegend    r$w
   #DefaultBalloon   r$w

   return $newchart
}

# create3DRibbonChart --
#    Create a chart that can display 3D lines and areas
# Arguments:
#    w           Name of the canvas
#    names       Labels along the x-axis
#    yscale      Minimum, maximum and step for y-axis
#    zscale      Minimum, maximum and step for z-axis
# Result:
#    Name of a new command
# Note:
#    The entire canvas will be dedicated to the 3D chart
#
proc ::Plotchart::create3DRibbonChart { w names yscale zscale } {
   variable data_series

   foreach s [array names data_series "$w,*"] {
      unset data_series($s)
   }

   set newchart "3dribbon_$w"
   interp alias {} $newchart {} ::Plotchart::PlotHandler 3dribbon $w
   CopyConfig 3dribbon $w

   foreach {pxmin pymin pxmax pymax} [Margins3DPlot $w] {break}

   foreach {xmin xmax xstep} {0.0 1.0 0.0} {break}
   foreach {ymin ymax ystep} $yscale {break}
   foreach {zmin zmax zstep} $zscale {break}

   set xstep [expr {1.0/[llength $names]}]
   set data_series($w,xbase)  [expr {1.0-0.15*$xstep}]
   set data_series($w,xstep)  $xstep
   set data_series($w,xwidth) [expr {0.7*$xstep}]

   viewPort           $w $pxmin $pymin $pxmax $pymax
   world3DCoordinates $w $xmin  $ymin  $zmin  $xmax  $ymax $zmax

   Draw3DAxes         $w $xmin  $ymin  $zmin  $xmax  $ymax $zmax \
                         $xstep $ystep $zstep $names
   DefaultLegend      $w
   DefaultBalloon     $w

   SetColours $w grey black

   return $newchart
}

# Load the private procedures
#
source [file join [file dirname [info script]] "plotpriv.tcl"]
source [file join [file dirname [info script]] "plotaxis.tcl"]
source [file join [file dirname [info script]] "plot3d.tcl"]
source [file join [file dirname [info script]] "scaling.tcl"]
source [file join [file dirname [info script]] "plotcontour.tcl"]
source [file join [file dirname [info script]] "plotgantt.tcl"]
source [file join [file dirname [info script]] "plotbusiness.tcl"]
source [file join [file dirname [info script]] "plotannot.tcl"]
source [file join [file dirname [info script]] "plotconfig.tcl"]
source [file join [file dirname [info script]] "plotpack.tcl"]
#source [file join [file dirname [info script]] "plotbind.tcl"]

# Announce our presence
#
package provide Plotchart 1.6.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/plotchart/plotconfig.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
# plotconfig.tcl --
#     Facilities for configuring the various procedures of Plotchart
#

namespace eval ::Plotchart {
    variable config

    set config(charttypes) {xyplot xlogyplot piechart polarplot
                            histogram horizbars vertbars ganttchart
                            timechart stripchart isometric 3dplot 3dbars
                            radialchart txplot 3dribbon boxplot}

    set config(xyplot,components)      {title margin text legend leftaxis rightaxis bottomaxis background}
    set config(xlogyplot,components)   {title margin text legend leftaxis bottomaxis background}
    set config(piechart,components)    {title margin text legend labels background}
    set config(polarplot,components)   {title margin text legend axis background}
    set config(histogram,components)   {title margin text legend leftaxis rightaxis bottomaxis background}
    set config(horizbars,components)   {title margin text legend leftaxis bottomaxis background}
    set config(vertbars,components)    {title margin text legend leftaxis bottomaxis background}
    set config(ganttchart,components)  {title margin text legend axis background}
    set config(timechart,components)   {title margin text legend leftaxis bottomaxis background}
    set config(stripchart,components)  {title margin text legend leftaxis bottomaxis background}
    set config(isometric,components)   {title margin text legend leftaxis bottomaxis background}
    set config(3dplot,components)      {title margin text legend xaxis yaxis zaxis background}
    set config(3dbars,components)      {title margin text legend leftaxis bottomaxis background}
    set config(radialchart,components) {title margin text legend leftaxis bottomaxis background}
    set config(txplot,components)      {title margin text legend leftaxis rightaxis bottomaxis background}
    set config(3dribbon,components)    {title margin text legend leftaxis bottomaxis background}
    set config(boxplot,components)     {title margin text legend leftaxis bottomaxis background}

    set config(axis,properties)        {color thickness font format ticklength textcolor}
    set config(leftaxis,properties)    $config(axis,properties)
    set config(rightaxis,properties)   $config(axis,properties)
    set config(topaxis,properties)     $config(axis,properties)
    set config(bottomaxis,properties)  $config(axis,properties)
    set config(xaxis,properties)       $config(axis,properties)
    set config(yaxis,properties)       $config(axis,properties)
    set config(zaxis,properties)       $config(axis,properties)
    set config(margin,properties)      {left right top bottom}
    set config(title,properties)       {textcolor font anchor}
    set config(text,properties)        {textcolor font anchor}
    set config(labels,properties)      {textcolor font}
    set config(background,properties)  {outercolor innercolor}
    set config(legend,properties)      {background border position}

    # TODO: default values
    canvas .invisibleCanvas
    set invisibleLabel [.invisibleCanvas create text 0 0 -text ""]

    set _color      "black"
    set _font       [.invisibleCanvas itemcget $invisibleLabel -font]
    set _thickness  1
    set _format     ""
    set _ticklength 3
    set _textcolor  "black"
    set _anchor     n
    set _left       80
    set _right      40
    set _top        28
    set _bottom     30
    set _bgcolor    "white"
    set _outercolor "white"
    set _innercolor "white"  ;# Not implemented yet: "$w lower data" gets in the way
    set _background "white"
    set _border     "black"
    set _position   "top-right"

    destroy .invisibleCanvas

    foreach type $config(charttypes) {
        foreach comp $config($type,components) {
            foreach prop $config($comp,properties) {
                set config($type,$comp,$prop)         [set _$prop]
                set config($type,$comp,$prop,default) [set _$prop]
            }
        }
    }
}

# plotconfig --
#     Set or query general configuration options of Plotchart
#
# Arguments:
#     charttype         Type of plot or chart or empty (optional)
#     component         Component of the type of plot or chart or empty (optional)
#     property          Property of the component or empty (optional)
#     value             New value of the property if given (optional)
#                       (if "default", default is restored)
#
# Result:
#     No arguments: list of supported chart types
#     Only chart type given: list of components for that type
#     Chart type and component given: list of properties for that component
#     Chart type, component and property given: current value
#     If a new value is given, nothing
#
# Note:
#     The command contains a lot of functionality, but its structure is
#     fairly simple. No property has an empty string as a sensible value.
#
proc ::Plotchart::plotconfig {{charttype {}} {component {}} {property {}} {value {}}} {
    variable config

    if { $charttype == {} } {
        return $config(charttypes)
    } else {
        if { [lsearch $config(charttypes) $charttype] < 0 } {
            return -code error "Unknown chart type - $charttype"
        }
    }

    if { $component == {} } {
        return $config($charttype,components)
    } else {
        if { [lsearch $config($charttype,components) $component] < 0 } {
            return -code error "Unknown component '$component' for this chart type - $charttype"
        }
    }

    if { $property == {} } {
        return $config($component,properties)
    } else {
        if { [lsearch $config($component,properties) $property] < 0 } {
            return -code error "Unknown property '$property' for this component '$component' (chart: $charttype)"
        }
    }

    if { $value == {} } {
        return $config($charttype,$component,$property)
    } elseif { $value == "default" } {
        set config($charttype,$component,$property) \
            $config($charttype,$component,$property,default)
        return $config($charttype,$component,$property)
    } else {
        if { $value == "none" } {
            set value ""
        }
        set config($charttype,$component,$property) $value
    }
}

# CopyConfig --
#     Copy the configuration options to a particular plot/chart
#
# Arguments:
#     charttype         Type of plot or chart
#     chart             Widget of the actual chart
#
# Result:
#     None
#
# Side effects:
#     The configuration options are available for the particular plot or
#     chart and can be modified specifically for that plot or chart.
#
proc ::Plotchart::CopyConfig {charttype chart} {
    variable config

    foreach {prop value} [array get config $charttype,*] {
        set chprop [string map [list $charttype, $chart,] $prop]
        set config($chprop) $value
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































Deleted scriptlibs/tklib0.5/plotchart/plotcontour.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
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
981
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
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
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
1210
1211
1212
1213
1214
1215
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
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
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
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
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
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
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
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
# plotcontour.tcl --
#     Contour plotting test program for the Plotchart package
#
#  Author: Mark Stucky
#
#  The basic idea behind the method used for contouring within this sample
#  is primarily based on :
#
#    (1) "Contour Plots of Large Data Sets" by Chris Johnston
#        Computer Language, May 1986
#
#  a somewhat similar method was also described in
#
#    (2) "A Contouring Subroutine" by Paul D. Bourke
#        BYTE, June 1987
#        http://astronomy.swin.edu.au/~pbourke/projection/conrec/
#
#  In (1) it is assumed that you have a N x M grid of data that you need
#  to process.  In order to generate a contour, each cell of the grid
#  is handled without regard to it's neighbors.  This is unlike many other
#  contouring algorithms that follow the current contour line into
#  neighboring cells in an attempt to produce "smoother" contours.
#
#  In general the method described is:
#
#     1) for each four cornered cell of the grid,
#        calculate the center of the cell (average of the four corners)
#
#           data(i  ,j)   : Point (1)
#           data(i+1,j)   : Point (2)
#           data(i+1,j+1) : Point (3)
#           data(i  ,j+1) : Point (4)
#           center        : Point (5)
#
#               (4)-------------(3)
#                | \           / |
#                |  \         /  |
#                |   \       /   |
#                |    \     /    |
#                |     \   /     |
#                |      (5)      |
#                |     /   \     |
#                |    /     \    |
#                |   /       \   |
#           ^    |  /         \  |
#           |    | /           \ |
#           J   (1)-------------(2)
#
#                I ->
#
#        This divides the cell into four triangles.
#
#     2) Each of the five points in the cell can be assigned a sign (+ or -)
#        depending upon whether the point is above (+) the current contour
#        or below (-).
#
#        A contour will cross an edge whenever the points on the boundary of
#        the edge are of an opposite sign.
#
#        A few examples :
#
#           (-)     (-)        (-)  |  (+)       (-)     (-)        (+)  |  (-)
#                                    \                _                   \
#                                     \              /  \                  \
#               (-)  -             (-) |          _ /(+) |           -  (+)  -
#                  /                  /                 /              \
#                 /                 /                  /                \
#           (-)  |  (+)        (-)  |  (+)       (+)  |  (-)        (-)  |  (+)
#
#
#        (Hopefully the "rough" character diagrams above give you the
#        general idea)
#
#        It turns out that there are 32 possibles combinations of + and -
#        and therefore 32 basic paths through the cell.  And if you swap
#        the (+) and (-) in the diagram above, the "same" basic path is
#        generated:
#
#           (+)     (+)        (+)  |  (-)       (+)     (+)        (-)  |  (+)
#                                    \                _                   \
#                                     \              /  \                  \
#               (+)  -             (+) |          _ /(-) |           -  (-)  -
#                  /                  /                 /              \
#                 /                 /                  /                \
#           (+)  |  (-)        (+)  |  (-)       (-)  |  (+)        (+)  |  (-)
#
#
#        So, it turns out that there are 16 basic paths through the cell.
#
###############################################################################
#
#  The original article/code worked on all four triangles together and
#  generated one of the 16 paths.
#
#  For this version of the code, I split the cell into the four triangles
#  and handle each triangle individually.
#
#  Doing it this way is slower than the above method for calculating the
#  contour lines.  But since it "simplifies" the code when doing "color filled"
#  contours, I opted for the longer calculation times.
#
#
# AM:
# Introduce the following methods in createXYPlot:
# - grid            Draw the grid (x,y needed)
# - contourlines    Draw isolines (x,y,z needed)
# - contourfill     Draw shades (x,y,z needed)
# - contourbox      Draw uniformly coloured cells (x,y,z needed)
#
# This needs still to be done:
# - colourmap       Set colours to be used (possibly interpolated)
#
# Note:
# To get the RGB values of a named colour:
# winfo rgb . color (divide by 256)
#
# The problem:
# What interface do we use?
#
# Changes:
# - Capitalised several proc names (to indicate they are private to
#   the Plotchart package)
# - Changed the data structure from an array to a list of lists.
#   This means:
#   - No confusion about the start of indices
#   - Lists can be passed as ordinary arguments
#   - In principle they are faster, but that does not really
#     matter here
# To do:
# - Absorb all global arrays into the Plotchart system of private data
# - Get rid of the bug in the shades algorithm ;)
#

# DrawGrid --
#     Draw the grid as contained in the lists of coordinates
# Arguments:
#     w           Canvas to draw in
#     x           X-coordinates of grid points (list of lists)
#     y           Y-coordinates of grid points (list of lists)
# Result:
#     None
# Side effect:
#     Grid drawn as lines between the vertices
# Note:
#     STILL TO DO
#     A cell is only drawn if there are four well-defined
#     corners. If the x or y coordinate is missing, the cell is
#     skipped.
#
proc ::Plotchart::DrawGrid {w x y} {

    set maxrow [llength $x]
    set maxcol [llength [lindex $x 0]]

    for {set i 0} {$i < $maxrow} {incr i} {
        set xylist {}
        for {set j 0} {$j < $maxcol} {incr j} {
            lappend xylist [lindex $x $i $j] [lindex $y $i $j]
        }
        C_line $w $xylist black
    }

    for {set j 0} {$j < $maxcol} {incr j} {
        set xylist {}
        for {set i 0} {$i < $maxrow} {incr i} {
            lappend xylist [lindex $x $i $j] [lindex $y $i $j]
        }
        C_line $w $xylist black
    }
}

# DrawIsolines --
#     Draw isolines in the given grid
# Arguments:
#     canv        Canvas to draw in
#     x           X-coordinates of grid points (list of lists)
#     y           Y-coordinates of grid points (list of lists)
#     f           Values of the parameter on the grid cell corners
#     cont        List of contour classes (or empty to indicate
#                 automatic scaling
# Result:
#     None
# Side effect:
#     Isolines drawn
# Note:
#     A cell is only drawn if there are four well-defined
#     corners. If the x or y coordinate is missing or the value is
#     missing, the cell is skipped.
#
proc ::Plotchart::DrawIsolines {canv x y f {cont {}} } {
    variable contour_options

    set contour_options(simple_box_contour) 0
    set contour_options(filled_contour) 0

#   DrawContour $canv $x $y $f 0.0 100.0 20.0
    DrawContour $canv $x $y $f $cont
}

# DrawShades --
#     Draw filled contours in the given grid
# Arguments:
#     canv        Canvas to draw in
#     x           X-coordinates of grid points (list of lists)
#     y           Y-coordinates of grid points (list of lists)
#     f           Values of the parameter on the grid cell corners
#     cont        List of contour classes (or empty to indicate
#                 automatic scaling
# Result:
#     None
# Side effect:
#     Shades (filled contours) drawn
# Note:
#     A cell is only drawn if there are four well-defined
#     corners. If the x or y coordinate is missing or the value is
#     missing, the cell is skipped.
#
proc ::Plotchart::DrawShades {canv x y f {cont {}} } {
    variable contour_options

    set contour_options(simple_box_contour) 0
    set contour_options(filled_contour) 1

#   DrawContour $canv $x $y $f 0.0 100.0 20.0
    DrawContour $canv $x $y $f $cont
}

# DrawBox --
#     Draw filled cells in the given grid (colour chosen according
#     to the _average_ of the four corner values)
# Arguments:
#     canv        Canvas to draw in
#     x           X-coordinates of grid points (list of lists)
#     y           Y-coordinates of grid points (list of lists)
#     f           Values of the parameter on the grid cell corners
#     cont        List of contour classes (or empty to indicate
#                 automatic scaling
# Result:
#     None
# Side effect:
#     Filled cells (quadrangles) drawn
# Note:
#     A cell is only drawn if there are four well-defined
#     corners. If the x or y coordinate is missing or the value is
#     missing, the cell is skipped.
#
proc ::Plotchart::DrawBox {canv x y f {cont {}} } {
    variable contour_options

    set contour_options(simple_box_contour) 1
    set contour_options(filled_contour) 0

#   DrawContour $canv $x $y $f 0.0 100.0 20.0
    DrawContour $canv $x $y $f $cont
}

# Draw3DFunctionContour --
#    Plot a function of x and y with a color filled contour
# Arguments:
#    w           Name of the canvas
#    function    Name of a procedure implementing the function
#    cont        contour levels
# Result:
#    None
# Side effect:
#    The plot of the function - given the grid
#
proc ::Plotchart::Draw3DFunctionContour { w function {cont {}} } {
    variable scaling
    variable contour_options

    set contour_options(simple_box_contour) 0
    set contour_options(filled_contour) 1
    set noTrans 0

    ::Plotchart::setColormapColors  [llength $cont]

    set nxcells $scaling($w,nxcells)
    set nycells $scaling($w,nycells)
    set xmin    $scaling($w,xmin)
    set xmax    $scaling($w,xmax)
    set ymin    $scaling($w,ymin)
    set ymax    $scaling($w,ymax)
    set dx      [expr {($xmax-$xmin)/double($nxcells)}]
    set dy      [expr {($ymax-$ymin)/double($nycells)}]

    foreach {fill border} $scaling($w,colours) {break}

    #
    # Draw the quadrangles making up the plot in the right order:
    # first y from minimum to maximum
    # then x from maximum to minimum
    #
    for { set j 0 } { $j < $nycells } { incr j } {
        set y1 [expr {$ymin + $dy*$j}]
        set y2 [expr {$y1   + $dy}]
        for { set i $nxcells } { $i > 0 } { incr i -1 } {
            set x2 [expr {$xmin + $dx*$i}]
            set x1 [expr {$x2   - $dx}]

            set z11 [$function $x1 $y1]
            set z12 [$function $x1 $y2]
            set z21 [$function $x2 $y1]
            set z22 [$function $x2 $y2]

            foreach {px11 py11} [coords3DToPixel $w $x1 $y1 $z11] {break}
            foreach {px12 py12} [coords3DToPixel $w $x1 $y2 $z12] {break}
            foreach {px21 py21} [coords3DToPixel $w $x2 $y1 $z21] {break}
            foreach {px22 py22} [coords3DToPixel $w $x2 $y2 $z22] {break}

            set xb [list $px11 $px21 $px22 $px12]
            set yb [list $py11 $py21 $py22 $py12]
            set fb [list $z11  $z21  $z22  $z12 ]

            Box_contour $w $xb $yb $fb $cont $noTrans

            $w create line $px11 $py11 $px21 $py21 $px22 $py22 \
                           $px12 $py12 $px11 $py11 \
                           -fill $border
      }
   }
}


# DrawContour --
#     Routine that loops over the grid and delegates the actual drawing
# Arguments:
#     canv        Canvas to draw in
#     x           X-coordinates of grid points (list of lists)
#     y           Y-coordinates of grid points (list of lists)
#     f           Values of the parameter on the grid cell corners
#     cont        List of contour classes (or empty to indicate
#                 automatic scaling)
# Result:
#     None
# Side effect:
#     Isolines, shades or boxes drawn
# Note:
#     A cell is only drawn if there are four well-defined
#     corners. If the x or y coordinate is missing or the value is
#     missing, the cell is skipped.
#
proc ::Plotchart::DrawContour {canv x y f cont} {
    variable contour_options
    variable colorMap

    #
    # Construct the class-colour list
    #
    set cont [MakeContourClasses $f $cont]

    set fmin  [lindex $cont 0 0]
    set fmax  [lindex $cont end 0]
    set ncont [llength $cont]

    # Now that we know how many entries (ncont), create
    # the colormap colors
    #
    # I moved this into MakeContourClasses...
    #    ::Plotchart::setColormapColors  $ncont

    set maxrow [llength $x]
    set maxcol [llength [lindex $x 0]]

    for {set i 0} {$i < $maxrow-1} {incr i} {
        set i1 [expr {$i + 1}]
        for {set j 0} {$j < $maxcol-1} {incr j} {
            set j1 [expr {$j + 1}]

            set x1 [lindex $x $i1 $j]
            set x2 [lindex $x $i $j]
            set x3 [lindex $x $i $j1]
            set x4 [lindex $x $i1 $j1]

            set y1 [lindex $y $i1 $j]
            set y2 [lindex $y $i $j]
            set y3 [lindex $y $i $j1]
            set y4 [lindex $y $i1 $j1]

            set f1 [lindex $f $i1 $j]
            set f2 [lindex $f $i $j]
            set f3 [lindex $f $i $j1]
            set f4 [lindex $f $i1 $j1]

            set xb [list $x1 $x2 $x3 $x4]
            set yb [list $y1 $y2 $y3 $y4]
            set fb [list $f1 $f2 $f3 $f4]

            if { [lsearch $fb {}] >= 0 ||
                 [lsearch $xb {}] >= 0 ||
                 [lsearch $yb {}] >= 0    } {
                continue
            }

            Box_contour $canv $xb $yb $fb $cont
        }
    }
}

# Box_contour --
#     Draw a filled box
# Arguments:
#     canv        Canvas to draw in
#     xb          X-coordinates of the four corners
#     yb          Y-coordinates of the four corners
#     fb          Values of the parameter on the four corners
#     cont        List of contour classes and colours
# Result:
#     None
# Side effect:
#     Box drawn for a single cell
#
proc ::Plotchart::Box_contour {canv xb yb fb cont {doTrans 1}} {
    variable colorMap
    variable contour_options

    foreach {x1 x2 x3 x4} $xb {}
    foreach {y1 y2 y3 y4} $yb {}
    foreach {f1 f2 f3 f4} $fb {}

    set xc [expr {($x1 + $x2 + $x3 + $x4) * 0.25}]
    set yc [expr {($y1 + $y2 + $y3 + $y4) * 0.25}]
    set fc [expr {($f1 + $f2 + $f3 + $f4) * 0.25}]

    if {$contour_options(simple_box_contour)} {

        set fmin  [lindex $cont 0]
        set fmax  [lindex $cont end]
        set ncont [llength $cont]

        set ic 0
        for {set i 0} {$i < $ncont} {incr i} {
            set ff [lindex $cont $i 0]
            if {$ff <= $fc} {
                set ic $i
            }
        }

        set xylist [list $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4]

        # canvasPlot::polygon $win $xylist -fill $cont($ic,color)
        ###        C_polygon $canv $xylist $cont($ic,color)
        C_polygon $canv $xylist [lindex $cont $ic 1]

    } else {

#debug#        puts "Tri_contour 1)"
        Tri_contour $canv $x1 $y1 $f1 $x2 $y2 $f2 $xc $yc $fc $cont $doTrans

#debug#        puts "Tri_contour 2)"
        Tri_contour $canv $x2 $y2 $f2 $x3 $y3 $f3 $xc $yc $fc $cont $doTrans

#debug#        puts "Tri_contour 3)"
        Tri_contour $canv $x3 $y3 $f3 $x4 $y4 $f4 $xc $yc $fc $cont $doTrans

#debug#        puts "Tri_contour 4)"
        Tri_contour $canv $x4 $y4 $f4 $x1 $y1 $f1 $xc $yc $fc $cont $doTrans

    }

}

# Tri_contour --
#     Draw isolines or shades in a triangle
# Arguments:
#     canv        Canvas to draw in
#     x1,x2,x3    X-coordinate  of the three corners
#     y1,y2,y3    Y-coordinates of the three corners
#     f1,f2,f3    Values of the parameter on the three corners
#     cont        List of contour classes and colours
# Result:
#     None
# Side effect:
#     Isolines/shades drawn for a single triangle
#
proc ::Plotchart::Tri_contour { canv x1 y1 f1 x2 y2 f2 x3 y3 f3 cont {doTrans 1} } {
    variable contour_options
    variable colorMap

    set ncont [llength $cont]


    # Find the min/max function values for this triangle
    #
    set tfmin  [min $f1 $f2 $f3]
    set tfmax  [max $f1 $f2 $f3]

    # Based on the above min/max, figure out which
    # contour levels/colors that bracket this interval
    #
    set imin 0
    set imax 0   ;#mbs#
    for {set i 0} {$i < $ncont} {incr i} {
        set ff [lindex $cont $i]           ; ### set ff $cont($i,fval)
        if {$ff <= $tfmin} {
            set imin $i
            set imax $i
        }
        if { $ff <= $tfmax} {
            set imax $i
        }
    }

    set vertlist {}

    # Loop over all contour levels of interest for this triangle
    #
    for {set ic $imin} {$ic <= $imax} {incr ic} {

        # Get the value for this contour level
        #
        set ff [lindex $cont $ic 0]         ;###  set ff $cont($ic,fval)

        set xylist   {}
        set pxylist  {}

        # Classify the triangle based on whether the functional values, f1,f2,f3
        # are above (+), below (-), or equal (=) to the current contour level ff
        #
        set s1 [::Plotchart::setFLevel $f1 $ff]
        set s2 [::Plotchart::setFLevel $f2 $ff]
        set s3 [::Plotchart::setFLevel $f3 $ff]

        set class "$s1$s2$s3"

        # Describe class here...

        # ( - - - )   : Case A,
        # ( - - = )   : Case B, color a point, do nothing
        # ( - - + )   : Case C, contour between {23}-{31}
        # ( - = - )   : Case D, color a point, do nothing
        # ( - = = )   : Case E, contour line between 2-3
        # ( - = + )   : Case F, contour between 2-{31}
        # ( - + - )   : Case G, contour between {12}-{23}
        # ( - + = )   : Case H, contour between {12}-3
        # ( - + + )   : Case I, contour between {12}-{31}
        # ( = - - )   : Case J, color a point, do nothing
        # ( = - = )   : Case K, contour line between 1-3
        # ( = - + )   : Case L, contour between 1-{23}
        # ( = = - )   : Case M, contour line between 1-2
        # ( = = = )   : Case N, fill full triangle, return
        # ( = = + )   : Case M,
        # ( = + - )   : Case L,
        # ( = + = )   : Case K,
        # ( = + + )   : Case J,
        # ( + - - )   : Case I,
        # ( + - = )   : Case H,
        # ( + - + )   : Case G,
        # ( + = - )   : Case F,
        # ( + = = )   : Case E,
        # ( + = + )   : Case D,
        # ( + + - )   : Case C,
        # ( + + = )   : Case B,
        # ( + + + )   : Case A,


        switch -- $class {

            ############### Case A ###############

            "---" {
#debug#                puts "class A = $class , $ic , $ff"
                if {$contour_options(filled_contour)} {
                    set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                return
            }

            "+++" {
#debug#                puts "class A = $class , $ic , $ff"
                if {$contour_options(filled_contour)} {
                    if {$ic == $imax} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }
            }

            ############### Case N ###############

            "===" {
#debug#                puts "class N = $class , $ic , $ff"
                if {$contour_options(filled_contour)} {
                    set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                return
            }

            ############### Case B ###############

            "--=" {
#debug#                puts "class B = $class , $ic , $ff"
                if {$contour_options(filled_contour)} {
                    set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                return
            }

            "++=" {
#debug#                puts "class B= $class , $ic , $ff , do nothing unless ic == imax"
                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }
            }

            ############### Case D ###############

            "-=-" {
#debug#                puts "class D = $class , $ic , $ff"
                if {$contour_options(filled_contour)} {
                    set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                return
            }

            "+=+" {
#debug#                puts "class D = $class , $ic , $ff , do nothing unless ic == imax"
                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }
            }

            ############### Case J ###############

            "=--" {
#debug#                puts "class J = $class , $ic , $ff"
                if {$contour_options(filled_contour)} {
                    set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                return
            }

            "=++" {
#debug#                puts "class J = $class , $ic , $ff , do nothing unless ic == imax"
                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }
            }

            ############### Case K ###############

            "=-=" {
#debug#                puts "class K = $class , $ic , $ff"
                set xylist [list $x1 $y1 $x3 $y3]
                if {$contour_options(filled_contour)} {
                    set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                return

            }

            "=+=" {
#debug#                puts "class K = $class , $ic , $ff"
                set xylist [list $x1 $y1 $x3 $y3]
                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                    C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                } else {
                    C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                }
            }

            ############### Case E ###############

            "-==" {
#debug#                puts "class E = $class , $ic , $ff"
                set xylist [list $x2 $y2 $x3 $y3]
                if {$contour_options(filled_contour)} {
                    set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                return
            }

            "+==" {
#debug#                puts "class E = $class , $ic , $ff"
                set xylist [list $x2 $y2 $x3 $y3]
                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                    C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                } else {
                    C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                }
            }

            ############### Case M ###############

            "==-" {
#debug#                puts "class M = $class , $ic , $ff"
                set xylist [list $x1 $y1 $x2 $y2]
                if {$contour_options(filled_contour)} {
                    set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                return
            }

            "==+" {
#debug#                puts "class M = $class , $ic , $ff"
                set xylist [list $x1 $y1 $x2 $y2]
                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                    C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                } else {
                    C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                }

            }

            ############### Case F ###############

            "-=+" {
#debug#                puts "class F = $class , $ic , $ff"
                set xylist [list $x2 $y2]
                set xyf2  [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff]
                foreach {xx yy} $xyf2 {}
                lappend xylist $xx $yy

                if {$contour_options(filled_contour)} {
                        set pxylist $xylist
                        lappend pxylist $x1 $y1
                        C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                set x1 $xx; set y1 $yy; set f1 $ff

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }

            }

            "+=-" {
#debug#                puts "class F = $class , $ic , $ff"
                set xylist [list $x2 $y2]
                set xyf2  [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff]
                foreach {xx yy} $xyf2 {}
                lappend xylist $xx $yy

                if {$contour_options(filled_contour)} {
                        set pxylist $xylist
                        lappend pxylist $x3 $y3
                        C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                set x3 $xx; set y3 $yy; set f3 $ff

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }

            }

            ############### Case H ###############

            "-+=" {
#debug#                puts "class H = $class , $ic , $ff"
                set xylist [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff]
                foreach {xx yy} $xylist {}
                lappend xylist $x3 $y3

                if {$contour_options(filled_contour)} {
                        set pxylist $xylist
                        lappend pxylist $x1 $y1
                        C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                set x1 $xx; set y1 $yy; set f1 $ff

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }

            }

            "+-=" {
#debug#                puts "class H = $class , $ic , $ff"
                set xylist [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff]
                foreach {xx yy} $xylist {}
                lappend xylist $x3 $y3
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                if {$contour_options(filled_contour)} {
                        set pxylist $xylist
                        lappend pxylist $x2 $y2
                        C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                set x2 $xx; set y2 $yy; set f2 $ff

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }

            }

            ############### Case L ###############

            "=-+" {
#debug#                puts "class L = $class , $ic , $ff"
                set xylist [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff]
                foreach {xx yy} $xylist {}
                lappend xylist $x1 $y1
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                if {$contour_options(filled_contour)} {
                        set pxylist $xylist
                        lappend pxylist $x2 $y2
                        C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                set x2 $xx; set y2 $yy; set f2 $ff

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }

            }

            "=+-" {
#debug#                puts "class L = $class , $ic , $ff"
                set xylist [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff]
                foreach {xx yy} $xylist {}
                lappend xylist $x1 $y1
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                if {$contour_options(filled_contour)} {
                        set pxylist $xylist
                        lappend pxylist $x3 $y3
                        C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans

                set x3 $xx; set y3 $yy; set f3 $ff

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }

            }

            ############### Case C ###############

            "--+" {
#debug#                puts "class C = $class , $ic , $ff"
                set xyf1  [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff]
                set xyf2  [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff]
                set xylist $xyf1
                foreach {xx1 yy1} $xyf1 {}
                foreach {xx2 yy2} $xyf2 {}
                lappend xylist $xx2 $yy2
                if {$contour_options(filled_contour)} {
                    set pxylist $xylist
                    lappend pxylist $x1 $y1 $x2 $y2
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                    if {$ic == $imax} {
                        set pxylist $xylist
                        lappend pxylist $x3 $y3
                        C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                    }
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                set oldlist {}
                set x1 $xx1; set y1 $yy1; set f1 $ff
                set x2 $xx2; set y2 $yy2; set f2 $ff
                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }
            }

            "++-" {
#debug#                puts "class C = $class , $ic , $ff"
                set xyf1  [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff]
                set xyf2  [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff]
                set xylist $xyf1
                foreach {xx1 yy1} $xyf1 {}
                foreach {xx2 yy2} $xyf2 {}
                lappend xylist $xx2 $yy2
                if {$contour_options(filled_contour)} {
                    set pxylist $xylist
                    lappend pxylist $x3 $y3
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist $xylist
                        lappend pxylist $x1 $y1 $x2 $y2
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                    }

                } else {

#debug#                    puts "call Tri_contour : 1) $class"
#debug#                    puts "   : $xx1 $yy1 $ff $xx2 $yy2 $ff $x1 $y1 $f1"
                    Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x1 $y1 $f1 $cont $doTrans

#debug#                    puts "call Tri_contour : 2) $class"
#debug#                    puts "   : $xx1 $yy1 $ff $x1 $y1 $f1 $x2 $y2 $f2"
                    Tri_contour $canv $xx1 $yy1 $ff $x1 $y1 $f1 $x2 $y2 $f2 $cont $doTrans

                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                return

            }

            ############### Case G ###############

            "-+-" {
#debug#                puts "class G = $class , $ic , $ff"
                set xyf1  [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff]
                set xyf2  [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff]
                set xylist $xyf1
                foreach {xx1 yy1} $xyf1 {}
                foreach {xx2 yy2} $xyf2 {}
                lappend xylist $xx2 $yy2
                if {$contour_options(filled_contour)} {
                    set pxylist $xylist
                    lappend pxylist $x3 $y3 $x1 $y1
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                    if {$ic == $imax} {
                        set pxylist $xylist
                        lappend pxylist $x2 $y2
                        C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                    }
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                set oldlist {}
                set x1 $xx1; set y1 $yy1; set f1 $ff
                set x3 $xx2; set y3 $yy2; set f3 $ff

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }

            }

            "+-+" {
#debug#                puts "class G = $class , $ic , $ff"
                set xyf1  [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff]
                set xyf2  [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff]
                foreach {xx1 yy1} $xyf1 {}
                foreach {xx2 yy2} $xyf2 {}
                set xylist $xyf1
                lappend xylist $xx2 $yy2
                if {$contour_options(filled_contour)} {
                    set pxylist $xylist
                    lappend pxylist $x2 $y2
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist $xylist
                        lappend pxylist $x3 $y3 $x1 $y1
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                    }

                } else {

#debug#                    puts "call Tri_contour : 1) $class"
#debug#                    puts "   : $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3"
                    Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3 $cont $doTrans

#debug#                    puts "call Tri_contour : 2) $class"
#debug#                    puts "   : $xx1 $yy1 $ff $x3 $y3 $f3 $x1 $y1 $f1"
                    Tri_contour $canv $xx1 $yy1 $ff $x3 $y3 $f3 $x1 $y1 $f1 $cont $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                return

            }

            ############### Case I ###############

            "+--" {
#debug#                puts "class I = $class , $ic , $ff"
                set xyf1  [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff]
                set xyf2  [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff]
                set xylist $xyf1
                foreach {xx1 yy1} $xyf1 {}
                foreach {xx2 yy2} $xyf2 {}
                lappend xylist $xx2 $yy2
                if {$contour_options(filled_contour)} {
                    set pxylist $xylist
                    lappend pxylist $x3 $y3 $x2 $y2
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                    if {$ic == $imax} {
                        set pxylist $xylist
                        lappend pxylist $x1 $y1
                        C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                    }
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                set oldlist {}
                set x2 $xx1; set y2 $yy1; set f2 $ff
                set x3 $xx2; set y3 $yy2; set f3 $ff

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3]
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                        return
                    }
                }

            }

            "-++" {
#debug#                puts "class I = $class , $ic , $ff"
                set xyf1  [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff]
                set xyf2  [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff]
                foreach {xx1 yy1} $xyf1 {}
                foreach {xx2 yy2} $xyf2 {}
                set xylist $xyf1
                lappend xylist $xx2 $yy2
                if {$contour_options(filled_contour)} {
                    set pxylist $xylist
                    lappend pxylist $x1 $y1
                    C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans
                }

                if {$ic == $imax} {
                    if {$contour_options(filled_contour)} {
                        set pxylist $xylist
                        lappend pxylist $x3 $y3 $x2 $y2
                        set ictmp [expr {$ic + 1}]
                        C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans
                    }

                } else {

#debug#                    puts "call Tri_contour : 1) $class"
#debug#                    puts "   : $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3"
                    Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3 $cont $doTrans

#debug#                    puts "call Tri_contour : 2) $class"
#debug#                    puts "   : $xx1 $yy1 $ff $x3 $y3 $f3 $x2 $y2 $f2"
                    Tri_contour $canv $xx1 $yy1 $ff $x3 $y3 $f3 $x2 $y2 $f2 $cont $doTrans
                }
                C_line $canv $xylist [lindex $colorMap $ic] $doTrans
                return

            }

        }

    }
}

# setFLevel --
#     Auxiliary function: used to classify one functional value to another
# Arguments:
#     f1          Second break point and value
#     f2          Value to find
# Result:
#     +    f1 > f2
#     =    f1 = f2
#     -    f1 < f2
#
proc ::Plotchart::setFLevel {f1 f2} {
    if {$f1 > $f2} {
        return "+"
    } else {
        if {$f1 < $f2} {
            return "-"
        } else {
            return "="
        }
    }
}

# fintpl --
#     Auxiliary function: inverse interpolation
# Arguments:
#     x1,y1,f1    First break point and value
#     x2,y2,f2    Second break point and value
#     ff          Value to find
# Result:
#     x,y coordinates of point with that value
#
proc ::Plotchart::fintpl {x1 y1 f1 x2 y2 f2 ff} {

    if {[expr {$f2 - $f1}] != 0.0} {
        set xx  [expr {$x1 + (($ff - $f1)*($x2 - $x1)/($f2 - $f1))}]
        set yy  [expr {$y1 + (($ff - $f1)*($y2 - $y1)/($f2 - $f1))}]
    } else {

        # If the logic was handled correctly above, this point
        # should never be reached.
        #
        # puts "FINTPL : f1 == f2 : x1,y1 : $x1 , $y1 : x2,y2 : $x2 , $y2"
        set xx $x1
        set yy $y1
    }

    set xmin [min $x1 $x2]
    set xmax [max $x1 $x2]
    set ymin [min $y1 $y2]
    set ymax [max $y1 $y2]

    if {$xx < $xmin} { set xx $xmin }
    if {$xx > $xmax} { set xx $xmax }
    if {$yy < $ymin} { set yy $ymin }
    if {$yy > $ymax} { set yy $ymax }

    return [list $xx $yy]
}

# min --
#     Auxiliary function: find the minimum of the arguments
# Arguments:
#     val         First value
#     args        All others
# Result:
#     Minimum over the arguments
#
proc ::Plotchart::min { val args } {
    set min $val
    foreach val $args {
        if { $val < $min } {
            set min $val
        }
    }
    return $min
}

# max --
#     Auxiliary function: find the maximum of the arguments
# Arguments:
#     val         First value
#     args        All others
# Result:
#     Maximum over the arguments
#
proc ::Plotchart::max { val args } {
    set max $val
    foreach val $args {
        if { $val > $max } {
            set max $val
        }
    }
    return $max
}

# C_line --
#     Draw a line
# Arguments:
#     canv        Canvas to draw in
#     xylist      List of raw coordinates
#     color       Chosen colour
#     args        Any additional arguments (for line style and such)
# Result:
#     None
#
proc ::Plotchart::C_line {canv xylist color {doTrans 1} } {

    if {$doTrans} {
        set wxylist {}
        foreach {xx yy} $xylist {
            foreach {pxcrd pycrd} [::Plotchart::coordsToPixel $canv $xx $yy] {break}
            lappend wxylist $pxcrd $pycrd
        }
        eval "$canv create line $wxylist -fill $color"

    } else {
        $canv create line $xylist -fill $color
    }
}

# C_polygon --
#     Draw a polygon
# Arguments:
#     canv        Canvas to draw in
#     xylist      List of raw coordinates
#     color       Chosen colour
#     args        Any additional arguments (for line style and such)
# Result:
#     None
#
proc ::Plotchart::C_polygon {canv xylist color {doTrans 1}} {

    if {$doTrans} {
        set wxylist {}
        foreach {xx yy} $xylist {
            foreach {pxcrd pycrd} [::Plotchart::coordsToPixel $canv $xx $yy] {break}
            lappend wxylist $pxcrd $pycrd
        }
        eval "$canv create polygon $wxylist -fill $color"

    } else {
        $canv create polygon $xylist -fill $color
    }
}

# MakeContourClasses --
#     Return contour classes and colours
# Arguments:
#     values      List of values
#     classes     Given list of classes or class/colours
# Result:
#     List of pairs of class limits and colours
# Note:
#     This should become more sophisticated!
#
proc ::Plotchart::MakeContourClasses {values classes} {
    variable contour_options
    variable colorMap

    if { [llength $classes] == 0 } {
        set min {}
        set max {}
        foreach row $values {
            foreach v $row {
                if { $v == {} } {continue}

                if { $min == {} || $min > $v } {
                    set min $v
                }

                if { $max == {} || $max < $v } {
                    set max $v
                }
            }
        }

        foreach {xmin xmax xstep} [determineScale $min $max] {break}

        #
        # The contour classes must encompass all values
        # There might be a problem with border cases
        #
        set classes {}
        set x $xmin

        while { $x < $xmax+0.5*$xstep } {
            #mbs# lappend classes [list $x]
            set  x [expr {$x+$xstep}]
            lappend classes [list $x]
        }

        # Now that we know how many entries (ncont), create
        # the colormap colors
        #
        ::Plotchart::setColormapColors  [expr [llength $classes] + 1]

    } elseif { [llength [lindex $classes 0]] == 1 } {
        #mbs#  Changed the above line from " == 2 " to " == 1 "
        ::Plotchart::setColormapColors  [llength $classes]
        return $classes
    }

    #
    # Add the colours
    #
#####    set cont {}
#####    set c 0
#####
#####    foreach x $classes {
#####        set col [lindex $contour_options(colourmap) $c]
#####        if { $col == {} } {
#####            set c 0
#####            set col [lindex $contour_options(colourmap) $c]
#####        }
#####        lappend cont [list $x $col]
#####        incr c
#####    }
#####
#####    return $cont

    puts "classes (cont) : $classes"

    return $classes
}


# setColormapColors --
#     Auxiliary function: Based on the current colormap type
#     create a colormap with requested number of entries
# Arguments:
#     ncont       Number of colors in the colormap
# Result:
#     List of colours
#
proc ::Plotchart::setColormapColors  {ncont} {
    variable colorMapType
    variable colorMap

#debug#    puts "SetColormapColors : ncont = $ncont"

    # Note : The default colormap is "jet"

    switch $colorMapType {

        custom {
            return
        }

        hsv {
            set hueStart     0.0
            set hueEnd     240.0
            set colorMap   {}

            for {set i 0} {$i <= $ncont} {incr i} {
                set dh [expr {($hueStart - $hueEnd) / ($ncont - 1)}]
                set hue  [expr {$hueStart - ($i * $dh)}]
                if {$hue < 0.0} {
                    set hue  [expr {360.0 + $hue}]
                }
                set rgbList [Hsv2rgb $hue 1.0 1.0]
                set r    [expr {int([lindex $rgbList 0] * 65535)}]
                set g    [expr {int([lindex $rgbList 1] * 65535)}]
                set b    [expr {int([lindex $rgbList 2] * 65535)}]

                set color  [format "#%.4x%.4x%.4x" $r $g $b]
                lappend colorMap $color
            }
        }

        hot {
            set colorMap {}
            set nc1          [expr {int($ncont * 0.33)}]
            set nc2          [expr {int($ncont * 0.67)}]

            for {set i 0} {$i <= $ncont} {incr i} {

                if {$i <= $nc1} {
                    set fval  [expr { double($i) / (double($nc1)) } ]
                    set r     [expr {int($fval * 65535)}]
                    set g     0
                    set b     0
                } else {
                    if {$i <= $nc2} {
                        set fval  [expr { double($i-$nc1) / (double($nc2-$nc1)) } ]
                        set r     65535
                        set g     [expr {int($fval * 65535)}]
                        set b     0
                    } else {
                        set fval  [expr { double($i-$nc2) / (double($ncont-$nc2)) } ]
                        set r     65535
                        set g     65535
                        set b     [expr {int($fval * 65535)}]
                    }
                }
                set color  [format "#%.4x%.4x%.4x" $r $g $b]
                lappend colorMap $color
            }
        }

        cool {
            set colorMap {}

            for {set i 0} {$i <= $ncont} {incr i} {

                set fval  [expr { double($i) / (double($ncont)-1) } ]
                set val   [expr { 1.0 - $fval }]

                set r    [expr {int($fval * 65535)}]
                set g    [expr {int($val * 65535)}]
                set b    65535

                set color  [format "#%.4x%.4x%.4x" $r $g $b]
                lappend colorMap $color
            }
        }

        grey -
        gray {
            set colorMap {}

            for {set i 0} {$i <= $ncont} {incr i} {

                set fval  [expr { double($i) / (double($ncont)-1) } ]
                set val  [expr {0.4 + (0.5 * $fval) }]

                set r    [expr {int($val * 65535)}]
                set g    [expr {int($val * 65535)}]
                set b    [expr {int($val * 65535)}]

                set color  [format "#%.4x%.4x%.4x" $r $g $b]
                lappend colorMap $color
            }
        }

        jet -
        default {
            set hueStart   240.0
            set hueEnd       0.0
            set colorMap   {}

            for {set i 0} {$i <= $ncont} {incr i} {
                set dh [expr {($hueStart - $hueEnd) / ($ncont - 1)}]
                set hue  [expr {$hueStart - ($i * $dh)}]
                if {$hue < 0.0} {
                    set hue  [expr {360.0 + $hue}]
                }
                set rgbList [Hsv2rgb $hue 1.0 1.0]
                set r    [expr {int([lindex $rgbList 0] * 65535)}]
                set g    [expr {int([lindex $rgbList 1] * 65535)}]
                set b    [expr {int([lindex $rgbList 2] * 65535)}]

                set color  [format "#%.4x%.4x%.4x" $r $g $b]
                lappend colorMap $color
            }
        }

    }
}

# colorMap --
#     Define the current colormap type
# Arguments:
#     cmap        Type of colormap
# Result:
#     Updated the internal variable "colorMapType"
# Note:
#     Possibly handle "custom" colormaps differently
#     At present, if the user passes in a list (length > 1)
#     rather than a string, then it is assumes that (s)he
#     passed in a list of colors.
#
proc ::Plotchart::colorMap {cmap} {
    variable colorMapType
    variable colorMap

    switch $cmap {

        "grey" -
        "gray" { set colorMapType $cmap }

        "jet"  { set colorMapType $cmap }

        "hot"  { set colorMapType $cmap }

        "cool" { set colorMapType $cmap }

        "hsv"  { set colorMapType $cmap }

        default {
            if {[string is alpha $cmap] == 1} {
                puts "Colormap : Unknown colorMapType, $cmap.  Using JET"
                set colorMapType jet

            } else {
                if {[llength $cmap] > 1} {
                    set colorMapType "custom"
                    set colorMap     $cmap
                }
            }
        }
    }
}



########################################################################
#  The following two routines were borrowed from :
#
#        http://mini.net/cgi-bin/wikit/666.html
########################################################################

# Rgb2hsv --
#
#       Convert a color value from the RGB model to HSV model.
#
# Arguments:
#       r g b  the red, green, and blue components of the color
#               value.  The procedure expects, but does not
#               ascertain, them to be in the range 0 to 1.
#
# Results:
#       The result is a list of three real number values.  The
#       first value is the Hue component, which is in the range
#       0.0 to 360.0, or -1 if the Saturation component is 0.
#       The following to values are Saturation and Value,
#       respectively.  They are in the range 0.0 to 1.0.
#
# Credits:
#       This routine is based on the Pascal source code for an
#       RGB/HSV converter in the book "Computer Graphics", by
#       Baker, Hearn, 1986, ISBN 0-13-165598-1, page 304.
#
proc ::Plotchart::Rgb2hsv {r g b} {
    set h [set s [set v 0.0]]]
    set sorted [lsort -real [list $r $g $b]]
    set v [expr {double([lindex $sorted end])}]
    set m [lindex $sorted 0]

    set dist [expr {double($v-$m)}]
    if {$v} {
        set s [expr {$dist/$v}]
    }
    if {$s} {
        set r' [expr {($v-$r)/$dist}] ;# distance of color from red
        set g' [expr {($v-$g)/$dist}] ;# distance of color from green
        set b' [expr {($v-$b)/$dist}] ;# distance of color from blue
        if {$v==$r} {
            if {$m==$g} {
                set h [expr {5+${b'}}]
            } else {
                set h [expr {1-${g'}}]
            }
        } elseif {$v==$g} {
            if {$m==$b} {
                set h [expr {1+${r'}}]
            } else {
                set h [expr {3-${b'}}]
            }
        } else {
            if {$m==$r} {
                set h [expr {3+${g'}}]
            } else {
                set h [expr {5-${r'}}]
            }
        }
        set h [expr {$h*60}]          ;# convert to degrees
    } else {
        # hue is undefined if s == 0
        set h -1
    }
    return [list $h $s $v]
}

# Hsv2rgb --
#
#       Convert a color value from the HSV model to RGB model.
#
# Arguments:
#       h s v  the hue, saturation, and value components of
#               the color value.  The procedure expects, but
#               does not ascertain, h to be in the range 0.0 to
#               360.0 and s, v to be in the range 0.0 to 1.0.
#
# Results:
#       The result is a list of three real number values,
#       corresponding to the red, green, and blue components
#       of a color value.  They are in the range 0.0 to 1.0.
#
# Credits:
#       This routine is based on the Pascal source code for an
#       HSV/RGB converter in the book "Computer Graphics", by
#       Baker, Hearn, 1986, ISBN 0-13-165598-1, page 304.
#
proc ::Plotchart::Hsv2rgb {h s v} {
    set v [expr {double($v)}]
    set r [set g [set b 0.0]]
    if {$h == 360} { set h 0 }
    # if you feed the output of rgb2hsv back into this
    # converter, h could have the value -1 for
    # grayscale colors.  Set it to any value in the
    # valid range.
    if {$h == -1} { set h 0 }
    set h [expr {$h/60}]
    set i [expr {int(floor($h))}]
    set f [expr {$h - $i}]
    set p1 [expr {$v*(1-$s)}]
    set p2 [expr {$v*(1-($s*$f))}]
    set p3 [expr {$v*(1-($s*(1-$f)))}]
    switch -- $i {
        0 { set r $v  ; set g $p3 ; set b $p1 }
        1 { set r $p2 ; set g $v  ; set b $p1 }
        2 { set r $p1 ; set g $v  ; set b $p3 }
        3 { set r $p1 ; set g $p2 ; set b $v  }
        4 { set r $p3 ; set g $p1 ; set b $v  }
        5 { set r $v  ; set g $p1 ; set b $p2 }
    }
    return [list $r $g $b]
}

#
# Define default colour maps
#
namespace eval ::Plotchart {
     set contour_options(colourmap,rainbow) \
        {darkblue blue cyan green yellow orange red magenta}
     set contour_options(colourmap,white-blue) \
        {white paleblue cyan blue darkblue}

     set contour_options(colourmap,detailed) {
#00000000ffff
#000035e4ffff
#00006bc9ffff
#0000a1aeffff
#0000d793ffff
#0000fffff285
#0000ffffbca0
#0000ffff86bc
#0000ffff50d7
#0000ffff1af2
#1af2ffff0000
#50d7ffff0000
#86bcffff0000
#bca0ffff0000
#f285ffff0000
#ffffd7930000
#ffffa1ae0000
#ffff6bc90000
#ffff35e40000
#ffff00000000
#ffff00000000
}
    set contour_options(colourmap) $contour_options(colourmap,detailed)
}
# End of plotcontour.tcl
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/plotchart/plotgantt.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
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
# plotgantt.tcl --
#    Facilities to draw Gantt charts in a dedicated canvas
#
# Note:
#    This source file contains the private functions for Gantt charts.
#    It is the companion of "plotchart.tcl"
#    Some functions have been derived from the similar time chart
#    functions.
#

# GanttColor --
#    Set the color of a component
# Arguments:
#    w           Name of the canvas
#    component   Component in question
#    color       New colour
# Result:
#    None
# Side effects:
#    Items with a tag equal to that component are changed
#
proc ::Plotchart::GanttColor { w component color } {
    variable settings

    set settings($w,color,$component) $color

    switch -- $component {
    "description" -
    "summary"     {
        $w itemconfigure $component -foreground $color
    }
    "odd"         -
    "even"        {
        $w itemconfigure $component -fill $color -outline $color
    }
    "completed"   -
    "left"        {
        $w itemconfigure $component -fill $color
    }
    }
}

# GanttFont --
#    Set the font of a component
# Arguments:
#    w           Name of the canvas
#    component   Component in question
#    font        New font
# Result:
#    None
# Side effects:
#    Items with a tag equal to that component are changed
#
proc ::Plotchart::GanttFont { w component font } {
    variable settings

    set settings($w,font,$component) $font

    switch -- $component {
    "description" -
    "summary"     {
        $w itemconfigure $component -font $font
    }
    }
}

# DrawGanttPeriod --
#    Draw a period
# Arguments:
#    w           Name of the canvas
#    text        Text to identify the "period" item
#    time_begin  Start time
#    time_end    Stop time
#    completed   Fraction completed (in %)
# Result:
#    List of item numbers, for further manipulation
# Side effects:
#    Data bars drawn in canvas
#
proc ::Plotchart::DrawGanttPeriod { w text time_begin time_end completed } {
    variable settings
    variable data_series
    variable scaling

    #
    # Draw the text first
    #
    set ytext [expr {$scaling($w,current)-0.5}]
    foreach {x y} [coordsToPixel $w $scaling($w,xmin) $ytext] {break}

    set items {}
    lappend items \
        [$w create text 5 $y -text $text -anchor w \
                                    -tag {description vertscroll above} \
                                    -font $settings($w,font,description)]

    #
    # Draw the bar to indicate the period
    #
    set xmin  [clock scan $time_begin]
    set xmax  [clock scan $time_end]
    set xcmp  [expr {$xmin + $completed*($xmax-$xmin)/100.0}]
    set ytop  [expr {$scaling($w,current)-0.5*(1.0-$scaling($w,dy))}]
    set ybott [expr {$scaling($w,current)-0.5*(1.0+$scaling($w,dy))}]

    foreach {x1 y1} [coordsToPixel $w $xmin $ytop ] {break}
    foreach {x2 y2} [coordsToPixel $w $xmax $ybott] {break}
    foreach {x3 y2} [coordsToPixel $w $xcmp $ybott] {break}

    lappend items \
        [$w create rectangle $x1 $y1 $x3 $y2 -fill $settings($w,color,completed) \
                                             -tag {completed vertscroll horizscroll below}] \
        [$w create rectangle $x3 $y1 $x2 $y2 -fill $settings($w,color,left) \
                                             -tag {left vertscroll horizscroll below}] \
        [$w create text      [expr {$x2+10}] $y -text "$completed%" \
                                             -anchor w \
                                             -tag {description vertscroll horizscroll below} \
                                             -font $settings($w,font,description)]

    set scaling($w,current) [expr {$scaling($w,current)-1.0}]

    ReorderChartItems $w

    return $items
}

# DrawGanttVertLine --
#    Draw a vertical line with a label
# Arguments:
#    w           Name of the canvas
#    text        Text to identify the line
#    time        Time for which the line is drawn
# Result:
#    None
# Side effects:
#    Line drawn in canvas
#
proc ::Plotchart::DrawGanttVertLine { w text time {colour black}} {
    variable settings
    variable data_series
    variable scaling

    #
    # Draw the text first
    #
    set xtime [clock scan $time]
    set ytext [expr {$scaling($w,ymax)-0.5*$scaling($w,dy)}]
    foreach {x y} [coordsToPixel $w $xtime $ytext] {break}

    $w create text $x $y -text $text -anchor w -font $settings($w,font,scale) \
        -tag {horizscroll timeline}

    #
    # Draw the line
    #
    foreach {x1 y1} [coordsToPixel $w $xtime $scaling($w,ymin)] {break}
    foreach {x2 y2} [coordsToPixel $w $xtime $scaling($w,ymax)] {break}

    $w create line $x1 $y1 $x2 $y2 -fill black -tag {horizscroll timeline tline}

    $w raise topmask
}

# DrawGanttMilestone --
#    Draw a "milestone"
# Arguments:
#    w           Name of the canvas
#    text        Text to identify the line
#    time        Time for which the milestone is drawn
#    colour      Optionally the colour
# Result:
#    None
# Side effects:
#    Triangle drawn in canvas
#
proc ::Plotchart::DrawGanttMilestone { w text time {colour black}} {
    variable settings
    variable data_series
    variable scaling

    #
    # Draw the text first
    #
    set ytext [expr {$scaling($w,current)-0.5}]
    foreach {x y} [coordsToPixel $w $scaling($w,xmin) $ytext] {break}

    set items {}
    lappend items \
       [$w create text 5 $y -text $text -anchor w -tag {description vertscroll above} \
             -font $settings($w,font,description)]
       # Colour text?

    #
    # Draw an upside-down triangle to indicate the time
    #
    set xcentre [clock scan $time]
    set ytop    [expr {$scaling($w,current)-0.2}]
    set ybott   [expr {$scaling($w,current)-0.8}]

    foreach {x1 y1} [coordsToPixel $w $xcentre $ybott] {break}
    foreach {x2 y2} [coordsToPixel $w $xcentre $ytop]  {break}

    set x2 [expr {$x1-0.4*($y1-$y2)}]
    set x3 [expr {$x1+0.4*($y1-$y2)}]
    set y3 $y2

    lappend items \
        [$w create polygon $x1 $y1 $x2 $y2 $x3 $y3 -fill $colour \
            -tag {vertscroll horizscroll below}]

    set scaling($w,current) [expr {$scaling($w,current)-1.0}]

    ReorderChartItems $w

    return $items
}

# DrawGanttConnect --
#    Draw a connection between two entries
# Arguments:
#    w           Name of the canvas
#    from        The from item
#    to          The to item
# Result:
#    List of item numbers, for further manipulation
# Side effects:
#    Arrow drawn in canvas
#
proc ::Plotchart::DrawGanttConnect { w from to } {
    variable settings
    variable data_series
    variable scaling

    foreach {xf1 yf1 xf2 yf2} [$w coords [lindex $from 2]] {break}
    foreach {xt1 yt1 xt2 yt2} [$w coords [lindex $to   1]] {break}

    set yfc [expr {($yf1+$yf2)/2.0}]
    set ytc [expr {($yt1+$yt2)/2.0}]

    if { $xf2 > $xf1-15 } {
        set coords [list $xf2             $yfc            \
                         [expr {$xf2+5}]  $yfc            \
                         [expr {$xf2+5}]  [expr {$yf2+5}] \
                         [expr {$xt1-10}] [expr {$yf2+5}] \
                         [expr {$xt1-10}] $ytc            \
                         $xt1             $ytc            ]
    } else {
        set coords [list $xf2             $yfc            \
                         [expr {$xf2+5}]  $yfc            \
                         [expr {$xt2+5}]  $ytc            \
                         $xt1             $ytc            ]
    }

    ReorderChartItems $w

    return [$w create line $coords -arrow last -tag {vertscroll horizscroll below}]
}

# DrawGanttSummary --
#    Draw a summary entry
# Arguments:
#    w           Name of the canvas
#    text        Text to describe the summary
#    args        List of items belonging to the summary
# Result:
#    List of canvas items making up the summary
# Side effects:
#    Items are shifted down to make room for the summary
#
proc ::Plotchart::DrawGanttSummary { w text args } {
    variable settings
    variable data_series
    variable scaling

    #
    # Determine the coordinates of the summary bar
    #
    set xmin {}
    set xmax {}
    set ymin {}
    set ymax {}
    foreach entry $args {
        foreach {x1 y1}             [$w coords [lindex $entry 1]] {break}
        foreach {dummy dummy x2 y2} [$w coords [lindex $entry 2]] {break}

        if { $xmin == {} || $xmin > $x1 } { set xmin $x1 }
        if { $xmax == {} || $xmax < $x2 } { set xmax $x2 }
        if { $ymin == {} || $ymin > $y1 } {
            set ymin  $y1
            set yminb $y2
        }
    }

    #
    # Compute the vertical shift
    #
    set yfirst $scaling($w,ymin)
    set ynext  [expr {$yfirst-1.0}]
    foreach {x y1} [coordsToPixel $w $scaling($w,xmin) $yfirst] {break}
    foreach {x y2} [coordsToPixel $w $scaling($w,xmin) $ynext ] {break}
    set dy [expr {$y2-$y1}]

    #
    # Shift the items
    #
    foreach entry $args {
        foreach item $entry {
            $w move $item 0 $dy
        }
    }

    #
    # Draw the summary text first
    #
    set ytext [expr {($ymin+$yminb)/2.0}]
    set ymin  [expr {$ymin+0.3*$dy}]

    set items {}
    lappend items \
        [$w create text 5 $ytext -text $text -anchor w -tag {summary vertscroll above} \
              -font $settings($w,font,summary)]
        # Colour text?

    #
    # Draw the bar
    #
    set coords [list [expr {$xmin-5}] [expr {$ymin-5}]  \
                     [expr {$xmax+5}] [expr {$ymin-5}]  \
                     [expr {$xmax+5}] [expr {$ymin+5}]  \
                     $xmax            [expr {$ymin+10}] \
                     [expr {$xmax-5}] [expr {$ymin+5}]  \
                     [expr {$xmin+5}] [expr {$ymin+5}]  \
                     $xmin            [expr {$ymin+10}] \
                     [expr {$xmin-5}] [expr {$ymin+5}]  ]

    lappend items \
        [$w create polygon $coords -tag {summarybar vertscroll horizscroll below} \
              -fill $settings($w,color,summarybar)]

    set scaling($w,current) [expr {$scaling($w,current)-1.0}]

    ReorderChartItems $w

    return $items
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/plotchart/plotpack.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
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
# plotpack.tcl --
#     Implement a pack-like geometry manager for Plotchart
#
#     Note:
#     The canvas:* procedures are taken directly from the Wiki,
#     these procedures were written by Maurice (ulis) Bredelet
#     I have not changed the formatting or the naming convention,
#     as a small token of my appreciation for his Tcl work
#     - he died in February 2008.
#
namespace eval ::Plotchart {
    variable packing
}

# GetCanvas --
#     Destill the name of the canvas from the plot command
#
# Arguments:
#     cmd             Plot command
#
# Result:
#     Name of the widget
#
proc ::Plotchart::GetCanvas {cmd} {
    regsub {^[^_]+_} $cmd "" w
    return $w
}


# plotpack --
#     Copy an existing plot/chart into another canvas widget
#
# Arguments:
#     w               Canvas widget to copy to
#     dir             Direction to attach the new plot to the existing contents
#     args            List of plots/charts to be copied
#
# Result:
#     None
#
proc ::Plotchart::plotpack {w dir args} {
    variable packing

    if { ![info exists packing($w,top)] } {
        set packing($w,top)    0
        set packing($w,left)   0
        set packing($w,right)  [WidthCanvas  $w]
        set packing($w,bottom) [HeightCanvas $w]
    }
    set top    $packing($w,top)
    set left   $packing($w,left)
    set right  $packing($w,right)
    set bottom $packing($w,bottom)

    foreach p $args {
        set save [canvas:save [GetCanvas $p]]
        switch -- $dir {
            "top" {
                 set xmove 0
                 set ymove $top
                 canvas:restore $w $save
                 $w move __NEW__ $xmove $ymove
                 $w dtag all __NEW__
                 set cwidth [WidthCanvas [GetCanvas $p]]
                 if { $left < $cwidth } {
                     set left $cwidth
                 }
                 set top  [expr {$top+[HeightCanvas [GetCanvas $p]]}]
            }
            "bottom" {
                 set xmove 0
                 set ymove [expr {$bottom-[HeightCanvas [GetCanvas $p]]}]
                 canvas:restore $w $save
                 $w move __NEW__ $xmove $ymove
                 $w dtag all __NEW__
                 set cwidth [WidthCanvas [GetCanvas $p]]
                 if { $left < $cwidth } {
                     set left $cwidth
                 }
                 set bottom $ymove
            }
            "left" {
                 set xmove $left
                 set ymove 0
                 canvas:restore $w $save
                 $w move __NEW__ $xmove $ymove
                 $w dtag all __NEW__
                 set left [expr {$left+[WidthCanvas [GetCanvas $p]]}]
                 set cheight [HeightCanvas [GetCanvas $p]]
                 if { $top < $cheight } {
                     set top $cheight
                 }
            }
            "right" {
                 set xmove [expr {$right-[WidthCanvas [GetCanvas $p]]}]
                 set ymove 0
                 canvas:restore $w $save
                 $w move __NEW__ $xmove $ymove
                 $w dtag all __NEW__
                 set right $xmove
                 if { $top < $cheight } {
                     set top $cheight
                 }
            }
        }
    }
    set packing($w,top)    $top
    set packing($w,left)   $left
    set packing($w,right)  $right
    set packing($w,bottom) $bottom
}

# canvas:* --
#     Procedures for copying the contents of a canvas widget - by "ulis"
#
namespace eval ::Plotchart {

# ==============================
#
#   clone a canvas widget
#
# ==============================

# ----------
#  canvas:clone proc
# ----------
# parm1: canvas widget
# parm2: clone canvas widget
# ----------

proc canvas:clone {canvas clone} { canvas:restore $clone [canvas:save $canvas] }

# ----------
#  options proc
#
#  return non empty options
# ----------
# parm: options list
# ----------
# return: non empty options list
# ----------

proc options {options} \
{
  set res {}
  foreach option $options \
  {
    set key   [lindex $option 0]
    set value [lindex $option 4]
    if {$value != ""} { lappend res [list $key $value] }
  }
  return $res
}

# ----------
#  canvas:save proc
#
#  serialize a canvas widget
# ----------
# parm1: canvas widget path
# ----------
# return: serialized widget
# ----------

proc canvas:save {w} \
{
  # canvas name
  lappend save $w
  # canvas option
  lappend save [options [$w configure]]
  # canvas focus
  lappend save [$w focus]
  # canvas items
  foreach id [$w find all] \
  {
    set item {}
    # type & id
    set type [$w type $id]
    lappend item [list $type $id]
    # coords
    lappend item [$w coords $id]
    # tags
    set tags [concat __NEW__ [$w gettags $id]] ;# AM: My change
    lappend item $tags
    # binds
    set binds {}
      # id binds
    set events [$w bind $id]
    foreach event $events \
    { lappend binds [list $id $event [$w bind $id $event]] }
      # tags binds
    foreach tag $tags \
    {
      set events [$w bind $tag]
      foreach event $events \
      { lappend binds [list $tag $event [$w bind $tag $event]] }
    }
    lappend item $binds
    # options
    lappend item [options [$w itemconfigure $id]]
    # type specifics
    set specifics {}
    switch $type \
    {
      arc       {}
      bitmap    {}
      image     \
      {
        # image name
        set iname [$w itemcget $id -image]
        lappend specifics $iname
        # image type
        lappend specifics [image type $iname]
        # image options
        lappend specifics [options [$iname configure]]
      }
      line      {}
      oval      {}
      polygon   {}
      rectangle {}
      text      \
      {
        foreach index {insert sel.first sel.last} \
        {
          # text indexes
          catch \
          { lappend specifics [$w index $id $index] }
        }
      }
      window    \
      {
        # window name
        set wname [$w itemcget $id -window]
        lappend specifics $wname
        # window type
        lappend specifics [string tolower [winfo class $wname]]
        # window options
        lappend specifics [options [$wname configure]]
      }
    }
    lappend item $specifics
    lappend save $item
  }
  # return serialized canvas
  return $save
}

# ----------
#  canvas:restore proc
#
#  restore a serialized canvas widget
# ----------
# parm1: canvas widget path
# parm2: serialized widget to restore
# ----------

proc canvas:restore {w save} \
{
  # create canvas options
  # eval canvas $w [join [lindex $save 1]] ;# AM: My change
  # items
  foreach item [lrange $save 3 end] \
  {
    foreach {typeid coords tags binds options specifics} $item \
    {
      # get type
      set type [lindex $typeid 0]
      # create bitmap or window
      switch $type \
      {
        image   \
        {
          foreach {iname itype ioptions} $specifics break
          if {![image inuse $iname]} \
          { eval image create $itype $iname [join $ioptions] }
        }
        window  \
        {
          foreach {wname wtype woptions} $specifics break
          if {![winfo exists $wname]} \
          { eval $wtype $wname [join $woptions] }
          raise $wname
        }
      }
      # create item
      set id [eval $w create $type $coords [join $options]]
      $w itemconfigure $id -tags $tags ;# AM: "options" may contain the old list of tags
      # item bindings
      foreach bind $binds \
      {
        foreach {id event script} $bind { $w bind $id $event $script }
      }
      # item specifics
      if {$specifics != ""} \
      {
        switch $type \
        {
          text    \
          {
            foreach {insert sel.first sel.last} $specifics break
            $w icursor $id $insert
            if {${sel.first} != ""} \
            {
              $w select from $id ${sel.first}
              $w select to   $id ${sel.last}
            }
          }
        }
      }
    }
  }
  # focused item
  set focus [lindex $save 2]
  if {$focus != ""} \
  {
    $w focus [lindex $save 2]
    focus -force $w
  }
  # return path
  return $w
}

# ----------
#  canvas:dump proc
#
#  dump a canvas widget
# ----------
# parm: canvas widget path
# ----------
# return: widget dump
# ----------

proc canvas:dump {w} \
{
  # canvas name
  lappend res [lindex $w 0]
  # canvas options
  foreach option [lindex $w 1] { lappend res [join $option \t] }
  # focused item
  lappend res [join [lindex $w 2] \t]
  # items
  foreach item [lrange $w 3 end] \
  {
    foreach {type coords tags binds options specifics} $item \
    {
      # item type
      lappend res [join $type \t]
      # item coords
      lappend res \tcoords\t$coords
      # item tags
      lappend res \ttags\t$tags
      # item bindings
      lappend res \tbinds
      foreach bind $binds { lappend res \t\t$bind }
      # item options
      lappend res \toptions
      foreach option $options \
      {
        set key [lindex $option 0]
        set value [lindex $option 1]
        lappend res \t\t$key\t$value
      }
      # item specifics
      if {$specifics != ""} \
      {
        lappend res \tspecifics
        foreach specific $specifics \
        {
          if {[llength $specific] == 1}  { lappend res \t\t$specific } \
          else { foreach token $specific { lappend res \t\t$token } }
        }
      }
    }
  }
  # return dump
  return [join $res \n]
}
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/plotchart/plotpriv.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
667
668
669
670
671
672
673
674
675
676
677
678
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
708
709
710
711
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
740
741
742
743
744
745
746
747
748
749
750
751
752
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
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
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
981
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
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
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
1210
1211
1212
1213
1214
1215
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
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
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
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
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
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
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
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
# plotpriv.tcl --
#    Facilities to draw simple plots in a dedicated canvas
#
# Note:
#    This source file contains the private functions.
#    It is the companion of "plotchart.tcl"
#

# WidthCanvas --
#    Return the width of the canvas
# Arguments:
#    w           Name of the canvas
# Result:
#    Width in pixels
#
proc ::Plotchart::WidthCanvas {w} {
    set width [winfo width $w]

    if { $width < 10 } {
        set width [$w cget -width]
    }
    return $width
}

# HeightCanvas --
#    Return the height of the canvas
# Arguments:
#    w           Name of the canvas
# Result:
#    Height in pixels
#
proc ::Plotchart::HeightCanvas {w} {
    set height [winfo height $w]

    if { $height < 10 } {
        set height [$w cget -height]
    }
    return $height
}

# SavePlot --
#    Save the plot/chart to a PostScript file (using default options)
# Arguments:
#    w           Name of the canvas
#    filename    Name of the file to write
#    args        Optional format (-format name)
# Result:
#    None
# Side effect:
#    A (new) PostScript file
#
proc ::Plotchart::SavePlot { w filename args } {

   if { [llength $args] == 0 } {
       #
       # Wait for the canvas to become visible - just in case.
       # Then write the file
       #
       update idletasks
       $w postscript -file $filename
   } else {
       if { [llength $args] == 2 && [lindex $args 0] == "-format" } {
           package require Img
           set format [lindex $args 1]

           #
           # This is a kludge:
           # Somehow tkwait does not always work (on Windows XP, that is)
           #
           raise [winfo toplevel $w]
          # tkwait visibility [winfo toplevel $w]
           after 2000 {set ::Plotchart::waited 0}
           vwait ::Plotchart::waited
           set img [image create photo -data $w -format window]
           $img write $filename -format $format
       } else {
           return -code error "Unknown option: $args - must be: -format img-format"
       }
   }
}

# MarginsRectangle --
#    Determine the margins for a rectangular plot/chart
# Arguments:
#    w           Name of the canvas
#    notext      Number of lines of text to make room for at the top
#                (default: 2.0)
#    text_width  Number of characters to be displayed at most on left
#                (default: 8)
# Result:
#    List of four values
#
proc ::Plotchart::MarginsRectangle { w {notext 2.0} {text_width 8}} {
   variable config
   set pxmin [expr {10*$text_width}]
   if { $pxmin < $config($w,margin,left) } {
       set pxmin $config($w,margin,left)
   }
   set pymin [expr {int(14*$notext)}]
   if { $pymin < $config($w,margin,top) } {
       set pymin $config($w,margin,top)
   }
   set pxmax [expr {[WidthCanvas $w]  - $config($w,margin,right)}]
   set pymax [expr {[HeightCanvas $w] - $config($w,margin,bottom)}]

   return [list $pxmin $pymin $pxmax $pymax]
}

# MarginsCircle --
#    Determine the margins for a circular plot/chart
# Arguments:
#    w           Name of the canvas
# Result:
#    List of four values
#
proc ::Plotchart::MarginsCircle { w } {
   set pxmin 80
   set pymin 30
   set pxmax [expr {[WidthCanvas $w]  - 80}]
   set pymax [expr {[HeightCanvas $w] - 30}]
   #set pxmax [expr {[$w cget -width]  - 80}]
   #set pymax [expr {[$w cget -height] - 30}]

   set dx [expr {$pxmax-$pxmin+1}]
   set dy [expr {$pymax-$pymin+1}]

   if { $dx < $dy } {
      set pyminn [expr {($pymin+$pymax-$dx)/2}]
      set pymaxn [expr {($pymin+$pymax+$dx)/2}]
      set pymin  $pyminn
      set pymax  $pymaxn
   } else {
      set pxminn [expr {($pxmin+$pxmax-$dy)/2}]
      set pxmaxn [expr {($pxmin+$pxmax+$dy)/2}]
      set pxmin  $pxminn
      set pxmax  $pxmaxn
   }

   return [list $pxmin $pymin $pxmax $pymax]
}

# Margins3DPlot --
#    Determine the margins for a 3D plot
# Arguments:
#    w           Name of the canvas
# Result:
#    List of four values
#
proc ::Plotchart::Margins3DPlot { w } {
   variable scaling

   set yfract 0.33
   set zfract 0.50
   if { [info exists scaling($w,yfract)] } {
      set yfract $scaling($w,yfract)
   } else {
      set scaling($w,yfract) $yfract
   }
   if { [info exists scaling($w,zfract)] } {
      set zfract $scaling($w,zfract)
   } else {
      set scaling($w,zfract) $zfract
   }

   set yzwidth  [expr {(-120+[WidthCanvas $w])/(1.0+$yfract)}]
   set yzheight [expr {(-60+[HeightCanvas $w])/(1.0+$zfract)}]
   #set yzwidth  [expr {(-120+[$w cget -width])/(1.0+$yfract)}]
   #set yzheight [expr {(-60+[$w cget -height])/(1.0+$zfract)}]

   set pxmin    [expr {60+$yfract*$yzwidth}]
   set pxmax    [expr {[WidthCanvas $w] - 60}]
   #set pxmax    [expr {[$w cget -width] - 60}]
   set pymin    30
   set pymax    [expr {30+$yzheight}]

   return [list $pxmin $pymin $pxmax $pymax]
}

# SetColours --
#    Set the colours for those plots that treat them as a global resource
# Arguments:
#    w           Name of the canvas
#    args        List of colours to be used
# Result:
#    None
#
proc ::Plotchart::SetColours { w args } {
   variable scaling

   set scaling($w,colours) $args
}

# CycleColours --
#    create cycling colours for those plots that treat them as a global resource
# Arguments:
#    colours     List of colours to be used. An empty list will activate to default colours
#    nr_data     Number of data records
# Result:
#    List of 'nr_data' colours to be used
#
proc ::Plotchart::CycleColours { colours nr_data } {
   if {![llength ${colours}]} {
       # force to most usable default colour list
       set colours {green blue red cyan yellow magenta}
   }

   if {[llength ${colours}] < ${nr_data}} {
	# cycle through colours
	set init_colours ${colours}
        set colours {}
        set pos 0
        for {set nr 0} {${nr} < ${nr_data}} {incr nr} {
            lappend colours [lindex ${init_colours} ${pos}]
            incr pos
            if {[llength ${init_colours}] <= ${pos}} {
                set pos 0
            }
	}
        if {[string equal [lindex ${colours} 0] [lindex ${colours} end]]} {
            # keep first and last colour different from selected colours
	    #    this will /sometimes fail in cases with only one/two colours in list
	    set colours [lreplace ${colours} end end [lindex ${colours} 1]]
        }
   }
   return ${colours}
}

# DataConfig --
#    Configure the data series
# Arguments:
#    w           Name of the canvas
#    series      Name of the series in question
#    args        Option and value pairs
# Result:
#    None
#
proc ::Plotchart::DataConfig { w series args } {
   variable data_series
   variable options
   variable option_keys
   variable option_values

   foreach {option value} $args {
      set idx [lsearch $options $option]
      if { $idx < 0 } {
         return -code error "Unknown or invalid option: $option (value: $value)"
      } else {
         set key [lindex $option_keys    $idx]
         set idx [lsearch $option_values $key]
         set values  [lindex $option_values [incr idx]]
         if { $values != "..." } {
            if { [lsearch $values $value] < 0 } {
               return -code error "Unknown or invalid value: $value for option $option - $values"
            }
         }
         set data_series($w,$series,$key) $value
      }
   }
}

# ScaleIsometric --
#    Determine the scaling for an isometric plot
# Arguments:
#    w           Name of the canvas
#    xmin        Minimum x coordinate
#    ymin        Minimum y coordinate
#    xmax        Maximum x coordinate
#    ymax        Maximum y coordinate
#                (default: 1.5)
# Result:
#    None
# Side effect:
#    Array with scaling parameters set
#
proc ::Plotchart::ScaleIsometric { w xmin ymin xmax ymax } {
   variable scaling

   set pxmin $scaling($w,pxmin)
   set pymin $scaling($w,pymin)
   set pxmax $scaling($w,pxmax)
   set pymax $scaling($w,pymax)

   set dx [expr {($xmax-$xmin)/($pxmax-$pxmin)}]
   set dy [expr {($ymax-$ymin)/($pymax-$pymin)}]

   #
   # Which coordinate is dominant?
   #
   if { $dy < $dx } {
      set yminn [expr {0.5*($ymax+$ymin) - 0.5 * $dx * ($pymax-$pymin)}]
      set ymaxn [expr {0.5*($ymax+$ymin) + 0.5 * $dx * ($pymax-$pymin)}]
      set ymin  $yminn
      set ymax  $ymaxn
   } else {
      set xminn [expr {0.5*($xmax+$xmin) - 0.5 * $dy * ($pxmax-$pxmin)}]
      set xmaxn [expr {0.5*($xmax+$xmin) + 0.5 * $dy * ($pxmax-$pxmin)}]
      set xmin  $xminn
      set xmax  $xmaxn
   }

   worldCoordinates $w $xmin $ymin $xmax $ymax
}

# PlotHandler --
#    Handle the subcommands for an XY plot or chart
# Arguments:
#    type        Type of plot/chart
#    w           Name of the canvas
#    command     Subcommand or method to run
#    args        Data for the command
# Result:
#    Whatever returned by the subcommand
#
proc ::Plotchart::PlotHandler { type w command args } {
   variable methodProc

   if { [info exists methodProc($type,$command)] } {
      eval $methodProc($type,$command) $w $args
   } else {
      return -code error "No such method - $command"
   }
}

# DrawMask --
#    Draw the stuff that masks the data lines outside the graph
# Arguments:
#    w           Name of the canvas
# Result:
#    None
# Side effects:
#    Several polygons drawn in the background colour
#
proc ::Plotchart::DrawMask { w } {
   variable scaling
   variable config

   set width  [expr {[WidthCanvas $w]  + 1}]
   set height [expr {[HeightCanvas $w] + 1}]
   set colour $config($w,background,outercolor)
   set pxmin  [expr {$scaling($w,pxmin)-1}]
   set pxmax  $scaling($w,pxmax)
   set pymin  [expr {$scaling($w,pymin)-1}]
   set pymax  $scaling($w,pymax)
   $w create rectangle 0      0      $pxmin $height -fill $colour -outline $colour -tag mask
   $w create rectangle 0      0      $width $pymin  -fill $colour -outline $colour -tag mask
   $w create rectangle 0      $pymax $width $height -fill $colour -outline $colour -tag mask
   $w create rectangle $pxmax 0      $width $height -fill $colour -outline $colour -tag mask

   $w lower mask
}

# DrawScrollMask --
#    Draw the masking rectangles for a time or Gantt chart
# Arguments:
#    w           Name of the canvas
# Result:
#    None
# Side effects:
#    Several polygons drawn in the background colour, with appropriate
#    tags
#
proc ::Plotchart::DrawScrollMask { w } {
   variable scaling
   variable config

   set width  [expr {[WidthCanvas $w]  + 1}]
   set height [expr {[HeightCanvas $w] + 1}]
   set colour $config($w,background,outercolor)
   set pxmin  [expr {$scaling($w,pxmin)-1}]
   set pxmax  $scaling($w,pxmax)
   set pymin  [expr {$scaling($w,pymin)-1}]
   set pymax  $scaling($w,pymax)
   $w create rectangle 0      0      $pxmin $height -fill $colour -outline $colour -tag vertmask
   $w create rectangle 0      0      $width $pymin  -fill $colour -outline $colour -tag horizmask
   $w create rectangle 0      $pymax $width $height -fill $colour -outline $colour -tag horizmask
   $w create rectangle $pxmax 0      $width $height -fill $colour -outline $colour -tag vertmask

   $w create rectangle 0      0      $pxmin $pymin  -fill $colour -outline $colour -tag {topmask top}
   $w create rectangle $pxmax 0      $width $pymin  -fill $colour -outline $colour -tag {topmask top}

   $w lower topmask
   $w lower horizmask
   $w lower vertmask
}

# DrawTitle --
#    Draw the title
# Arguments:
#    w           Name of the canvas
#    title       Title to appear above the graph
# Result:
#    None
# Side effects:
#    Text string drawn
#
proc ::Plotchart::DrawTitle { w title } {
   variable scaling
   variable config

   set width  [WidthCanvas $w]
   #set width  [$w cget -width]
   set pymin  $scaling($w,pymin)

   $w create text [expr {$width/2}] 3 -text $title \
       -tags title -font $config($w,title,font) \
       -fill $config($w,title,textcolor) -anchor $config($w,title,anchor)
}

# DrawData --
#    Draw the data in an XY-plot
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    xcrd        Next x coordinate
#    ycrd        Next y coordinate
# Result:
#    None
# Side effects:
#    New data drawn in canvas
#
proc ::Plotchart::DrawData { w series xcrd ycrd } {
   variable data_series
   variable scaling

   #
   # Check for missing values
   #
   if { $xcrd == "" || $ycrd == "" } {
       unset data_series($w,$series,x)
       return
   }

   #
   # Draw the line piece
   #
   set colour "black"
   if { [info exists data_series($w,$series,-colour)] } {
      set colour $data_series($w,$series,-colour)
   }

   set type "line"
   if { [info exists data_series($w,$series,-type)] } {
      set type $data_series($w,$series,-type)
   }
   set filled "no"
   if { [info exists data_series($w,$series,-filled)] } {
      set filled $data_series($w,$series,-filled)
   }
   set fillcolour white
   if { [info exists data_series($w,$series,-fillcolour)] } {
      set fillcolour $data_series($w,$series,-fillcolour)
   }

   foreach {pxcrd pycrd} [coordsToPixel $w $xcrd $ycrd] {break}

   if { [info exists data_series($w,$series,x)] } {
       set xold $data_series($w,$series,x)
       set yold $data_series($w,$series,y)
       foreach {pxold pyold} [coordsToPixel $w $xold $yold] {break}

       if { $filled ne "no" } {
           if { $filled eq "down" } {
               set pym $scaling($w,pymax)
           } else {
               set pym $scaling($w,pymin)
           }
           $w create polygon $pxold $pym $pxold $pyold $pxcrd $pycrd $pxcrd $pym \
               -fill $fillcolour -outline {} -tag [list data data_$series]
       }

       if { $type == "line" || $type == "both" } {
          $w create line $pxold $pyold $pxcrd $pycrd \
                         -fill $colour -tag [list data data_$series]
       }
   }

   if { $type == "symbol" || $type == "both" } {
      set symbol "dot"
      if { [info exists data_series($w,$series,-symbol)] } {
         set symbol $data_series($w,$series,-symbol)
      }
      DrawSymbolPixel $w $series $pxcrd $pycrd $symbol $colour [list "data" data_$series]
   }

   $w lower data

   set data_series($w,$series,x) $xcrd
   set data_series($w,$series,y) $ycrd
}

# DrawStripData --
#    Draw the data in a stripchart
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    xcrd        Next x coordinate
#    ycrd        Next y coordinate
# Result:
#    None
# Side effects:
#    New data drawn in canvas
#
proc ::Plotchart::DrawStripData { w series xcrd ycrd } {
   variable data_series
   variable scaling

   #
   # Check for missing values
   #
   if { $xcrd == "" || $ycrd == "" } {
       unset data_series($w,$series,x)
       return
   }

   if { $xcrd > $scaling($w,xmax) } {
      set xdelt $scaling($w,xdelt)
      set xmin  $scaling($w,xmin)
      set xmax  $scaling($w,xmax)

      set xminorg $xmin
      while { $xmax < $xcrd } {
         set xmin [expr {$xmin+$xdelt}]
         set xmax [expr {$xmax+$xdelt}]
      }
      set ymin  $scaling($w,ymin)
      set ymax  $scaling($w,ymax)

      worldCoordinates $w $xmin $ymin $xmax $ymax
      DrawXaxis $w $xmin $xmax $xdelt

      foreach {pxminorg pyminorg} [coordsToPixel $w $xminorg $ymin] {break}
      foreach {pxmin pymin}       [coordsToPixel $w $xmin    $ymin] {break}
      $w move data [expr {$pxminorg-$pxmin+1}] 0
   }

   DrawData $w $series $xcrd $ycrd
}

# DrawLogData --
#    Draw the data in an X-logY-plot
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    xcrd        Next x coordinate
#    ycrd        Next y coordinate
# Result:
#    None
# Side effects:
#    New data drawn in canvas
#
proc ::Plotchart::DrawLogData { w series xcrd ycrd } {

    DrawData $w $series $xcrd [expr {log10($ycrd)}]
}

# DrawInterval --
#    Draw the data as an error interval in an XY-plot
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    xcrd        X coordinate
#    ymin        Minimum y coordinate
#    ymax        Maximum y coordinate
#    ycentr      Central y coordinate (optional)
# Result:
#    None
# Side effects:
#    New interval drawn in canvas
#
proc ::Plotchart::DrawInterval { w series xcrd ymin ymax {ycentr {}} } {
   variable data_series
   variable scaling

   #
   # Check for missing values
   #
   if { $xcrd == "" || $ymin == "" || $ymax == "" } {
       return
   }

   #
   # Draw the line piece
   #
   set colour "black"
   if { [info exists data_series($w,$series,-colour)] } {
      set colour $data_series($w,$series,-colour)
   }

   foreach {pxcrd pymin} [coordsToPixel $w $xcrd $ymin] {break}
   foreach {pxcrd pymax} [coordsToPixel $w $xcrd $ymax] {break}
   if { $ycentr != "" } {
       foreach {pxcrd pycentr} [coordsToPixel $w $xcrd $ycentr] {break}
   }

   #
   # Draw the I-shape (note the asymmetry!)
   #
   $w create line $pxcrd $pymin $pxcrd $pymax \
                        -fill $colour -tag [list data data_$series]
   $w create line [expr {$pxcrd-3}] $pymin [expr {$pxcrd+4}] $pymin \
                        -fill $colour -tag [list data data_$series]
   $w create line [expr {$pxcrd-3}] $pymax [expr {$pxcrd+4}] $pymax \
                        -fill $colour -tag [list data data_$series]

   if { $ycentr != "" } {
      set symbol "dot"
      if { [info exists data_series($w,$series,-symbol)] } {
         set symbol $data_series($w,$series,-symbol)
      }
      DrawSymbolPixel $w $series $pxcrd $pycentr $symbol $colour [list data data_$series]
   }

   $w lower data
}

# DrawSymbolPixel --
#    Draw a symbol in an xy-plot, polar plot or stripchart
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    pxcrd       Next x (pixel) coordinate
#    pycrd       Next y (pixel) coordinate
#    symbol      What symbol to draw
#    colour      What colour to use
#    tag         What tag to use
# Result:
#    None
# Side effects:
#    New symbol drawn in canvas
#
proc ::Plotchart::DrawSymbolPixel { w series pxcrd pycrd symbol colour tag } {
   variable data_series
   variable scaling

   set pxmin  [expr {$pxcrd-4}]
   set pxmax  [expr {$pxcrd+4}]
   set pymin  [expr {$pycrd-4}]
   set pymax  [expr {$pycrd+4}]

   switch -- $symbol {
   "plus"     { $w create line $pxmin $pycrd $pxmax $pycrd \
                               $pxcrd $pycrd $pxcrd $pymin \
                               $pxcrd $pymax \
                               -fill $colour -tag $tag \
                               -capstyle projecting
              }
   "cross"    { $w create line $pxmin $pymin $pxmax $pymax \
                               $pxcrd $pycrd $pxmax $pymin \
                               $pxmin $pymax \
                               -fill $colour -tag $tag \
                               -capstyle projecting
              }
   "circle"   { $w create oval $pxmin $pymin $pxmax $pymax \
                               -outline $colour -tag $tag
              }
   "dot"      { $w create oval $pxmin $pymin $pxmax $pymax \
                               -outline $colour -fill $colour -tag $tag
              }
   "up"       { $w create polygon $pxmin $pymax $pxmax $pymax \
                               $pxcrd $pymin \
                               -outline $colour -fill {} -tag $tag
              }
   "upfilled" { $w create polygon $pxmin $pymax $pxmax $pymax \
                              $pxcrd $pymin \
                              -outline $colour -fill $colour -tag $tag
              }
   "down"     { $w create polygon $pxmin $pymin $pxmax $pymin \
                              $pxcrd $pymax \
                              -outline $colour -fill {} -tag $tag
              }
   "downfilled" { $w create polygon $pxmin $pymin $pxmax $pymin \
                              $pxcrd $pymax \
                              -outline $colour -fill $colour -tag $tag
              }
   }
}

# DrawTimeData --
#    Draw the data in an TX-plot
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    time        Next date/time value
#    xcrd        Next x coordinate (vertical axis)
# Result:
#    None
# Side effects:
#    New data drawn in canvas
#
proc ::Plotchart::DrawTimeData { w series time xcrd } {
    DrawData $w $series [clock scan $time] $xcrd
}

# DetermineMedian --
#    Determine the median of a sorted list of values
# Arguments:
#    values      Sorted values
# Result:
#    Median value
#
proc ::Plotchart::DetermineMedian { values } {
    set length [llength $values]

    if { $length == 1 } {
        set median [lindex $values 0]
    } elseif { $length % 2 == 1 } {
        set median [lindex $values [expr {$length/2}]]
    } else {
        set median1 [lindex $values [expr {$length/2-1}]]
        set median2 [lindex $values [expr {$length/2}]]
        set median  [expr {($median1 + $median2)/2.0}]
    }
    return $median
}

# DrawBoxWhiskers --
#    Draw the data in an XY-plot as box-and-whiskers
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    xcrd        Next x coordinate or a list of coordinates
#    ycrd        Next y coordinate or a list of coordinates
# Result:
#    None
# Side effects:
#    New data drawn in canvas
# Note:
#    We can do either a horizontal box (one y value) or
#    a vertical box (one x value). Not both
#
proc ::Plotchart::DrawBoxWhiskers { w series xcrd ycrd } {
    variable data_series
    variable scaling

    #
    # Check orientation
    #
    set type "?"
    if { [llength $xcrd] > 1 && [llength $ycrd] == 1 } {
        set type h
    }
    if { [llength $xcrd] == 1 && [llength $ycrd] > 1 } {
        set type v
    }
    if { $type == "?" } {
        return -code error "Use either a list of x values or a list of y values - not both"
    }

    #
    # Determine the quartiles
    #
    if { $type == "h" } {
        set data [lsort -real -increasing $xcrd]
    } else {
        set data [lsort -real -increasing $ycrd]
    }
    set length    [llength $data]
    if { $length % 2 == 0 } {
        set lowerhalf [expr {($length-1)/2}]
        set upperhalf [expr {($length+1)/2}]
    } else {
        set lowerhalf [expr {$length/2-1}]
        set upperhalf [expr {$length/2+1}]
    }

    set quartile2 [DetermineMedian $data]
    set quartile1 [DetermineMedian [lrange $data 0 $lowerhalf]]
    set quartile3 [DetermineMedian [lrange $data $upperhalf end]]

    set hspread   [expr {$quartile3-$quartile1}]

    set lower     [expr {$quartile1-1.5*$hspread}]
    set upper     [expr {$quartile3+1.5*$hspread}]
    set outlower  [expr {$quartile1-3.0*$hspread}]
    set outupper  [expr {$quartile3+3.0*$hspread}]

    set minimum {}
    set maximum {}
    foreach value $data {
        if { $value >= $lower } {
            if { $minimum == {} || $minimum > $value } {
                set minimum $value
            }
        }
        if { $value <= $upper } {
            if { $maximum == {} || $maximum < $value } {
                set maximum $value
            }
        }
    }

    #
    # Draw the box and whiskers
    #
    set colour "black"
    if { [info exists data_series($w,$series,-colour)] } {
       set colour $data_series($w,$series,-colour)
    }
    set filled "no"
    if { [info exists data_series($w,$series,-filled)] } {
       set filled $data_series($w,$series,-filled)
    }
    set fillcolour white
    if { [info exists data_series($w,$series,-fillcolour)] } {
       set fillcolour $data_series($w,$series,-fillcolour)
    }
    set boxwidth 10
    if { [info exists data_series($w,$series,-boxwidth)] } {
       set boxwidth $data_series($w,$series,-boxwidth)
    }

    if { $type == "h" } {
        foreach {pxcrdm pycrd1} [coordsToPixel $w $minimum   $ycrd] {break}
        foreach {pxcrd1 pycrd2} [coordsToPixel $w $quartile1 $ycrd] {break}
        foreach {pxcrd2 pycrd2} [coordsToPixel $w $quartile2 $ycrd] {break}
        foreach {pxcrd3 pycrd2} [coordsToPixel $w $quartile3 $ycrd] {break}
        foreach {pxcrdM pycrd2} [coordsToPixel $w $maximum   $ycrd] {break}

        set pycrd0  [expr {$pycrd1-$boxwidth/2}]
        set pycrd2  [expr {$pycrd1+$boxwidth/2}]
        set pycrd0h [expr {$pycrd1-$boxwidth/4}]
        set pycrd2h [expr {$pycrd1+$boxwidth/4}]

        $w create line      $pxcrdm $pycrd1 $pxcrd1 $pycrd1 \
                             -fill $colour -tag [list data data_$series]
        $w create line      $pxcrdm $pycrd0h $pxcrdm $pycrd2h \
                             -fill $colour -tag [list data data_$series]
        $w create line      $pxcrd3 $pycrd1 $pxcrdM $pycrd1 \
                             -fill $colour -tag [list data data_$series]
        $w create line      $pxcrdM $pycrd0h $pxcrdM $pycrd2h \
                             -fill $colour -tag [list data data_$series]
        $w create rectangle $pxcrd1 $pycrd0 $pxcrd3 $pycrd2 \
            -outline $colour -fill $fillcolour -tag [list data data_$series]
        $w create line      $pxcrd2 $pycrd0 $pxcrd2 $pycrd2 -width 2 \
                             -fill $colour -tag [list data data_$series]

        foreach value $data {
            if { $value < $outlower || $value > $outupper } {
                foreach {px py} [coordsToPixel $w $value $ycrd] {break}
                $w create text $px $py -text "*" -anchor c \
                             -fill $colour -tag [list data data_$series]
                continue
            }
            if { $value < $lower || $value > $upper } {
                foreach {px py} [coordsToPixel $w $value $ycrd] {break}
                $w create oval [expr {$px-2}] [expr {$py-2}] \
                               [expr {$px+2}] [expr {$py+2}] \
                             -fill $colour -tag [list data data_$series]
                continue
            }
        }

    } else {
        foreach {pxcrd1 pycrdm} [coordsToPixel $w $xcrd $minimum  ] {break}
        foreach {pxcrd2 pycrd1} [coordsToPixel $w $xcrd $quartile1] {break}
        foreach {pxcrd2 pycrd2} [coordsToPixel $w $xcrd $quartile2] {break}
        foreach {pxcrd2 pycrd3} [coordsToPixel $w $xcrd $quartile3] {break}
        foreach {pxcrd2 pycrdM} [coordsToPixel $w $xcrd $maximum  ] {break}

        set pxcrd0  [expr {$pxcrd1-$boxwidth/2}]
        set pxcrd2  [expr {$pxcrd1+$boxwidth/2}]
        set pxcrd0h [expr {$pxcrd1-$boxwidth/4}]
        set pxcrd2h [expr {$pxcrd1+$boxwidth/4}]

        $w create line      $pxcrd1 $pycrdm $pxcrd1 $pycrd1 \
                             -fill $colour -tag [list data data_$series]
        $w create line      $pxcrd0h $pycrdm $pxcrd2h $pycrdm \
                             -fill $colour -tag [list data data_$series]
        $w create line      $pxcrd1 $pycrd3 $pxcrd1 $pycrdM \
                             -fill $colour -tag [list data data_$series]
        $w create line      $pxcrd0h $pycrdM $pxcrd2h $pycrdM \
                             -fill $colour -tag [list data data_$series]
        $w create rectangle $pxcrd0 $pycrd1 $pxcrd2 $pycrd3 \
            -outline $colour -fill $fillcolour -tag [list data data_$series]
        $w create line      $pxcrd0 $pycrd2 $pxcrd2 $pycrd2 -width 2 \
                             -fill $colour -tag [list data data_$series]

        foreach value $data {
            if { $value < $outlower || $value > $outupper } {
                foreach {px py} [coordsToPixel $w $xcrd $value] {break}
                $w create text $px $py -text "*" \
                             -fill $colour -tag [list data data_$series]
                continue
            }
            if { $value < $lower || $value > $upper } {
                foreach {px py} [coordsToPixel $w $xcrd $value] {break}
                $w create oval [expr {$px-3}] [expr {$py-3}] \
                               [expr {$px+3}] [expr {$py+3}] \
                             -fill $colour -tag [list data data_$series]
                continue
            }
        }
    }

    $w lower data
}

# DrawBoxData --
#    Draw the data in a boxplot (y-axis consists of labels)
# Arguments:
#    w           Name of the canvas
#    label       Label on the y-axis to put the box on
#    xcrd        Next x coordinate or a list of coordinates
# Result:
#    None
# Side effects:
#    New data drawn in canvas
#
proc ::Plotchart::DrawBoxData { w label xcrd } {
   variable config
   variable scaling

   set index [lsearch $config($w,axisnames) $label]
   if { $index == -1 } {
       return "Label $label not found on y-axis"
   }

   set ycrd [expr {$index+0.5}]

   DrawBoxWhiskers $w box $xcrd $ycrd
}

# DrawPie --
#    Draw the pie
# Arguments:
#    w           Name of the canvas
#    data        Data series (pairs of label-value)
# Result:
#    None
# Side effects:
#    Pie filled
#
proc ::Plotchart::DrawPie { w data } {
   variable data_series
   variable scaling

   set pxmin $scaling($w,pxmin)
   set pymin $scaling($w,pymin)
   set pxmax $scaling($w,pxmax)
   set pymax $scaling($w,pymax)

   set colours $scaling(${w},colours)

   if {[llength ${data}] == 2} {
       # use canvas create oval as arc does not fill with colour for a full circle
       set colour [lindex ${colours} 0]
       ${w} create oval ${pxmin} ${pymin} ${pxmax} ${pymax} -fill ${colour}
       # text looks nicer at 45 degree
       set rad [expr {45.0 * 3.1415926 / 180.0}]
       set xtext [expr {(${pxmin}+${pxmax}+cos(${rad})*(${pxmax}-${pxmin}+20))/2}]
       set ytext [expr {(${pymin}+${pymax}-sin(${rad})*(${pymax}-${pymin}+20))/2}]
       foreach {label value} ${data} {
           break
       }
       ${w} create text ${xtext} ${ytext} -text ${label} -anchor w
       set scaling($w,angles) {0 360}
   } else {
       #
       # Determine the scale for the values
       # (so we can draw the correct angles)
       #

       set sum 0.0
       foreach {label value} $data {
          set sum [expr {$sum + $value}]
       }
       set factor [expr {360.0/$sum}]

       #
       # Draw the line piece
       #
       set angle_bgn 0.0
       set angle_ext 0.0
       set sum       0.0

       set idx 0

       array unset scaling ${w},angles
       set colours [CycleColours ${colours} [expr {[llength ${data}] / 2}]]

       foreach {label value} $data {
          set colour [lindex $colours $idx]
          incr idx

          if { $value == "" } {
              break
          }

          set angle_bgn [expr {$sum   * $factor}]
          set angle_ext [expr {$value * $factor}]
          lappend scaling(${w},angles) [expr {int(${angle_bgn})}]

          $w create arc  $pxmin $pymin $pxmax $pymax \
                         -start $angle_bgn -extent $angle_ext \
                         -fill $colour -style pieslice

          set rad   [expr {($angle_bgn+0.5*$angle_ext)*3.1415926/180.0}]
          set xtext [expr {($pxmin+$pxmax+cos($rad)*($pxmax-$pxmin+20))/2}]
          set ytext [expr {($pymin+$pymax-sin($rad)*($pymax-$pymin+20))/2}]
          if { $xtext > ($pxmin+$pymax)/2 } {
             set dir w
          } else {
             set dir e
          }

          $w create text $xtext $ytext -text $label -anchor $dir

          set sum [expr {$sum + $value}]
       }
   }
}

# DrawPolarData --
#    Draw data given in polar coordinates
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    rad         Next radius
#    phi         Next angle (in degrees)
# Result:
#    None
# Side effects:
#    Data drawn in canvas
#
proc ::Plotchart::DrawPolarData { w series rad phi } {
   variable torad
   set xcrd [expr {$rad*cos($phi*$torad)}]
   set ycrd [expr {$rad*sin($phi*$torad)}]

   DrawData $w $series $xcrd $ycrd
}

# DrawVertBarData --
#    Draw the vertical bars
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    ydata       Series of y data
#    colour      The colour to use (optional)
#    dir         Direction if graded colours are used (see DrawGradientBackground)
# Result:
#    None
# Side effects:
#    Data bars drawn in canvas
#
proc ::Plotchart::DrawVertBarData { w series ydata {colour black} {dir {}} } {
   variable data_series
   variable scaling
   variable legend

   #
   # Draw the bars
   #
   set x $scaling($w,xbase)

   #
   # set the colours
   #
   if {[llength ${colour}]} {
       set colours ${colour}
   } elseif {[info exists scaling(${w},colours)]} {
       set colours $scaling(${w},colours)
   } else {
       set colours {}
   }
   set colours [CycleColours ${colours} [llength ${ydata}]]

   #
   # Legend information
   #
   set legendcol [lindex $colours 0]
   set data_series($w,$series,-colour) $legendcol
   set data_series($w,$series,-type)   rectangle
   if { [info exists legend($w,canvas)] } {
       set legendw $legend($w,canvas)
       $legendw itemconfigure $series -fill $legendcol
   }

   set newbase {}

   set idx 0
   foreach yvalue $ydata ybase $scaling($w,ybase) {
      set colour [lindex ${colours} ${idx}]
      incr idx

      if { $yvalue == "" } {
          set yvalue 0.0
      }

      set xnext [expr {$x+$scaling($w,barwidth)}]
      set y     [expr {$yvalue+$ybase}]
      foreach {px1 py1} [coordsToPixel $w $x     $ybase] {break}
      foreach {px2 py2} [coordsToPixel $w $xnext $y    ] {break}

      if { $dir == {} } {
          $w create rectangle $px1 $py1 $px2 $py2 \
                         -fill $colour -tag [list data data_$series]
      } else {
          DrawGradientBackground $w $colour $dir [list $px1 $py1 $px2 $py2]
      }
      $w lower data

      set x [expr {$x+1.0}]

      lappend newbase $y
   }

   #
   # Prepare for the next series
   #
   if { $scaling($w,stacked) } {
      set scaling($w,ybase) $newbase
   }

   set scaling($w,xbase) [expr {$scaling($w,xbase)+$scaling($w,xshift)}]
}

# DrawHorizBarData --
#    Draw the horizontal bars
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    xdata       Series of x data
#    colour      The colour to use (optional)
#    dir         Direction if graded colours are used (see DrawGradientBackground)
# Result:
#    None
# Side effects:
#    Data bars drawn in canvas
#
proc ::Plotchart::DrawHorizBarData { w series xdata {colour black} {dir {}} } {
   variable data_series
   variable scaling

   #
   # Draw the bars
   #
   set y $scaling($w,ybase)

   #
   # set the colours
   #
   if {[llength ${colour}]} {
       set colours ${colour}
   } elseif {[info exists scaling(${w},colours)]} {
       set colours $scaling(${w},colours)
   } else {
       set colours {}
   }
   set colours [CycleColours ${colours} [llength ${xdata}]]

   #
   # Legend information
   #
   set legendcol [lindex $colours 0]
   set data_series($w,$series,-colour) $legendcol
   if { [info exists legend($w,canvas)] } {
       set legendw $legend($w,canvas)
       $legendw itemconfigure $series -fill $legendcol
   }

   set newbase {}

   set idx 0
   foreach xvalue $xdata xbase $scaling($w,xbase) {
      set colour [lindex ${colours} ${idx}]
      incr idx

      if { $xvalue == "" } {
          set xvalue 0.0
      }

      set ynext [expr {$y+$scaling($w,barwidth)}]
      set x     [expr {$xvalue+$xbase}]
      foreach {px1 py1} [coordsToPixel $w $xbase $y    ] {break}
      foreach {px2 py2} [coordsToPixel $w $x     $ynext] {break}

      if { $dir == {} } {
          $w create rectangle $px1 $py1 $px2 $py2 \
                         -fill $colour -tag data
      } else {
          DrawGradientBackground $w $colour $dir [list $px1 $py1 $px2 $py2]
      }

      $w lower data

      set y [expr {$y+1.0}]

      lappend newbase $x
   }

   #
   # Prepare for the next series
   #
   if { $scaling($w,stacked) } {
      set scaling($w,xbase) $newbase
   }

   set scaling($w,ybase) [expr {$scaling($w,ybase)+$scaling($w,yshift)}]
}

# DrawHistogramData --
#    Draw the vertical bars for a histogram
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    xcrd        X coordinate (for the righthand side of the bar)
#    ycrd        Y coordinate
# Result:
#    None
# Side effects:
#    Data bars drawn in canvas
#
proc ::Plotchart::DrawHistogramData { w series xcrd ycrd } {
   variable data_series
   variable scaling

   #
   # Check for missing values (only y-value can be missing!)
   #
   if { $ycrd == "" } {
       set data_series($w,$series,x) $xcrd
       return
   }

   #
   # Draw the bar
   #
   set colour "black"
   if { [info exists data_series($w,$series,-colour)] } {
      set colour $data_series($w,$series,-colour)
   }

   foreach {pxcrd pycrd} [coordsToPixel $w $xcrd $ycrd] {break}

   if { [info exists data_series($w,$series,x)] } {
      set xold $data_series($w,$series,x)
   } else {
      set xold $scaling($w,xmin)
   }
   set yold $scaling($w,ymin)
   foreach {pxold pyold} [coordsToPixel $w $xold $yold] {break}

   $w create rectangle $pxold $pyold $pxcrd $pycrd \
                         -fill $colour -outline $colour -tag data
   $w lower data

   set data_series($w,$series,x) $xcrd
}

# DrawTimePeriod --
#    Draw a period
# Arguments:
#    w           Name of the canvas
#    text        Text to identify the "period" item
#    time_begin  Start time
#    time_end    Stop time
#    colour      The colour to use (optional)
# Result:
#    None
# Side effects:
#    Data bars drawn in canvas
#
proc ::Plotchart::DrawTimePeriod { w text time_begin time_end {colour black}} {
   variable data_series
   variable scaling

   #
   # Draw the text first
   #
   set ytext [expr {$scaling($w,current)+0.5*$scaling($w,dy)}]
   foreach {x y} [coordsToPixel $w $scaling($w,xmin) $ytext] {break}

   $w create text 5 $y -text $text -anchor w \
       -tags [list vertscroll above item_[expr {int($scaling($w,current))}]]

   #
   # Draw the bar to indicate the period
   #
   set xmin  [clock scan $time_begin]
   set xmax  [clock scan $time_end]
   set ybott [expr {$scaling($w,current)+$scaling($w,dy)}]

   foreach {x1 y1} [coordsToPixel $w $xmin $scaling($w,current)] {break}
   foreach {x2 y2} [coordsToPixel $w $xmax $ybott              ] {break}

   $w create rectangle $x1 $y1 $x2 $y2 -fill $colour \
       -tags [list vertscroll horizscroll below item_[expr {int($scaling($w,current))}]]

   ReorderChartItems $w

   set scaling($w,current) [expr {$scaling($w,current)-1.0}]

   RescaleChart $w
}

# DrawTimeVertLine --
#    Draw a vertical line with a label
# Arguments:
#    w           Name of the canvas
#    text        Text to identify the line
#    time        Time for which the line is drawn
# Result:
#    None
# Side effects:
#    Line drawn in canvas
#
proc ::Plotchart::DrawTimeVertLine { w text time {colour black}} {
   variable data_series
   variable scaling

   #
   # Draw the text first
   #
   set xtime [clock scan $time]
   #set ytext [expr {$scaling($w,ymax)-0.5*$scaling($w,dy)}]
   set ytext $scaling($w,ymax)
   foreach {x y} [coordsToPixel $w $xtime $ytext] {break}
   set y [expr {$y-5}]

   $w create text $x $y -text $text -anchor sw -tags {horizscroll timeline}

   #
   # Draw the line
   #
   foreach {x1 y1} [coordsToPixel $w $xtime $scaling($w,ymin)] {break}
   foreach {x2 y2} [coordsToPixel $w $xtime $scaling($w,ymax)] {break}

   $w create line $x1 $y1 $x2 $y2 -fill black -tags {horizscroll timeline tline}

   $w raise topmask
}

# DrawTimeMilestone --
#    Draw a "milestone"
# Arguments:
#    w           Name of the canvas
#    text        Text to identify the line
#    time        Time for which the milestone is drawn
#    colour      Optionally the colour
# Result:
#    None
# Side effects:
#    Line drawn in canvas
#
proc ::Plotchart::DrawTimeMilestone { w text time {colour black}} {
   variable data_series
   variable scaling

   #
   # Draw the text first
   #
   set ytext [expr {$scaling($w,current)+0.5*$scaling($w,dy)}]
   foreach {x y} [coordsToPixel $w $scaling($w,xmin) $ytext] {break}

   $w create text 5 $y -text $text -anchor w \
       -tags [list vertscroll above item_[expr {int($scaling($w,current))}]]

   #
   # Draw an upside-down triangle to indicate the time
   #
   set xcentre [clock scan $time]
   set ytop    $scaling($w,current)
   set ybott   [expr {$scaling($w,current)+0.8*$scaling($w,dy)}]

   foreach {x1 y1} [coordsToPixel $w $xcentre $ybott] {break}
   foreach {x2 y2} [coordsToPixel $w $xcentre $ytop]  {break}

   set x2 [expr {$x1-0.4*($y1-$y2)}]
   set x3 [expr {$x1+0.4*($y1-$y2)}]
   set y3 $y2

   $w create polygon $x1 $y1 $x2 $y2 $x3 $y3 -fill $colour \
       -tags [list vertscroll horizscroll below item_[expr {int($scaling($w,current))}]]

   ReorderChartItems $w

   set scaling($w,current) [expr {$scaling($w,current)-1.0}]

   RescaleChart $w
}

# ScaleItems --
#    Scale all items by a given factor
# Arguments:
#    w           Name of the canvas
#    xcentre     X-coordinate of centre
#    ycentre     Y-coordinate of centre
#    factor      The factor to scale them by
# Result:
#    None
# Side effects:
#    All items are scaled by the given factor and the
#    world coordinates are adjusted.
#
proc ::Plotchart::ScaleItems { w xcentre ycentre factor } {
   variable scaling

   $w scale all $xcentre $ycentre $factor $factor

   foreach {xc yc} [pixelToCoords $w $xcentre $ycentre] {break}

   set rfact               [expr {1.0/$factor}]
   set scaling($w,xfactor) [expr {$scaling($w,xfactor)*$factor}]
   set scaling($w,yfactor) [expr {$scaling($w,yfactor)*$factor}]
   set scaling($w,xmin)    [expr {(1.0-$rfact)*$xc+$rfact*$scaling($w,xmin)}]
   set scaling($w,xmax)    [expr {(1.0-$rfact)*$xc+$rfact*$scaling($w,xmax)}]
   set scaling($w,ymin)    [expr {(1.0-$rfact)*$yc+$rfact*$scaling($w,ymin)}]
   set scaling($w,ymax)    [expr {(1.0-$rfact)*$yc+$rfact*$scaling($w,ymax)}]
}

# MoveItems --
#    Move all items by a given vector
# Arguments:
#    w           Name of the canvas
#    xmove       X-coordinate of move vector
#    ymove       Y-coordinate of move vector
# Result:
#    None
# Side effects:
#    All items are moved by the given vector and the
#    world coordinates are adjusted.
#
proc ::Plotchart::MoveItems { w xmove ymove } {
   variable scaling

   $w move all $xmove $ymove

   set dx                  [expr {$scaling($w,xfactor)*$xmove}]
   set dy                  [expr {$scaling($w,yfactor)*$ymove}]
   set scaling($w,xmin)    [expr {$scaling($w,xmin)+$dx}]
   set scaling($w,xmax)    [expr {$scaling($w,xmax)+$dx}]
   set scaling($w,ymin)    [expr {$scaling($w,ymin)+$dy}]
   set scaling($w,ymax)    [expr {$scaling($w,ymax)+$dy}]
}

# DrawIsometricData --
#    Draw the data in an isometric plot
# Arguments:
#    w           Name of the canvas
#    type        Type of data
#    args        Coordinates and so on
# Result:
#    None
# Side effects:
#    New data drawn in canvas
#
proc ::Plotchart::DrawIsometricData { w type args } {
   variable data_series

   #
   # What type of data?
   #
   if { $type == "rectangle" } {
      foreach {x1 y1 x2 y2 colour} [concat $args "black"] {break}
      foreach {px1 py1} [coordsToPixel $w $x1 $y1] {break}
      foreach {px2 py2} [coordsToPixel $w $x2 $y2] {break}
      $w create rectangle $px1 $py1 $px2 $py2 \
                     -outline $colour -tag data
      $w lower data
   }

   if { $type == "filled-rectangle" } {
      foreach {x1 y1 x2 y2 colour} [concat $args "black"] {break}
      foreach {px1 py1} [coordsToPixel $w $x1 $y1] {break}
      foreach {px2 py2} [coordsToPixel $w $x2 $y2] {break}
      $w create rectangle $px1 $py1 $px2 $py2 \
                     -outline $colour -fill $colour -tag data
      $w lower data
   }

   if { $type == "filled-circle" } {
      foreach {x1 y1 rad colour} [concat $args "black"] {break}
      set x2 [expr {$x1+$rad}]
      set y2 [expr {$y1+$rad}]
      set x1 [expr {$x1-$rad}]
      set y1 [expr {$y1-$rad}]
      foreach {px1 py1} [coordsToPixel $w $x1 $y1] {break}
      foreach {px2 py2} [coordsToPixel $w $x2 $y2] {break}
      $w create oval $px1 $py1 $px2 $py2 \
                     -outline $colour -fill $colour -tag data
      $w lower data
   }

   if { $type == "circle" } {
      foreach {x1 y1 rad colour} [concat $args "black"] {break}
      set x2 [expr {$x1+$rad}]
      set y2 [expr {$y1+$rad}]
      set x1 [expr {$x1-$rad}]
      set y1 [expr {$y1-$rad}]
      foreach {px1 py1} [coordsToPixel $w $x1 $y1] {break}
      foreach {px2 py2} [coordsToPixel $w $x2 $y2] {break}
      $w create oval $px1 $py1 $px2 $py2 \
                     -outline $colour -tag data
      $w lower data
   }

}

# BackgroundColour --
#    Set the background colour or other aspects of the background
# Arguments:
#    w           Name of the canvas
#    part        Which part: axes or plot
#    colour      Colour to use (or if part is "image", name of the image)
#    dir         Direction of increasing whiteness (optional, for "gradient"
#
# Result:
#    None
# Side effect:
#    Colour of the relevant part is changed
#
proc ::Plotchart::BackgroundColour { w part colour {dir {}} } {
    if { $part == "axes" } {
        $w configure -highlightthickness 0
        $w itemconfigure mask -fill $colour -outline $colour
    }
    if { $part == "plot" } {
        $w configure -highlightthickness 0
        $w configure -background $colour
    }
    if { $part == "gradient" } {
        DrawGradientBackground $w $colour $dir
    }
    if { $part == "image" } {
        DrawImageBackground $w $colour
    }
}

# DrawRadialSpokes --
#    Draw the spokes of the radial chart
# Arguments:
#    w           Name of the canvas
#    names       Names of the spokes
# Result:
#    None
# Side effects:
#    Radial chart filled in
#
proc ::Plotchart::DrawRadialSpokes { w names } {
   variable settings
   variable scaling

   set pxmin $scaling($w,pxmin)
   set pymin $scaling($w,pymin)
   set pxmax $scaling($w,pxmax)
   set pymax $scaling($w,pymax)

   $w create oval $pxmin $pymin $pxmax $pymax -outline black

   set dangle [expr {2.0 * 3.1415926 / [llength $names]}]
   set angle  0.0
   set xcentr [expr {($pxmin+$pxmax)/2.0}]
   set ycentr [expr {($pymin+$pymax)/2.0}]

   foreach name $names {
       set xtext  [expr {$xcentr+cos($angle)*($pxmax-$pxmin+20)/2}]
       set ytext  [expr {$ycentr-sin($angle)*($pymax-$pymin+20)/2}]
       set xspoke [expr {$xcentr+cos($angle)*($pxmax-$pxmin)/2}]
       set yspoke [expr {$ycentr-sin($angle)*($pymax-$pymin)/2}]

       if { cos($angle) >= 0.0 } {
           set anchor w
       } else {
           set anchor e
       }

       if { abs($xspoke-$xcentr) < 2 } {
           set xspoke $xcentr
       }
       if { abs($yspoke-$ycentr) < 2 } {
           set yspoke $ycentr
       }

       $w create text $xtext $ytext -text $name -anchor $anchor
       $w create line $xcentr $ycentr $xspoke $yspoke -fill black

       set angle [expr {$angle+$dangle}]
   }
}

# DrawRadial --
#    Draw the data for the radial chart
# Arguments:
#    w           Name of the canvas
#    values      Values for each spoke
#    colour      Colour of the line
#    thickness   Thickness of the line (optional)
# Result:
#    None
# Side effects:
#    New line drawn
#
proc ::Plotchart::DrawRadial { w values colour {thickness 1} } {
   variable data_series
   variable settings
   variable scaling

   if { [llength $values] != $settings($w,number) } {
       return -code error "Incorrect number of data given - should be $settings($w,number)"
   }

   set pxmin $scaling($w,pxmin)
   set pymin $scaling($w,pymin)
   set pxmax $scaling($w,pxmax)
   set pymax $scaling($w,pymax)

   set dangle [expr {2.0 * 3.1415926 / [llength $values]}]
   set angle  0.0
   set xcentr [expr {($pxmin+$pxmax)/2.0}]
   set ycentr [expr {($pymin+$pymax)/2.0}]

   set coords {}

   if { ! [info exists data_series($w,base)] } {
       set data_series($w,base) {}
       foreach value $values {
           lappend data_series($w,base) 0.0
       }
   }

   set newbase {}
   foreach value $values base $data_series($w,base) {
       if { $settings($w,style) != "lines" } {
           set value [expr {$value+$base}]
       }
       set factor [expr {$value/$settings($w,scale)}]
       set xspoke [expr {$xcentr+$factor*cos($angle)*($pxmax-$pxmin)/2}]
       set yspoke [expr {$ycentr-$factor*sin($angle)*($pymax-$pymin)/2}]

       if { abs($xspoke-$xcentr) < 2 } {
           set xspoke $xcentr
       }
       if { abs($yspoke-$ycentr) < 2 } {
           set yspoke $ycentr
       }

       lappend coords $xspoke $yspoke
       lappend newbase $value
       set angle [expr {$angle+$dangle}]
   }

   set data_series($w,base) $newbase

   if { $settings($w,style) == "filled" } {
       set fillcolour $colour
   } else {
       set fillcolour ""
   }

   set id [$w create polygon $coords -outline $colour -width $thickness -fill $fillcolour -tags data]
   $w lower $id
}

# DrawTrendLine --
#    Draw a trend line based on the given data in an XY-plot
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    xcrd        Next x coordinate
#    ycrd        Next y coordinate
# Result:
#    None
# Side effects:
#    New/updated trend line drawn in canvas
#
proc ::Plotchart::DrawTrendLine { w series xcrd ycrd } {
    variable data_series
    variable scaling

    #
    # Check for missing values
    #
    if { $xcrd == "" || $ycrd == "" } {
        return
    }

    #
    # Compute the coefficients of the line
    #
    if { [info exists data_series($w,$series,xsum)] } {
        set nsum  [expr {$data_series($w,$series,nsum)  + 1.0}]
        set xsum  [expr {$data_series($w,$series,xsum)  + $xcrd}]
        set x2sum [expr {$data_series($w,$series,x2sum) + $xcrd*$xcrd}]
        set ysum  [expr {$data_series($w,$series,ysum)  + $ycrd}]
        set xysum [expr {$data_series($w,$series,xysum) + $ycrd*$xcrd}]
    } else {
        set nsum  [expr {1.0}]
        set xsum  [expr {$xcrd}]
        set x2sum [expr {$xcrd*$xcrd}]
        set ysum  [expr {$ycrd}]
        set xysum [expr {$ycrd*$xcrd}]
    }

    if { $nsum*$x2sum != $xsum*$xsum } {
        set a [expr {($nsum*$xysum-$xsum*$ysum)/($nsum*$x2sum - $xsum*$xsum)}]
    } else {
        set a 0.0
    }
    set b [expr {($ysum-$a*$xsum)/$nsum}]

    set xmin $scaling($w,xmin)
    set xmax $scaling($w,xmax)

    foreach {pxmin pymin} [coordsToPixel $w $xmin [expr {$a*$xmin+$b}]] {break}
    foreach {pxmax pymax} [coordsToPixel $w $xmax [expr {$a*$xmax+$b}]] {break}

    #
    # Draw the actual line
    #
    set colour "black"
    if { [info exists data_series($w,$series,-colour)] } {
        set colour $data_series($w,$series,-colour)
    }

    if { [info exists data_series($w,$series,trend)] } {
        $w coords $data_series($w,$series,trend) $pxmin $pymin $pxmax $pymax
    } else {
        set data_series($w,$series,trend) \
            [$w create line $pxmin $pymin $pxmax $pymax -fill $colour -tag [list data data_$series]]
    }

    $w lower data

    set data_series($w,$series,nsum)  $nsum
    set data_series($w,$series,xsum)  $xsum
    set data_series($w,$series,x2sum) $x2sum
    set data_series($w,$series,ysum)  $ysum
    set data_series($w,$series,xysum) $xysum
}

# VectorConfigure --
#    Set configuration options for vectors
# Arguments:
#    w           Name of the canvas
#    series      Data series (identifier for vectors)
#    args        Pairs of configuration options:
#                -scale|-colour|-centred|-type {cartesian|polar|nautical}
# Result:
#    None
# Side effects:
#    Configuration options are stored
#
proc ::Plotchart::VectorConfigure { w series args } {
    variable data_series
    variable scaling

    foreach {option value} $args {
        switch -- $option {
            "-scale" {
                if { $value > 0.0 } {
                    set scaling($w,$series,vectorscale) $value
                } else {
                    return -code error "Scale factor must be positive"
                }
            }
            "-colour" - "-color" {
                set data_series($w,$series,vectorcolour) $value
            }
            "-centered" - "-centred" {
                set data_series($w,$series,vectorcentred) $value
            }
            "-type" {
                if { [lsearch {cartesian polar nautical} $value] >= 0 } {
                    set data_series($w,$series,vectortype) $value
                } else {
                    return -code error "Unknown vector components option: $value"
                }
            }
            default {
                return -code error "Unknown vector option: $option ($value)"
            }
        }
    }
}

# DrawVector --
#    Draw a vector at the given coordinates with the given components
# Arguments:
#    w           Name of the canvas
#    series      Data series (identifier for the vectors)
#    xcrd        X coordinate of start or centre
#    ycrd        Y coordinate of start or centre
#    ucmp        X component or length
#    vcmp        Y component or angle
# Result:
#    None
# Side effects:
#    New arrow drawn in canvas
#
proc ::Plotchart::DrawVector { w series xcrd ycrd ucmp vcmp } {
    variable data_series
    variable scaling

    #
    # Check for missing values
    #
    if { $xcrd == "" || $ycrd == "" } {
        return
    }
    #
    # Check for missing values
    #
    if { $ucmp == "" || $vcmp == "" } {
        return
    }

    #
    # Get the options
    #
    set scalef  1.0
    set colour  black
    set centred 0
    set type    cartesian
    if { [info exists scaling($w,$series,vectorscale)] } {
        set scalef $scaling($w,$series,vectorscale)
    }
    if { [info exists data_series($w,$series,vectorcolour)] } {
        set colour $data_series($w,$series,vectorcolour)
    }
    if { [info exists data_series($w,$series,vectorcentred)] } {
        set centred $data_series($w,$series,vectorcentred)
    }
    if { [info exists data_series($w,$series,vectortype)] } {
        set type $data_series($w,$series,vectortype)
    }

    #
    # Compute the coordinates of beginning and end of the arrow
    #
    switch -- $type {
        "polar" {
            set x1 [expr {$ucmp * cos( 3.1415926 * $vcmp / 180.0 ) }]
            set y1 [expr {$ucmp * sin( 3.1415926 * $vcmp / 180.0 ) }]
            set ucmp $x1
            set vcmp $y1
        }
        "nautical" {
            set x1 [expr {$ucmp * sin( 3.1415926 * $vcmp / 180.0 ) }]
            set y1 [expr {$ucmp * cos( 3.1415926 * $vcmp / 180.0 ) }]
            set ucmp $x1
            set vcmp $y1
        }
    }

    set u1 [expr {$scalef * $ucmp}]
    set v1 [expr {$scalef * $vcmp}]

    foreach {x1 y1} [coordsToPixel $w $xcrd $ycrd] {break}

    if { $centred } {
        set x1 [expr {$x1 - 0.5 * $u1}]
        set y1 [expr {$y1 + 0.5 * $v1}]
    }

    set x2 [expr {$x1 + $u1}]
    set y2 [expr {$y1 - $v1}]

    #
    # Draw the arrow
    #
    $w create line $x1 $y1 $x2 $y2 -fill $colour -tag [list data data_$series] -arrow last
    $w lower data
}

# DotConfigure --
#    Set configuration options for dots
# Arguments:
#    w           Name of the canvas
#    series      Data series (identifier for dots)
#    args        Pairs of configuration options:
#                -radius|-colour|-classes {value colour ...}|-outline|-scalebyvalue|
#                -scale
# Result:
#    None
# Side effects:
#    Configuration options are stored
#
proc ::Plotchart::DotConfigure { w series args } {
    variable data_series
    variable scaling

    foreach {option value} $args {
        switch -- $option {
            "-scale" {
                if { $value > 0.0 } {
                    set scaling($w,$series,dotscale) $value
                } else {
                    return -code error "Scale factor must be positive"
                }
            }
            "-colour" - "-color" {
                set data_series($w,$series,dotcolour) $value
            }
            "-radius" {
                set data_series($w,$series,dotradius) $value
            }
            "-scalebyvalue" {
                set data_series($w,$series,dotscalebyvalue) $value
            }
            "-outline" {
                set data_series($w,$series,dotoutline) $value
            }
            "-classes" {
                set data_series($w,$series,dotclasses) $value
            }
            default {
                return -code error "Unknown dot option: $option ($value)"
            }
        }
    }
}

# DrawDot --
#    Draw a dot at the given coordinates, size and colour based on the given value
# Arguments:
#    w           Name of the canvas
#    series      Data series (identifier for the vectors)
#    xcrd        X coordinate of start or centre
#    ycrd        Y coordinate of start or centre
#    value       Value to be used
# Result:
#    None
# Side effects:
#    New oval drawn in canvas
#
proc ::Plotchart::DrawDot { w series xcrd ycrd value } {
    variable data_series
    variable scaling

    #
    # Check for missing values
    #
    if { $xcrd == "" || $ycrd == "" || $value == "" } {
        return
    }

    #
    # Get the options
    #
    set scalef   1.0
    set colour   black
    set usevalue 1
    set outline  black
    set radius   3
    set classes  {}
    if { [info exists scaling($w,$series,dotscale)] } {
        set scalef $scaling($w,$series,dotscale)
    }
    if { [info exists data_series($w,$series,dotcolour)] } {
        set colour $data_series($w,$series,dotcolour)
    }
    if { [info exists data_series($w,$series,dotoutline)] } {
        set outline {}
        if { $data_series($w,$series,dotoutline) } {
            set outline black
        }
    }
    if { [info exists data_series($w,$series,dotradius)] } {
        set radius $data_series($w,$series,dotradius)
    }
    if { [info exists data_series($w,$series,dotclasses)] } {
        set classes $data_series($w,$series,dotclasses)
    }
    if { [info exists data_series($w,$series,dotscalebyvalue)] } {
        set usevalue $data_series($w,$series,dotscalebyvalue)
    }

    #
    # Compute the radius and the colour
    #
    if { $usevalue } {
        set radius [expr {$scalef * $value}]
    }
    if { $classes != {} } {
        foreach {limit col} $classes {
            if { $value < $limit } {
                set colour $col
                break
            }
        }
    }

    foreach {x y} [coordsToPixel $w $xcrd $ycrd] {break}

    set x1 [expr {$x - $radius}]
    set y1 [expr {$y - $radius}]
    set x2 [expr {$x + $radius}]
    set y2 [expr {$y + $radius}]

    #
    # Draw the oval
    #
    $w create oval $x1 $y1 $x2 $y2 -fill $colour -tag [list data data_$series] -outline $outline
    $w lower data
}

# DrawRchart --
#    Draw data together with two horizontal lines representing the
#    expected range
# Arguments:
#    w           Name of the canvas
#    series      Data series
#    xcrd        X coordinate of the data point
#    ycrd        Y coordinate of the data point
# Result:
#    None
# Side effects:
#    New data point drawn, lines updated
#
proc ::Plotchart::DrawRchart { w series xcrd ycrd } {
    variable data_series
    variable scaling

    #
    # Check for missing values
    #
    if { $xcrd == "" || $ycrd == "" } {
        return
    }

    #
    # In any case, draw the data point
    #
    DrawData $w $series $xcrd $ycrd

    #
    # Compute the expected range
    #
    if { ! [info exists data_series($w,$series,rchart)] } {
        set data_series($w,$series,rchart) $ycrd
    } else {
        lappend data_series($w,$series,rchart) $ycrd

        if { [llength $data_series($w,$series,rchart)] < 2 } {
            return
        }

        set filtered $data_series($w,$series,rchart)
        set outside  1
        while { $outside } {
            set data     $filtered
            foreach {ymin ymax} [RchartValues $data] {break}
            set filtered {}
            set outside  0
            foreach y $data {
                if { $y < $ymin || $y > $ymax } {
                    set outside 1
                } else {
                    lappend filtered $y
                }
            }
        }

        #
        # Draw the limit lines
        #
        if { [info exists data_series($w,$series,rchartlimits)] } {
            eval $w delete $data_series($w,$series,rchartlimits)
        }

        set colour "black"
        if { [info exists data_series($w,$series,-colour)] } {
            set colour $data_series($w,$series,-colour)
        }

        set xmin $scaling($w,xmin)
        set xmax $scaling($w,xmax)

        foreach {pxmin pymin} [coordsToPixel $w $xmin $ymin] {break}
        foreach {pxmax pymax} [coordsToPixel $w $xmax $ymax] {break}


        set data_series($w,$series,rchartlimits) [list \
            [$w create line $pxmin $pymin $pxmax $pymin -fill $colour -tag [list data data_$series]] \
            [$w create line $pxmin $pymax $pxmax $pymax -fill $colour -tag [list data data_$series]]]
    }
}

# RchartValues --
#    Compute the expected range for a series of data
# Arguments:
#    data        Data to be examined
# Result:
#    Expected minimum and maximum
#
proc ::Plotchart::RchartValues { data } {
    set sum   0.0
    set sum2  0.0
    set ndata [llength $data]

    if { $ndata <= 1 } {
        return [list $data $data]
    }

    foreach v $data {
        set sum   [expr {$sum  + $v}]
        set sum2  [expr {$sum2 + $v*$v}]
    }

    if { $ndata < 2 } {
       return [list $v $v]
    }

    set variance [expr {($sum2 - $sum*$sum/double($ndata))/($ndata-1.0)}]
    if { $variance < 0.0 } {
        set variance 0.0
    }

    set vmean [expr {$sum/$ndata}]
    set stdev [expr {sqrt($variance)}]
    set vmin  [expr {$vmean - 3.0 * $stdev}]
    set vmax  [expr {$vmean + 3.0 * $stdev}]

    return [list $vmin $vmax]
}

# ReorderChartItems --
#    Rearrange the drawing order of time and Gantt chart items
# Arguments:
#    w           Canvas widget containing them
# Result:
#    None
#
proc ::Plotchart::ReorderChartItems { w } {

    $w lower above
    $w lower vertmask
    $w lower tline
    $w lower below
    $w lower lowest

}

# RescaleChart --
#    Reset the scaling of the scrollbar(s) for time and Gantt charts
# Arguments:
#    w           Canvas widget containing them
# Result:
#    None
# Note:
#    To be called after scaling($w,current) has been updated
#    or a new time line has been added
#
proc ::Plotchart::RescaleChart { w } {
    variable scaling

    if { [info exists scaling($w,vscroll)] } {
        if { $scaling($w,current) >= 0.0 } {
            set scaling($w,theight) $scaling($w,ymax)
            $scaling($w,vscroll) set 0.0 1.0
        } else {
            set scaling($w,theight) [expr {$scaling($w,ymax)-$scaling($w,current)}]
            $scaling($w,vscroll) set $scaling($w,curpos) \
                [expr {$scaling($w,curpos) + $scaling($w,ymax)/$scaling($w,theight)}]
        }
    }

    if { [info exists scaling($w,hscroll)] } {
        foreach {xmin dummy xmax} [$w bbox $w horizscroll] {break}
        set scaling($w,twidth) [expr {$xmax-$xmin}]
        if { $scaling($w,twidth) < $scaling($w,pxmax)-$scaling($w,pxmin) } {
            $scaling($w,hscroll) set 0.0 1.0
        } else {
            $scaling($w,hscroll) set $scaling($w,curhpos) \
                [expr {$scaling($w,curhpos) + \
                         ($scaling($w,pxmax)-$scaling($w,pxmin)) \
                         /double($scaling($w,twidth))}]
        }
    }
}

# ConnectVertScrollbar --
#    Connect a vertical scroll bar to the chart
# Arguments:
#    w           Canvas widget containing them
#    scrollbar   Scroll bar in question
# Result:
#    None
#
proc ::Plotchart::ConnectVertScrollbar { w scrollbar } {
    variable scaling

    $scrollbar configure -command [list ::Plotchart::VertScrollChart $w]
    bind $w <4> [list ::Plotchart::VertScrollChart $w scroll  -1 units]
    bind $w <5> [list ::Plotchart::VertScrollChart $w scroll   1 units]
    bind $w <MouseWheel> [list ::Plotchart::VertScrollChart $w scroll %D wheel]
    set scaling($w,vscroll) $scrollbar

    RescaleChart $w
}

# ConnectHorizScrollbar --
#    Connect a horizontal scroll bar to the chart
# Arguments:
#    w           Canvas widget containing them
#    scrollbar   Scroll bar in question
# Result:
#    None
#
proc ::Plotchart::ConnectHorizScrollbar { w scrollbar } {
    variable scaling

    $scrollbar configure -command [list ::Plotchart::HorizScrollChart $w]
    set scaling($w,hscroll) $scrollbar

    RescaleChart $w
}

# VertScrollChart --
#    Scroll a chart using the vertical scroll bar
# Arguments:
#    w           Canvas widget containing them
#    operation   Operation to respond to
#    number      Number representing the size of the displacement
#    unit        Unit of displacement
# Result:
#    None
#
proc ::Plotchart::!VertScrollChart { w operation number {unit {}}} {
    variable scaling

    set pixheight [expr {$scaling($w,pymax)-$scaling($w,pymin)}]
    set height    [expr {$pixheight*$scaling($w,theight)/$scaling($w,ymax)}]

    switch -- $operation {
        "moveto" {
            set dy                 [expr {$height*($scaling($w,curpos)-$number)}]
            set scaling($w,curpos) $number
        }
        "scroll" {
            if { $unit == "units" } {
                set dy     [expr {-$number*$height/$scaling($w,theight)}]
                set newpos [expr {$scaling($w,curpos) + $number/$scaling($w,theight)}]
            } else {
                set dy     [expr {-$number*$pixheight}]
                set newpos [expr {$scaling($w,curpos) + $number*$scaling($w,ymax)/$scaling($w,theight)}]
            }

            if { $newpos < 0.0 } {
                set newpos 0.0
                set dy     [expr {$...}]
            }

            if { $newpos > 1.0 } {
                set newpos 1.0
                set dy     [expr {$...}]
            }
            set scaling($w,curpos) $newpos
        }
    }

    #
    # TODO: limit the position between 0 and 1
    #

    $w move vertscroll 0 $dy

    RescaleChart $w
}
proc ::Plotchart::VertScrollChart { w operation number {unit {}}} {
    variable scaling

    # Get the height of the scrolling region and the current position of the slider
    set height [expr {$scaling($w,pymax)-$scaling($w,pymin)}]
    foreach {ts bs} [$scaling($w,vscroll) get] {break}

    if { $unit == "wheel" } {
        set operation "scroll"
        set unit      "units"
        set number    [expr {$number>0? 1 : -1}]
    }

    switch -- $operation {
        "moveto" {
            # No scrolling if we are already at the top or bottom
            if { $number < 0.0 } {
                set number 0.0
            }
            if { $number+($bs-$ts) > 1.0 } {
                set number [expr {1.0-($bs-$ts)}]
            }
            set dy     [expr {$height*($scaling($w,curpos)-$number)/($bs-$ts)}]
            set scaling($w,curpos) $number
            $w move vertscroll 0 $dy
        }
        "scroll" {
            # Handle "units" and "pages" the same

            # No scrolling if we are at the top or bottom
            if {$number == -1 && $ts == 0.0} {
                return
            }

            if {$number == 1 && $bs == 1.0} {
                return
            }

            # Scroll 1 unit in coordinate space, converted to pixel space
            foreach {x1 y1} [coordsToPixel $w 0 0.0] {break}
            foreach {x2 y2} [coordsToPixel $w 0 1.0] {break}

            # This is the amount to scroll based on the current height
            set amt [expr {$number*($y2-$y1)/$height}]

            # Handle boundary conditions, don't want to scroll too far off
            # the top or bottom.
            if {$number == 1 && $bs-$amt > 1.0} {
                set amt [expr {$bs-1.0}]
            } elseif {$number == -1 && $ts-$amt < 0.0} {
                set amt $ts
            }

            # Set the scrolling parameters and scroll
            set dy  [expr {$height*($scaling($w,curpos)-($ts-$amt))/($bs-$ts)}]
            set scaling($w,curpos) [expr {$ts-$amt}]
            $w move vertscroll 0 $dy
        }
    }

    RescaleChart $w
}

# HorizScrollChart --
#    Scroll a chart using the horizontal scroll bar
# Arguments:
#    w           Canvas widget containing them
#    operation   Operation to respond to
#    number      Number representing the size of the displacement
#    unit        Unit of displacement
# Result:
#    None
#
proc ::Plotchart::HorizScrollChart { w operation number {unit {}}} {
    variable scaling

    # Get the width of the scrolling region and the current position of the slider
    set width [expr {double($scaling($w,pxmax)-$scaling($w,pxmin))}]
    foreach {ts bs} [$scaling($w,hscroll) get] {break}

    switch -- $operation {
        "moveto" {
            # No scrolling if we are already at the top or bottom
            if { $number < 0.0 } {
                set number 0.0
            }
            if { $number+($bs-$ts) > 1.0 } {
                set number [expr {1.0-($bs-$ts)}]
            }
            set dx     [expr {$width*($scaling($w,curhpos)-$number)/($bs-$ts)}]
            set scaling($w,curhpos) $number
            $w move horizscroll $dx 0
        }
        "scroll" {
            # Handle "units" and "pages" the same

            # No scrolling if we are at the top or bottom
            if {$number == -1 && $ts == 0.0} {
                return
            }

            if {$number == 1 && $bs == 1.0} {
                return
            }

            # Scroll 1 unit in coordinate space, converted to pixel space
            set dx [expr {0.1*($scaling($w,xmax)-$scaling($w,xmin))}]
            foreach {x1 y1} [coordsToPixel $w 0   0.0] {break}
            foreach {x2 y2} [coordsToPixel $w $dx 0.0] {break}

            # This is the amount to scroll based on the current width
            set amt [expr {$number*($x2-$x1)/$width}]

            # Handle boundary conditions, don't want to scroll too far off
            # the left or the right
            if {$number == 1 && $bs-$amt > 1.0} {
                set amt [expr {$bs-1.0}]
            } elseif {$number == -1 && $ts-$amt < 0.0} {
                set amt $ts
            }

            # Set the scrolling parameters and scroll
            set dx  [expr {$width*($scaling($w,curhpos)-($ts-$amt))/($bs-$ts)}]
            set scaling($w,curhpos) [expr {$ts-$amt}]
            $w move horizscroll $dx 0
        }
    }

    RescaleChart $w
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/plotchart/scaling.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
# scaling.tcl --
#    Make a nice scale for the axes in the Plotchart package
#

namespace eval ::Plotchart {
   namespace export determineScale

   #
   # Try and load the math::fuzzy package for better
   # comparisons
   #
   if { [catch {
            package require math::fuzzy
            namespace import ::math::fuzzy::tlt
            namespace import ::math::fuzzy::tgt
         }] } {
      proc tlt {a b} {
         expr {$a < $b }
      }
      proc tgt {a b} {
         expr {$a > $b }
      }
   }
}

# determineScale --
#    Determine nice values for an axis from the given extremes
#
# Arguments:
#    xmin      Minimum value
#    xmax      Maximum value
#    inverted  Whether to return values for an inverted axis (1) or not (0)
#              Defaults to 0.
# Result:
#    A list of three values, a nice minimum and maximum
#    and stepsize
# Note:
#    xmin is assumed to be smaller or equal xmax
#
proc ::Plotchart::determineScale { xmin xmax {inverted 0} } {
   set dx [expr {abs($xmax-$xmin)}]

   if { $dx == 0.0 } {
      if { $xmin == 0.0 } {
         return [list -0.1 0.1 0.1]
      } else {
         set dx [expr {0.2*abs($xmax)}]
         set xmin [expr {$xmin-0.5*$dx}]
         set xmax [expr {$xmin+0.5*$dx}]
      }
   }

   #
   # Determine the factor of 10 so that dx falls within the range 1-10
   #
   set expon  [expr {int(log10($dx))}]
   set factor [expr {pow(10.0,$expon)}]

   set dx     [expr {$dx/$factor}]

   foreach {limit step} {1.4 0.2 2.0 0.5 5.0 1.0 10.0 2.0} {
      if { $dx < $limit } {
         break
      }
   }

   set nicemin [expr {$step*$factor*int($xmin/$factor/$step)}]
   set nicemax [expr {$step*$factor*int($xmax/$factor/$step)}]

   if { [tlt $nicemax $xmax] } {
      set nicemax [expr {$nicemax+$step*$factor}]
   }
   if { [tgt $nicemin $xmin] } {
      set nicemin [expr {$nicemin-$step*$factor}]
   }

   if { !$inverted } {
       return [list $nicemin $nicemax [expr {$step*$factor}]]
   } else {
       return [list $nicemax $nicemin [expr {-$step*$factor}]]
   }
}

# determineTimeScale --
#    Determine nice date/time values for an axis from the given extremes
#
# Arguments:
#    tmin      Minimum date/time
#    tmax      Maximum date/time
# Result:
#    A list of three values, a nice minimum and maximum
#    and stepsize
# Note:
#    tmin is assumed to be smaller or equal tmax
#
proc ::Plotchart::determineTimeScale { tmin tmax } {
    set ttmin [clock scan $tmin]
    set ttmax [clock scan $tmax]

    set dt [expr {abs($ttmax-$ttmin)}]

    if { $dt == 0.0 } {
        set dt 86400.0
        set ttmin [expr {$ttmin-$dt}]
        set ttmax [expr {$ttmin+$dt}]
    }

    foreach {limit step} {2.0 0.5 5.0 1.0 10.0 2.0 50.0 7.0 300.0 30.0 1.0e10 365.0} {
        if { $dt/86400.0 < $limit } {
            break
        }
    }

    set nicemin [expr {$step*floor($ttmin/$step)}]
    set nicemax [expr {$step*floor($ttmax/$step)}]

    if { $nicemax < $ttmax } {
        set nicemax [expr {$nicemax+$step}]
    }
    if { $nicemin > $ttmin } {
        set nicemin [expr {$nicemin-$step}]
    }

    set nicemin [expr {int($nicemin)}]
    set nicemax [expr {int($nicemax)}]

    return [list [clock format $nicemin -format "%Y-%m-%d %H:%M:%S"] \
                 [clock format $nicemax -format "%Y-%m-%d %H:%M:%S"] \
                 $step]
}

if 0 {
    #
    # Some simple test cases
    #
    namespace import ::Plotchart::determineScale
    puts [determineScale 0.1 1.0]
    puts [determineScale 0.001 0.01]
    puts [determineScale -0.2 0.9]
    puts [determineScale -0.25 0.85]
    puts [determineScale -0.25 0.7999]
    puts [determineScale 10001 10010]
    puts [determineScale 10001 10015]
}
if 0 {
    puts [::Plotchart::determineTimeScale "2007-01-15" "2007-01-16"]
    puts [::Plotchart::determineTimeScale "2007-03-15" "2007-06-16"]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































Deleted scriptlibs/tklib0.5/style/as.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
# as_style.tcl --
#
#	This file implements package style::as.
#
# Copyright (c) 2003 ActiveState Corporation, a division of Sophos
#
# Basic use:
#
# style::as::init ?which?
# style::as::reset ?which?
# style::as::enable ?what ?args??
#	ie: enable control-mousewheel local|global
#

package require Tk

namespace eval style::as {
    variable version 1.4
    variable highlightbg "#316AC5" ; # SystemHighlight
    variable highlightfg "white"   ; # SystemHighlightText
    variable bg          "white"   ; # SystemWindow
    variable fg          "black"   ; # SystemWindowText
    if {[string equal $::tcl_platform(platform) "windows"]} {
	# Use the system colors on Windows, as they can adapt
	# to the user's personal color scheme
	set highlightbg "SystemHighlight"
	set highlightfg "SystemHighlightText"
	set bg          "SystemWindow"
	set fg          "SystemWindowText"
    }

    # This may need to be adjusted for some window managers that are
    # more aggressive with their own Xdefaults (like KDE and CDE)
    variable prio "widgetDefault"

    # assume MouseWheel binding is the same across widget classes
    variable mw
    set mw(classes) [list Text Listbox Table TreeCtrl]
    if {![info exists mw(binding)]} {
	# do this only once, in case of re-source-ing
	set mw(binding) [bind Text <MouseWheel>]
	set mw(s-binding) [bind Text <Shift-MouseWheel>]
	if {[tk windowingsystem] eq "x11"} {
	    set mw(binding4) [bind Text <4>]
	    set mw(binding5) [bind Text <5>]
	}
    }
    if {[tk windowingsystem] eq "aqua"} {
	set mw(ctrl) "Command"
    } else {
	set mw(ctrl) "Control"
    }
}; # end of namespace style::as

proc style::as::init {args} {
    package require Tk
    variable prio

    if {[llength $args]} {
	set arg [lindex $args 0]
	set len [string length $arg]
	if {$len > 2 && [string equal -len $len $arg "-priority"]} {
	    set prio [lindex $args 1]
	    set args [lrange $args 2 end]
	}
    }
    if {[llength $args]} {
	foreach what $args {
	    style::as::init_$what
	}
    } else {
	foreach cmd [info procs init_*] {
	    $cmd
	}
    }

    if {$::tcl_platform(os) eq "Windows CE"} {
	# WinCE is for small screens, with 240x320 (QVGA) the most common.
	# Adapt the defaults to that size.
	option add *font			{Tahoma 7} $prio
	option add *Button.borderWidth		1 $prio
	option add *Entry.borderWidth		1 $prio
	option add *Listbox.borderWidth		1 $prio
	option add *Spinbox.borderWidth		1 $prio
	option add *Text.borderWidth		1 $prio
	option add *Scrollbar.width		11 $prio
	option add *padY			0 $prio
    }
}
proc style::as::reset {args} {
    if {[llength $args]} {
	foreach what $args {
	    style::as::reset_$what
	}
    } else {
	foreach cmd [info commands style::as::reset_*] {
	    $cmd
	}
    }
}
proc style::as::enable {what args} {
    variable mw
    switch -exact $what {
	mousewheel { init_mousewheel }
	control-mousewheel {
	    set type [lindex $args 0]; # should be local or global
	    bind all <Control-MouseWheel> \
		[list ::style::as::CtrlMouseWheel %W %X %Y %D $type]
	    bind all <$mw(ctrl)-plus> \
		[list ::style::as::CtrlMouseWheel %W %X %Y 120 $type]
	    bind all <$mw(ctrl)-minus> \
		[list ::style::as::CtrlMouseWheel %W %X %Y -120 $type]
	    if {[tk windowingsystem] eq "x11"} {
		bind all <Control-ButtonPress-4> \
		    [list ::style::as::CtrlMouseWheel %W %X %Y 120 $type]
		bind all <Control-ButtonPress-5> \
		    [list ::style::as::CtrlMouseWheel %W %X %Y -120 $type]
	    }
	}
	default {
	    return -code error "unknown option \"$what\""
	}
    }
}
proc style::as::disable {what args} {
    variable mw
    switch -exact $what {
	mousewheel { reset_mousewheel }
	control-mousewheel {
	    bind all <Control-MouseWheel> {}
	    bind all <$mw(ctrl)-plus> {}
	    bind all <$mw(ctrl)-minus> {}
	    if {[tk windowingsystem] eq "x11"} {
		bind all <Control-ButtonPress-4> {}
		bind all <Control-ButtonPress-5> {}
	    }
	}
	default {
	    return -code error "unknown option \"$what\""
	}
    }
}

## Fonts
##
proc style::as::init_fonts {args} {
    if {[lsearch -exact [font names] ASfont] == -1} {
	switch -exact [tk windowingsystem] {
	    "x11" {
		set size	-12
		set family	Helvetica
		set fsize	-12
		set ffamily	Courier
	    }
	    "win32" {
		set size	8
		set family	Tahoma
		set fsize	9
		set ffamily	Courier
	    }
	    "aqua" - "macintosh" {
		set size	11
		set family	"Lucida Grande"
		set fsize	11
		set ffamily	Courier
	    }
	}
	font create ASfont      -size $size -family $family
	font create ASfontBold  -size $size -family $family -weight bold
	font create ASfontFixed -size $fsize -family $ffamily
	font create ASfontFixedBold -size $fsize -family $ffamily -weight bold
	for {set i -2} {$i <= 4} {incr i} {
	    set isize  [expr {$size + ($i * (($size > 0) ? 1 : -1))}]
	    set ifsize [expr {$fsize + ($i * (($fsize > 0) ? 1 : -1))}]
	    font create ASfont$i      -size $isize -family $family
	    font create ASfontBold$i  -size $isize -family $family -weight bold
	    font create ASfontFixed$i -size $ifsize -family $ffamily
	    font create ASfontFixedBold$i \
		-size $fsize -family $ffamily -weight bold
	}
    }

    if {1 || [tk windowingsystem] eq "x11"} {
	variable prio

	option add *Text.font		ASfontFixed $prio
	option add *Button.font		ASfont $prio
	option add *Canvas.font		ASfont $prio
	option add *Checkbutton.font	ASfont $prio
	option add *Entry.font		ASfont $prio
	option add *Label.font		ASfont $prio
	option add *Labelframe.font	ASfont $prio
	option add *Listbox.font	ASfont $prio
	option add *Menu.font		ASfont $prio
	option add *Menubutton.font	ASfont $prio
	option add *Message.font	ASfont $prio
	option add *Radiobutton.font	ASfont $prio
	option add *Spinbox.font	ASfont $prio

	option add *Table.font		ASfont $prio
	option add *TreeCtrl*font	ASfont $prio
    }
}

proc style::as::reset_fonts {args} {
}

proc style::as::CtrlMouseWheel {W X Y D {what local}} {
    set w [winfo containing $X $Y]
    if {[winfo exists $w]} {
	set top [winfo toplevel $w]
	while {[catch {$w cget -font} font]
	       || ![string match "ASfont*" $font]} {
	    if {$w eq $top} { return }
	    set w [winfo parent $w]
	}
	if {$what eq "local"} {
	    # get current font size (0 by default) and adjust the current
	    # widget's font to the next sized preconfigured font
	    set cnt [regexp -nocase -- {([a-z]+)(\-?\d)?} $font -> name size]
	    if {$size eq ""} {
		set size [expr {($D > 0) ? 1 : -1}]
	    } else {
		set size [expr {$size + (($D > 0) ? 1 : -1)}]
	    }
	    set font $name$size
	    if {[lsearch -exact [font names] $font] != -1} {
		catch {$w configure -font $font}
	    }
	} else {
	    # readjust all the font sizes based on the current one
	    set size [font configure ASfont -size]
	    # handle negative font sizes (by pixel instead of point)
	    set neg [expr {($size < 0) ? -1 : 1}]
	    incr size [expr {$neg * (($D > 0) ? 1 : -1)}]
	    # but we do have limits on how small/large things can get
	    if {abs($size) < 6 || abs($size) > 18} { return }
	    font configure ASfont      -size $size
	    font configure ASfontBold  -size $size
	    font configure ASfontFixed -size [expr {$size+(1*$neg)}]
	    # force reconfigure of this widget with the same font in
	    # case it doesn't have a WorldChanged function
	    catch {$w configure -font $font}
	    if {0} {
		# we shouldn't need this if the user isn't improperly
		# switching between global/local ctrl-mswhl modes
		for {set i -2} {$i <= 4} {incr i} {
		    font configure ASfont$i      \
			-size [expr {$size+($i*$neg)}] -family $family
		    font configure ASfontBold$i  \
			-size [expr {$size+($i*$neg)}] -family $family \
			-weight bold
		    font configure ASfontFixed$i \
			-size [expr {$size+((1+$i)*$neg)}] -family Courier
		}
	    }
	}
    }
}

## Misc
##
proc style::as::init_misc {args} {
    variable prio
    variable highlightbg
    variable highlightfg
    variable bg
    variable fg
    option add *ScrolledWindow.ipad		0 $prio

    # Various other common widgets from popular widget sets
    foreach class {HList Tree Tree.c TixHList TixTree} {
	option add *$class.borderWidth		1 $prio
	option add *$class.background		$bg $prio
	option add *$class.foreground		$fg $prio
	option add *$class.selectBorderWidth	0 $prio
	option add *$class.selectForeground	$highlightfg $prio
	option add *$class.selectBackground	$highlightbg $prio
    }
    if {[tk windowingsystem] ne "x11"} {
	option add *TreeCtrl.useTheme 1
    }
}

## Listbox
##
proc style::as::init_listbox {args} {
    variable prio
    if {[tk windowingsystem] eq "x11"} {
	variable highlightbg
	variable highlightfg
	variable bg
	variable fg
	option add *Listbox.background		$bg $prio
	option add *Listbox.foreground		$fg $prio
	option add *Listbox.selectBorderWidth	0 $prio
	option add *Listbox.selectForeground	$highlightfg $prio
	option add *Listbox.selectBackground	$highlightbg $prio
    }
    option add *Listbox.activeStyle		dotbox $prio
}

## Button
##
proc style::as::init_button {args} {
    variable prio
    if {[tk windowingsystem] eq "x11"} {
	option add *Button.padX			1 $prio
	option add *Button.padY			2 $prio
    }
    option add *Button.highlightThickness	1 $prio
}

## Entry
##
proc style::as::init_entry {args} {
    if {[tk windowingsystem] eq "x11"} {
	variable prio
	variable highlightbg
	variable highlightfg
	variable bg
	variable fg
	option add *Entry.background		$bg $prio
	option add *Entry.foreground		$fg $prio
	option add *Entry.selectBorderWidth	0 $prio
	option add *Entry.selectForeground	$highlightfg $prio
	option add *Entry.selectBackground	$highlightbg $prio
    }
}

## Spinbox
##
proc style::as::init_spinbox {args} {
    if {[tk windowingsystem] eq "x11"} {
	variable prio
	variable highlightbg
	variable highlightfg
	variable bg
	variable fg
	option add *Spinbox.background		$bg $prio
	option add *Spinbox.foreground		$fg $prio
	option add *Spinbox.selectBorderWidth	0 $prio
	option add *Spinbox.selectForeground	$highlightfg $prio
	option add *Spinbox.selectBackground	$highlightbg $prio
    }
}

## Text
##
proc style::as::init_text {args} {
    if {[tk windowingsystem] eq "x11"} {
	variable prio
	variable highlightbg
	variable highlightfg
	variable bg
	variable fg
	option add *Text.background		$bg $prio
	option add *Text.foreground		$fg $prio
	option add *Text.selectBorderWidth	0 $prio
	option add *Text.selectForeground	$highlightfg $prio
	option add *Text.selectBackground	$highlightbg $prio
    }
}

## Menu
##
proc style::as::init_menu {args} {
    if {[tk windowingsystem] eq "x11"} {
	variable prio
	variable highlightbg
	variable highlightfg
	option add *Menu.activeBackground	$highlightbg $prio
	option add *Menu.activeForeground	$highlightfg $prio
	option add *Menu.activeBorderWidth	1 $prio
	option add *Menu.borderWidth		1 $prio
    }
}

## Menubutton
##
proc style::as::init_menubutton {args} {
    variable prio
    variable highlightbg
    variable highlightfg
    option add *Menubutton.activeBackground	$highlightbg $prio
    option add *Menubutton.activeForeground	$highlightfg $prio
    option add *Menubutton.activeBorderWidth	1 $prio
    option add *Menubutton.borderWidth		1 $prio
    option add *Menubutton.highlightThickness	0 $prio
    option add *Menubutton*padX			4 $prio
    option add *Menubutton*padY			3 $prio
}

## Scrollbar
##
proc style::as::init_scrollbar {args} {
    variable prio
    if {[tk windowingsystem] eq "x11"} {
	option add *Scrollbar.width		12 $prio
	option add *Scrollbar.troughColor	"#bdb6ad" $prio
    }
    option add *Scrollbar.borderWidth		1 $prio
    option add *Scrollbar.highlightThickness	0 $prio
}

## PanedWindow
##
proc style::as::init_panedwindow {args} {
    variable prio
    option add *Panedwindow.borderWidth		0 $prio
    option add *Panedwindow.sashWidth		3 $prio
    option add *Panedwindow.showHandle		0 $prio
    option add *Panedwindow.sashPad		0 $prio
    option add *Panedwindow.sashRelief		flat $prio
    option add *Panedwindow.relief		flat $prio
}

## MouseWheel
##
proc style::as::MouseWheel {wFired X Y D {shifted 0}} {
    # Set event to check based on call
    set evt "<[expr {$shifted?{Shift-}:{}}]MouseWheel>"
    # do not double-fire in case the class already has a binding
    if {[bind [winfo class $wFired] $evt] ne ""} { return }
    # obtain the window the mouse is over
    set w [winfo containing $X $Y]
    # if we are outside the app, try and scroll the focus widget
    if {![winfo exists $w]} { catch {set w [focus]} }
    if {[winfo exists $w]} {
	if {[bind $w $evt] ne ""} {
	    # Awkward ... this widget has a MouseWheel binding, but to
	    # trigger successfully in it, we must give it focus.
	    # XXX For now, let's do nothing - maybe check containing != focus?
	    # Users should restrict MouseWheel bindings to special cases only.
	    if {0} {
		catch {focus} old
		if {$w ne $old} { focus $w }
		event generate $w $evt -rootx $X -rooty $Y -delta $D
		if {$w ne $old} { catch {focus $old} }
	    }
	    return
	}
	# aqua and x11/win32 have different delta handling
	if {[tk windowingsystem] ne "aqua"} {
	    set delta [expr {- ($D / 30)}]
	} else {
	    set delta [expr {- ($D)}]
	}
	# scrollbars have different call conventions
	if {[string match "*Scrollbar" [winfo class $w]]} {
	    catch {tk::ScrollByUnits $w \
		       [string index [$w cget -orient] 0] $delta}
	} else {
	    set view [expr {$shifted ? "xview" : "yview"}]
	    # Walking up to find the proper widget handles cases like
	    # embedded widgets in a canvas
	    while {[catch {$w $view scroll $delta units}]
		   && [winfo toplevel $w] ne $w} {
		set w [winfo parent $w]
	    }
	}
    }
}
proc style::as::init_mousewheel {args} {
    variable mw

    # Create a catch-all MouseWheel proc & binding and
    # alter default bindings to allow toplevel binding to control all
    bind all <MouseWheel> [list ::style::as::MouseWheel %W %X %Y %D 0]
    bind all <Shift-MouseWheel> [list ::style::as::MouseWheel %W %X %Y %D 1]
    foreach class $mw(classes) {
	bind $class <MouseWheel> {}
	bind $class <Shift-MouseWheel> {}
    }
    #if {[bind [winfo toplevel %W] <MouseWheel>] ne ""} { continue }
    #%W yview scroll [expr {- (%D / 120) * 4}] units

    if {[tk windowingsystem] eq "x11"} {
	# Support for mousewheels on Linux/Unix commonly comes through
	# mapping the wheel to the extended buttons.
	bind all <Button-4> [list ::style::as::MouseWheel %W %X %Y 120]
	bind all <Button-5> [list ::style::as::MouseWheel %W %X %Y -120]
	foreach class $mw(classes) {
	    bind $class <Button-4> {}
	    bind $class <Button-5> {}
	}
    }
    # Disable this bwidget proc if it exists.  It creates bindings that
    # are unnecessary and possibly dangerous in combination
    catch { proc ::BWidget::bindMouseWheel args {} }
}
proc style::as::reset_mousewheel {args} {
    # Remove catch-all MouseWheel binding and restore default bindings
    variable mw

    bind all <MouseWheel> {}
    bind all <Shift-MouseWheel> {}
    foreach class $mw(classes) {
	bind $class <MouseWheel> $mw(binding)
	bind $class <Shift-MouseWheel> $mw(s-binding)
    }
    if {[tk windowingsystem] eq "x11"} {
	bind all <Button-4> {}
	bind all <Button-5> {}
	foreach class $mw(classes) {
	    bind $class <Button-4> $mw(binding4)
	    bind $class <Button-5> $mw(binding5)
	}
    }
}

package provide style::as $style::as::version
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/style/lobster.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
# lobster.tcl --

# The code formerly known as "gtklook" on the Tcl'ers
# wiki.  Most of this code was originally written by Jeremy Collins.

# $Id: lobster.tcl,v 1.7 2005/05/18 16:19:53 andreas_kupries Exp $

package require Tk

namespace eval style::lobster {
    # This may need to be adjusted for some window managers that are
    # more aggressive with their own Xdefaults (like KDE and CDE)
    variable prio "widgetDefault"
}

proc style::lobster::init {args} {
    package require Tk
    variable prio

    if {[llength $args]} {
	set arg [lindex $args 0]
	set len [string length $arg]
	if {$len > 2 && [string equal -len $len $arg "-priority"]} {
	    set prio [lindex $args 1]
	    set args [lrange $args 2 end]
	}
    }

    if {[string equal [tk windowingsystem] "x11"]} {
	set size   -12
	set family Helvetica
	font create LobsterFont -size $size -family $family
	font create LobsterBold -size $size -family $family -weight bold

	option add *borderWidth			1 $prio
	option add *activeBorderWidth		1 $prio
	option add *selectBorderWidth		1 $prio
	option add *font			LobsterFont $prio

	option add *padX			2 $prio
	option add *padY			4 $prio

	option add *Listbox.background		white $prio
	option add *Listbox.selectBorderWidth	0 $prio
	option add *Listbox.selectForeground	white $prio
	option add *Listbox.selectBackground	#4a6984 $prio

	option add *Entry.background		white $prio
	option add *Entry.foreground		black $prio
	option add *Entry.selectBorderWidth	0 $prio
	option add *Entry.selectForeground	white $prio
	option add *Entry.selectBackground	#4a6984 $prio

	option add *Text.background		white $prio
	option add *Text.selectBorderWidth	0 $prio
	option add *Text.selectForeground	white $prio
	option add *Text.selectBackground	#4a6984 $prio

	option add *Menu.activeBackground	#4a6984 $prio
	option add *Menu.activeForeground	white $prio
	option add *Menu.activeBorderWidth	0 $prio
	option add *Menu.highlightThickness	0 $prio
	option add *Menu.borderWidth		2 $prio

	option add *Menubutton.activeBackground	#4a6984 $prio
	option add *Menubutton.activeForeground	white $prio
	option add *Menubutton.activeBorderWidth 0 $prio
	option add *Menubutton.highlightThickness 0 $prio
	option add *Menubutton.borderWidth	0 $prio

	option add *Labelframe.borderWidth	2 $prio
	option add *Frame.borderWidth		2 $prio
	option add *Labelframe.padY		8 $prio
	option add *Labelframe.padX		12 $prio

	option add *highlightThickness		0 $prio
	option add *troughColor			#c3c3c3 $prio

	option add *Scrollbar.width		12 $prio
	option add *Scrollbar.borderWidth	1 $prio
	option add *Scrollbar.highlightThickness 0 $prio

	# These don't seem to take effect without the startupFile
	# level specified.
	option add *Dialog.msg.font LobsterBold startupFile
	option add *Dialog.dtl.font LobsterBold startupFile
    }
}

package provide style::lobster 0.2
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































Deleted scriptlibs/tklib0.5/style/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded style 0.3 [list source [file join $dir style.tcl]]
package ifneeded style::as 1.4 [list source [file join $dir as.tcl]]
package ifneeded style::lobster 0.2 [list source [file join $dir lobster.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<


























Deleted scriptlibs/tklib0.5/style/style.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
# style.tcl -- Styles for Tk.

# $Id: style.tcl,v 1.4 2005/08/23 22:21:32 hobbs Exp $

# Copyright 2004 David N. Welton <davidw@dedasys.com>
# Copyright 2004 ActiveState Corporation

namespace eval style {
    # Available styles
    variable available [list lobster as]
}

# style::names --
#
#	Return the names of all available styles.

proc style::names {} {
    variable available
    return $available
}

# style::use --
#
#	Until I see a better way of doing it, this is just a wrapper
#	for package require.  The problem is that 'use'ing different
#	styles won't undo the changes made by previous styles.

proc style::use {newstyle args} {
    package require style::${newstyle}
    eval [linsert $args 0 style::${newstyle}::init]
}

package provide style 0.3
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































Deleted scriptlibs/tklib0.5/swaplist/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if { ![package vsatisfies [package provide Tcl] 8.4] } { return }
package ifneeded swaplist 0.2 [list source [file join $dir swaplist.tcl]]

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


























Deleted scriptlibs/tklib0.5/swaplist/swaplist.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
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
# swaplist.tcl --
#
#       A dialog which allows a user to move options between two lists
#
# Copyright (c) 2005    Aaron Faupell <afaupell@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: swaplist.tcl,v 1.6 2008/02/06 07:15:16 afaupell Exp $

package require Tk
package provide swaplist 0.2

namespace eval swaplist {
    namespace export swaplist
}

if {[tk windowingsystem] == "win32"} {
    option add *Swaplist*Button.width -10 widgetDefault
    option add *Swaplist*Button.padX 1m widgetDefault
    option add *Swaplist*Border.borderWidth 2 widgetDefault
    option add *Swaplist*Border*Listbox.borderWidth 0 widgetDefault
} else {
    option add *Swaplist.borderWidth 1 widgetDefault
    option add *Swaplist*Button.width 5 widgetDefault
}

proc ::swaplist::swaplist {w var list1 list2 args} {
    array set options {
        -title "Configuration"
    }
    parseOpts options {{-llabel {}} {-rlabel {}} {-title {}} -embed \
                       {-reorder boolean} {-geometry {}} {-lbuttontext {}} \
                       {-rbuttontext {}} {-ubuttontext {}} {-dbuttontext {}}} \
                      $args

    if {[info exists options(-embed)]} {
        frame $w
        unset options(-embed)
        return [eval [list ::swaplist::createSwaplist $w $var $list1 $list2] [array get options]]
    }

    catch {destroy $w}
    set focus [focus]
    set grab [grab current .]
    
    toplevel $w -class Swaplist -relief raised
    wm title $w $options(-title)
    wm protocol $w WM_DELETE_WINDOW {set ::swaplist::whichButton 0}
    wm transient $w [winfo toplevel [winfo parent $w]]

    eval [list ::swaplist::createSwaplist $w ::swaplist::selectedList $list1 $list2] [array get options]

    frame $w.oc -pady 7
    button $w.oc.ok -default active -text "OK" -command {set ::swaplist::whichButton 1}
    button $w.oc.cancel -text "Cancel" -command {set ::swaplist::whichButton 0}
    pack $w.oc.cancel -side right -padx 7
    pack $w.oc.ok -side right
    grid $w.oc -columnspan 4 -row 2 -column 0 -sticky ew -columnspan 4

    bind $w <Return> [list $w.oc.ok invoke]
    bind $w <Escape> [list $w.oc.cancel invoke]
    bind $w <Destroy> {set ::swaplist::whichButton 0}

    #SetButtonState $w
    
    wm withdraw $w
    update idletasks
    if {[info exists options(-geometry)]} {
        wm geometry $w $options(-geometry)
    } elseif {[winfo parent $w] == "."} {
        set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}]
        set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}]
        wm geometry $w +$x+$y
    } else {
        set t [winfo toplevel [winfo parent $w]]
        set x [expr {[winfo width $t]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}]
        set y [expr {[winfo height $t]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}]
        wm geometry $w +$x+$y
    }
    wm deiconify $w
    grab $w

    tkwait variable ::swaplist::whichButton
    upvar $var results
    set results $::swaplist::selectedList
    bind $w <Destroy> {}
    grab release $w
    destroy $w
    focus -force $focus
    if {$grab != ""} {grab $grab}
    update idletasks
    return $::swaplist::whichButton
}

proc ::swaplist::createSwaplist {w var list1 list2 args} {
    array set options {
        -reorder 1
        -llabel "Available:"
        -rlabel "Selected:"
        -lbuttontext "<<"
        -rbuttontext ">>"
        -ubuttontext "Move Up"
        -dbuttontext "Move Down"
    }
    parseOpts options {{-llabel {}} {-rlabel {}} {-title {}} \
                       {-reorder boolean} {-lbuttontext {}} {-geometry {}}\
                       {-rbuttontext {}} {-ubuttontext {}} {-dbuttontext {}}} \
                      $args

    set olist $list1
    
    # remove items in list2 from list1
    foreach x $list2 {
        if {[set i [lsearch $list1 $x]] >= 0} {
            set list1 [lreplace $list1 $i $i]
        }
    }

    label $w.heading1 -text $options(-llabel) -anchor w
    label $w.heading2 -text $options(-rlabel) -anchor w

    foreach x {list1 list2} {
        frame $w.$x -class Border -relief sunken
        scrollbar $w.$x.scrolly -orient v -command [list $w.$x.list yview]
        scrollbar $w.$x.scrollx -orient h -command [list $w.$x.list xview]
        listbox $w.$x.list -selectmode extended -yscrollcommand [list $w.$x.scrolly set] -xscrollcommand [list $w.$x.scrollx set]
        grid $w.$x.list -row 0 -column 0 -sticky nesw
        grid $w.$x.scrolly -row 0 -column 1 -sticky ns
        grid $w.$x.scrollx -row 1 -column 0 -sticky ew
        grid columnconfigure $w.$x 0 -weight 1
        grid rowconfigure $w.$x 0 -weight 1
    }
    $w.list2.list configure -listvariable $var
    $w.list2.list delete 0 end
    eval [list $w.list1.list insert end] $list1
    eval [list $w.list2.list insert end] $list2

    set width [min 5 $options(-lbuttontext) $options(-rbuttontext)]
    frame $w.lr
    button $w.lr.left -width $width -text $options(-lbuttontext) -command [list ::swaplist::ShiftL $w $olist]
    if {$options(-reorder)} {
        button $w.lr.right -width $width -text $options(-rbuttontext) -command [list ::swaplist::ShiftRNormal $w $olist]
    } else {
        button $w.lr.right -width $width -text $options(-rbuttontext) -command [list ::swaplist::ShiftRNoReorder $w $olist]
    }
    grid $w.lr.right -pady 4
    grid $w.lr.left -pady 4
    grid columnconfigure $w.lr 0 -uniform 1

    set width [min 3 $options(-ubuttontext) $options(-dbuttontext)]
    frame $w.ud
    button $w.ud.up   -width $width -text $options(-ubuttontext) -command [list ::swaplist::ShiftUD $w.list2.list u]
    button $w.ud.down -width $width -text $options(-dbuttontext) -command [list ::swaplist::ShiftUD $w.list2.list d]
    pack $w.ud.up   -side top    -pady 4
    pack $w.ud.down -side bottom -pady 4

    grid $w.heading1 -row 0 -column 0 -sticky ew   -padx {3 0} -pady 3
    grid $w.heading2 -row 0 -column 2 -sticky ew   -padx {0 3} -pady 3
    grid $w.list1    -row 1 -column 0 -sticky nesw -padx {3 0}
    grid $w.lr       -row 1 -column 1              -padx 7
    grid $w.list2    -row 1 -column 2 -sticky nesw -padx {0 3}
    if {$options(-reorder)} {
        grid $w.ud -row 1 -column 3 -padx {2 5}
    }
    grid columnconfigure $w {0 2} -weight 1
    grid rowconfigure $w 1 -weight 1

    bind $w <Key-Up> [list ::swaplist::UpDown %W %K]
    bind $w <Key-Down> [list ::swaplist::UpDown %W %K]
    bind $w.list1.list <Double-Button-1> [list ::swaplist::Double %W]
    bind $w.list2.list <Double-Button-1> [list ::swaplist::Double %W]
    #bind $w.list1.list <<ListboxSelect>> [list ::swaplist::SetButtonState %W]
    #bind $w.list2.list <<ListboxSelect>> [list ::swaplist::SetButtonState %W]
    
    if {![catch {package present autoscroll}]} {
        ::autoscroll::autoscroll $w.list1.scrollx
        ::autoscroll::autoscroll $w.list1.scrolly
        ::autoscroll::autoscroll $w.list2.scrollx
        ::autoscroll::autoscroll $w.list2.scrolly
    }

    #SetButtonState $w
    return $w
}

proc ::swaplist::parseOpts {var opts input} {
    upvar $var output
    for {set i 0} {$i < [llength $input]} {incr i} {
        for {set a 0} {$a < [llength $opts]} {incr a} {
           if {[lindex $opts $a 0] == [lindex $input $i]} { break }
        }
        if {$a == [llength $opts]} { error "unknown option [lindex $input $i]" }
        set opt [lindex $opts $a]
        if {[llength $opt] > 1} {
            foreach {opt type} $opt {break}
            if {[incr i] >= [llength $input]} { error "$opt requires an argument" }
            if {$type != "" && ![string is $type -strict [lindex $input $i]]} { error "$opt requires argument of type $type" }
            set output($opt) [lindex $input $i]
        } else {
            set output($opt) {}
        }
    }
}

# return the min unless string1 or string2 is longer, if so return length of the longer one
proc ::swaplist::min {min s1 s2} {
    if {[string length $s1] > $min || [string length $s2] > $min} {
        return [expr {
                ([string length $s1] > [string length $s2]) \
                ? [string length $s1] \
                : [string length $s2]
               }]
    } else {
        return $min
    }
}

# return a list in reversed order
proc ::swaplist::lreverse {list} {
    set new {}
    foreach x $list {set new [linsert $new 0 $x]}
    return $new
}

# binding for "move left" button
proc ::swaplist::ShiftL {w olist} {
    set from $w.list2.list
    set to $w.list1.list
        
    if {[set cur [$from curselection]] == ""} { return }
    foreach x [lreverse $cur] {
        set name [$from get $x]
        $from delete $x
        set i [FindPos $olist [$to get 0 end] $name]
        $to insert $i $name
        $to selection set $i
    }
    if {[llength $cur] == 1} {$to see $i}
    if {[lindex $cur 0] == 0} {
        $from selection set 0
    } elseif {[lindex $cur 0] == [$from index end]} {
        $from selection set end
    } else {
        $from selection set [lindex $cur 0]
    }
}

# binding for "move right" button if -reorder is true
proc ::swaplist::ShiftRNormal {w olist} {
    set from $w.list1.list
    set to $w.list2.list

    if {[set cur [$from curselection]] == ""} { return }
    $to selection clear 0 end
    foreach x $cur {
        $to insert end [$from get $x]
        $to selection set end
    }
    foreach x [lreverse $cur] {
        $from delete $x
    }
    $to see end
}

# binding for "move right" button if -reorder is false
proc ::swaplist::ShiftRNoReorder {w olist} {
    set from $w.list1.list
    set to $w.list2.list
        
    if {[set cur [$from curselection]] == ""} { return }
    foreach x $cur {
        set name [$from get $x]
        set pos [FindPos $olist [$to get 0 end] $name]
        $to insert $pos $name
        lappend new $pos
    }
    foreach x [lreverse $cur] { $from delete $x }
    if {[$from index end] == 0} {
        foreach x $new {$to selection set $x}
    } elseif {[lindex $cur 0] == 0} {
        $from selection set 0
    } elseif {[lindex $cur 0] == [$from index end]} {
        $from selection set end
    } else {
        $from selection set [lindex $cur 0]
    }
}

# binding for "move up" and "move down" buttons
proc ::swaplist::ShiftUD {w dir} {
    if {[set sel [$w curselection]] == ""} { return }
    set list {}
    # delete in reverse order so shifting indexes dont bite us
    foreach x [lreverse $sel] {
        # make a list in correct order with the items index and contents
        set list [linsert $list 0 [list $x [$w get $x]]]
        $w delete $x
    }
    if {$dir == "u"} {
        set n 0
        foreach x $list {
            set i [lindex $x 0]
            if {[incr i -1] < $n} {set i $n}
            $w insert $i [lindex $x 1]
            $w selection set $i
            incr n
        }
        $w see [expr {[lindex $list 0 0] - 1}]
    }
    if {$dir == "d"} {
        set n [$w index end]
        foreach x $list {
            set i [lindex $x 0]
            if {[incr i] > $n} {set i $n}
            $w insert $i [lindex $x 1]
            $w selection set $i
            incr n
        }
        $w see $i
    }
}

# find the position $el should have in $curlist, by looking at $olist
# $curlist should be a subset of $olist
proc ::swaplist::FindPos {olist curlist el} {
    set orig [lsearch $olist $el]
    set end [llength $curlist]
    for {set i 0} {$i < $end} {incr i} {
        if {[lsearch $olist [lindex $curlist $i]] > $orig} { break }
    }
    return $i
}

# binding for the up and down arrow keys, just dispatch and have tk
# do the right thing
proc ::swaplist::UpDown {w key} {
    if {[winfo toplevel $w] != $w} {return}
    if {[set cur [$w.list2.list curselection]] != ""} {
        tk::ListboxUpDown $w.list2.list [string map {Up -1 Down 1} $key]
    } elseif {[set cur [$w.list1.list curselection]] != ""} {
        tk::ListboxUpDown $w.list1.list [string map {Up -1 Down 1} $key]
    } else {
        return
    }
}

# binding for double click, just invoke the left or right button
proc ::swaplist::Double {w} {
    set top [winfo toplevel $w]
    if {[string match *.list1.* $w]} {
        $top.lr.right invoke
    } elseif {[string match *.list2.* $w]} {
        $top.lr.left invoke
    }
}

proc ::swaplist::SetButtonState {w} {
    set top [winfo toplevel $w]
    if {[$top.list2.list curselection] != ""} {
        $top.lr.left  configure -state normal
        $top.lr.right configure -state disabled
    } elseif {[$top.list1.list curselection] != ""} {
        $top.lr.left  configure -state disabled
        $top.lr.right configure -state normal
    } else {
        $top.lr.left  configure -state disabled
        $top.lr.right configure -state disabled
    }

    if {[set cur [$top.list2.list curselection]] == ""} {
        $top.ud.up configure -state disabled
        $top.ud.down configure -state disabled
    } elseif {$cur == 0} {
        $top.ud.up configure -state disabled
        $top.ud.down configure -state normal
    } elseif {$cur == ([$top.list2.list index end] - 1)} {
        $top.ud.up configure -state normal
        $top.ud.down configure -state disabled
    } else {
        $top.ud.up configure -state normal
        $top.ud.down configure -state normal
    }
}

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




































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_doc/autoscroll.html.

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
<! -- -*- tcl -*- doctools manpage
   -->
<html><head>
<title>autoscroll - Automatic mapping of scrollbars </title>
</head>
<! -- Generated from file './modules/autoscroll/autoscroll.man' by tcllib/doctools with format 'html'
   -->
<! -- CVS: $Id$ autoscroll.n
   -->

<body>
<h1> autoscroll(n) 1.1 autoscroll &quot;Automatic mapping of scrollbars&quot;</h1>
<h2><a name="name">NAME</a></h2>
<p>
<p> autoscroll - Provides for a scrollbar to automatically mapped and unmapped as needed




<h2><a name="table_of_contents">TABLE OF CONTENTS</a></h2>
<p>&nbsp;&nbsp;&nbsp;&nbsp;<a href="#table_of_contents">TABLE OF CONTENTS</a><br>
&nbsp;&nbsp;&nbsp;&nbsp;<a href="#synopsis">SYNOPSIS</a><br>
&nbsp;&nbsp;&nbsp;&nbsp;<a href="#description">DESCRIPTION</a><br>
&nbsp;&nbsp;&nbsp;&nbsp;<a href="#keywords">KEYWORDS</a><br>
<h2><a name="synopsis">SYNOPSIS</a></h2>
<p>
package require <b>Tcl</b><br>
package require <b>autoscroll ?1.1?</b><br>
<br><table border=1 width=100% cellspacing=0 cellpadding=0><tr            bgcolor=lightyellow><td bgcolor=lightyellow><table 0 width=100% cellspacing=0 cellpadding=0><tr valign=top ><td ><a href="#1"><b class='cmd'>::autoscroll::autoscroll</b> <i class='arg'>scrollbar</i></a></td></tr>
<tr valign=top ><td ><a href="#2"><b class='cmd'>::autoscroll::unautoscroll</b> <i class='arg'>scrollbar</i></a></td></tr>
<tr valign=top ><td ><a href="#3"><b class='cmd'>::autoscroll::wrap</b> </a></td></tr>
<tr valign=top ><td ><a href="#4"><b class='cmd'>::autoscroll::unwrap</b> </a></td></tr>
</table></td></tr></table>
<h2><a name="description">DESCRIPTION</a></h2>
<p>

This package allows scrollbars to be mapped and
unmapped as needed depending on the size and
content of the scrollbars scrolled widget. The
scrollbar must be managed by either pack or grid,
other geometry managers are not supported.

<p>

When managed by pack, any geometry changes made in the
scrollbars parent between the time a scrollbar is
unmapped, and when it is mapped will be lost. It is
an error to destroy any of the scrollbars siblings while the
scrollbar is unmapped. When managed by grid, if anything
becomes gridded in the same row and column the scrollbar
occupied it will be replaced by the scrollbar when remapped.

<p>

This package may be used on any scrollbar-like widget
as long as it supports the <strong>set</strong> subcommand in the same
style as scrollbar. If the <strong>set</strong> subcommand is not used
then this package will have no effect.

<p>

<dl>

<dt><a name="1"><b class='cmd'>::autoscroll::autoscroll</b> <i class='arg'>scrollbar</i></a><dd>


Arranges for the already existing scrollbar <strong>scrollbar</strong>
to be mapped and unmapped as needed.

<br><br>
<dt><a name="2"><b class='cmd'>::autoscroll::unautoscroll</b> <i class='arg'>scrollbar</i></a><dd>


Returns the named scrollbar to its original static state.

<br><br>
<dt><a name="3"><b class='cmd'>::autoscroll::wrap</b> </a><dd>


Arranges for all scrollbars created after this command is run
to be automatically mapped and unmapped as needed.

<br><br>
<dt><a name="4"><b class='cmd'>::autoscroll::unwrap</b> </a><dd>


Turns off the automatic autoscrolling of all new scrollbars.
Does not effect existing scrollbars

</dl>

<p><table><tr><td bgcolor=black>&nbsp;</td><td><pre class='sample'>
text .t -yscrollcommand &quot;.scrolly set&quot;
scrollbar .scrolly -orient v -command &quot;.t yview&quot;
pack .scrolly -side right -fill y
pack .t -side left -fill both -expand 1
::autoscroll::autoscroll .scrolly
</pre></td></tr></table></p>



<h2><a name="keywords">KEYWORDS</a></h2>
<p>
scroll, scrollbar
</body></html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/canvas/city.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
#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
# ### ### ### ######### ######### #########

## DEMO. Show pseudo-city map using semi-random (*) street tiles.
##       (*) Random + restrictions about what tiles can be neighbours.
##           This part in citygrid.tcl

# ### ### ### ######### ######### #########
## Use canvas package relative to example location.

set selfdir  [file dirname [file normalize [info script]]]
set modules [file join [file dirname [file dirname $selfdir]] modules]

source $modules/canvas/canvas_sqmap.tcl
source $selfdir/citygrid.tcl

# ### ### ### ######### ######### #########
## Other requirements for this example.

package require Tk
package require widget::scrolledwindow
package require canvas::sqmap
package require crosshair

package require struct::set      ; # citygrid.tcl
package require snit             ; # canvas::sqmap dependency
package require uevent::onidle   ; # ditto
package require cache::async 0.2 ; # ditto

# ### ### ### ######### ######### #########

set location {}

proc GUI {} {
    widget::scrolledwindow .sw
    canvas::sqmap          .map
    button                 .exit -command exit    -text Exit
    button                 .shfl -command Shuffle -text Shuffle
    entry                  .loc  -textvariable location \
	-bd 2 -relief sunken -bg white -width 40

    .sw setwidget .map

    # Panning via mouse
    bind .map <ButtonPress-2> {%W scan mark   %x %y}
    bind .map <B2-Motion>     {%W scan dragto %x %y}

    # Cross hairs ...
    .map configure -cursor tcross
    crosshair::crosshair .map -width 0 -fill \#999999 -dash {.}
    crosshair::track on  .map TRACK

    set tile [city::tile]
    set city [expr {$tile * 64}]

    #.map configure -grid-show-borders 1 ;# This leaks items = memory
    if 0 {
	# This routes the requests and results through GOT/GET logging
	# commands.
	.map configure \
	    -grid-cell-command GET \
	    -grid-cell-width  $tile \
	    -grid-cell-height $tile \
	    -scrollregion [list 0 0 $city $city]
    } else {
	# This routes the requests directly to the grid provider, and
	# results back.
	.map configure \
	    -grid-cell-command ::city::grid \
	    -grid-cell-width  $tile \
	    -grid-cell-height $tile \
	    -scrollregion [list 0 0 $city $city]
    }

    pack .sw    -expand 1 -fill both -side bottom
    pack .exit  -expand 0 -fill both -side left
    pack .shfl  -expand 0 -fill both -side left
    pack .loc   -expand 0 -fill both -side left

    return
}

proc Shuffle {} {
    .map flush
    return
}

# ### ### ### ######### ######### #########
# Basic callback structure, log for logging, facade to transform the
# cache/tiles result into what xcanvas is expecting.

proc GET {__ at donecmd} {
    puts "GET ($at) ($donecmd)"
    ::city::grid get $at [list GOT $donecmd]
    return
}

proc GOT {donecmd what at args} {
    puts "\tGOT $donecmd $what ($at) $args"
    if {[catch {
	uplevel #0 [eval [linsert $args 0 linsert $donecmd end $what $at]]
    }]} { puts $::errorInfo }
    return
}

# ### ### ### ######### ######### #########

proc TRACK {win x y args} {
    # args = viewport, pixels, see also xcanvas, SetPixelView.
    global location
    set location "@ $x, $y"
    return
}

# ### ### ### ######### ######### #########
## Basic interface.
GUI
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/canvas/citygrid.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
# -*- tcl -*-

package require Tk
package require cache::async
package require struct::set

namespace eval ::city {

    proc block {n} { variable part ; return [expr {$n * $part}] }

    variable tessel 64
    variable part   [expr {$tessel/8}]
    variable cstart [block 2]
    variable cend   [block 6]
    variable rstart [block 3]
    variable rend   [block 5]

    variable parcel [image create photo -height $part -width $part]
    $parcel put black -to 0 0 $part $part

    variable tilecache [cache::async tc ::city::Gen]

    variable lego  {}
    variable neigh ; array set neigh {} ; # name,dir -> list(name)
    variable map   ; array set map   {} ; # name -> (type flags)
    variable grid  ; array set grid  {} ; # at -> name
}

proc ::city::tile {} {
    variable tessel
    return  $tessel
}

proc ::city::grid {__ at donecmd} {
    Tile get [Randomize $at] [list ::city::ToGrid $at $donecmd --]
    return
}
proc ::city::ToGrid {at donecmd -- what key args} {
    # Route the cache result retrieved by name to the grid cell the
    # original request came from.
    #puts "\tToGrid ($at) '$donecmd' $what ($key) <$args>"
    if {[catch {
	uplevel #0 [eval [linsert $args 0 linsert $donecmd end $what $at]]
    }]} { puts $::errorInfo }
}

proc ::city::Randomize {at} {
    variable grid
    set p [Possibilities $at]
    if {[llength $p] == 1} {
	set res [lindex $p 0]
    } else {
	set res [lindex $p [Rand [llength $p]]]
    }
    #puts "($at) = $p"
    set grid($at) $res
    return $res
}

proc ::city::Rand {n} {
    # 0...n-1
    # (0,1) -> (0,n)
    expr {int(rand()*$n)}
}

proc ::city::Possibilities {at} {
    variable lego
    variable grid
    foreach {y x} $at break

    set l [list [expr {$x - 1}] $y]
    set r [list [expr {$x + 1}] $y]
    set u [list $x [expr {$y - 1}]]
    set d [list $x [expr {$y - 1}]]

    set allowed $lego
    Cut $l r allowed
    Cut $r l allowed
    Cut $u d allowed
    Cut $d u allowed

    return $allowed
}

proc ::city::Cut {at dir v} {
    variable grid
    variable neigh
    upvar 1 $v allowed
    foreach {y x} $at break
    if {![info exists grid($at)]} return
    set allowed [struct::set intersect $allowed $neigh($grid($at),$dir)]
    return
}

proc ::city::Tile {__ name donecmd} {
    variable tilecache
    #puts "__ $name ($donecmd)"
    $tilecache get $name $donecmd
    return
}

proc ::city::Gen {__ name donecmd} {
    variable tessel
    variable cstart
    variable cend
    variable rstart
    variable rend
    variable parcel
    variable map

    #puts "\tGENERATE $name ($donecmd)"

    foreach {olx orx oux odx ilx irx iux idx cx} $map($name) break
    set tile [image create photo -height $tessel -width $tessel]
    $tile put white -to 0 0 $tessel $tessel
    #puts ([join $map($name) {)(}])|$olx|$orx|$oux|$odx|$ilx|$irx|$iux|$idx|$cx|
    if {$cx}  { $tile copy $parcel -to $rstart $rstart $rend   $rend   } ; # center

    if {$olx} { $tile copy $parcel -to 0       $rstart $cstart $rend   } ; # ou left
    if {$orx} { $tile copy $parcel -to $cend   $rstart $tessel $rend   } ; # ou right
    if {$oux} { $tile copy $parcel -to $rstart 0       $rend   $cstart } ; # ou up
    if {$odx} { $tile copy $parcel -to $rstart $cend   $rend   $tessel } ; # ou down

    if {$ilx} { $tile copy $parcel -to $cstart $rstart $rstart $rend   } ; # in left
    if {$irx} { $tile copy $parcel -to $rend   $rstart $cend   $rend   } ; # in right
    if {$iux} { $tile copy $parcel -to $rstart $cstart $rend   $rstart } ; # in up
    if {$idx} { $tile copy $parcel -to $rstart $cend   $rend   $cend   } ; # in down

    if 0 {
	set label $olx$orx$oux$odx/$ilx$irx$iux$idx/$cx
	#set label [string range $name 0 3]/[string range $name 4 7]/[string index $name 8]
	label .l$name -image $tile -bd 2 -relief sunken
	pack .l$name -side left
	tooltip::tooltip .l$name $label
    }

    #puts "run ([linsert $donecmd end set $name $tile])"
    uplevel #0 [linsert $donecmd end set $name $tile]
    return
}

proc ::city::Name {olx orx oux odx ilx irx iux idx cx} {
    #set name "$olx$orx$oux$odx$ilx$irx$iux$idx$cx"
    set name ""
    if {$cx}  { append name c } ; # center
    if {$olx} { append name l } ; # left
    if {$ilx} { append name - } ; # left
    if {$orx} { append name r } ; # right
    if {$irx} { append name _ } ; # right
    if {$oux} { append name u } ; # up
    if {$iux} { append name = } ; # up
    if {$odx} { append name d } ; # down
    if {$idx} { append name % } ; # down
    if {$name eq ""} { set name empty }
    #puts $name\ ...
    return $name
}

proc ::city::Init {} {
    variable lego
    variable neigh
    variable map

    foreach olx {0 1} {
	foreach orx {0 1} {
	    foreach oux {0 1} {
		foreach odx {0 1} {
		    foreach ilx {0 1} {
			foreach irx {0 1} {
			    foreach iux {0 1} {
				foreach idx {0 1} {
				    foreach cx {0 1} {
					# inner not allowed without center
					if {!$cx && $ilx} continue
					if {!$cx && $irx} continue
					if {!$cx && $iux} continue
					if {!$cx && $idx} continue

					#if {!$olx && $ilx} continue
					#if {!$orx && $irx} continue
					#if {!$oux && $iux} continue
					#if {!$odx && $idx} continue

					set n [Name $olx $orx $oux $odx $ilx $irx $iux $idx $cx]
					set map($n) [list $olx $orx $oux $odx $ilx $irx $iux $idx $cx]
					lappend bins(l$olx) $n
					lappend bins(r$orx) $n
					lappend bins(u$oux) $n
					lappend bins(d$odx) $n
					lappend lego $n
				    }
				}
			    }
			}
		    }
		}
	    }
	}
    }

    #puts /[llength $lego]
    
    # Now compute which tiles can be neighbours of what others, for
    # all four sides.

    foreach t $bins(d0) { foreach n $bins(u0) { lappend neigh($t,d) $n } }
    foreach t $bins(d1) { foreach n $bins(u1) { lappend neigh($t,d) $n } }
    foreach t $bins(l0) { foreach n $bins(r0) { lappend neigh($t,l) $n } }
    foreach t $bins(l1) { foreach n $bins(r1) { lappend neigh($t,l) $n } }
    foreach t $bins(u0) { foreach n $bins(d0) { lappend neigh($t,u) $n } }
    foreach t $bins(u1) { foreach n $bins(d1) { lappend neigh($t,u) $n } }
    foreach t $bins(r0) { foreach n $bins(l0) { lappend neigh($t,r) $n } }
    foreach t $bins(r1) { foreach n $bins(l1) { lappend neigh($t,r) $n } }

    foreach k [array names neigh] { set neigh($k) [lsort -unique $neigh($k)] }
    return
}

::city::Init
#exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/canvas/locationmarks.gps.

1
2
3
poi 50.7764185111 6.086769104 Aachen
poi 51.1653    -115.5322      Banff
poi 49.30198   -123.13724     {Lost Lagoon}
<
<
<






Deleted scriptlibs/tklib0.5/tklib_examples0.5/canvas/morgens.jpg.

cannot compute difference between binary files

Deleted scriptlibs/tklib0.5/tklib_examples0.5/canvas/osm.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
# ### ### ### ######### ######### #########

## DEMO. Uses openstreetmap to show a tile-based world map.

## Call without arguments for a plain web-served map.
## Call with single argument (dir path) to use a tile cache.

## Syntax: osm ?cachedir?

## -- Note: The cache may not exist, it is automatically filled and/or
##    extended from the web-served data. This cache can grow very
##    large very quickly (I have currently seen ranging in size from
##    4K (water) to 124K (dense urban area)).

## Note: The editing of waypoints shows my inexperience with the
##       canvas. Adding points is with <1>, bound to the canvas
##       itself. Removing is with <3>, bound to the item
##       itself. However, often it doesn't work, or rather, only if a
##       add a new point X via <1> over the point of interest, and
##       then remove both X and the point of interest by using <3>
##       twice.
##
##	 Oh, and removal via <1> bound the item works not at all,
##	 because this triggers the global binding as well, re-adding
##	 the point immediately after its removal. Found no way of
##	 blocking that.
##
## Note: Currently new point can be added only at the end of the
##       trail. No insertion in the middle possible, although deletion
##       in the middle works. No moving points, yet.
##
## Note: This demo is reaching a size there it should be shifted to
##       tclapps for further development, and cleaned up, with many of
##       the messes encapsulated into snit types or other niceties,
##       separate packages, etc.

# ### ### ### ######### ######### #########
## Use canvas package relative to example location.

set selfdir  [file dirname [file normalize [info script]]]
set modules  [file join [file dirname [file dirname $selfdir]] modules]
set lmodule  [file join [file dirname [file dirname [file dirname [file dirname $selfdir]]]] Tcllib Head modules]

set dir $lmodule/map
source $lmodule/map/pkgIndex.tcl
unset dir
source $modules/canvas/canvas_sqmap.tcl ; # The main map support
source $modules/canvas/canvas_zoom.tcl  ; # Zoom control

## Ideas:
## == DONE ==
## -- Add zoom-control to switch between zoom levels. This has to
##    adjust the scroll-region as well. The control can be something
##    using basic Tk widgets (scale, button), or maybe some constructed
##    from canvas items, to make the map look more like the web-based
##    map displays. For the latter we have to get viewport tracking
##    data out of the canvas::sqmap to move the item-group in sync
##    with scrolling, so that they appaear to stay in place.
##
## == DONE ==
## -- Add a filesystem based tile cache to speed up their loading. The
##    pure http access is slow (*) OTOH, this makes the workings of
##    sqmap more observable, as things do not happen as fast as for
##    puzzle and city. (*) The xy store generates some output so you
##    can see that something is happening.
##
## -- Yes, it is possible to use google maps as well. Spying on a
##    browser easily shows the urls needed. But, they are commercial,
##    and some of the servers (sat image data) want some auth cookie.
##    Without they deliver a few proper tiles and then return errors.
##
##    Hence this demo uses the freely available openstreetmap(.org)
##    data instead.
##
## -- Select two locations, then compute the geo distance between
##    them. Or, select a series of location, like following a road,
##    and compute the partial and total distances.

## == DONE == (roughly)
## -- Mark, save, load series of points (gps tracks, own tracks).
##    Name point series. Name individual points (location marks).

# ### ### ### ######### ######### #########
## Other requirements for this example.

package require Tk
package require widget::scrolledwindow
package require canvas::sqmap
package require canvas::zoom
package require crosshair
package require img::png
package require tooltip

package require map::slippy             ; # Slippy utilities
package require map::slippy::fetcher    ; # Slippy server access
package require map::slippy::cache      ; # Local slippy tile cache
#package require map::slippy::prefetcher ; # Agressive prefetch

package require snit             ; # canvas::sqmap dependency
package require uevent::onidle   ; # ditto
package require cache::async 0.2 ; # ditto

# ### ### ### ######### ######### #########

proc Main {} {
    InitModel
    GUI
    LoadMarks ; # Geo Bookmarks.
    tkwait visibility .map
    Aachen 12
}

# ### ### ### ######### ######### #########

proc InitModel {} {
    global argv cachedir loaddir provider zoom

    set zoom     -1
    set cachedir ""
    set loaddir  [pwd]

    # OpenStreetMap. Mapnik rendered tiles.
    # alternative  http://tah.openstreetmap.org/Tiles/tile

    set provider [map::slippy::fetcher FETCH 19 http://tile.openstreetmap.org]

    # Nothing to do if no cache is specified, and fail for wrong#args

    if {![llength $argv]} return
    if {[llength $argv] > 1} Usage

    # A cache is specified. Create the directory, if necessary, and
    # initialize the necessary objects.

    set cachedir [lindex $argv 0]
    set loaddir  $cachedir
    set provider [map::slippy::cache CACHE $cachedir FETCH]

    # Pre-filling the cache based on map requests. Half-baked. Takes
    # currently to much cycles from the main requests themselves.  set
    #provider [map::slippy::prefetcher PREFE CACHE]
    return
}

proc Usage {} {
    global argv0
    puts stderr "wrong\#args, expected: $argv0 ?cachedir?"
    exit 1
}

# ### ### ### ######### ######### #########

proc GUI {} {
    global provider
    # ---------------------------------------------------------
    # The gui elements, plus connections.

    widget::scrolledwindow .sw
    widget::scrolledwindow .sl

    set th [$provider tileheight]
    set tw [$provider tilewidth]

    canvas::sqmap          .map   -closeenough 3 \
	-viewport-command VPTRACK -grid-cell-command GET \
	-grid-cell-width $tw -grid-cell-height $th
	
    canvas::zoom           .z    -variable ::zoom -command ZOOM \
	-orient vertical -levels [$provider levels]

    entry                  .loc  -textvariable ::location \
	-bd 2 -relief sunken -bg white -width 60

    listbox                .lm   -listvariable ::locations \
	-selectmode single

    button                 .exit -command exit        -text Exit
    button                 .goto -command GotoMark    -text Goto
    button                 .clr  -command ClearPoints -text {Clear Points}
    button                 .ld   -command LoadPoints  -text {Load Points}
    button                 .sv   -command SavePoints  -text {Save Points}

    .sw setwidget .map
    .sl setwidget .lm

    # ---------------------------------------------------------
    # layout of the elements

    grid .sl   -row 1 -column 0 -sticky swen -columnspan 2
    grid .z    -row 1 -column 2 -sticky wen
    grid .sw   -row 1 -column 3 -sticky swen -columnspan 5

    grid .exit -row 0 -column 0 -sticky wen
    grid .goto -row 0 -column 1 -sticky wen
    grid .clr  -row 0 -column 3 -sticky wen
    grid .ld   -row 0 -column 4 -sticky wen
    grid .sv   -row 0 -column 5 -sticky wen
    grid .loc  -row 0 -column 6 -sticky wen

    grid rowconfigure . 0 -weight 0
    grid rowconfigure . 1 -weight 1

    grid columnconfigure . 0 -weight 0
    grid columnconfigure . 1 -weight 0
    grid columnconfigure . 2 -weight 0
    grid columnconfigure . 3 -weight 0
    grid columnconfigure . 7 -weight 1

    # ---------------------------------------------------------
    # Behaviours

    # Panning via mouse
    bind .map <ButtonPress-2> {%W scan mark   %x %y}
    bind .map <B2-Motion>     {%W scan dragto %x %y}

    # Mark/unmark a point on the canvas
    bind .map <1> {RememberPoint %x %y}

    # Cross hairs ...
    .map configure -cursor tcross
    crosshair::crosshair .map -width 0 -fill \#999999 -dash {.}
    crosshair::track on  .map TRACK

    # ---------------------------------------------------------
    return
}

# ### ### ### ######### ######### #########

set location  {} ; # geo location of the mouse in the canvas (crosshair)

proc VPTRACK {xl yt xr yb} {
    # args = viewport, pixels, see also canvas::sqmap, SetPixelView.
    global viewport
    set viewport [list $xl $yt $xr $yb]
    #puts VP-TRACK($viewport)
    return
}

proc TRACK {win x y args} {
    # args = viewport, pixels, see also canvas::sqmap, SetPixelView.
    global location zoom

    # Convert pixels to geographic location.
    set point [list $zoom $y $x]
    foreach {_ lat lon} [map::slippy point 2geo $point] break

    # Update entry field.
    set location "$lat, $lon"
    return
}

# ### ### ### ######### ######### #########
# Basic callback structure, log for logging, facade to transform the
# cache/tiles result into what xcanvas is expecting.

proc GET {__ at donecmd} {
    global provider zoom
    set tile [linsert $at 0 $zoom]

    if {![map::slippy tile valid $tile [$provider levels]]} {
	GOT $donecmd unset $tile
	return
    }

    #puts "GET ($tile) ($donecmd)"
    $provider get $tile [list GOT $donecmd]
    return
}

proc GOT {donecmd what tile args} {
    #puts "\tGOT $donecmd $what ($tile) $args"
    set at [lrange $tile 1 end]
    if {[catch {
	uplevel #0 [eval [linsert $args 0 linsert $donecmd end $what $at]]
    }]} { puts $::errorInfo }
    return
}

# ### ### ### ######### ######### #########

proc ZOOM {w level} {
    # The variable 'zoom' is already set to level, as the -variable of
    # our zoom control .z

    #puts ".z = $level"

    set rlength [map::slippy length $level]
    set region  [list 0 0 $rlength $rlength]

    .map configure -scrollregion $region

    ShowPoints
    return
}

# ### ### ### ######### ######### #########

proc Goto {geo} {
    global zoom

    #puts Jump($geo)

    # The geo location is converted to pixels, then to a fraction of
    # the scrollregion. This is adjusted so that the fraction
    # specifies the center of the viewed region, and not the upper
    # left corner. for this translation we need the viewport data of
    # VPTRACK.

    foreach {z y x} [map::slippy geo 2point $geo] break
    set zoom $z
    after 200 [list Jigger $z $y $x]
    #.map xview moveto $ofx
    #.map yview moveto $ofy
    return
}

proc Jigger {z y x} {
    global viewport
    set len [map::slippy length $z]
    foreach {l t r b} $viewport break
    set ofy [expr {($y - ($b - $t)/2.0)/$len}]
    set ofx [expr {($x - ($r - $l)/2.0)/$len}]

    .map xview moveto $ofx
    .map yview moveto $ofy
    return
}

# ### ### ### ######### ######### #########

set points    {} ; # way-points loaded list (list (lat lon comment))
set locations {} ; # Location markers (locationmark.gps)
set lmarks    {} ; #

proc SavePoints {} {
    global loaddir

    set chosen [tk_getSaveFile -defaultextension .gps \
		    -filetypes {
			{GPS {.gps}}
			{ALL {*}}
		    } \
		    -initialdir $loaddir \
		    -title   {Save waypoints} \
		    -parent .map]

    if {$chosen eq ""} return

    global points
    set lines {}
    foreach p $points {
	foreach {lat lon comment} $p break
	lappend lines [list waypoint $lat $lon $comment]
    }

    fileutil::writeFile $chosen [join $lines \n]\n
    return
}

proc LoadPoints {} {
    global loaddir

    set chosen [tk_getOpenFile -defaultextension .gps \
		    -filetypes {
			{GPS {.gps}}
			{ALL {*}}
		    } \
		    -initialdir $loaddir \
		    -title   {Load waypoints} \
		    -parent .map]

    if {$chosen eq ""} return
    if {[catch {
	set waypoints [fileutil::cat $chosen]
    }]} {
	return
    }

    set loaddir [file dirname $chosen]

    ClearPoints
    # Content is TRUSTED. In a proper app this has to be isolated from
    # the main system through a safe interp.
    eval $waypoints
    ShowPoints
    return
}

proc waypoint {lat lon comment} {
    global  points
    lappend points [list $lat $lon $comment]
    return
}

proc ShowPoints {} {
    global points zoom

    if {![llength $points]} return

    set cmds {}
    set cmd [list .map create line]

    foreach point $points {
	foreach {lat lon comment} $point break
	foreach {_ y x} [map::slippy geo 2point [list $zoom $lat $lon]] break
	lappend cmd  $x $y
	lappend cmds [list POI $y $x $lat $lon $comment -fill salmon -tags Series]
    }
    lappend cmd -width 2 -tags Series -capstyle round ;#-smooth 1

    if {[llength $points] > 1} {
	set cmds [linsert $cmds 0 $cmd]
    }

    .map delete Series
    #puts [join $cmds \n]
    eval [join $cmds \n]
    return
}

global pcounter
set pcounter 0
proc RememberPoint {x y} {
    #puts REMEMBER///
    global pcounter zoom
    incr   pcounter

    set point [list $zoom [.map canvasy $y] [.map canvasx $x]]
    foreach {_ lat lon} [map::slippy point 2geo $point] break

    set comment "$pcounter:<$lat,$lon>"
    #puts $x/$y/$lat/$lon/$comment/$pcounter

    global  points
    lappend points [list $lat $lon $comment $pcounter]
    ShowPoints

    # This is handled weird. Placing the mouse on top of a point
    # doesn't trigger, however when I create a new point <1> at the
    # position, and then immediately after use <3> I can remove the
    # new point, and the second click the point underneath triggers as
    # well. Could this be a stacking issue?
    .map bind T/$comment <3> "[list ForgetPoint $pcounter];break"

    # Alternative: Bind <3> and the top level and use 'find
    # overlapping'. In that case however either we, or the sqmap
    # should filter out the background items.

    return
}

proc ForgetPoint {pid} {

    #    puts [.map find overlapping $x $y $x $y]
    #return

    #puts //FORGET//$pid

    global points
    set pos -1
    foreach p $points {
	incr pos
	foreach {lat lon comment id} $p break
	if {$id != $pid} continue
	#puts \tFound/$pos
	set points [lreplace $points $pos $pos]
	if {![llength $points]} {
	    ClearPoints
	} else {
	    ShowPoints
	}
	return
    }
    #puts Missed
    return
}

proc POI {y x lat lon comment args} {
    set x1 [expr { $x + 6 }]
    set y1 [expr { $y + 6 }]
    set x  [expr { $x - 6 }]
    set y  [expr { $y - 6 }]

    set id [eval [linsert $args 0 .map create oval $x $y $x1 $y1]]
    if {$comment eq ""} return
    tooltip::tooltip .map -item $id $comment
    .map addtag T/$comment withtag $id 
    return
}

proc ClearPoints {} {
    global points
    set points {}
    .map delete Series
    return
}

proc FindMarks {v} {
    upvar 1 $v file
    global cachedir loaddir selfdir
    set base locationmarks.gps

    foreach d [list $cachedir $loaddir [pwd] $selfdir] {
	set lm [file join $d $base]
	if {![file exists $lm]} continue
	set file $lm
	return 1
    }
    return 0
}

proc LoadMarks {} {
    if {![FindMarks lm]} return

    if {[catch {
	set waypoints [fileutil::cat $lm]
    }]} {
	return
    }

    ClearMarks
    # Content is TRUSTED. In a proper app this has to be isolated from
    # the main system through a safe interp.
    eval $waypoints
    ShowMarks
    return
}

proc ClearMarks {} {
    global lmarks locations
    set lmarks {}
    set locations {}
    return
}

proc poi {lat lon comment} {
    global lmarks locations
    lappend lmarks [list $lat $lon]
    lappend locations $comment
    return
}

proc ShowMarks {} {
    # locations traced by .lm
    return
}

proc GotoMark {} {
    global lmarks zoom
    set sel [.lm curselection]
    if {![llength $sel]} return
    set sel [lindex $sel 0]
    set sel [lindex $lmarks $sel]
    foreach {lat lon} $sel break
    Goto [list $zoom $lat $lon]
    return
}

# ### ### ### ######### ######### #########

proc ShowGrid {} {
    # Activating the grid leaks items = memory
    .map configure -grid-show-borders 1
    .map flush
    return
}

proc Aachen {z} {
    # City of Aachen, NRW. Germany, Europe.
    Goto [list $z 50.7764185111 6.086769104]
    return
}

# ### ### ### ######### ######### #########
# ### ### ### ######### ######### #########
Main
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/canvas/puzzle.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
#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
# ### ### ### ######### ######### #########

## DEMO. Slice image into tiles and show them, in order, or randomly
##       shuffled. Image can be provided as argument, or uses the
##       'morgens.jpg' from the example directory as default. Accepts
##       jpeg and png images.

# ### ### ### ######### ######### #########
## Use canvas package relative to example location.

set selfdir  [file dirname [file normalize [info script]]]
set modules [file join [file dirname [file dirname $selfdir]] modules]

source $modules/canvas/canvas_sqmap.tcl

## Ideas: It should be possible to get feedback on mouse clicks and
## use that to let the user swaps cells, until the shown image is
## restored to order.

# ### ### ### ######### ######### #########
## Other requirements for this example.

package require Tk
package require widget::scrolledwindow
package require canvas::sqmap
package require crosshair
package require img::jpeg
package require img::png

package require snit             ; # canvas::sqmap dependency
package require uevent::onidle   ; # ditto
package require cache::async 0.2 ; # ditto

# ### ### ### ######### ######### #########

proc Init {} {
    global argv tile scrollw scrollh basepicks maxw maxh

    set image [lindex $argv 0]
    if {$image eq ""} {
	set image [file join [file dirname [file normalize [info script]]] morgens.jpg]
    }
    set image [image create photo -file $image]

    set scrollw    [image width  $image]
    set scrollh    [image height $image]
    set tile 256

    set maxh 0
    for {set y 0} {$y < $scrollh} {incr y $tile} {
	set y1 $y ; incr y1 $tile
	if {$y1 > $scrollh} { set y1 $scrollh }
	set maxw 0
	for {set x 0} {$x < $scrollw} {incr x $tile} {
	    set x1 $x ; incr x1 $tile
	    if {$x1 > $scrollw} { set x1 $scrollh }

	    set parcel [image create photo -height $tile -width $tile]
	    $parcel copy $image -from $x $y $x1 $y1
	    lappend basepicks $parcel
	    incr maxw
	}
	incr maxh
    }

    image delete $image

    InitPicksUnordered
    return
}

# ### ### ### ######### ######### #########

set location {}

proc GUI {} {
    global tile scrollw scrollh

    widget::scrolledwindow .sw
    canvas::sqmap          .map
    button                 .exit -command exit    -text Exit
    button                 .shfl -command Shuffle -text Shuffle
    button                 .ord  -command Order   -text Original
    entry                  .loc  -textvariable location \
	-bd 2 -relief sunken -bg white -width 40

    .sw setwidget .map

    # Panning via mouse
    bind .map <ButtonPress-2> {%W scan mark   %x %y}
    bind .map <B2-Motion>     {%W scan dragto %x %y}

    # Cross hairs ...
    .map configure -cursor tcross
    crosshair::crosshair .map -width 0 -fill \#999999 -dash {.}
    crosshair::track on  .map TRACK

    #.map configure -grid-show-borders 1 ;# This leaks items = memory
    if 0 {
	# This routes the requests and results through GOT/GET logging
	# commands.
	.map configure \
	    -grid-cell-command GET \
	    -grid-cell-width  $tile \
	    -grid-cell-height $tile \
	    -scrollregion [list 0 0 $scrollw $scrollh]
    } else {
	# This routes the requests directly to the grid provider, and
	# results back.
	.map configure \
	    -grid-cell-command Pick \
	    -grid-cell-width  $tile \
	    -grid-cell-height $tile \
	    -scrollregion [list 0 0 $scrollw $scrollh]
    }

    pack .sw    -expand 1 -fill both -side bottom
    pack .exit  -expand 0 -fill both -side left
    pack .shfl  -expand 0 -fill both -side left
    pack .ord   -expand 0 -fill both -side left
    pack .loc   -expand 0 -fill both -side left

    return
}

proc Shuffle {} {
    InitPicksUnordered
    .map flush
    return
}

proc Order {} {
    InitPicksOrdered
    .map flush
    return
}

proc InitPicksUnordered {} {
    global picks basepicks order
    set picks [shuffle5a $basepicks]
    set order 0
    return
}

proc InitPicksOrdered {} {
    global picks basepicks order
    set picks $basepicks
    set order 1
    return
}

# ### ### ### ######### ######### #########
# Basic callback structure, log for logging, facade to transform the
# cache/tiles result into what xcanvas is expecting.

proc GET {__ at donecmd} {
    puts "GET ($at) ($donecmd)"
    Pick get $at [list GOT $donecmd]
    return
}

proc GOT {donecmd what at args} {
    puts "\tGOT $donecmd $what ($at) $args"
    if {[catch {
	uplevel #0 [eval [linsert $args 0 linsert $donecmd end $what $at]]
    }]} { puts $::errorInfo }
    return
}

# ### ### ### ######### ######### #########

proc TRACK {win x y args} {
    # args = viewport, pixels, see also xcanvas, SetPixelView.
    global location
    set location "@ $x, $y"
    return
}

# ### ### ### ######### ######### #########

proc Pick {__ at donecmd} {
    global picks image order maxw maxh
    if {[llength $picks]} {
	if {$order} {
	    foreach {r c} $at break
	    set i [expr {$c + ($r * $maxw)}]
	    set choice [lindex $picks $i]
	} else {
	    set choice [lindex $picks end]
	    set picks  [lreplace [K $picks [unset picks]] end end]
	}
	uplevel #0 [linsert $donecmd end set $at $choice]
    } else {
	uplevel #0 [linsert $donecmd end unset $at]
    }
    return
}

proc shuffle5a { list } {
    set n 1
    set slist {}
    foreach item $list {
	set index [expr {int(rand()*$n)}]
	set slist [linsert [K $slist [set slist {}]] $index $item]
	incr n
    }
    return $slist
}

proc K { x y } { set x }

# ### ### ### ######### ######### #########
## Basic interface.

Init
GUI
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/canvas/seawalk.gps.

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
# seawalk - around lost lagoon and stanley park.
waypoint 49.2928086642 -123.142125607 33:<49.2928086642,-123.142125607>
waypoint 49.2932005102 -123.142731786 34:<49.2932005102,-123.142731786>
waypoint 49.2940086827 -123.14384222 35:<49.2940086827,-123.14384222>
waypoint 49.2949113013 -123.144899011 36:<49.2949113013,-123.144899011>
waypoint 49.2958873703 -123.145623207 37:<49.2958873703,-123.145623207>
waypoint 49.2961287607 -123.145805597 38:<49.2961287607,-123.145805597>
waypoint 49.2963106773 -123.145317435 39:<49.2963106773,-123.145317435>
waypoint 49.2964506127 -123.144614697 40:<49.2964506127,-123.144614697>
waypoint 49.2965310754 -123.143954873 41:<49.2965310754,-123.143954873>
waypoint 49.2965310754 -123.143096566 42:<49.2965310754,-123.143096566>
waypoint 49.296583551 -123.142442107 43:<49.296583551,-123.142442107>
waypoint 49.2968319347 -123.141857386 44:<49.2968319347,-123.141857386>
waypoint 49.2970768188 -123.141433597 45:<49.2970768188,-123.141433597>
waypoint 49.2971712738 -123.140843511 46:<49.2971712738,-123.140843511>
waypoint 49.2971922638 -123.140253425 47:<49.2971922638,-123.140253425>
waypoint 49.2971992604 -123.13965261 48:<49.2971992604,-123.13965261>
waypoint 49.2971572805 -123.139110804 49:<49.2971572805,-123.139110804>
waypoint 49.297248237 -123.138429523 50:<49.297248237,-123.138429523>
waypoint 49.2973182034 -123.137962818 51:<49.2973182034,-123.137962818>
waypoint 49.2972972135 -123.137469292 52:<49.2972972135,-123.137469292>
waypoint 49.2971642772 -123.1372118 53:<49.2971642772,-123.1372118>
waypoint 49.296996357 -123.137018681 54:<49.296996357,-123.137018681>
waypoint 49.2968564232 -123.136857748 55:<49.2968564232,-123.136857748>
waypoint 49.2966605151 -123.136734366 56:<49.2966605151,-123.136734366>
waypoint 49.2963561564 -123.136643171 57:<49.2963561564,-123.136643171>
waypoint 49.296079783 -123.136600256 58:<49.296079783,-123.136600256>
waypoint 49.2957334395 -123.136739731 59:<49.2957334395,-123.136739731>
waypoint 49.2954080844 -123.136863112 60:<49.2954080844,-123.136863112>
waypoint 49.2950582377 -123.137013316 61:<49.2950582377,-123.137013316>
waypoint 49.294760866 -123.137260079 62:<49.294760866,-123.137260079>
waypoint 49.2946419169 -123.137308359 63:<49.2946419169,-123.137308359>
waypoint 49.2945964363 -123.137201071 64:<49.2945964363,-123.137201071>
waypoint 49.2945859407 -123.137040138 65:<49.2945859407,-123.137040138>
waypoint 49.2946489139 -123.136959672 66:<49.2946489139,-123.136959672>
waypoint 49.294746872 -123.136863112 67:<49.294746872,-123.136863112>
waypoint 49.2949182983 -123.136610985 68:<49.2949182983,-123.136610985>
waypoint 49.2952891368 -123.135854602 69:<49.2952891368,-123.135854602>
waypoint 49.2959258529 -123.135640025 70:<49.2959258529,-123.135640025>
waypoint 49.2964506127 -123.135221601 71:<49.2964506127,-123.135221601>
waypoint 49.2969543769 -123.134336472 74:<49.2969543769,-123.134336472>
waypoint 49.2970418355 -123.133097291 75:<49.2970418355,-123.133097291>
waypoint 49.2969613736 -123.132469654 76:<49.2969613736,-123.132469654>
waypoint 49.2970208454 -123.132083416 77:<49.2970208454,-123.132083416>
waypoint 49.2974441427 -123.131450415 78:<49.2974441427,-123.131450415>
waypoint 49.2976855255 -123.130844235 79:<49.2976855255,-123.130844235>
waypoint 49.2977484948 -123.130297065 80:<49.2977484948,-123.130297065>
waypoint 49.2976610375 -123.129991293 81:<49.2976610375,-123.129991293>
waypoint 49.2974441427 -123.129776716 82:<49.2974441427,-123.129776716>
waypoint 49.2968319347 -123.129444122 83:<49.2968319347,-123.129444122>
waypoint 49.2965625608 -123.129191995 86:<49.2965625608,-123.129191995>
waypoint 49.2961882335 -123.128714561 87:<49.2961882335,-123.128714561>
waypoint 49.2960168117 -123.128280044 88:<49.2960168117,-123.128280044>
waypoint 49.2959713323 -123.127883077 89:<49.2959713323,-123.127883077>
waypoint 49.2961322591 -123.12730372 90:<49.2961322591,-123.12730372>
waypoint 49.2970033537 -123.126815557 91:<49.2970033537,-123.126815557>
waypoint 49.2976050647 -123.125935793 92:<49.2976050647,-123.125935793>
waypoint 49.2977589896 -123.125442266 93:<49.2977589896,-123.125442266>
waypoint 49.2978289553 -123.124836087 94:<49.2978289553,-123.124836087>
waypoint 49.2978044673 -123.124192357 95:<49.2978044673,-123.124192357>
waypoint 49.2976715324 -123.123301864 96:<49.2976715324,-123.123301864>
waypoint 49.2975106106 -123.122776151 97:<49.2975106106,-123.122776151>
waypoint 49.2975840749 -123.122491837 98:<49.2975840749,-123.122491837>
waypoint 49.2981158137 -123.121907115 99:<49.2981158137,-123.121907115>
waypoint 49.2983886774 -123.121263385 100:<49.2983886774,-123.121263385>
waypoint 49.2983012212 -123.120684028 101:<49.2983012212,-123.120684028>
waypoint 49.2980143639 -123.119965196 102:<49.2980143639,-123.119965196>
waypoint 49.2979618899 -123.119396567 103:<49.2979618899,-123.119396567>
waypoint 49.2980353536 -123.118661642 104:<49.2980353536,-123.118661642>
waypoint 49.2980423501 -123.117744327 105:<49.2980423501,-123.117744327>
waypoint 49.2981542945 -123.117401004 106:<49.2981542945,-123.117401004>
waypoint 49.2988819271 -123.116864562 107:<49.2988819271,-123.116864562>
waypoint 49.2995640729 -123.116730452 108:<49.2995640729,-123.116730452>
waypoint 49.3001307715 -123.116542697 109:<49.3001307715,-123.116542697>
waypoint 49.3005365516 -123.116666079 110:<49.3005365516,-123.116666079>
waypoint 49.3006344981 -123.11688602 111:<49.3006344981,-123.11688602>
waypoint 49.3006869693 -123.117384911 112:<49.3006869693,-123.117384911>
waypoint 49.3004945745 -123.117679954 113:<49.3004945745,-123.117679954>
waypoint 49.3001062846 -123.117915988 114:<49.3001062846,-123.117915988>
waypoint 49.2999138876 -123.118312955 115:<49.2999138876,-123.118312955>
waypoint 49.2996480287 -123.119106889 116:<49.2996480287,-123.119106889>
waypoint 49.2996270397 -123.120185137 117:<49.2996270397,-123.120185137>
waypoint 49.2998369286 -123.121300936 118:<49.2998369286,-123.121300936>
waypoint 49.3008723672 -123.124117255 119:<49.3008723672,-123.124117255>
waypoint 49.3023310393 -123.126155734 120:<49.3023310393,-123.126155734>
waypoint 49.3024779535 -123.126756549 121:<49.3024779535,-123.126756549>
waypoint 49.3024499699 -123.127942085 122:<49.3024499699,-123.127942085>
waypoint 49.3025793941 -123.129132986 123:<49.3025793941,-123.129132986>
waypoint 49.3030376228 -123.130474091 124:<49.3030376228,-123.130474091>
waypoint 49.3039155911 -123.131600618 125:<49.3039155911,-123.131600618>
waypoint 49.3057729147 -123.133124113 126:<49.3057729147,-123.133124113>
waypoint 49.3065284161 -123.134459853 127:<49.3065284161,-123.134459853>
waypoint 49.3068536979 -123.135420084 128:<49.3068536979,-123.135420084>
waypoint 49.3085954928 -123.136187196 129:<49.3085954928,-123.136187196>
waypoint 49.3112290536 -123.138139844 130:<49.3112290536,-123.138139844>
waypoint 49.3123866567 -123.139218092 131:<49.3123866567,-123.139218092>
waypoint 49.3130441351 -123.13965261 132:<49.3130441351,-123.13965261>
waypoint 49.3134987694 -123.140189052 133:<49.3134987694,-123.140189052>
waypoint 49.3136001872 -123.140339255 134:<49.3136001872,-123.140339255>
waypoint 49.3140373306 -123.140913248 135:<49.3140373306,-123.140913248>
waypoint 49.3140303364 -123.142066598 136:<49.3140303364,-123.142066598>
waypoint 49.3137820393 -123.143407702 137:<49.3137820393,-123.143407702>
waypoint 49.3133239105 -123.146438599 138:<49.3133239105,-123.146438599>
waypoint 49.3128343025 -123.148745298 139:<49.3128343025,-123.148745298>
waypoint 49.3127258887 -123.149834275 140:<49.3127258887,-123.149834275>
waypoint 49.3122292802 -123.151298761 141:<49.3122292802,-123.151298761>
waypoint 49.3116277478 -123.152114153 142:<49.3116277478,-123.152114153>
waypoint 49.3111765936 -123.152677417 146:<49.3111765936,-123.152677417>
waypoint 49.3105120955 -123.15297246 147:<49.3105120955,-123.15297246>
waypoint 49.3094523773 -123.154174089 148:<49.3094523773,-123.154174089>
waypoint 49.3084066264 -123.156116009 149:<49.3084066264,-123.156116009>
waypoint 49.3065983693 -123.156673908 150:<49.3065983693,-123.156673908>
waypoint 49.3051083436 -123.156673908 151:<49.3051083436,-123.156673908>
waypoint 49.3039925437 -123.157086968 152:<49.3039925437,-123.157086968>
waypoint 49.3017748601 -123.157274723 153:<49.3017748601,-123.157274723>
waypoint 49.3013376078 -123.158787489 154:<49.3013376078,-123.158787489>
waypoint 49.3010962429 -123.158900142 155:<49.3010962429,-123.158900142>
waypoint 49.3005015707 -123.158476353 156:<49.3005015707,-123.158476353>
waypoint 49.2989728804 -123.158599734 157:<49.2989728804,-123.158599734>
waypoint 49.2977310033 -123.158320785 158:<49.2977310033,-123.158320785>
waypoint 49.2973986647 -123.15725863 159:<49.2973986647,-123.15725863>
waypoint 49.2971957621 -123.156523705 160:<49.2971957621,-123.156523705>
waypoint 49.2971747721 -123.154147267 161:<49.2971747721,-123.154147267>
waypoint 49.2964121305 -123.153541088 162:<49.2964121305,-123.153541088>
waypoint 49.2953905921 -123.152623773 163:<49.2953905921,-123.152623773>
waypoint 49.2948763164 -123.151051998 164:<49.2948763164,-123.151051998>
waypoint 49.2951491981 -123.148938417 171:<49.2951491981,-123.148938417>
waypoint 49.2948413315 -123.148648739 172:<49.2948413315,-123.148648739>
waypoint 49.2949182983 -123.148262501 173:<49.2949182983,-123.148262501>
waypoint 49.2936868148 -123.147822618 174:<49.2936868148,-123.147822618>
waypoint 49.2934908941 -123.147672415 175:<49.2934908941,-123.147672415>
waypoint 49.2932949726 -123.147382736 176:<49.2932949726,-123.147382736>
waypoint 49.2931130449 -123.147039413 177:<49.2931130449,-123.147039413>
waypoint 49.2929521082 -123.146309853 178:<49.2929521082,-123.146309853>
waypoint 49.2929521082 -123.145591021 179:<49.2929521082,-123.145591021>
waypoint 49.2930220807 -123.144786358 180:<49.2930220807,-123.144786358>
waypoint 49.2930920532 -123.143852949 181:<49.2930920532,-123.143852949>
waypoint 49.2930500697 -123.143026829 182:<49.2930500697,-123.143026829>
waypoint 49.2928086642 -123.142125607 33:<49.2928086642,-123.142125607>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/ntext/ntextDemoBindings.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"

# Copyright (c) 2005-2007 Keith Nash.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

### This demo explores the ntext options
### For a short example, see ntextExample.tcl
### To explore ntext indentation, try ntextDemoIndent.tcl

# This string defines the text that will be displayed in each widget:
set message {QOTW:  "C/C++, which is used by 16% of users, is the most popular programming language, but Tcl, used by 0%, seems to be the language of choice for the highest scoring users."

example code {alph {bet {b}} {gam {c}}} {
    # Example code rich in punctuation
    if {!($alph eq "a" && $bet eq "b")} {
        puts "$gam $::messages::demo(d)"
    }
}

Try editing the text with the keyboard and mouse; compare the bindings for Text (left panel) and Ntext (right panel).

Try word-by-word navigation (Control key with left cursor or right cursor key); try word selection (double click); try these for the different word-break detection options (selected below).

The classicMouseSelect and classicAnchor options are discussed in the man page for ntextBindings.}
# End of string for widget text.

package require ntext

# Whether Shift-Button-1 ignores changes made by the kbd to the insert mark:
set ::ntext::classicMouseSelect 0

# Whether Shift-Button-1 has a variable or fixed anchor:
set ::ntext::classicAnchor      0

# Whether the traditional "extra" bindings are activated:
set ::ntext::classicExtras      1

# Whether to use new or classic word boundary detection:
set ::ntext::classicWordBreak   0

# Set to 0 to align wrapped display lines with the first display line of the logical line:
set ::ntext::classicWrap        1

pack [frame .rhf] -side right -anchor nw
pack [text .rhf.new ]
bindtags .rhf.new {.rhf.new Ntext . all}

.rhf.new configure -wrap word -undo 1
.rhf.new configure -width 42 -height 29 -font {{Courier} -15} -bg white
.rhf.new insert end "  I use the Ntext bindings.\n\n$message"
.rhf.new edit separator

pack [frame .lhf] -side left -anchor ne
pack [text .lhf.classic ]
.lhf.classic configure -width 42 -height 29 -wrap word -undo 1 -font {{Courier} -15} -bg #FFFFEE
.lhf.classic insert end "  I use the (default) Text bindings.\n\n$message"
.lhf.classic edit separator
pack [label  .lhf.m -text "(The controls do not apply\nto the left-hand text widget)"]

pack [frame .rhf.h] -fill x
pack [radiobutton .rhf.h.on  -text "On " -variable ::ntext::classicMouseSelect -value 1] -side right
pack [radiobutton .rhf.h.off -text "Off" -variable ::ntext::classicMouseSelect -value 0] -side right
pack [label  .rhf.h.l -text "classicMouseSelect: "] -side right

pack [frame .rhf.g] -anchor ne
pack [radiobutton .rhf.g.on  -text "On " -variable ::ntext::classicAnchor -value 1] -side right
pack [radiobutton .rhf.g.off -text "Off" -variable ::ntext::classicAnchor -value 0] -side right
pack [label  .rhf.g.l -text "classicAnchor: "] -side right

pack [frame .rhf.k] -anchor ne
pack [radiobutton .rhf.k.on  -text "On " -variable ::ntext::classicExtras -value 1] -side right
pack [radiobutton .rhf.k.off -text "Off" -variable ::ntext::classicExtras -value 0] -side right
pack [label  .rhf.k.l -text "classicExtras: "] -side right

pack [frame .rhf.j] -anchor ne
set wordBreakChoice new
pack [radiobutton .rhf.j.wind -text "On (Windows)" -variable wordBreakChoice -value "windows" -command {setPattern}] -side right
pack [radiobutton .rhf.j.unix -text "On (Unix)" -variable wordBreakChoice -value "unix" -command {setPattern}] -side right
pack [radiobutton .rhf.j.off  -text "Off" -variable wordBreakChoice -value "new" -command {setPattern}] -side right
pack [label  .rhf.j.l -text "classicWordBreak: "] -side right

proc setPattern {} {
    global wordBreakChoice
    set platform $::tcl_platform(platform)

    if {$wordBreakChoice eq "unix"} {
        set ::tcl_platform(platform) unix
        set ::ntext::classicWordBreak 1
    } elseif {$wordBreakChoice eq "windows"} {
        set ::tcl_platform(platform) windows
        set ::ntext::classicWordBreak 1
    } else {
        set ::ntext::classicWordBreak 0
    }

    ::ntext::initializeMatchPatterns
    set ::tcl_platform(platform) $platform
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/ntext/ntextDemoIndent.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"

# Copyright (c) 2005-2007 Keith Nash.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

### This demo explores ntext indentation
### For a short example, see ntextExample.tcl
### To explore the ntext options, try ntextDemoBindings.tcl

### Points to note when using ntext's indent facilities are commented and numbered (1) to (6).

### If the text in your widget is manipulated only by the keyboard and mouse, then (1), (2) and (3) are all you need to do.  If the text or its layout are manipulated by the script, then you also need to call the function ::ntext::wrapIndent - see comments (4) to (6), and the man page for ntextIndent.

# This string defines the text that will be displayed in each widget:
set message {    This demo shows ntext's indentation facilities.  These are switched off by default, but in this demo they have been switched on.

  To try the demo - place the cursor at the start of a paragraph and change the amount of initial space. The paragraph is a logical line of text; its first display line may have leading whitespace, and ntext indents any subsequent (wrapped) display lines to match the first.
	This paragraph is indented by a tab. Again, the display lines are all indented to match the first.
 Try any text-widget operation, and test whether ntext's handling of display line indentation is satisfactory.  Please report any bugs - for instructions, see the ntext Wiki page, http://wiki.tcl.tk/14918
}
# End of string for widget text.

package require ntext

### (1) Indentation is disabled by default.  Set this variable to 0 to enable it:
set ::ntext::classicWrap        0

#  Activate the traditional "extra" bindings so these can be tested too:
set ::ntext::classicExtras      1

pack [frame .rhf] -side right -anchor nw
pack [text .rhf.new ]

### (2) Set the widget's binding tags to use 'Ntext' instead of the default 'Text':
bindtags .rhf.new {.rhf.new Ntext . all}

### (3) Set the widget to '-wrap word' mode:
.rhf.new configure -wrap word -undo 1
.rhf.new configure -width 42 -height 26 -font {{Courier} -15} -bg white
.rhf.new insert end "  I use the Ntext bindings.\n\n$message"
.rhf.new edit separator

### (4) The script (not the keyboard or mouse) has inserted text.  Because the widget has not yet been drawn, ::ntext::wrapIndent will be called by the <Configure> binding, so it is not really necessary to call it here.  It is necessary in most other cases when the 'insert' command is called by the script.
::ntext::wrapIndent .rhf.new

pack [frame .lhf] -side left -anchor ne
pack [text .lhf.classic ]
.lhf.classic configure -width 42 -height 26 -wrap word -undo 1 -font {{Courier} -15} -bg #FFFFEE
.lhf.classic insert end "  I use the (default) Text bindings.\n\n$message"
.lhf.classic edit separator
pack [label  .lhf.m -text "(The controls do not apply\nto the left-hand text widget)"]

pack [frame .rhf.h] -fill x
### (5) When indentation is switched on or off, call ::ntext::wrapIndent to calculate or clear indentation for the entire widget:
pack [radiobutton .rhf.h.off -text "Indent Off" -variable ::ntext::classicWrap -value 1 -command {::ntext::wrapIndent .rhf.new}] -side right
pack [radiobutton .rhf.h.on  -text "Indent On"  -variable ::ntext::classicWrap -value 0 -command {::ntext::wrapIndent .rhf.new}] -side right
pack [label  .rhf.h.l -text "Switch indentation on/off: "] -side right

pack [frame .rhf.g] -anchor ne
pack [entry  .rhf.g.e -width 3] -side right -padx 5
pack [button .rhf.g.b -text "Click to set tab spacing to value in box" -command changeTabs] -side right

proc changeTabs {} {
    set nTabs [.rhf.g.e get]
    if {[string is integer -strict $nTabs] && $nTabs > 0} {
        set font [lindex [.rhf.new configure -font] 4]
        .rhf.new configure -tabs "[expr {$nTabs * [font measure $font 0]}] left"
        ### (6) Changing the tabs may change the indentation of the first display line of a logical line; if so, the indentation of the other display lines must be recalculated:
        ::ntext::wrapIndent .rhf.new
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/ntext/ntextExample.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"

# Copyright (c) 2005-2007 Keith Nash.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

### This is a short, simple example.  It shows the difference
### between a default text widget and one that uses ntext.

### To explore the ntext options, try ntextDemoBindings.tcl
### To explore ntext indentation, try ntextDemoIndent.tcl

# This string defines the text that will be displayed in each widget:
set message {QOTW:  "C/C++, which is used by 16% of users, is the most popular programming language, but Tcl, used by 0%, seems to be the language of choice for the highest scoring users."
}
# End of string for widget text.

package require ntext

#  Whether Shift-Button-1 ignores changes made by the kbd to the insert mark:
set ::ntext::classicMouseSelect 0

#  Whether Shift-Button-1 has a variable or fixed anchor:
set ::ntext::classicAnchor      0

# Whether to activate certain traditional "extra" bindings
variable classicExtras            1

#  Whether to use new or classic word boundary detection:
set ::ntext::classicWordBreak   0

pack [text .right ] -side right
.right configure -width 28 -height 12 -wrap word -font {{Courier} -15} -bg white
.right insert end "  I use the Ntext bindings.\n\n$message"

bindtags .right {.right Ntext . all}

pack [text .left ] -side right
.left configure -width 28 -height 12 -wrap word -font {{Courier} -15} -bg #FFFFEE
.left insert end "  I use the (default) Text bindings.\n\n$message"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/plotchart/plotdemos1.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
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

package require Tcl 8.4
package require Tk
package require Plotchart

# plotdemos1.tcl --
#    Test program 1 for the Plotchart package
#

#
# Main code
#
canvas .c  -background white -width 400 -height 200
canvas .c2 -background white -width 400 -height 200
canvas .c3 -background white -width 400 -height 200
canvas .c4 -background white -width 400 -height 200
pack   .c .c2 .c3 .c4 -fill both -side top

toplevel .h
canvas .h.c  -background white -width 400 -height 200
canvas .h.c2 -background white -width 400 -height 200
pack   .h.c .h.c2 -fill both -side top

toplevel .v
canvas .v.c  -background white -width 400 -height 200
canvas .v.c2 -background white -width 400 -height 200
canvas .v.c3 -background white -width 400 -height 200
pack   .v.c .v.c2 .v.c3 -fill both -side top

set s [::Plotchart::createXYPlot .c {0.0 100.0 10.0} {0.0 100.0 20.0}]
set r [::Plotchart::createRightAxis .c {0.0 0.1 0.01}]

set xd    5.0
set yd   20.0
set xold  0.0
set yold 50.0

$s dataconfig series1 -colour "red"
$s dataconfig series2 -colour "blue"
$s dataconfig series3 -colour "magenta"

for { set i 0 } { $i < 20 } { incr i } {
   set xnew [expr {$xold+$xd}]
   set ynew [expr {$yold+(rand()-0.5)*$yd}]
   set ynew2 [expr {$yold+(rand()-0.5)*2.0*$yd}]
   $s plot series1 $xnew $ynew
   $s plot series2 $xnew $ynew2
   $s trend series3 $xnew $ynew2
   set xold $xnew
   set yold $ynew
}

$s interval series2 50.0 40.0 60.0 52.0
$s interval series2 60.0 40.0 60.0

$s xtext "X-coordinate"
$s ytext "Y-data"
$r ytext "Right axis"
$s title "Aha!"

#
# Some data for the right axis
#
$r dataconfig right -type both -symbol circle -colour green
$r plot right 10.0 0.01
$r plot right 30.0 0.03
$r plot right 40.0 0.02

tkwait visibility .c
#$s saveplot "aha.ps"

set s [::Plotchart::createPiechart .c2]

$s plot {"Long names" 10 "Short names" 30 "Average" 40
         "Ultra-short names" 5}
#
# Note: title should be shifted up
#       - distinguish a separate title area
#
$s title "Okay - this works"



set s [::Plotchart::createPolarplot .c3 {3.0 1.0}]

for { set angle 0 } { $angle < 360.0 } { set angle [expr {$angle+10.0}] } {
   set rad [expr {1.0+cos($angle*$::Plotchart::torad)}]
   $s plot "cardioid" $rad $angle
}

$s title "Cardioid"


set s [::Plotchart::createBarchart .h.c {A B C D E} {0.0 10.0 2.0} 2.5]

$s legend series1 "Series 1"
$s legend series2 "Series 2"

$s plot series1 {1.0 4.0 6.0 1.0 7.0} red
$s plot series2 {0.0 3.0 7.0 9.3 2.0} green
$s title "Arbitrary data"


set s [::Plotchart::createBarchart .h.c2 {A B C D E} {0.0 20.0 5.0} stacked]

$s plot series1 {1.0 4.0 6.0 1.0 7.0} red
$s plot series2 {0.0 3.0 7.0 9.3 2.0} green
$s title "Stacked diagram"



set s [::Plotchart::createHorizontalBarchart .v.c {0.0 10.0 2.0} {A B C D E} 2]

$s plot series1 {1.0 4.0 6.0 1.0 7.0} red
$s plot series2 {0.0 3.0 7.0 9.3 2.0} green
$s title "Arbitrary data"


set s [::Plotchart::createHorizontalBarchart .v.c2 {0.0 20.0 5.0} {A B C D E} stacked]

$s plot series1 {1.0 4.0 6.0 1.0 7.0} red
$s plot series2 {0.0 3.0 7.0 9.3 2.0} green
$s title "Stacked diagram"


set s [::Plotchart::createTimechart .v.c3 "1 january 2004" \
                                          "31 december 2004" 4]

$s period "Spring" "1 march 2004" "1 june 2004" green
$s period "Summer" "1 june 2004" "1 september 2004" yellow
$s vertline "1 jan" "1 january 2004"
$s vertline "1 apr" "1 april 2004"
$s vertline "1 jul" "1 july 2004"
$s vertline "1 oct" "1 october 2004"
$s milestone "Longest day" "21 july 2004"
$s title "Seasons (northern hemisphere)"

proc cowboyhat {x y} {
   set x1 [expr {$x/9.0}]
   set y1 [expr {$y/9.0}]

   expr { 3.0 * (1.0-($x1*$x1+$y1*$y1))*(1.0-($x1*$x1+$y1*$y1)) }
}

toplevel .h3
canvas .h3.c  -bg white -width 400 -height 300
canvas .h3.c2 -bg white -width 400 -height 250
pack .h3.c .h3.c2

set s [::Plotchart::create3DPlot .h3.c {0 10 3} {-10 10 10} {0 10 2.5}]
$s title "3D Plot"
$s plotfunc cowboyhat

set s [::Plotchart::create3DPlot .h3.c2 {0 10 3} {-10 10 10} {0 10 2.5}]
$s title "3D Plot - data "
$s colour "green" "black"
$s plotdata { {1.0 2.0 1.0 0.0} {1.1 3.0 1.1 -0.5} {3.0 1.0 4.0 5.0} }


set s [::Plotchart::createTXPlot .c4 {2006-01-01 2007-01-01 120} {0.0 100.0 20.0}]

$s dataconfig series1 -colour "red"
$s dataconfig series2 -colour "blue"

$s xtext "Time"
$s ytext "Data"
$s xticklines

$s plot series1 2006-02-01 10.0
$s plot series1 2006-02-11 50.0
$s plot series1 2006-03-01 50.0
$s plot series1 2006-07-01 40.0
$s plot series1 2006-08-21 20.0
$s plot series1 2006-08-22  1.0
$s plot series1 2006-12-11 78.0

$s plot series2 2006-03-01 110.0
$s plot series2 2006-04-11  50.0
$s plot series2 2006-07-28  20.0
$s plot series2 2006-10-21  99.0
$s plot series2 2006-11-22   1.0
$s plot series2 2006-12-31  78.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/plotchart/plotdemos2.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
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

package require Tcl 8.4
package require Tk

package require Plotchart

# plotdemos2.tcl --
#    Second test program for the Plotchart package
#

#
# Main code
#
canvas .c  -background white -width 400 -height 200
canvas .c2 -background white -width 400 -height 200
pack   .c .c2 -fill both -side top

#
# Set up a strip chart
#
set s [::Plotchart::createStripchart .c {0.0 100.0 10.0} {0.0 100.0 20.0}]

proc gendata {slipchart xold xd yold yd} {
   set xnew [expr {$xold+$xd}]
   set ynew [expr {$yold+(rand()-0.5)*$yd}]
   set ynew2 [expr {$yold+(rand()-0.5)*2.0*$yd}]
   $slipchart plot series1 $xnew $ynew
   $slipchart plot series2 $xnew $ynew2

   if { $xnew < 200 } {
   after 500 [list gendata $slipchart $xnew $xd $ynew $yd]
   }
}

after 100 [list gendata $s 0.0 15.0 50.0 30.0]

$s title "Aha!"

#
# Set up an isometric plot
#
set s [::Plotchart::createIsometricPlot .c2 {0.0 100.0} {0.0 200.0} noaxes]
::Plotchart::setZoomPan .c2
$s plot rectangle        10.0 10.0 50.0 50.0 green
$s plot filled-rectangle 20.0 20.0 40.0 40.0 red
$s plot filled-circle    70.0 70.0 40.0 yellow
$s plot circle           70.0 70.0 42.0

#
# Check the symbols
#
toplevel .h
canvas   .h.c -bg white -width 400 -height 200
pack     .h.c -fill both
set s [::Plotchart::createXYPlot .h.c {0.0 100.0 10.0} {0.0 100.0 20.0}]

$s dataconfig series1 -colour red   -type symbol
$s dataconfig series2 -colour green -type both

$s yconfig -format "%12.2e"

set x 5.0
foreach symbol {plus cross circle up down dot upfilled downfilled} {
   $s dataconfig series1 -symbol $symbol
   $s dataconfig series2 -symbol $symbol
   $s plot series1 $x 50.0
   $s plot series2 $x 20
   set x [expr {$x+10}]
}

#
# Second window: XY-plot with background and a Pareto plot
# Note:
# The data series is filled upwards, so that a white polygon
# hides the shading above the line. You need to let the
# series cover the whole axis, otherwise the effect is lost.
#
toplevel .t2
canvas .t2.c  -background white -width 400 -height 200
canvas .t2.c2 -background white -width 400 -height 200
pack .t2.c .t2.c2 -fill both

set s [::Plotchart::createXYPlot .t2.c {0.0 100.0 10.0} {0.0 100.0 20.0}]

$s background gradient green top-down

$s dataconfig series1 -filled up -fillcolour white

$s plot series1  0.0 20.0
$s plot series1 10.0 20.0
$s plot series1 30.0 50.0
$s plot series1 35.0 45.0
$s plot series1 45.0 25.0
$s plot series1 75.0 55.0
$s plot series1 100.0 55.0

$s plaintext 30.0 60.0 "Peak" south

set s2 [::Plotchart::createXYPlot .t2.c2 {0.0 100.0 10.0} {0.0 100.0 20.0}]

set image [image create photo bg -file [file join [file dirname [info script]] tcllogo.gif]]
$s2 background image $image

#$s2 dataconfig series1 -filled up -fillcolour white

$s2 plot series1  0.0 20.0
$s2 plot series1 10.0 20.0
$s2 plot series1 30.0 50.0
$s2 plot series1 35.0 45.0
$s2 plot series1 45.0 25.0
$s2 plot series1 75.0 55.0
$s2 plot series1 100.0 55.0

$s2 plaintext 30.0 60.0 "Peak" south

#
# Not ready for prime time
if { 0 } {
set s3 [::Plotchart::createBarchart .t2.c3 {{} "Type 1" "Type 2" "Type 3" } \
             {0.0 50.0 10.0} 1]

set s4 [::Plotchart::createRightAxis .t2.c3 {0.0 100.0 20.0}]

set data {0.0 20.0 5.0 30.0}
$s3 plot series1 {0.0 20.0 5.0 30.0} blue
$s4 plot series2  0.5  0.0
$s4 plot series2  1.5 20.0
$s4 plot series2  2.5  5.0
$s4 plot series2  2.5 30.0
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/plotchart/plotdemos3.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
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

package require Tcl 8.4
package require Tk

package require Plotchart

# plotdemos3.tcl --
#     Show a Gantt chart
#

canvas .c -width 500 -height 200 -bg white
pack   .c -fill both
.c delete all

set s [::Plotchart::createGanttchart .c "1 january 2004" \
        "31 december 2004" 4]

set from [$s task "Spring" "1 march 2004" "1 june 2004" 30]
set to   [$s task "Summer" "1 june 2004" "1 september 2004" 10]
$s summary "First half" $from $to
$s connect $from $to
$s vertline "1 jan" "1 january 2004"
$s vertline "1 apr" "1 april 2004"
$s vertline "1 jul" "1 july 2004"
$s vertline "1 oct" "1 october 2004"
$s milestone "Longest day" "21 july 2004"
$s title "Seasons (northern hemisphere)"

#
# Copy the thing:
# Should result in this configuration:
#  = =
#  =
toplevel .t
canvas   .t.c -width 700 -height 500
pack .t.c
::Plotchart::plotpack .t.c top $s $s
::Plotchart::plotpack .t.c left $s
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/plotchart/plotdemos4.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
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

package require Tcl 8.4
package require Tk

package require Plotchart

# plotdemos4.tcl --
#     Show a 3D bar chart
#

canvas .c  -width 400 -height 400 -bg white
toplevel .t
canvas .t.c2 -width 300 -height 200 -bg white
canvas .t.c3 -width 300 -height 200 -bg white
canvas .t.c4 -width 300 -height 200 -bg white
pack   .c -fill both
pack   .t.c2 .t.c3 .t.c4 -fill both

#
# 3D barchart
#
set s [::Plotchart::create3DBarchart .c {-200.0 900.0 100.0} 7]

foreach {bar value} {red 765 green 234 blue 345 yellow 321
                     magenta 567 cyan -123 white 400} {

    $s plot $bar $value $bar
}

$s title "3D Bars"

$s balloon 1.2 100 "Arrow pointing\nat second bar" south-east

#
# Three styles of radial charts
#
foreach {style canvas} {lines .t.c2 cumulative .t.c3 filled .t.c4} {
    set s [::Plotchart::createRadialchart $canvas {A B LongerName C D} 10.0 $style]

    $s plot {1 2 3 4 3} green 2
    $s plot {4 5 0 1 4} red   3

    $s title "Sample of a radial chart - style: $style"
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/plotchart/plotdemos5.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
#! /bin/sh
# the next line restarts with tclsh \
exec tclsh "$0" ${1+"$@"}

package require Tcl 8.4
package require Tk
package require Plotchart

# plotdemos5.tcl --
#     Contour and isoline plots
#
proc cowboyhat {x y} {
   set x1 [expr {$x/9.0}]
   set y1 [expr {$y/9.0}]

   expr { 3.0 * (1.0-($x1*$x1+$y1*$y1))*(1.0-($x1*$x1+$y1*$y1)) }
}


#
# Main code
#
set choice 1

if {$choice == 0} {

set x { {0.0 1.0 2.0 3.0}
        {0.0 1.0 2.0 3.0}
        {0.0 1.0 2.0 3.0}
        {0.0 1.0 2.0 3.0} }

set y { {0.0 0.0 0.0 0.0}
        {1.0 1.0 1.0 1.0}
        {2.0 2.0 2.0 2.0}
        {3.0 3.0 3.0 3.0} }


set f { {0.0 0.0 2.0 3.0}
        {0.0 0.0 2.0 3.0}
        {2.0 2.0 3.0 4.0}
        {3.0 3.0 4.0 5.0} }

set contours [list 1.0 2.0 3.0 4.0 5.0 ]

# set contours [list 1.0 1.3 1.6 2.0 2.3 2.6 3.0 3.3 3.6 4.0 4.3 4.6 5.0 5.3 ]

set xlimits {0 3.5 0.5}
set ylimits {0 3.5 0.5}

}


if {$choice == 1} {

set x { {0.0 100.0 200.0}
        {0.0 100.0 200.0}
        {0.0 100.0 200.0}
        {0.0 100.0 200.0}}
set y { {0.0   0.0   0.0}
       {30.0  30.0  30.0}
       {60.0  60.0  60.0}
       {90.0  90.0  90.0}}
set f { {0.0   1.0  10.0}
       { 0.0  30.0  30.0}
       {10.0  60.0  60.0}
       {30.0  90.0  90.0}}

set contours [list \
     0.0             \
     5.2631578947    \
     10.5263157895   \
     15.7894736842   \
     21.0526315789   \
     26.3157894737   \
     31.5789473684   \
     36.8421052632   \
     42.1052631579   \
     47.3684210526   \
     52.6315789474   \
     57.8947368421   \
     63.1578947368   \
     68.4210526316   \
     73.6842105263   \
     78.9473684211   \
     84.2105263158   \
     89.4736842105   \
     94.7368421053   \
     100.0           \
     105.263157895   \
              ]

 set xlimits {0 200 50}
 set ylimits {0 100 20}

}

########################################################################

wm title . "Contour Demo : shade (jet colormap)"

set c [canvas .c  -background white \
          -width 500 -height 500]

pack   $c  -fill both -side top

set chart [::Plotchart::createXYPlot $c $xlimits $ylimits]

::Plotchart::colorMap jet

#$chart contourlines $x $y $f $contours
$chart contourfill $x $y $f $contours
#$chart contourbox $x $y $f $contours
$chart grid $x $y

set t [toplevel .contourlines]
lappend windows $t
wm title $t "Contour Demo : contourlines (default colormap)"
set c [canvas $t.c  -background white \
          -width 500 -height 500]
pack   $c  -fill both -side top

set chart1 [::Plotchart::createXYPlot $c $xlimits $ylimits]
$chart1 grid $x $y
$chart1 contourlines $x $y $f $contours


set t [toplevel .hot]
lappend windows $t
wm title $t "Contour Demo : contourlines (hot colormap)"
set c [canvas $t.c  -background white \
          -width 500 -height 500]
pack   $c  -fill both -side top

set chart2 [::Plotchart::createXYPlot $c $xlimits $ylimits]
::Plotchart::colorMap hot
$chart2 contourfill $x $y $f $contours
$chart2 grid $x $y


set t [toplevel .gray]
lappend windows $t
wm title $t "Contour Demo : gray contourfill , jet contourlines"
set c [canvas $t.c  -background white \
          -width 500 -height 500]
pack   $c  -fill both -side top

set chart3 [::Plotchart::createXYPlot $c $xlimits $ylimits]
::Plotchart::colorMap gray
$chart3 contourfill $x $y $f $contours

::Plotchart::colorMap jet
$chart3 contourlines $x $y $f $contours
$chart3 grid $x $y


set t [toplevel .cool]
lappend windows $t
wm title $t "Contour Demo : contourlines (cool colormap)"
set c [canvas $t.c  -background white \
          -width 500 -height 500]
pack   $c  -fill both -side top

set chart4 [::Plotchart::createXYPlot $c $xlimits $ylimits]
::Plotchart::colorMap cool
$chart4 contourfill $x $y $f $contours
$chart4 grid $x $y



set t [toplevel .defcont]
lappend windows $t
wm title $t "Contour Demo : default contours (jet colormap)"
set c [canvas $t.c  -background white \
          -width 500 -height 500]
pack   $c  -fill both -side top

set chart5 [::Plotchart::createXYPlot $c $xlimits $ylimits]
::Plotchart::colorMap jet
$chart5 contourfill $x $y $f
$chart5 grid $x $y



set t [toplevel .3dcontour]
lappend windows $t
wm title $t "Contour Demo : contours on a 3DPlot"
set c [canvas $t.c  -background white \
          -width 500 -height 500]
pack   $c  -fill both -side top

set xlimits {-10. 10.  10.  }
set ylimits {-10. 10.  10.  }
set zlimits { -5. 10.   5.  }

set zmin   0.0
set zmax   3.0

set nc    51
set dz    [expr {($zmax - $zmin) / ($nc - 1)}]

set contours {}
for {set cnt 1} {$cnt < $nc} {incr cnt} {
    set zval [expr {$zmin + ($dz * ($cnt - 1))}]
    lappend contours $zval
}

set chart6 [::Plotchart::create3DPlot $c $xlimits $ylimits $zlimits]
::Plotchart::colorMap jet
$chart6 title "3D Plot"
$chart6 plotfuncont cowboyhat $contours
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/plotchart/plotdemos6.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
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

package require Tcl 8.4
package require Tk
package require Plotchart

# plotdemos6.tcl --
#    Test/demo program 6 for the Plotchart package
#

#
# Main code
# Note:
# The extremes and the canvas sizes are chosen so that the
# coordinate mapping is isometric!
#
#
canvas .c  -background white -width 400 -height 400
canvas .c2 -background white -width 400 -height 200
pack   .c .c2 -fill both -side top

set s [::Plotchart::createXYPlot .c {0.0 100.0 10.0} {0.0 100.0 20.0}]

$s vectorconfig series1 -colour "red"   -scale 40
$s vectorconfig series2 -colour "blue"  -scale 50 -type nautical -centred 1

#
# Cartesian
#
set data {1.0 0.0 0.0 1.0 0.5 0.5 -2.0 1.0}

set x 30.0
set y 20.0
foreach {u v} $data {
   $s vector series1 $x $y $u $v
}

#
# Nautical
#
set data {1.0 0.0 1.0 45.0 2.0 90.0}

set x 60.0
set y 40.0
foreach {length angle} $data {
   $s vector series2 $x $y $length $angle
}

set s2 [::Plotchart::createXYPlot .c2 {0.0 100.0 10.0} {0.0 100.0 20.0}]

$s2 dotconfig series1 -colour "red" -scalebyvalue 1 -scale 2.5
$s2 dotconfig series2 -colour "magenta" -classes {0 blue 1 green 2 yellow 3 red} \
    -scalebyvalue 0 -outline 0
$s2 dotconfig series3 -colour "magenta" -classes {0 blue 1 green 2 yellow 3 red} \
    -scalebyvalue 1 -scale 2.5

set y1 20
set y2 50
set y3 80
set x  10
foreach value {-1.0 0.5 1.5 2.5 3.5 4.5} {
    $s2 dot series1 $x $y1 $value
    $s2 dot series2 $x $y2 $value
    $s2 dot series3 $x $y3 $value
    set x [expr {$x + 10}]
}

#
# A more interesting vector plot: the forces in a dipole field
#
proc forcesDipole {x y} {
    set xd1 51.0
    set yd1 50.0
    set xd2 49.0
    set yd2 50.0

    set r1p3 [expr {pow(hypot($x-$xd1,$y-$yd1),3.0)}]
    set r2p3 [expr {pow(hypot($x-$xd2,$y-$yd2),3.0)}]

    set fx [expr {($x-$xd1)/$r1p3 - ($x-$xd2)/$r2p3}]
    set fy [expr {($y-$yd1)/$r1p3 - ($y-$yd2)/$r2p3}]

    return [list $fx $fy]
}

toplevel .dipole
canvas .dipole.c -background white -width 500 -height 500
pack   .dipole.c -fill both -side top

set s [::Plotchart::createXYPlot .dipole.c {45.0 55.0 1.0} {45.0 55.0 1.0}]

$s title "Forces in a dipole field"

$s vectorconfig series1 -colour "black" -scale 40 -type polar

$s dotconfig dipole -colour red -scalebyvalue 0 -radius 5
$s dot dipole 49.0 50.0 1.0
$s dot dipole 51.0 50.0 1.0

for {set y 45.25} {$y < 55.0} {set y [expr {$y+0.5}]} {
    for {set x 45.25} {$x < 55.0} {set x [expr {$x+0.5}]} {
        foreach {u v} [forcesDipole $x $y] {break}

        # Scale the vector for better display

        set angle  [expr {180.0*atan2($v,$u)/3.1415926}]
        set length [expr {(0.5+hypot($u,$v))/(1.0+hypot($u,$v))}]

        $s vector series1 $x $y $length $angle
    }
}

#
# Simple demonstration of an R-chart
#
toplevel .rchart
canvas .rchart.c -background white -width 400 -height 200
pack   .rchart.c -fill both -side top

set s [::Plotchart::createXYPlot .rchart.c {0.0 100.0 10.0} {0.0 50.0 10.0}]

$s title "R-chart (arbitrary data)"

$s dataconfig series1 -colour "green"

for {set x 1.0} {$x < 50.0} {set x [expr {$x+3.0}]} {
    set y [expr {20.0 + 3.0*rand()}]
    $s rchart series1 $x $y
}

#
# Now some data outside the expected range
#

$s rchart series1 50.0 41.0
$s rchart series1 52.0 42.0
$s rchart series1 54.0 39.0

#
# And continue with the well-behaved series
#
for {set x 57.0} {$x < 100.0} {set x [expr {$x+3.0}]} {
    set y [expr {20.0 + 3.0*rand()}]
    $s rchart series1 $x $y
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/plotchart/plotdemos7.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
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

# plotdemos7.tcl --
#     This test/demo script focuses on customising the plots
#

package require Tcl 8.4
package require Tk
package require Plotchart

# plotdemos7.tcl --
#    Test/demo program 7 for the Plotchart package
#

#
# Main code
#
canvas .c  -background white -width 400 -height 200
canvas .c2 -background white -width 400 -height 200
canvas .c3 -background white -width 400 -height 200
canvas .c4 -background white -width 400 -height 200
pack   .c .c2 .c3 .c4 -fill both -side top

toplevel .h
canvas .h.c  -background white -width 400 -height 200
canvas .h.c2 -background white -width 400 -height 200
pack   .h.c .h.c2 -fill both -side top

toplevel .v
canvas .v.c  -background white -width 400 -height 200
canvas .v.c2 -background white -width 400 -height 200
canvas .v.c3 -background white -width 400 -height 200
pack   .v.c .v.c2 .v.c3 -fill both -side top

::Plotchart::plotconfig xyplot title font "Times 14"
::Plotchart::plotconfig xyplot title textcolor "red"
::Plotchart::plotconfig xyplot leftaxis font "Helvetica 10 italic"
::Plotchart::plotconfig xyplot leftaxis thickness 2
::Plotchart::plotconfig xyplot leftaxis ticklength -5
::Plotchart::plotconfig xyplot rightaxis font "Times 10 bold"
::Plotchart::plotconfig xyplot rightaxis color green
::Plotchart::plotconfig xyplot rightaxis thickness 2
::Plotchart::plotconfig xyplot margin right 100

set s [::Plotchart::createXYPlot .c {0.0 100.0 10.0} {0.0 100.0 20.0}]
set r [::Plotchart::createRightAxis .c {0.0 0.1 0.01}]

set xd    5.0
set yd   20.0
set xold  0.0
set yold 50.0

$s dataconfig series1 -colour "red"
$s dataconfig series2 -colour "blue"
$s dataconfig series3 -colour "magenta"

for { set i 0 } { $i < 20 } { incr i } {
   set xnew [expr {$xold+$xd}]
   set ynew [expr {$yold+(rand()-0.5)*$yd}]
   set ynew2 [expr {$yold+(rand()-0.5)*2.0*$yd}]
   $s plot series1 $xnew $ynew
   $s plot series2 $xnew $ynew2
   $s trend series3 $xnew $ynew2
   set xold $xnew
   set yold $ynew
}

$s interval series2 50.0 40.0 60.0 52.0
$s interval series2 60.0 40.0 60.0

$s xtext "X-coordinate"
$s ytext "Y-data"
$r ytext "Right axis"
$s title "Aha!"

#
# Some data for the right axis
#
$r dataconfig right -type both -symbol circle -colour green
$r plot right 10.0 0.01
$r plot right 30.0 0.03
$r plot right 40.0 0.02

tkwait visibility .c
#$s saveplot "aha.ps"


set s [::Plotchart::createPiechart .c2]

$s plot {"Long names" 10 "Short names" 30 "Average" 40
         "Ultra-short names" 5}
#
# Note: title should be shifted up
#       - distinguish a separate title area
#
$s title "Okay - this works"



set s [::Plotchart::createPolarplot .c3 {3.0 1.0}]

for { set angle 0 } { $angle < 360.0 } { set angle [expr {$angle+10.0}] } {
   set rad [expr {1.0+cos($angle*$::Plotchart::torad)}]
   $s plot "cardioid" $rad $angle
}

$s title "Cardioid"


set s [::Plotchart::createBarchart .h.c {A B C D E} {0.0 10.0 2.0} 2.5]

$s legend series1 "Series 1"
$s legend series2 "Series 2"

$s plot series1 {1.0 4.0 6.0 1.0 7.0} red
$s plot series2 {0.0 3.0 7.0 9.3 2.0} green
$s title "Arbitrary data"


set s [::Plotchart::createBarchart .h.c2 {A B C D E} {0.0 20.0 5.0} stacked]

$s plot series1 {1.0 4.0 6.0 1.0 7.0} red
$s plot series2 {0.0 3.0 7.0 9.3 2.0} green
$s title "Stacked diagram"



::Plotchart::plotconfig horizbars leftaxis font "Helvetica 10 italic"
::Plotchart::plotconfig horizbars background outercolor steelblue3
::Plotchart::plotconfig horizbars bottomaxis ticklength -5

set s [::Plotchart::createHorizontalBarchart .v.c {0.0 10.0 2.0} \
         {Antarctica Eurasia "The Americas" "Australia and Oceania" Ocean} 2]

$s plot series1 {1.0 4.0 6.0 1.0 7.0} red left-right
$s plot series2 {0.0 3.0 7.0 9.3 2.0} green right-left
$s title "Arbitrary data"


set s [::Plotchart::createHorizontalBarchart .v.c2 {0.0 20.0 5.0} {A B C D E} stacked]

$s plot series1 {1.0 4.0 6.0 1.0 7.0} red left-right
$s plot series2 {0.0 3.0 7.0 9.3 2.0} green
$s title "Stacked diagram"


set s [::Plotchart::createTimechart .v.c3 "1 january 2004" \
                                          "31 december 2004" 4]

$s period "Spring" "1 march 2004" "1 june 2004" green
$s period "Summer" "1 june 2004" "1 september 2004" yellow
$s vertline "1 jan" "1 january 2004"
$s vertline "1 apr" "1 april 2004"
$s vertline "1 jul" "1 july 2004"
$s vertline "1 oct" "1 october 2004"
$s milestone "Longest day" "21 july 2004"
$s title "Seasons (northern hemisphere)"

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
































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/plotchart/plotdemos8.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
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

package require Tcl 8.4
package require Tk

package require Plotchart


# plotdemos8.tcl --
#     Demonstration of a boxplot
#
pack [canvas .c] -fill both -side top

set p [::Plotchart::createBoxplot .c {0 40 5} {A B C D E F}]

$p plot A {0 1 2 5 7 1 4 5 0.6 5 5.5}
$p plot C {2 2 3 6 1.5 3}

$p plot E {2 3 3 4 7 8 9 9 10 10 11 11 11 14 15 17 17 20 24 29}

#
# Demonstration of selected x labels - for version 1.6.2
#
if {0} {
set s [::Plotchart::createXYPlot .c2 {1990 2050 {}} {0.0 100.0 20.0} \
    -xlabels {1990 2020 2030 2050}]

$s xconfig -format "%.0f"

foreach {x y} {1990 32.0 2025 50.0 2030 60.0 2050 11.0 } {
    $s plot series1 $x $y
}

$s title "Data series"
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/plotchart/tcllogo.gif.

cannot compute difference between binary files

Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/browse.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
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
#==============================================================================
# Demonstrates how to implement a tablelist widget for displaying information
# about the children of an arbitrary widget.
#
# Copyright (c) 2000-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist

namespace eval demo {
    variable dir [file dirname [info script]]

    #
    # Create two images, needed in the procedure putChildren
    #
    variable leafImg [image create bitmap -file [file join $dir leaf.xbm] \
		      -background coral -foreground gray50]
    variable compImg [image create bitmap -file [file join $dir comp.xbm] \
		      -background yellow -foreground gray50]
}

source [file join $demo::dir config.tcl]

#------------------------------------------------------------------------------
# demo::displayChildren
#
# Displays information on the children of the widget w in a tablelist widget
# contained in a newly created top-level widget.  Returns the name of the
# tablelist widget.
#------------------------------------------------------------------------------
proc demo::displayChildren w {
    if {![winfo exists $w]} {
	bell
	tk_messageBox -icon error -message "Bad window path name \"$w\"" \
		      -type ok
	return ""
    }

    #
    # Create a top-level widget of the class DemoTop
    #
    set top .browseTop
    for {set n 2} {[winfo exists $top]} {incr n} {
	set top .browseTop$n
    }
    toplevel $top -class DemoTop

    #
    # Create a vertically scrolled tablelist widget with 9 dynamic-width
    # columns and interactive sort capability within the top-level
    #
    set tf $top.tf
    frame $tf
    set tbl $tf.tbl
    set vsb $tf.vsb
    tablelist::tablelist $tbl \
	-columns {0 "Path Name"	left
		  0 "Class"	left
		  0 "X"		right
		  0 "Y"		right
		  0 "Width"	right
		  0 "Height"	right
		  0 "Mapped"	center
		  0 "Viewable"	center
		  0 "Manager"	left} \
	-labelcommand demo::labelCmd -yscrollcommand [list $vsb set] -width 0
    if {[$tbl cget -selectborderwidth] == 0} {
	$tbl configure -spacing 1
    }
    foreach col {2 3 4 5} {
	$tbl columnconfigure $col -sortmode integer
    }
    foreach col {6 7} {
	$tbl columnconfigure $col -formatcommand demo::formatBoolean
    }
    scrollbar $vsb -orient vertical -command [list $tbl yview]

    #
    # When displaying the information about the children of any
    # ancestor of the label widgets, the widths of some of the
    # labels and thus also the widths and x coordinates of some
    # children may change.  For this reason, make sure the items
    # will be updated after any change in the sizes of the labels
    #
    foreach l [$tbl labels] {
	bind $l <Configure> [list demo::updateItemsDelayed $tbl]
    }
    bind $tbl <Configure> [list demo::updateItemsDelayed $tbl]

    #
    # Create a pop-up menu with two command entries; bind the script
    # associated with its first entry to the <Double-1> event, too
    #
    set menu $top.menu
    menu $menu -tearoff no
    $menu add command -label "Display children" \
		      -command [list demo::putChildrenOfSelWidget $tbl]
    $menu add command -label "Display config" \
		      -command [list demo::dispConfigOfSelWidget $tbl]
    set bodyTag [$tbl bodytag]
    bind $bodyTag <<Button3>>  [bind TablelistBody <Button-1>]
    bind $bodyTag <<Button3>> +[bind TablelistBody <ButtonRelease-1>]
    bind $bodyTag <<Button3>> +[list demo::postPopupMenu $top %X %Y]
    bind $bodyTag <Double-1>   [list demo::putChildrenOfSelWidget $tbl]

    #
    # Create three buttons within a frame child of the top-level widget
    #
    set bf $top.bf
    frame $bf
    set b1 $bf.b1
    set b2 $bf.b2
    set b3 $bf.b3
    button $b1 -text "Refresh"
    button $b2 -text "Parent"
    button $b3 -text "Close" -command [list destroy $top]

    #
    # Manage the widgets
    #
    grid $tbl -row 0 -column 0 -sticky news
    grid $vsb -row 0 -column 1 -sticky ns
    grid rowconfigure    $tf 0 -weight 1
    grid columnconfigure $tf 0 -weight 1
    pack $b1 $b2 $b3 -side left -expand yes -pady 10
    pack $bf -side bottom -fill x
    pack $tf -side top -expand yes -fill both

    #
    # Populate the tablelist with the data of the given widget's children
    #
    putChildren $w $tbl
    return $tbl
}

#------------------------------------------------------------------------------
# demo::putChildren
#
# Outputs the data of the children of the widget w into the tablelist widget
# tbl.
#------------------------------------------------------------------------------
proc demo::putChildren {w tbl} {
    #
    # The following check is necessary because this procedure
    # is also invoked by the "Refresh" and "Parent" buttons
    #
    if {![winfo exists $w]} {
	bell
	set choice [tk_messageBox -default ok -icon warning \
		    -message "Bad window path name \"$w\" -- replacing\
			      it with nearest existent ancestor" \
		    -parent [winfo toplevel $tbl] -type okcancel]
	if {[string compare $choice "ok"] == 0} {
	    while {![winfo exists $w]} {
		set last [string last "." $w]
		if {$last != 0} {
		    incr last -1
		}
		set w [string range $w 0 $last]
	    }
	} else {
	    return ""
	}
    }

    set top [winfo toplevel $tbl]
    wm title $top "Children of the [winfo class $w] Widget \"$w\""

    #
    # Display the data of the children of the
    # widget w in the tablelist widget tbl
    #
    variable leafImg
    variable compImg
    $tbl resetsortinfo
    $tbl delete 0 end
    foreach c [winfo children $w] {
	#
	# Insert the data of the current child into the tablelist widget
	#
	set item {}
	lappend item $c [winfo class $c] [winfo x $c] [winfo y $c] \
		     [winfo width $c] [winfo height $c] [winfo ismapped $c] \
		     [winfo viewable $c] [winfo manager $c]
	$tbl insert end $item

	#
	# Insert an image into the first cell of the row
	#
	if {[llength [winfo children $c]] == 0} {
	    $tbl cellconfigure end,0 -image $leafImg
	} else {
	    $tbl cellconfigure end,0 -image $compImg
	}
    }

    #
    # Configure the "Refresh" and "Parent" buttons
    #
    $top.bf.b1 configure -command [list demo::putChildren $w $tbl]
    set b2 $top.bf.b2
    set p [winfo parent $w]
    if {[string compare $p ""] == 0} {
	$b2 configure -state disabled
    } else {
	$b2 configure -state normal -command [list demo::putChildren $p $tbl]
    }
}

#------------------------------------------------------------------------------
# demo::formatBoolean
#
# Returns "yes" or "no", according to the specified boolean value.
#------------------------------------------------------------------------------
proc demo::formatBoolean val {
    return [expr {$val ? "yes" : "no"}]
}

#------------------------------------------------------------------------------
# demo::labelCmd
#
# Sorts the contents of the tablelist widget tbl by its col'th column and makes
# sure the items will be updated 500 ms later (because one of the items might
# refer to a canvas containing the arrow that displays the sort order).
#------------------------------------------------------------------------------
proc demo::labelCmd {tbl col} {
    tablelist::sortByColumn $tbl $col
    updateItemsDelayed $tbl
}

#------------------------------------------------------------------------------
# demo::updateItemsDelayed
#
# Arranges for the items of the tablelist widget tbl to be updated 500 ms later.
#------------------------------------------------------------------------------
proc demo::updateItemsDelayed tbl {
    #
    # Schedule the demo::updateItems command for execution
    # 500 ms later, but only if it is not yet pending
    #
    if {[string compare [$tbl attrib afterId] ""] == 0} {
	$tbl attrib afterId [after 500 [list demo::updateItems $tbl]]
    }
}

#------------------------------------------------------------------------------
# demo::updateItems
#
# Updates the items of the tablelist widget tbl.
#------------------------------------------------------------------------------
proc demo::updateItems tbl {
    #
    # Reset the tablelist's "afterId" attribute
    #
    $tbl attrib afterId ""

    #
    # Update the items
    #
    set rowCount [$tbl size]
    for {set row 0} {$row < $rowCount} {incr row} {
	set c [$tbl cellcget $row,0 -text]
	if {![winfo exists $c]} {
	    continue
	}

	set item {}
	lappend item $c [winfo class $c] [winfo x $c] [winfo y $c] \
		     [winfo width $c] [winfo height $c] [winfo ismapped $c] \
		     [winfo viewable $c] [winfo manager $c]
	$tbl rowconfigure $row -text $item
    }

    #
    # Repeat the last sort operation
    #
    if {[set sortCol [$tbl sortcolumn]] >= 0} {
	$tbl sortbycolumn $sortCol -[$tbl sortorder]
    }
}

#------------------------------------------------------------------------------
# demo::putChildrenOfSelWidget
#
# Outputs the data of the children of the selected widget into the tablelist
# widget tbl.
#------------------------------------------------------------------------------
proc demo::putChildrenOfSelWidget tbl {
    set w [$tbl cellcget [$tbl curselection],0 -text]
    if {![winfo exists $w]} {
	bell
	tk_messageBox -icon error -message "Bad window path name \"$w\"" \
		      -parent [winfo toplevel $tbl] -type ok
	return ""
    }

    if {[llength [winfo children $w]] == 0} {
	bell
    } else {
	putChildren $w $tbl
    }
}

#------------------------------------------------------------------------------
# demo::dispConfigOfSelWidget
#
# Displays the configuration options of the selected widget within the
# tablelist tbl in a tablelist widget contained in a newly created top-level
# widget.
#------------------------------------------------------------------------------
proc demo::dispConfigOfSelWidget tbl {
    demo::displayConfig [$tbl cellcget [$tbl curselection],0 -text]
}

#------------------------------------------------------------------------------
# demo::postPopupMenu
#
# Posts the pop-up menu $top.menu at the given screen position.  Before posting
# the menu, the procedure enables/disables its first entry, depending upon
# whether the selected widget has children or not.
#------------------------------------------------------------------------------
proc demo::postPopupMenu {top rootX rootY} {
    set tbl $top.tf.tbl
    set w [$tbl cellcget [$tbl curselection],0 -text]
    if {![winfo exists $w]} {
	bell
	tk_messageBox -icon error -message "Bad window path name \"$w\"" \
		      -parent $top -type ok
	return ""
    }

    set menu $top.menu
    if {[llength [winfo children $w]] == 0} {
	$menu entryconfigure 0 -state disabled
    } else {
	$menu entryconfigure 0 -state normal
    }

    tk_popup $menu $rootX $rootY
}

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

if {$tcl_interactive} {
    return "\nTo display information about the children of an arbitrary\
	    widget, enter\n\n\tdemo::displayChildren <widgetName>\n"
} else {
    wm withdraw .
    tk_messageBox -icon warning -title $argv0 -type ok -message \
	"Please source this script into\nan interactive wish session"
    exit 1
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/browse_tile.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
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
#==============================================================================
# Demonstrates how to implement a tablelist widget for displaying information
# about the children of an arbitrary widget.
#
# Copyright (c) 2000-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist_tile

namespace eval demo {
    variable dir [file dirname [info script]]

    #
    # Create two images, needed in the procedure putChildren
    #
    variable leafImg [image create bitmap -file [file join $dir leaf.xbm] \
		      -background coral -foreground gray50]
    variable compImg [image create bitmap -file [file join $dir comp.xbm] \
		      -background yellow -foreground gray50]
}

source [file join $demo::dir config_tile.tcl]

#
# Work around the improper appearance of the tile scrollbars in the aqua theme
#
if {[tablelist::getCurrentTheme] eq "aqua"} {
    interp alias {} ttk::scrollbar {} ::scrollbar
}

#------------------------------------------------------------------------------
# demo::displayChildren
#
# Displays information on the children of the widget w in a tablelist widget
# contained in a newly created top-level widget.  Returns the name of the
# tablelist widget.
#------------------------------------------------------------------------------
proc demo::displayChildren w {
    if {![winfo exists $w]} {
	bell
	tk_messageBox -icon error -message "Bad window path name \"$w\"" \
		      -type ok
	return ""
    }

    #
    # Create a top-level widget of the class DemoTop
    #
    set top .browseTop
    for {set n 2} {[winfo exists $top]} {incr n} {
	set top .browseTop$n
    }
    toplevel $top -class DemoTop

    #
    # Create a vertically scrolled tablelist widget with 9 dynamic-width
    # columns and interactive sort capability within the top-level
    #
    set tf $top.tf
    ttk::frame $tf
    set tbl $tf.tbl
    set vsb $tf.vsb
    tablelist::tablelist $tbl \
	-columns {0 "Path Name"	left
		  0 "Class"	left
		  0 "X"		right
		  0 "Y"		right
		  0 "Width"	right
		  0 "Height"	right
		  0 "Mapped"	center
		  0 "Viewable"	center
		  0 "Manager"	left} \
	-labelcommand demo::labelCmd -yscrollcommand [list $vsb set] -width 0
    if {[$tbl cget -selectborderwidth] == 0} {
	$tbl configure -spacing 1
    }
    foreach col {2 3 4 5} {
	$tbl columnconfigure $col -sortmode integer
    }
    foreach col {6 7} {
	$tbl columnconfigure $col -formatcommand demo::formatBoolean
    }
    ttk::scrollbar $vsb -orient vertical -command [list $tbl yview]

    #
    # When displaying the information about the children of any
    # ancestor of the label widgets, the widths of some of the
    # labels and thus also the widths and x coordinates of some
    # children may change.  For this reason, make sure the items
    # will be updated after any change in the sizes of the labels
    #
    foreach l [$tbl labels] {
	bind $l <Configure> [list demo::updateItemsDelayed $tbl]
    }
    bind $tbl <Configure> [list demo::updateItemsDelayed $tbl]

    #
    # Create a pop-up menu with two command entries; bind the script
    # associated with its first entry to the <Double-1> event, too
    #
    set menu $top.menu
    menu $menu -tearoff no
    $menu add command -label "Display children" \
		      -command [list demo::putChildrenOfSelWidget $tbl]
    $menu add command -label "Display config" \
		      -command [list demo::dispConfigOfSelWidget $tbl]
    set bodyTag [$tbl bodytag]
    bind $bodyTag <<Button3>>  [bind TablelistBody <Button-1>]
    bind $bodyTag <<Button3>> +[bind TablelistBody <ButtonRelease-1>]
    bind $bodyTag <<Button3>> +[list demo::postPopupMenu $top %X %Y]
    bind $bodyTag <Double-1>   [list demo::putChildrenOfSelWidget $tbl]

    #
    # Create three buttons within a tile frame child of the top-level widget
    #
    set bf $top.bf
    ttk::frame $bf
    set b1 $bf.b1
    set b2 $bf.b2
    set b3 $bf.b3
    ttk::button $b1 -text "Refresh"
    ttk::button $b2 -text "Parent"
    ttk::button $b3 -text "Close" -command [list destroy $top]

    #
    # Manage the widgets
    #
    grid $tbl -row 0 -column 0 -sticky news
    grid $vsb -row 0 -column 1 -sticky ns
    grid rowconfigure    $tf 0 -weight 1
    grid columnconfigure $tf 0 -weight 1
    pack $b1 $b2 $b3 -side left -expand yes -pady 10
    pack $bf -side bottom -fill x
    pack $tf -side top -expand yes -fill both

    #
    # Populate the tablelist with the data of the given widget's children
    #
    putChildren $w $tbl
    return $tbl
}

#------------------------------------------------------------------------------
# demo::putChildren
#
# Outputs the data of the children of the widget w into the tablelist widget
# tbl.
#------------------------------------------------------------------------------
proc demo::putChildren {w tbl} {
    #
    # The following check is necessary because this procedure
    # is also invoked by the "Refresh" and "Parent" buttons
    #
    if {![winfo exists $w]} {
	bell
	set choice [tk_messageBox -default ok -icon warning \
		    -message "Bad window path name \"$w\" -- replacing\
			      it with nearest existent ancestor" \
		    -parent [winfo toplevel $tbl] -type okcancel]
	if {[string compare $choice "ok"] == 0} {
	    while {![winfo exists $w]} {
		set last [string last "." $w]
		if {$last != 0} {
		    incr last -1
		}
		set w [string range $w 0 $last]
	    }
	} else {
	    return ""
	}
    }

    set top [winfo toplevel $tbl]
    wm title $top "Children of the [winfo class $w] Widget \"$w\""

    #
    # Display the data of the children of the
    # widget w in the tablelist widget tbl
    #
    variable leafImg
    variable compImg
    $tbl resetsortinfo
    $tbl delete 0 end
    foreach c [winfo children $w] {
	#
	# Insert the data of the current child into the tablelist widget
	#
	set item {}
	lappend item $c [winfo class $c] [winfo x $c] [winfo y $c] \
		     [winfo width $c] [winfo height $c] [winfo ismapped $c] \
		     [winfo viewable $c] [winfo manager $c]
	$tbl insert end $item

	#
	# Insert an image into the first cell of the row
	#
	if {[llength [winfo children $c]] == 0} {
	    $tbl cellconfigure end,0 -image $leafImg
	} else {
	    $tbl cellconfigure end,0 -image $compImg
	}
    }

    #
    # Configure the "Refresh" and "Parent" buttons
    #
    $top.bf.b1 configure -command [list demo::putChildren $w $tbl]
    set b2 $top.bf.b2
    set p [winfo parent $w]
    if {[string compare $p ""] == 0} {
	$b2 configure -state disabled
    } else {
	$b2 configure -state normal -command [list demo::putChildren $p $tbl]
    }
}

#------------------------------------------------------------------------------
# demo::formatBoolean
#
# Returns "yes" or "no", according to the specified boolean value.
#------------------------------------------------------------------------------
proc demo::formatBoolean val {
    return [expr {$val ? "yes" : "no"}]
}

#------------------------------------------------------------------------------
# demo::labelCmd
#
# Sorts the contents of the tablelist widget tbl by its col'th column and makes
# sure the items will be updated 500 ms later (because one of the items might
# refer to a canvas containing the arrow that displays the sort order).
#------------------------------------------------------------------------------
proc demo::labelCmd {tbl col} {
    tablelist::sortByColumn $tbl $col
    updateItemsDelayed $tbl
}

#------------------------------------------------------------------------------
# demo::updateItemsDelayed
#
# Arranges for the items of the tablelist widget tbl to be updated 500 ms later.
#------------------------------------------------------------------------------
proc demo::updateItemsDelayed tbl {
    #
    # Schedule the demo::updateItems command for execution
    # 500 ms later, but only if it is not yet pending
    #
    if {[string compare [$tbl attrib afterId] ""] == 0} {
	$tbl attrib afterId [after 500 [list demo::updateItems $tbl]]
    }
}

#------------------------------------------------------------------------------
# demo::updateItems
#
# Updates the items of the tablelist widget tbl.
#------------------------------------------------------------------------------
proc demo::updateItems tbl {
    #
    # Reset the tablelist's "afterId" attribute
    #
    $tbl attrib afterId ""

    #
    # Update the items
    #
    set rowCount [$tbl size]
    for {set row 0} {$row < $rowCount} {incr row} {
	set c [$tbl cellcget $row,0 -text]
	if {![winfo exists $c]} {
	    continue
	}

	set item {}
	lappend item $c [winfo class $c] [winfo x $c] [winfo y $c] \
		     [winfo width $c] [winfo height $c] [winfo ismapped $c] \
		     [winfo viewable $c] [winfo manager $c]
	$tbl rowconfigure $row -text $item
    }

    #
    # Repeat the last sort operation
    #
    if {[set sortCol [$tbl sortcolumn]] >= 0} {
	$tbl sortbycolumn $sortCol -[$tbl sortorder]
    }
}

#------------------------------------------------------------------------------
# demo::putChildrenOfSelWidget
#
# Outputs the data of the children of the selected widget into the tablelist
# widget tbl.
#------------------------------------------------------------------------------
proc demo::putChildrenOfSelWidget tbl {
    set w [$tbl cellcget [$tbl curselection],0 -text]
    if {![winfo exists $w]} {
	bell
	tk_messageBox -icon error -message "Bad window path name \"$w\"" \
		      -parent [winfo toplevel $tbl] -type ok
	return ""
    }

    if {[llength [winfo children $w]] == 0} {
	bell
    } else {
	putChildren $w $tbl
    }
}

#------------------------------------------------------------------------------
# demo::dispConfigOfSelWidget
#
# Displays the configuration options of the selected widget within the
# tablelist tbl in a tablelist widget contained in a newly created top-level
# widget.
#------------------------------------------------------------------------------
proc demo::dispConfigOfSelWidget tbl {
    demo::displayConfig [$tbl cellcget [$tbl curselection],0 -text]
}

#------------------------------------------------------------------------------
# demo::postPopupMenu
#
# Posts the pop-up menu $top.menu at the given screen position.  Before posting
# the menu, the procedure enables/disables its first entry, depending upon
# whether the selected widget has children or not.
#------------------------------------------------------------------------------
proc demo::postPopupMenu {top rootX rootY} {
    set tbl $top.tf.tbl
    set w [$tbl cellcget [$tbl curselection],0 -text]
    if {![winfo exists $w]} {
	bell
	tk_messageBox -icon error -message "Bad window path name \"$w\"" \
		      -parent $top -type ok
	return ""
    }

    set menu $top.menu
    if {[llength [winfo children $w]] == 0} {
	$menu entryconfigure 0 -state disabled
    } else {
	$menu entryconfigure 0 -state normal
    }

    tk_popup $menu $rootX $rootY
}

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

if {$tcl_interactive} {
    return "\nTo display information about the children of an arbitrary\
	    widget, enter\n\n\tdemo::displayChildren <widgetName>\n"
} else {
    wm withdraw .
    tk_messageBox -icon warning -title $argv0 -type ok -message \
	"Please source this script into\nan interactive wish session"
    exit 1
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/bwidget.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates the interactive tablelist cell editing with the aid of some
# widgets from the BWidget package and of the Tk core checkbutton widget.
#
# Copyright (c) 2004-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require Tk 8.3				;# because of entry validation
package require tablelist
package require BWidget

wm title . "Serial Line Configuration"

#
# Add some entries to the Tk option database
#
set dir [file dirname [info script]]
source [file join $dir option.tcl]
option add *Tablelist*Checkbutton.background		white
option add *Tablelist*Checkbutton.activeBackground	white
option add *Tablelist*Entry.background			white

#
# Register some widgets from the BWidget package for interactive cell editing
#
tablelist::addBWidgetEntry
tablelist::addBWidgetSpinBox
tablelist::addBWidgetComboBox

#
# Create two images, to be displayed in tablelist cells with boolean values
#
set checkedImg   [image create photo -file [file join $dir checked.gif]]
set uncheckedImg [image create photo -file [file join $dir unchecked.gif]]

#
# Create a tablelist widget with editable columns (except the first one)
#
set tbl .tbl
tablelist::tablelist $tbl \
    -columns {0 "No."		  right
	      0 "Available"	  center
	      0 "Name"		  left
	      0 "Baud Rate"	  right
	      0 "Data Bits"	  center
	      0 "Parity"	  left
	      0 "Stop Bits"	  center
	      0 "Handshake"	  left
	      0 "Activation Date" center
	      0 "Activation Time" center} \
    -editstartcommand editStartCmd -editendcommand editEndCmd \
    -height 0 -width 0
if {[$tbl cget -selectborderwidth] == 0} {
    $tbl configure -spacing 1
}
$tbl columnconfigure 0 -sortmode integer
$tbl columnconfigure 1 -name available -editable yes -editwindow checkbutton \
    -formatcommand emptyStr
$tbl columnconfigure 2 -name lineName  -editable yes -editwindow Entry \
    -sortmode dictionary
$tbl columnconfigure 3 -name baudRate  -editable yes -editwindow ComboBox \
    -sortmode integer
$tbl columnconfigure 4 -name dataBits  -editable yes -editwindow SpinBox
$tbl columnconfigure 5 -name parity    -editable yes -editwindow ComboBox
$tbl columnconfigure 6 -name stopBits  -editable yes -editwindow ComboBox
$tbl columnconfigure 7 -name handshake -editable yes -editwindow ComboBox
$tbl columnconfigure 8 -name actDate   -editable yes -editwindow Entry \
    -formatcommand formatDate -sortmode integer
$tbl columnconfigure 9 -name actTime   -editable yes -editwindow Entry \
    -formatcommand formatTime -sortmode integer

proc emptyStr   val { return "" }
proc formatDate val { return [clock format $val -format "%Y-%m-%d"] }
proc formatTime val { return [clock format $val -format "%H:%M:%S"] }

#
# Populate the tablelist widget; set the activation
# date & time to 10 minutes past the current clock value
#
set clock [clock seconds]
incr clock 600
for {set n 1} {$n <= 8} {incr n} {
    $tbl insert end [list $n 1 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $checkedImg
}
for {set n 9} {$n <= 16} {incr n} {
    $tbl insert end [list $n 0 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $uncheckedImg
}

set btn [button .btn -text "Close" -command exit]

#
# Manage the widgets
#
pack $btn -side bottom -pady 10
pack $tbl -side top -expand yes -fill both

#------------------------------------------------------------------------------
# editStartCmd
#
# Applies some configuration options to the edit window; if the latter is a
# ComboBox, the procedure populates it.
#------------------------------------------------------------------------------
proc editStartCmd {tbl row col text} {
    set w [$tbl editwinpath]

    switch [$tbl columncget $col -name] {
	lineName {
	    #
	    # Set an upper limit of 20 for the number of characters
	    #
	    $w configure -invalidcommand bell -validate key \
			 -validatecommand {expr {[string length %P] <= 20}}
	}

	baudRate {
	    #
	    # Populate the ComboBox and allow no more
	    # than 6 digits in its Entry component
	    #
	    $w configure -values {50 75 110 300 1200 2400 4800 9600 19200 38400
				  57600 115200 230400 460800 921600}
	    $w configure -invalidcommand bell -validate key -validatecommand \
		{expr {[string length %P] <= 6 && [regexp {^[0-9]*$} %S]}}
	}

	dataBits {
	    #
	    # Configure the SpinBox
	    #
	    $w configure -range {5 8 1} -editable no
	}

	parity {
	    #
	    # Populate the ComboBox and make it non-editable
	    #
	    $w configure -values {None Even Odd Mark Space} -editable no
	}

	stopBits {
	    #
	    # Populate the ComboBox and make it non-editable
	    #
	    $w configure -values {1 1.5 2} -editable no
	}

	handshake {
	    #
	    # Populate the ComboBox and make it non-editable
	    #
	    $w configure -values {XON/XOFF RTS/CTS None} -editable no
	}

	actDate {
	    #
	    # Set an upper limit of 10 for the number of characters
	    # and allow only digits and the "-" character in it
	    #
	    $w configure -invalidcommand bell -validate key -validatecommand \
		{expr {[string length %P] <= 10 && [regexp {^[0-9-]*$} %S]}}
	}

	actTime {
	    #
	    # Set an upper limit of 8 for the number of characters
	    # and allow only digits and the ":" character in it
	    #
	    $w configure -invalidcommand bell -validate key -validatecommand \
		{expr {[string length %P] <= 8 && [regexp {^[0-9:]*$} %S]}}
	}
    }

    return $text
}

#------------------------------------------------------------------------------
# editEndCmd
#
# Performs a final validation of the text contained in the edit window and gets
# the cell's internal contents.
#------------------------------------------------------------------------------
proc editEndCmd {tbl row col text} {
    switch [$tbl columncget $col -name] {
	available {
	    #
	    # Update the image contained in the cell
	    #
	    set img [expr {$text ? $::checkedImg : $::uncheckedImg}]
	    $tbl cellconfigure $row,$col -image $img
	}

	baudRate {
	    #
	    # Check whether the baud rate is an integer in the range 50..921600
	    #
	    if {![regexp {^[0-9]+$} $text] || $text < 50 || $text > 921600} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The baud rate must be an integer in the range 50..921600"
		$tbl rejectinput
	    }
	}

	actDate {
	    #
	    # Get the activation date in seconds from the last argument 
	    #
	    if {[catch {clock scan $text} actDate] != 0} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "Invalid date"
		$tbl rejectinput
		return ""
	    }

	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actTime [$tbl cellcget $row,actTime -text]
	    set actClock [clock scan [formatTime $actTime] -base $actDate]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actTime -text $actClock
		return $actClock
	    }
	}

	actTime {
	    #
	    # Get the activation clock value in seconds from the last argument 
	    #
	    set actDate [$tbl cellcget $row,actDate -text]
	    if {[catch {clock scan $text -base $actDate} actClock] != 0} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "Invalid time"
		$tbl rejectinput
		return ""
	    }

	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actDate -text $actClock
		return $actClock
	    }
	}
    }

    return $text
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/bwidget_tile.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates the interactive tablelist cell editing with the aid of some
# widgets from the BWidget package and of the Tk core checkbutton widget.
#
# Copyright (c) 2004-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist_tile
package require BWidget

wm title . "Serial Line Configuration"

#
# Add some entries to the Tk option database
#
set dir [file dirname [info script]]
source [file join $dir option_tile.tcl]
option add *Tablelist*Checkbutton.background		white
option add *Tablelist*Checkbutton.activeBackground	white
option add *Tablelist*Entry.background			white

#
# Register some widgets from the BWidget package for interactive cell editing
#
tablelist::addBWidgetEntry
tablelist::addBWidgetSpinBox
tablelist::addBWidgetComboBox

#
# Create two images, to be displayed in tablelist cells with boolean values
#
set checkedImg   [image create photo -file [file join $dir checked.gif]]
set uncheckedImg [image create photo -file [file join $dir unchecked.gif]]

#
# Improve the window's appearance by using a tile
# frame as a container for the other widgets
#
set f [ttk::frame .f]

#
# Create a tablelist widget with editable columns (except the first one)
#
set tbl $f.tbl
tablelist::tablelist $tbl \
    -columns {0 "No."		  right
	      0 "Available"	  center
	      0 "Name"		  left
	      0 "Baud Rate"	  right
	      0 "Data Bits"	  center
	      0 "Parity"	  left
	      0 "Stop Bits"	  center
	      0 "Handshake"	  left
	      0 "Activation Date" center
	      0 "Activation Time" center} \
    -editstartcommand editStartCmd -editendcommand editEndCmd \
    -height 0 -width 0
if {[$tbl cget -selectborderwidth] == 0} {
    $tbl configure -spacing 1
}
$tbl columnconfigure 0 -sortmode integer
$tbl columnconfigure 1 -name available -editable yes -editwindow checkbutton \
    -formatcommand emptyStr
$tbl columnconfigure 2 -name lineName  -editable yes -editwindow Entry \
    -sortmode dictionary
$tbl columnconfigure 3 -name baudRate  -editable yes -editwindow ComboBox \
    -sortmode integer
$tbl columnconfigure 4 -name dataBits  -editable yes -editwindow SpinBox
$tbl columnconfigure 5 -name parity    -editable yes -editwindow ComboBox
$tbl columnconfigure 6 -name stopBits  -editable yes -editwindow ComboBox
$tbl columnconfigure 7 -name handshake -editable yes -editwindow ComboBox
$tbl columnconfigure 8 -name actDate   -editable yes -editwindow Entry \
    -formatcommand formatDate -sortmode integer
$tbl columnconfigure 9 -name actTime   -editable yes -editwindow Entry \
    -formatcommand formatTime -sortmode integer

proc emptyStr   val { return "" }
proc formatDate val { return [clock format $val -format "%Y-%m-%d"] }
proc formatTime val { return [clock format $val -format "%H:%M:%S"] }

#
# Populate the tablelist widget; set the activation
# date & time to 10 minutes past the current clock value
#
set clock [clock seconds]
incr clock 600
for {set n 1} {$n <= 8} {incr n} {
    $tbl insert end [list $n 1 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $checkedImg
}
for {set n 9} {$n <= 16} {incr n} {
    $tbl insert end [list $n 0 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $uncheckedImg
}

set btn [ttk::button $f.btn -text "Close" -command exit]

#
# Manage the widgets
#
pack $btn -side bottom -pady 10
pack $tbl -side top -expand yes -fill both
pack $f -expand yes -fill both

#------------------------------------------------------------------------------
# editStartCmd
#
# Applies some configuration options to the edit window; if the latter is a
# ComboBox, the procedure populates it.
#------------------------------------------------------------------------------
proc editStartCmd {tbl row col text} {
    set w [$tbl editwinpath]

    switch [$tbl columncget $col -name] {
	lineName {
	    #
	    # Set an upper limit of 20 for the number of characters
	    #
	    $w configure -invalidcommand bell -validate key \
			 -validatecommand {expr {[string length %P] <= 20}}
	}

	baudRate {
	    #
	    # Populate the ComboBox and allow no more
	    # than 6 digits in its Entry component
	    #
	    $w configure -values {50 75 110 300 1200 2400 4800 9600 19200 38400
				  57600 115200 230400 460800 921600}
	    $w configure -invalidcommand bell -validate key -validatecommand \
		{expr {[string length %P] <= 6 && [regexp {^[0-9]*$} %S]}}
	}

	dataBits {
	    #
	    # Configure the SpinBox
	    #
	    $w configure -range {5 8 1} -editable no
	}

	parity {
	    #
	    # Populate the ComboBox and make it non-editable
	    #
	    $w configure -values {None Even Odd Mark Space} -editable no
	}

	stopBits {
	    #
	    # Populate the ComboBox and make it non-editable
	    #
	    $w configure -values {1 1.5 2} -editable no
	}

	handshake {
	    #
	    # Populate the ComboBox and make it non-editable
	    #
	    $w configure -values {XON/XOFF RTS/CTS None} -editable no
	}

	actDate {
	    #
	    # Set an upper limit of 10 for the number of characters
	    # and allow only digits and the "-" character in it
	    #
	    $w configure -invalidcommand bell -validate key -validatecommand \
		{expr {[string length %P] <= 10 && [regexp {^[0-9-]*$} %S]}}
	}

	actTime {
	    #
	    # Set an upper limit of 8 for the number of characters
	    # and allow only digits and the ":" character in it
	    #
	    $w configure -invalidcommand bell -validate key -validatecommand \
		{expr {[string length %P] <= 8 && [regexp {^[0-9:]*$} %S]}}
	}
    }

    return $text
}

#------------------------------------------------------------------------------
# editEndCmd
#
# Performs a final validation of the text contained in the edit window and gets
# the cell's internal contents.
#------------------------------------------------------------------------------
proc editEndCmd {tbl row col text} {
    switch [$tbl columncget $col -name] {
	available {
	    #
	    # Update the image contained in the cell
	    #
	    set img [expr {$text ? $::checkedImg : $::uncheckedImg}]
	    $tbl cellconfigure $row,$col -image $img
	}

	baudRate {
	    #
	    # Check whether the baud rate is an integer in the range 50..921600
	    #
	    if {![regexp {^[0-9]+$} $text] || $text < 50 || $text > 921600} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The baud rate must be an integer in the range 50..921600"
		$tbl rejectinput
	    }
	}

	actDate {
	    #
	    # Get the activation date in seconds from the last argument 
	    #
	    if {[catch {clock scan $text} actDate] != 0} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "Invalid date"
		$tbl rejectinput
		return ""
	    }

	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actTime [$tbl cellcget $row,actTime -text]
	    set actClock [clock scan [formatTime $actTime] -base $actDate]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actTime -text $actClock
		return $actClock
	    }
	}

	actTime {
	    #
	    # Get the activation clock value in seconds from the last argument 
	    #
	    set actDate [$tbl cellcget $row,actDate -text]
	    if {[catch {clock scan $text -base $actDate} actClock] != 0} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "Invalid time"
		$tbl rejectinput
		return ""
	    }

	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actDate -text $actClock
		return $actClock
	    }
	}
    }

    return $text
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/checked.gif.

cannot compute difference between binary files

Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/comp.xbm.

1
2
3
4
5
#define comp_width 12
#define comp_height 10
static unsigned char comp_bits[] = {
   0xff, 0x0f, 0x01, 0x08, 0xfd, 0x0f, 0x05, 0x08, 0xf5, 0x0f, 0x15, 0x08,
   0xd5, 0x0f, 0x55, 0x08, 0x55, 0x08, 0xff, 0x0f};
<
<
<
<
<










Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/config.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
#==============================================================================
# Demonstrates how to implement a tablelist widget for displaying and editing
# the configuration options of an arbitrary widget.
#
# Copyright (c) 2000-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist

namespace eval demo {
    #
    # Get the current windowing system ("x11", "win32", "classic", or "aqua")
    # and add some entries to the Tk option database for the following
    # widget hierarchy within a top-level widget of the class DemoTop:
    #
    # Name		Class
    # -----------------------------
    # tf		Frame
    #   tbl		  Tabellist
    #   vsb, hsb	  Scrollbar
    # bf		Frame
    #   b1, b2, b3	  Button
    #
    variable winSys
    if {[catch {tk windowingsystem} winSys] != 0} {
	switch $::tcl_platform(platform) {
	    unix	{ set winSys x11 }
	    windows	{ set winSys win32 }
	    macintosh	{ set winSys classic }
	}
    }
    if {[string compare $winSys "x11"] == 0} {
	#
	# Create the font TkDefaultFont if not yet present
	#
	catch {font create TkDefaultFont -family Helvetica -size -12}

	option add *DemoTop*Font			TkDefaultFont
	option add *DemoTop*selectBackground		#678db2
	option add *DemoTop*selectForeground		white
    } else {
	option add *DemoTop.tf.borderWidth		2
	option add *DemoTop.tf.relief			sunken
	option add *DemoTop.tf.tbl.borderWidth		0
	option add *DemoTop.tf.tbl.highlightThickness	0
    }
    if {[string compare $winSys "classic"] == 0} {
	option add *DemoTop*background			#dedede
    }
    option add *DemoTop.tf.tbl.background		gray98
    option add *DemoTop.tf.tbl.stripeBackground		#e0e8f0
    option add *DemoTop.tf.tbl*Entry.background		white
    option add *DemoTop.tf.tbl.setGrid			yes
    option add *DemoTop.bf.Button.width			10
}

#------------------------------------------------------------------------------
# demo::displayConfig
#
# Displays the configuration options of the widget w in a tablelist widget
# contained in a newly created top-level widget.  Returns the name of the
# tablelist widget.
#------------------------------------------------------------------------------
proc demo::displayConfig w {
    if {![winfo exists $w]} {
	bell
	tk_messageBox -icon error -message "Bad window path name \"$w\"" \
		      -type ok
	return ""
    }

    #
    # Create a top-level widget of the class DemoTop
    #
    set top .configTop
    for {set n 2} {[winfo exists $top]} {incr n} {
	set top .configTop$n
    }
    toplevel $top -class DemoTop
    wm title $top "Configuration Options of the [winfo class $w] Widget \"$w\""

    #
    # Create a scrolled tablelist widget with 5 dynamic-width
    # columns and interactive sort capability within the top-level
    #
    set tf $top.tf
    frame $tf
    set tbl $tf.tbl
    set vsb $tf.vsb
    set hsb $tf.hsb
    tablelist::tablelist $tbl \
	-columns {0 "Command-Line Name"
		  0 "Database/Alias Name"
		  0 "Database Class"
		  0 "Default Value"
		  0 "Current Value"} \
	-labelcommand tablelist::sortByColumn -sortcommand demo::compareAsSet \
	-editendcommand demo::applyValue -height 15 -width 100 -stretch all \
	-xscrollcommand [list $hsb set] -yscrollcommand [list $vsb set]
    if {[$tbl cget -selectborderwidth] == 0} {
	$tbl configure -spacing 1
    }
    $tbl columnconfigure 3 -maxwidth 30
    $tbl columnconfigure 4 -maxwidth 30 -editable yes
    scrollbar $vsb -orient vertical   -command [list $tbl yview]
    scrollbar $hsb -orient horizontal -command [list $tbl xview]

    #
    # Create three buttons within a frame child of the top-level widget
    #
    set bf $top.bf
    frame $bf
    set b1 $bf.b1
    set b2 $bf.b2
    set b3 $bf.b3
    button $b1 -text "Refresh"     -command [list demo::putConfig $w $tbl]
    button $b2 -text "Sort as set" -command [list $tbl sort]
    button $b3 -text "Close"       -command [list destroy $top]

    #
    # Manage the widgets
    #
    grid $tbl -row 0 -column 0 -sticky news
    grid $vsb -row 0 -column 1 -sticky ns
    grid $hsb -row 1 -column 0 -sticky ew
    grid rowconfigure    $tf 0 -weight 1
    grid columnconfigure $tf 0 -weight 1
    pack $b1 $b2 $b3 -side left -expand yes -pady 10
    pack $bf -side bottom -fill x
    pack $tf -side top -expand yes -fill both

    #
    # Populate the tablelist with the configuration options of the given widget
    #
    putConfig $w $tbl
    return $tbl
}

#------------------------------------------------------------------------------
# demo::putConfig
#
# Outputs the configuration options of the widget w into the tablelist widget
# tbl.
#------------------------------------------------------------------------------
proc demo::putConfig {w tbl} {
    if {![winfo exists $w]} {
	bell
	tk_messageBox -icon error -message "Bad window path name \"$w\"" \
		      -parent [winfo toplevel $tbl] -type ok
	return ""
    }

    #
    # Display the configuration options of w in the tablelist widget tbl
    #
    $tbl delete 0 end
    foreach configSet [$w configure] {
	#
	# Insert the list configSet into the tablelist widget
	#
	$tbl insert end $configSet

	if {[llength $configSet] == 2} {
	    $tbl rowconfigure end -foreground gray50 -selectforeground gray75
	    $tbl cellconfigure end -editable no
	} else {
	    #
	    # Change the colors of the first and last cell of the row
	    # if the current value is different from the default one
	    #
	    set default [lindex $configSet 3]
	    set current [lindex $configSet 4]
	    if {[string compare $default $current] != 0} {
		foreach col {0 4} {
		    $tbl cellconfigure end,$col \
			 -foreground red -selectforeground yellow
		}
	    }
	}
    }

    $tbl sortbycolumn 0
    $tbl activate 0
    $tbl attrib widget $w
}

#------------------------------------------------------------------------------
# demo::compareAsSet
#
# Compares two items of a tablelist widget used to display the configuration
# options of an arbitrary widget.  The item in which the current value is
# different from the default one is considered to be less than the other; if
# both items fulfil this condition or its negation then string comparison is
# applied to the two option names.
#------------------------------------------------------------------------------
proc demo::compareAsSet {item1 item2} {
    foreach {opt1 dbName1 dbClass1 default1 current1} $item1 \
	    {opt2 dbName2 dbClass2 default2 current2} $item2 {
	set changed1 [expr {[string compare $default1 $current1] != 0}]
	set changed2 [expr {[string compare $default2 $current2] != 0}]
	if {$changed1 == $changed2} {
	    return [string compare $opt1 $opt2]
	} elseif {$changed1} {
	    return -1
	} else {
	    return 1
	}
    }
}

#------------------------------------------------------------------------------
# demo::applyValue
#
# Applies the new value of the configuraton option contained in the given row
# of the tablelist widget tbl to the widget whose options are displayed in it,
# and updates the colors of the first and last cell of the row.
#------------------------------------------------------------------------------
proc demo::applyValue {tbl row col text} {
    #
    # Try to apply the new value of the option contained in
    # the given row to the widget whose options are displayed
    # in the tablelist; reject the value if the attempt fails
    #
    set w [$tbl attrib widget]
    set opt [$tbl cellcget $row,0 -text]
    if {[catch {$w configure $opt $text} result] != 0} {
	bell
	tk_messageBox -parent [winfo toplevel $tbl] -title Error \
		      -icon error -message $result -type ok
	$tbl rejectinput
	return ""
    }

    #
    # Replace the new option value with its canonical form and
    # update the colors of the first and last cell of the row
    #
    set text [$w cget $opt]
    set default [$tbl cellcget $row,3 -text]
    if {[string compare $default $text] == 0} {
	foreach col {0 4} {
	    $tbl cellconfigure $row,$col \
		 -foreground "" -selectforeground ""
	}
    } else {
	foreach col {0 4} {
	    $tbl cellconfigure $row,$col \
		 -foreground red -selectforeground yellow
	}
    }

    return $text
}

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

if {$tcl_interactive} {
    return "\nTo display the configuration options of an arbitrary\
	    widget, enter\n\n\tdemo::displayConfig <widgetName>\n"
} else {
    wm withdraw .
    tk_messageBox -icon warning -title $argv0 -type ok -message \
	"Please source this script into\nan interactive wish session"
    exit 1
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/config_tile.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
#==============================================================================
# Demonstrates how to implement a tablelist widget for displaying and editing
# the configuration options of an arbitrary widget.
#
# Copyright (c) 2000-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist_tile

namespace eval demo {
    #
    # Get the current windowing system ("x11", "win32", or "aqua")
    # and add some entries to the Tk option database for the following
    # widget hierarchy within a top-level widget of the class DemoTop:
    #
    # Name		Class
    # -----------------------------
    # tf		TFrame
    #   tbl		  Tabellist
    #   vsb, hsb	  TScrollbar
    # bf		TFrame
    #   b1, b2, b3	  TButton
    #
    if {[tk windowingsystem] eq "x11"} {
	tablelist::setTheme alt
	option add *DemoTop*Font			TkDefaultFont
    }
    tablelist::setThemeDefaults
    variable currentTheme [tablelist::getCurrentTheme]
    if {$currentTheme ne "aqua"} {
	option add *DemoTop*selectBackground \
		   $tablelist::themeDefaults(-selectbackground)
	option add *DemoTop*selectForeground \
		   $tablelist::themeDefaults(-selectforeground)
	option add *DemoTop*selectBorderWidth \
		   $tablelist::themeDefaults(-selectborderwidth)
    }
    option add *DemoTop.tf.borderWidth			2
    option add *DemoTop.tf.relief			sunken
    option add *DemoTop.tf.tbl.background		gray98
    option add *DemoTop.tf.tbl.stripeBackground		#e0e8f0
    option add *DemoTop.tf.tbl*Entry.background		white
    option add *DemoTop.tf.tbl.borderWidth		0
    option add *DemoTop.tf.tbl.setGrid			yes
    option add *DemoTop.bf.TButton.width		10
}

#
# Work around the improper appearance of the tile scrollbars in the aqua theme
#
if {$demo::currentTheme eq "aqua"} {
    interp alias {} ttk::scrollbar {} ::scrollbar
}

#------------------------------------------------------------------------------
# demo::displayConfig
#
# Displays the configuration options of the widget w in a tablelist widget
# contained in a newly created top-level widget.  Returns the name of the
# tablelist widget.
#------------------------------------------------------------------------------
proc demo::displayConfig w {
    if {![winfo exists $w]} {
	bell
	tk_messageBox -icon error -message "Bad window path name \"$w\"" \
		      -type ok
	return ""
    }

    #
    # Create a top-level widget of the class DemoTop
    #
    set top .configTop
    for {set n 2} {[winfo exists $top]} {incr n} {
	set top .configTop$n
    }
    toplevel $top -class DemoTop
    wm title $top "Configuration Options of the [winfo class $w] Widget \"$w\""

    #
    # Create a scrolled tablelist widget with 5 dynamic-width
    # columns and interactive sort capability within the top-level
    #
    set tf $top.tf
    ttk::frame $tf
    set tbl $tf.tbl
    set vsb $tf.vsb
    set hsb $tf.hsb
    tablelist::tablelist $tbl \
	-columns {0 "Command-Line Name"
		  0 "Database/Alias Name"
		  0 "Database Class"
		  0 "Default Value"
		  0 "Current Value"} \
	-labelcommand tablelist::sortByColumn -sortcommand demo::compareAsSet \
	-editendcommand demo::applyValue -height 15 -width 100 -stretch all \
	-xscrollcommand [list $hsb set] -yscrollcommand [list $vsb set]
    if {[$tbl cget -selectborderwidth] == 0} {
	$tbl configure -spacing 1
    }
    $tbl columnconfigure 3 -maxwidth 30
    $tbl columnconfigure 4 -maxwidth 30 -editable yes
    ttk::scrollbar $vsb -orient vertical   -command [list $tbl yview]
    ttk::scrollbar $hsb -orient horizontal -command [list $tbl xview]

    #
    # Create three buttons within a tile frame child of the top-level widget
    #
    set bf $top.bf
    ttk::frame $bf
    set b1 $bf.b1
    set b2 $bf.b2
    set b3 $bf.b3
    ttk::button $b1 -text "Refresh"     -command [list demo::putConfig $w $tbl]
    ttk::button $b2 -text "Sort as set" -command [list $tbl sort]
    ttk::button $b3 -text "Close"       -command [list destroy $top]

    #
    # Manage the widgets
    #
    grid $tbl -row 0 -column 0 -sticky news
    grid $vsb -row 0 -column 1 -sticky ns
    grid $hsb -row 1 -column 0 -sticky ew
    grid rowconfigure    $tf 0 -weight 1
    grid columnconfigure $tf 0 -weight 1
    pack $b1 $b2 $b3 -side left -expand yes -pady 10
    pack $bf -side bottom -fill x
    pack $tf -side top -expand yes -fill both

    #
    # Populate the tablelist with the configuration options of the given widget
    #
    putConfig $w $tbl
    return $tbl
}

#------------------------------------------------------------------------------
# demo::putConfig
#
# Outputs the configuration options of the widget w into the tablelist widget
# tbl.
#------------------------------------------------------------------------------
proc demo::putConfig {w tbl} {
    if {![winfo exists $w]} {
	bell
	tk_messageBox -icon error -message "Bad window path name \"$w\"" \
		      -parent [winfo toplevel $tbl] -type ok
	return ""
    }

    #
    # Display the configuration options of w in the tablelist widget tbl
    #
    $tbl delete 0 end
    foreach configSet [$w configure] {
	#
	# Insert the list configSet into the tablelist widget
	#
	$tbl insert end $configSet

	if {[llength $configSet] == 2} {
	    $tbl rowconfigure end -foreground gray50 -selectforeground gray75
	    $tbl cellconfigure end -editable no
	} else {
	    #
	    # Change the colors of the first and last cell of the row
	    # if the current value is different from the default one
	    #
	    set default [lindex $configSet 3]
	    set current [lindex $configSet 4]
	    if {[string compare $default $current] != 0} {
		foreach col {0 4} {
		    $tbl cellconfigure end,$col \
			 -foreground red -selectforeground yellow
		}
	    }
	}
    }

    $tbl sortbycolumn 0
    $tbl activate 0
    $tbl attrib widget $w
}

#------------------------------------------------------------------------------
# demo::compareAsSet
#
# Compares two items of a tablelist widget used to display the configuration
# options of an arbitrary widget.  The item in which the current value is
# different from the default one is considered to be less than the other; if
# both items fulfil this condition or its negation then string comparison is
# applied to the two option names.
#------------------------------------------------------------------------------
proc demo::compareAsSet {item1 item2} {
    foreach {opt1 dbName1 dbClass1 default1 current1} $item1 \
	    {opt2 dbName2 dbClass2 default2 current2} $item2 {
	set changed1 [expr {[string compare $default1 $current1] != 0}]
	set changed2 [expr {[string compare $default2 $current2] != 0}]
	if {$changed1 == $changed2} {
	    return [string compare $opt1 $opt2]
	} elseif {$changed1} {
	    return -1
	} else {
	    return 1
	}
    }
}

#------------------------------------------------------------------------------
# demo::applyValue
#
# Applies the new value of the configuraton option contained in the given row
# of the tablelist widget tbl to the widget whose options are displayed in it,
# and updates the colors of the first and last cell of the row.
#------------------------------------------------------------------------------
proc demo::applyValue {tbl row col text} {
    #
    # Try to apply the new value of the option contained in
    # the given row to the widget whose options are displayed
    # in the tablelist; reject the value if the attempt fails
    #
    set w [$tbl attrib widget]
    set opt [$tbl cellcget $row,0 -text]
    if {[catch {$w configure $opt $text} result] != 0} {
	bell
	tk_messageBox -parent [winfo toplevel $tbl] -title Error \
		      -icon error -message $result -type ok
	$tbl rejectinput
	return ""
    }

    #
    # Replace the new option value with its canonical form and
    # update the colors of the first and last cell of the row
    #
    set text [$w cget $opt]
    set default [$tbl cellcget $row,3 -text]
    if {[string compare $default $text] == 0} {
	foreach col {0 4} {
	    $tbl cellconfigure $row,$col \
		 -foreground "" -selectforeground ""
	}
    } else {
	foreach col {0 4} {
	    $tbl cellconfigure $row,$col \
		 -foreground red -selectforeground yellow
	}
    }

    return $text
}

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

if {$tcl_interactive} {
    return "\nTo display the configuration options of an arbitrary\
	    widget, enter\n\n\tdemo::displayConfig <widgetName>\n"
} else {
    wm withdraw .
    tk_messageBox -icon warning -title $argv0 -type ok -message \
	"Please source this script into\nan interactive wish session"
    exit 1
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/embeddedWindows.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates the use of embedded windows in tablelist widgets.
#
# Copyright (c) 2004-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist

wm title . "Tk Library Scripts"

#
# Add some entries to the Tk option database
#
set dir [file dirname [info script]]
source [file join $dir option.tcl]

#
# Create the font TkFixedFont if not yet present
#
catch {font create TkFixedFont -family Courier -size -12}

#
# Create an image to be displayed in buttons embedded in a tablelist widget
#
set openImg [image create photo -file [file join $dir open.gif]]

#
# Create a vertically scrolled tablelist widget with 5
# dynamic-width columns and interactive sort capability
#
set tbl .tbl
set vsb .vsb
tablelist::tablelist $tbl \
    -columns {0 "File Name" left
	      0 "Bar Chart" center
	      0 "File Size" right
	      0 "View"      center
	      0 "Seen"      center} \
    -setgrid no -yscrollcommand [list $vsb set] -width 0
if {[$tbl cget -selectborderwidth] == 0} {
    $tbl configure -spacing 1
}
$tbl columnconfigure 0 -name fileName
$tbl columnconfigure 1 -formatcommand emptyStr -sortmode integer
$tbl columnconfigure 2 -name fileSize -sortmode integer
$tbl columnconfigure 4 -name seen
scrollbar $vsb -orient vertical -command [list $tbl yview]

proc emptyStr val { return "" }

eval font create BoldFont [font actual [$tbl cget -font]] -weight bold

#
# Populate the tablelist widget
#
cd $tk_library
set maxFileSize 0
foreach fileName [lsort [glob *.tcl]] {
    set fileSize [file size $fileName]
    $tbl insert end [list $fileName $fileSize $fileSize "" no]

    if {$fileSize > $maxFileSize} {
	set maxFileSize $fileSize
    }
}

#------------------------------------------------------------------------------
# createFrame
#
# Creates a frame widget w to be embedded into the specified cell of the
# tablelist widget tbl, as well as a child frame representing the size of the
# file whose name is diplayed in the first column of the cell's row.
#------------------------------------------------------------------------------
proc createFrame {tbl row col w} {
    #
    # Create the frame and replace the binding tag "Frame"
    # with "TablelistBody" in the list of its binding tags
    #
    frame $w -width 102 -height 14 -background ivory -borderwidth 1 \
	     -relief solid
    bindtags $w [lreplace [bindtags $w] 1 1 TablelistBody]

    #
    # Create the child frame and replace the binding tag "Frame"
    # with "TablelistBody" in the list of its binding tags
    #
    frame $w.f -height 12 -background red -borderwidth 1 -relief raised
    bindtags $w.f [lreplace [bindtags $w] 1 1 TablelistBody]

    #
    # Manage the child frame
    #
    set fileSize [$tbl cellcget $row,fileSize -text]
    place $w.f -relwidth [expr {double($fileSize) / $::maxFileSize}]
}

#------------------------------------------------------------------------------
# createButton
#
# Creates a button widget w to be embedded into the specified cell of the
# tablelist widget tbl.
#------------------------------------------------------------------------------
proc createButton {tbl row col w} {
    set key [$tbl getkeys $row]
    button $w -image $::openImg -highlightthickness 0 -takefocus 0 \
	      -command [list viewFile $tbl $key]
}

#------------------------------------------------------------------------------
# viewFile
#
# Displays the contents of the file whose name is contained in the row with the
# given key of the tablelist widget tbl.
#------------------------------------------------------------------------------
proc viewFile {tbl key} {
    set top .top$key
    if {[winfo exists $top]} {
	raise $top
	return ""
    }

    toplevel $top
    set fileName [$tbl cellcget k$key,fileName -text]
    wm title $top "File \"$fileName\""

    #
    # Create a vertically scrolled text widget as a child of the toplevel
    #
    set txt $top.txt
    set vsb $top.vsb
    text $txt -background white -font TkFixedFont -setgrid yes \
	      -yscrollcommand [list $vsb set]
    catch {$txt configure -tabstyle wordprocessor}		;# for Tk 8.5
    scrollbar $vsb -orient vertical -command [list $txt yview]

    #
    # Insert the file's contents into the text widget
    #
    set chan [open $fileName]
    $txt insert end [read $chan]
    close $chan

    set btn [button $top.btn -text "Close" -command [list destroy $top]]

    #
    # Manage the widgets
    #
    grid $txt -row 0 -column 0 -sticky news
    grid $vsb -row 0 -column 1 -sticky ns
    grid $btn -row 1 -column 0 -columnspan 2 -pady 10
    grid rowconfigure    $top 0 -weight 1
    grid columnconfigure $top 0 -weight 1

    #
    # Mark the file as seen
    #
    $tbl rowconfigure k$key -font BoldFont
    $tbl cellconfigure k$key,seen -text yes
}

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

#
# Create embedded windows in the columns no. 1 and 3
#
set rowCount [$tbl size]
for {set row 0} {$row < $rowCount} {incr row} {
    $tbl cellconfigure $row,1 -window createFrame -stretchwindow yes
    $tbl cellconfigure $row,3 -window createButton
}

set btn [button .btn -text "Close" -command exit]

#
# Manage the widgets
#
grid $tbl -row 0 -column 0 -sticky news
grid $vsb -row 0 -column 1 -sticky ns
grid $btn -row 1 -column 0 -columnspan 2 -pady 10
grid rowconfigure    . 0 -weight 1
grid columnconfigure . 0 -weight 1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/embeddedWindows_tile.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates the use of embedded windows in tablelist widgets.
#
# Copyright (c) 2004-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist_tile

wm title . "Tile Library Scripts"

#
# Add some entries to the Tk option database
#
set dir [file dirname [info script]]
source [file join $dir option_tile.tcl]

#
# Create the font TkFixedFont if not yet present
#
catch {font create TkFixedFont -family Courier -size -12}

#
# Create an image to be displayed in buttons embedded in a tablelist widget
#
set openImg [image create photo -file [file join $dir open.gif]]

if {[tablelist::getCurrentTheme] eq "aqua"} {
    #
    # Work around the improper appearance of the tile scrollbars
    #
    interp alias {} ttk::scrollbar {} ::scrollbar
} else {
    #
    # Make the embedded buttons as small as possible.  Recall that in most
    # themes, the tile buttons consist of the following element hierarchy:
    #
    # Button.border
    #     Button.focus	      (one of its options is -focusthickness)
    #         Button.padding  (two of its options are -padding and -shiftrelief)
    #             Button.label
    #
    if {[info commands "::ttk::style"] ne ""} {
	interp alias {} styleConfig {} ttk::style configure
    } elseif {[string compare $tile::version "0.7"] >= 0} {
	interp alias {} styleConfig {} style configure
    } else {
	interp alias {} styleConfig {} style default
    }
    styleConfig Embedded.TButton -focusthickness 0 -padding 0 -shiftrelief 0
}

#
# Improve the window's appearance by using a tile
# frame as a container for the other widgets
#
set f [ttk::frame .f]

#
# Create a vertically scrolled tablelist widget with 5
# dynamic-width columns and interactive sort capability
#
set tbl $f.tbl
set vsb $f.vsb
tablelist::tablelist $tbl \
    -columns {0 "File Name" left
	      0 "Bar Chart" center
	      0 "File Size" right
	      0 "View"      center
	      0 "Seen"      center} \
    -setgrid no -yscrollcommand [list $vsb set] -width 0
if {[$tbl cget -selectborderwidth] == 0} {
    $tbl configure -spacing 1
}
$tbl columnconfigure 0 -name fileName
$tbl columnconfigure 1 -formatcommand emptyStr -sortmode integer
$tbl columnconfigure 2 -name fileSize -sortmode integer
$tbl columnconfigure 4 -name seen
ttk::scrollbar $vsb -orient vertical -command [list $tbl yview]

proc emptyStr val { return "" }

eval font create BoldFont [font actual [$tbl cget -font]] -weight bold

#
# Populate the tablelist widget
#
if {[info exists ttk::library]} {
    cd $ttk::library
} else {
    cd $tile::library
}
set maxFileSize 0
foreach fileName [lsort [glob *.tcl]] {
    set fileSize [file size $fileName]
    $tbl insert end [list $fileName $fileSize $fileSize "" no]

    if {$fileSize > $maxFileSize} {
	set maxFileSize $fileSize
    }
}

#------------------------------------------------------------------------------
# createFrame
#
# Creates a frame widget w to be embedded into the specified cell of the
# tablelist widget tbl, as well as a child frame representing the size of the
# file whose name is diplayed in the first column of the cell's row.
#------------------------------------------------------------------------------
proc createFrame {tbl row col w} {
    #
    # Create the frame and replace the binding tag "Frame"
    # with "TablelistBody" in the list of its binding tags
    #
    frame $w -width 102 -height 14 -background ivory -borderwidth 1 \
	     -relief solid
    bindtags $w [lreplace [bindtags $w] 1 1 TablelistBody]

    #
    # Create the child frame and replace the binding tag "Frame"
    # with "TablelistBody" in the list of its binding tags
    #
    frame $w.f -height 12 -background red -borderwidth 1 -relief raised
    bindtags $w.f [lreplace [bindtags $w] 1 1 TablelistBody]

    #
    # Manage the child frame
    #
    set fileSize [$tbl cellcget $row,fileSize -text]
    place $w.f -relwidth [expr {double($fileSize) / $::maxFileSize}]
}

#------------------------------------------------------------------------------
# createButton
#
# Creates a button widget w to be embedded into the specified cell of the
# tablelist widget tbl.
#------------------------------------------------------------------------------
proc createButton {tbl row col w} {
    set key [$tbl getkeys $row]
    ttk::button $w -style Embedded.TButton -image $::openImg -takefocus 0 \
		   -command [list viewFile $tbl $key]
}

#------------------------------------------------------------------------------
# viewFile
#
# Displays the contents of the file whose name is contained in the row with the
# given key of the tablelist widget tbl.
#------------------------------------------------------------------------------
proc viewFile {tbl key} {
    set top .top$key
    if {[winfo exists $top]} {
	raise $top
	return ""
    }

    toplevel $top
    set fileName [$tbl cellcget k$key,fileName -text]
    wm title $top "File \"$fileName\""

    #
    # Improve the window's appearance by using a tile
    # frame as a container for the other widgets
    #
    set f [ttk::frame $top.f]

    #
    # Create a vertically scrolled text widget as a child of the toplevel
    #
    set txt $f.txt
    set vsb $f.vsb
    text $txt -background white -font TkFixedFont -highlightthickness 0 \
	      -setgrid yes -yscrollcommand [list $vsb set]
    catch {$txt configure -tabstyle wordprocessor}		;# for Tk 8.5
    ttk::scrollbar $vsb -orient vertical -command [list $txt yview]

    #
    # Insert the file's contents into the text widget
    #
    set chan [open $fileName]
    $txt insert end [read $chan]
    close $chan

    set btn [ttk::button $f.btn -text "Close" -command [list destroy $top]]

    #
    # Manage the widgets
    #
    grid $txt -row 0 -column 0 -sticky news
    grid $vsb -row 0 -column 1 -sticky ns
    grid $btn -row 1 -column 0 -columnspan 2 -pady 10
    grid rowconfigure    $f 0 -weight 1
    grid columnconfigure $f 0 -weight 1
    pack $f -expand yes -fill both

    #
    # Mark the file as seen
    #
    $tbl rowconfigure k$key -font BoldFont
    $tbl cellconfigure k$key,seen -text yes
}

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

#
# Create embedded windows in the columns no. 1 and 3
#
set rowCount [$tbl size]
for {set row 0} {$row < $rowCount} {incr row} {
    $tbl cellconfigure $row,1 -window createFrame -stretchwindow yes
    $tbl cellconfigure $row,3 -window createButton
}

set btn [ttk::button $f.btn -text "Close" -command exit]

#
# Manage the widgets
#
grid $tbl -row 0 -column 0 -sticky news
grid $vsb -row 0 -column 1 -sticky ns
grid $btn -row 1 -column 0 -columnspan 2 -pady 10
grid rowconfigure    $f 0 -weight 1
grid columnconfigure $f 0 -weight 1
pack $f -expand yes -fill both
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/iwidgets.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates the interactive tablelist cell editing with the aid of some
# widgets from the Iwidgets package and of the Tk core checkbutton widget.
#
# Copyright (c) 2004-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist
package require Iwidgets

wm title . "Serial Line Configuration"

#
# Add some entries to the Tk option database
#
set dir [file dirname [info script]]
source [file join $dir option.tcl]
option add *Tablelist*Checkbutton.background		white
option add *Tablelist*Checkbutton.activeBackground	white
option add *Tablelist*textBackground			white
option add *Tablelist*Entry.disabledBackground		white
option add *Tablelist*Entry.disabledForeground		black
option add *Tablelist*Dateentry*Label.background	white
option add *Tablelist*Timeentry*Label.background	white

#
# Register some widgets from the Iwidgets package for interactive cell editing
#
tablelist::addIncrEntryfield
tablelist::addIncrSpinint
tablelist::addIncrCombobox
tablelist::addIncrDateTimeWidget dateentry -seconds
tablelist::addIncrDateTimeWidget timeentry -seconds

#
# Create two images, to be displayed in tablelist cells with boolean values
#
set checkedImg   [image create photo -file [file join $dir checked.gif]]
set uncheckedImg [image create photo -file [file join $dir unchecked.gif]]

#
# Create a tablelist widget with editable columns (except the first one)
#
set tbl .tbl
tablelist::tablelist $tbl \
    -columns {0 "No."		  right
	      0 "Available"	  center
	      0 "Name"		  left
	      0 "Baud Rate"	  right
	      0 "Data Bits"	  center
	      0 "Parity"	  left
	      0 "Stop Bits"	  center
	      0 "Handshake"	  left
	      0 "Activation Date" center
	      0 "Activation Time" center} \
    -editstartcommand editStartCmd -editendcommand editEndCmd \
    -height 0 -width 0
if {[$tbl cget -selectborderwidth] == 0} {
    $tbl configure -spacing 1
}
$tbl columnconfigure 0 -sortmode integer
$tbl columnconfigure 1 -name available -editable yes -editwindow checkbutton \
    -formatcommand emptyStr
$tbl columnconfigure 2 -name lineName  -editable yes -editwindow entryfield \
    -sortmode dictionary
$tbl columnconfigure 3 -name baudRate  -editable yes -editwindow combobox \
    -sortmode integer
$tbl columnconfigure 4 -name dataBits  -editable yes -editwindow spinint
$tbl columnconfigure 5 -name parity    -editable yes -editwindow combobox
$tbl columnconfigure 6 -name stopBits  -editable yes -editwindow combobox
$tbl columnconfigure 7 -name handshake -editable yes -editwindow combobox
$tbl columnconfigure 8 -name actDate   -editable yes -editwindow dateentry \
    -formatcommand formatDate -sortmode integer
$tbl columnconfigure 9 -name actTime   -editable yes -editwindow timeentry \
    -formatcommand formatTime -sortmode integer

proc emptyStr   val { return "" }
proc formatDate val { return [clock format $val -format "%Y-%m-%d"] }
proc formatTime val { return [clock format $val -format "%H:%M:%S"] }

#
# Populate the tablelist widget; set the activation
# date & time to 10 minutes past the current clock value
#
set clock [clock seconds]
incr clock 600
for {set n 1} {$n <= 8} {incr n} {
    $tbl insert end [list $n 1 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $checkedImg
}
for {set n 9} {$n <= 16} {incr n} {
    $tbl insert end [list $n 0 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $uncheckedImg
}

set btn [button .btn -text "Close" -command exit]

#
# Manage the widgets
#
pack $btn -side bottom -pady 10
pack $tbl -side top -expand yes -fill both

#------------------------------------------------------------------------------
# editStartCmd
#
# Applies some configuration options to the edit window; if the latter is a
# combobox, the procedure populates it.
#------------------------------------------------------------------------------
proc editStartCmd {tbl row col text} {
    set w [$tbl editwinpath]

    switch [$tbl columncget $col -name] {
	lineName {
	    #
	    # Set an upper limit of 20 for the number of characters
	    #
	    $w configure -pasting no -fixed 20
	}

	baudRate {
	    #
	    # Populate the combobox and allow no more
	    # than 6 digits in its entry component
	    #
	    $w insert list end 50 75 110 300 1200 2400 4800 9600 19200 38400 \
			       57600 115200 230400 460800 921600
	    $w configure -pasting no -fixed 6 -validate numeric
	}

	dataBits {
	    #
	    # Configure the spinint widget
	    #
	    $w configure -range {5 8} -wrap no -pasting no -fixed 1 \
			 -validate {regexp {^[5-8]$} %c}
	}

	parity {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w insert list end None Even Odd Mark Space
	    $w configure -editable no -listheight 120
	}

	stopBits {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w insert list end 1 1.5 2
	    $w configure -editable no -listheight 90
	}

	handshake {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w insert list end XON/XOFF RTS/CTS None
	    $w configure -editable no -listheight 90
	}

	actDate {
	    #
	    # Set the date format "%Y-%m-%d"
	    #
	    $w configure -int yes
	}

	actTime {
	    #
	    # Set the time format "%H:%M:%S"
	    #
	    $w configure -format military
	}
    }

    return $text
}

#------------------------------------------------------------------------------
# editEndCmd
#
# Performs a final validation of the text contained in the edit window and gets
# the cell's internal contents.
#------------------------------------------------------------------------------
proc editEndCmd {tbl row col text} {
    switch [$tbl columncget $col -name] {
	available {
	    #
	    # Update the image contained in the cell
	    #
	    set img [expr {$text ? $::checkedImg : $::uncheckedImg}]
	    $tbl cellconfigure $row,$col -image $img
	}

	baudRate {
	    #
	    # Check whether the baud rate is an integer in the range 50..921600
	    #
	    if {![regexp {^[0-9]+$} $text] || $text < 50 || $text > 921600} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The baud rate must be an integer in the range 50..921600"
		$tbl rejectinput
	    }
	}

	dataBits {
	    #
	    # Check whether the # of data bits is an integer in the range 5..8
	    #
	    if {![regexp {^[5-8]$} $text]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The # of data bits must be an integer in the range 5..8"
		$tbl rejectinput
	    }
	}

	actDate {
	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actTime [$tbl cellcget $row,actTime -text]
	    set actClock [clock scan [formatTime $actTime] -base $text]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actTime -text $actClock
		return $actClock
	    }
	}

	actTime {
	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actDate [$tbl cellcget $row,actDate -text]
	    set actClock [clock scan [formatTime $text] -base $actDate]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actDate -text $actClock
		return $actClock
	    }
	}
    }

    return $text
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/iwidgets_tile.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates the interactive tablelist cell editing with the aid of some
# widgets from the Iwidgets package and of the Tk core checkbutton widget.
#
# Copyright (c) 2004-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist_tile
package require Iwidgets

wm title . "Serial Line Configuration"

#
# Add some entries to the Tk option database
#
set dir [file dirname [info script]]
source [file join $dir option_tile.tcl]
option add *Tablelist*Checkbutton.background		white
option add *Tablelist*Checkbutton.activeBackground	white
option add *Tablelist*textBackground			white
option add *Tablelist*Entry.disabledBackground		white
option add *Tablelist*Entry.disabledForeground		black
option add *Tablelist*Dateentry*Label.background	white
option add *Tablelist*Timeentry*Label.background	white

#
# Register some widgets from the Iwidgets package for interactive cell editing
#
tablelist::addIncrEntryfield
tablelist::addIncrSpinint
tablelist::addIncrCombobox
tablelist::addIncrDateTimeWidget dateentry -seconds
tablelist::addIncrDateTimeWidget timeentry -seconds

#
# Create two images, to be displayed in tablelist cells with boolean values
#
set checkedImg   [image create photo -file [file join $dir checked.gif]]
set uncheckedImg [image create photo -file [file join $dir unchecked.gif]]

#
# Improve the window's appearance by using a tile
# frame as a container for the other widgets
#
set f [ttk::frame .f]

#
# Create a tablelist widget with editable columns (except the first one)
#
set tbl $f.tbl
tablelist::tablelist $tbl \
    -columns {0 "No."		  right
	      0 "Available"	  center
	      0 "Name"		  left
	      0 "Baud Rate"	  right
	      0 "Data Bits"	  center
	      0 "Parity"	  left
	      0 "Stop Bits"	  center
	      0 "Handshake"	  left
	      0 "Activation Date" center
	      0 "Activation Time" center} \
    -editstartcommand editStartCmd -editendcommand editEndCmd \
    -height 0 -width 0
if {[$tbl cget -selectborderwidth] == 0} {
    $tbl configure -spacing 1
}
$tbl columnconfigure 0 -sortmode integer
$tbl columnconfigure 1 -name available -editable yes -editwindow checkbutton \
    -formatcommand emptyStr
$tbl columnconfigure 2 -name lineName  -editable yes -editwindow entryfield \
    -sortmode dictionary
$tbl columnconfigure 3 -name baudRate  -editable yes -editwindow combobox \
    -sortmode integer
$tbl columnconfigure 4 -name dataBits  -editable yes -editwindow spinint
$tbl columnconfigure 5 -name parity    -editable yes -editwindow combobox
$tbl columnconfigure 6 -name stopBits  -editable yes -editwindow combobox
$tbl columnconfigure 7 -name handshake -editable yes -editwindow combobox
$tbl columnconfigure 8 -name actDate   -editable yes -editwindow dateentry \
    -formatcommand formatDate -sortmode integer
$tbl columnconfigure 9 -name actTime   -editable yes -editwindow timeentry \
    -formatcommand formatTime -sortmode integer

proc emptyStr   val { return "" }
proc formatDate val { return [clock format $val -format "%Y-%m-%d"] }
proc formatTime val { return [clock format $val -format "%H:%M:%S"] }

#
# Populate the tablelist widget; set the activation
# date & time to 10 minutes past the current clock value
#
set clock [clock seconds]
incr clock 600
for {set n 1} {$n <= 8} {incr n} {
    $tbl insert end [list $n 1 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $checkedImg
}
for {set n 9} {$n <= 16} {incr n} {
    $tbl insert end [list $n 0 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $uncheckedImg
}

set btn [ttk::button $f.btn -text "Close" -command exit]

#
# Manage the widgets
#
pack $btn -side bottom -pady 10
pack $tbl -side top -expand yes -fill both
pack $f -expand yes -fill both

#------------------------------------------------------------------------------
# editStartCmd
#
# Applies some configuration options to the edit window; if the latter is a
# combobox, the procedure populates it.
#------------------------------------------------------------------------------
proc editStartCmd {tbl row col text} {
    set w [$tbl editwinpath]

    switch [$tbl columncget $col -name] {
	lineName {
	    #
	    # Set an upper limit of 20 for the number of characters
	    #
	    $w configure -pasting no -fixed 20
	}

	baudRate {
	    #
	    # Populate the combobox and allow no more
	    # than 6 digits in its entry component
	    #
	    $w insert list end 50 75 110 300 1200 2400 4800 9600 19200 38400 \
			       57600 115200 230400 460800 921600
	    $w configure -pasting no -fixed 6 -validate numeric
	}

	dataBits {
	    #
	    # Configure the spinint widget
	    #
	    $w configure -range {5 8} -wrap no -pasting no -fixed 1 \
			 -validate {regexp {^[5-8]$} %c}
	}

	parity {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w insert list end None Even Odd Mark Space
	    $w configure -editable no -listheight 120
	}

	stopBits {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w insert list end 1 1.5 2
	    $w configure -editable no -listheight 90
	}

	handshake {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w insert list end XON/XOFF RTS/CTS None
	    $w configure -editable no -listheight 90
	}

	actDate {
	    #
	    # Set the date format "%Y-%m-%d"
	    #
	    $w configure -int yes
	}

	actTime {
	    #
	    # Set the time format "%H:%M:%S"
	    #
	    $w configure -format military
	}
    }

    return $text
}

#------------------------------------------------------------------------------
# editEndCmd
#
# Performs a final validation of the text contained in the edit window and gets
# the cell's internal contents.
#------------------------------------------------------------------------------
proc editEndCmd {tbl row col text} {
    switch [$tbl columncget $col -name] {
	available {
	    #
	    # Update the image contained in the cell
	    #
	    set img [expr {$text ? $::checkedImg : $::uncheckedImg}]
	    $tbl cellconfigure $row,$col -image $img
	}

	baudRate {
	    #
	    # Check whether the baud rate is an integer in the range 50..921600
	    #
	    if {![regexp {^[0-9]+$} $text] || $text < 50 || $text > 921600} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The baud rate must be an integer in the range 50..921600"
		$tbl rejectinput
	    }
	}

	dataBits {
	    #
	    # Check whether the # of data bits is an integer in the range 5..8
	    #
	    if {![regexp {^[5-8]$} $text]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The # of data bits must be an integer in the range 5..8"
		$tbl rejectinput
	    }
	}

	actDate {
	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actTime [$tbl cellcget $row,actTime -text]
	    set actClock [clock scan [formatTime $actTime] -base $text]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actTime -text $actClock
		return $actClock
	    }
	}

	actTime {
	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actDate [$tbl cellcget $row,actDate -text]
	    set actClock [clock scan [formatTime $text] -base $actDate]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actDate -text $actClock
		return $actClock
	    }
	}
    }

    return $text
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/leaf.xbm.

1
2
3
4
5
#define leaf_width 12
#define leaf_height 10
static unsigned char leaf_bits[] = {
   0xff, 0x0f, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08,
   0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0xff, 0x0f};
<
<
<
<
<










Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/miscWidgets.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates the interactive tablelist cell editing with the aid of Bryan
# Oakley's combobox, the mentry widgets of type "Date" and "Time", and of the
# Tk core entry, spinbox, and checkbutton widgets.
#
# Copyright (c) 2004-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require Tk 8.4			;# because of the spinbox widget
package require tablelist
package require combobox
package require mentry

wm title . "Serial Line Configuration"

#
# Add some entries to the Tk option database
#
set dir [file dirname [info script]]
source [file join $dir option.tcl]
option add *Tablelist*Checkbutton.background		white
option add *Tablelist*Checkbutton.activeBackground	white
option add *Tablelist*Entry.background			white
option add *Tablelist*Spinbox.background		white
option add *Tablelist*Spinbox.readonlyBackground	white
option add *Tablelist*Combobox.background		white
option add *Tablelist*Combobox.elementBorderWidth	2
option add *Tablelist*Mentry.background			white

#
# Register Bryan Oakley's combobox widget as well as the mentry
# widgets of type "Date" and "Time" for interactive cell editing
#
tablelist::addOakleyCombobox
tablelist::addDateMentry Ymd -
tablelist::addTimeMentry HMS :

#
# Create two images, to be displayed in tablelist cells with boolean values
#
set checkedImg   [image create photo -file [file join $dir checked.gif]]
set uncheckedImg [image create photo -file [file join $dir unchecked.gif]]

#
# Create a tablelist widget with editable columns (except the first one)
#
set tbl .tbl
tablelist::tablelist $tbl \
    -columns {0 "No."		  right
	      0 "Available"	  center
	      0 "Name"		  left
	      0 "Baud Rate"	  right
	      0 "Data Bits"	  center
	      0 "Parity"	  left
	      0 "Stop Bits"	  center
	      0 "Handshake"	  left
	      0 "Activation Date" center
	      0 "Activation Time" center} \
    -editstartcommand editStartCmd -editendcommand editEndCmd \
    -height 0 -width 0
if {[$tbl cget -selectborderwidth] == 0} {
    $tbl configure -spacing 1
}
$tbl columnconfigure 0 -sortmode integer
$tbl columnconfigure 1 -name available -editable yes -editwindow checkbutton \
    -formatcommand emptyStr
$tbl columnconfigure 2 -name lineName  -editable yes -editwindow entry \
    -sortmode dictionary
$tbl columnconfigure 3 -name baudRate  -editable yes -editwindow combobox \
    -sortmode integer
$tbl columnconfigure 4 -name dataBits  -editable yes -editwindow spinbox
$tbl columnconfigure 5 -name parity    -editable yes -editwindow combobox
$tbl columnconfigure 6 -name stopBits  -editable yes -editwindow combobox
$tbl columnconfigure 7 -name handshake -editable yes -editwindow combobox
$tbl columnconfigure 8 -name actDate   -editable yes -editwindow dateMentry \
    -formatcommand formatDate -sortmode integer
$tbl columnconfigure 9 -name actTime   -editable yes -editwindow timeMentry \
    -formatcommand formatTime -sortmode integer

proc emptyStr   val { return "" }
proc formatDate val { return [clock format $val -format "%Y-%m-%d"] }
proc formatTime val { return [clock format $val -format "%H:%M:%S"] }

#
# Populate the tablelist widget; set the activation
# date & time to 10 minutes past the current clock value
#
set clock [clock seconds]
incr clock 600
for {set n 1} {$n <= 8} {incr n} {
    $tbl insert end [list $n 1 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $checkedImg
}
for {set n 9} {$n <= 16} {incr n} {
    $tbl insert end [list $n 0 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $uncheckedImg
}

set btn [button .btn -text "Close" -command exit]

#
# Manage the widgets
#
pack $btn -side bottom -pady 10
pack $tbl -side top -expand yes -fill both

#------------------------------------------------------------------------------
# editStartCmd
#
# Applies some configuration options to the edit window; if the latter is a
# combobox, the procedure populates it.
#------------------------------------------------------------------------------
proc editStartCmd {tbl row col text} {
    set w [$tbl editwinpath]

    switch [$tbl columncget $col -name] {
	lineName {
	    #
	    # Set an upper limit of 20 for the number of characters
	    #
	    wcb::callback $w before insert {wcb::checkEntryLen 20}
	}

	baudRate {
	    #
	    # Populate the combobox and allow no more
	    # than 6 digits in its entry component
	    #
	    $w list insert end 50 75 110 300 1200 2400 4800 9600 19200 38400 \
			       57600 115200 230400 460800 921600
	    wcb::callback [$tbl entrypath] before insert \
		{wcb::checkEntryLen 6} {wcb::checkStrForRegExp {^[0-9]*$}}
	}

	dataBits {
	    #
	    # Configure the spinbox
	    #
	    $w configure -from 5 -to 8 -state readonly
	}

	parity {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w list insert end None Even Odd Mark Space
	    $w configure -editable no
	}

	stopBits {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w list insert end 1 1.5 2
	    $w configure -editable no
	}

	handshake {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w list insert end XON/XOFF RTS/CTS None
	    $w configure -editable no
	}

	actDate -
	actTime {
	    #
	    # Configure the mentry widget
	    #
	    $w configure -justify center
	}
    }

    return $text
}

#
# Message strings corresponding to the values
# returned by mentry::getClockVal on failure
#
array set msgs {
    EMPTY	"Field value missing"
    BAD		"Invalid field value"
    BAD_DATE	"Invalid date"
    BAD_YEAR	"Unsupported year"
}

#------------------------------------------------------------------------------
# editEndCmd
#
# Performs a final validation of the text contained in the edit window and gets
# the cell's internal contents.
#------------------------------------------------------------------------------
proc editEndCmd {tbl row col text} {
    switch [$tbl columncget $col -name] {
	available {
	    #
	    # Update the image contained in the cell
	    #
	    set img [expr {$text ? $::checkedImg : $::uncheckedImg}]
	    $tbl cellconfigure $row,$col -image $img
	}

	baudRate {
	    #
	    # Check whether the baud rate is an integer in the range 50..921600
	    #
	    if {![regexp {^[0-9]+$} $text] || $text < 50 || $text > 921600} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The baud rate must be an integer in the range 50..921600"
		$tbl rejectinput
	    }
	}

	actDate {
	    #
	    # Check whether the last argument is a clock value in seconds
	    #
	    if {![string is digit $text]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    $::msgs($text)
		$tbl rejectinput
		return ""
	    }

	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actTime [$tbl cellcget $row,actTime -text]
	    set actClock [clock scan [formatTime $actTime] -base $text]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actTime -text $actClock
		return $actClock
	    }
	}

	actTime {
	    #
	    # Check whether the last argument is a clock value in seconds
	    #
	    if {![string is digit $text]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    $::msgs($text)
		$tbl rejectinput
		return ""
	    }

	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actDate [$tbl cellcget $row,actDate -text]
	    set actClock [clock scan [formatTime $text] -base $actDate]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actDate -text $actClock
		return $actClock
	    }
	}
    }

    return $text
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/miscWidgets_tile.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates the interactive tablelist cell editing with the aid of Bryan
# Oakley's combobox, the mentry widgets of type "Date" and "Time", and of the
# Tk core entry, spinbox, and checkbutton widgets.
#
# Copyright (c) 2004-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist_tile
package require combobox
package require mentry

wm title . "Serial Line Configuration"

#
# Add some entries to the Tk option database
#
set dir [file dirname [info script]]
source [file join $dir option_tile.tcl]
option add *Tablelist*Checkbutton.background		white
option add *Tablelist*Checkbutton.activeBackground	white
option add *Tablelist*Entry.background			white
option add *Tablelist*Spinbox.background		white
option add *Tablelist*Spinbox.readonlyBackground	white
option add *Tablelist*Combobox.background		white
option add *Tablelist*Combobox.elementBorderWidth	2
option add *Tablelist*Mentry.background			white

#
# Register Bryan Oakley's combobox widget as well as the mentry
# widgets of type "Date" and "Time" for interactive cell editing
#
tablelist::addOakleyCombobox
tablelist::addDateMentry Ymd -
tablelist::addTimeMentry HMS :

#
# Create two images, to be displayed in tablelist cells with boolean values
#
set checkedImg   [image create photo -file [file join $dir checked.gif]]
set uncheckedImg [image create photo -file [file join $dir unchecked.gif]]

#
# Improve the window's appearance by using a tile
# frame as a container for the other widgets
#
set f [ttk::frame .f]

#
# Create a tablelist widget with editable columns (except the first one)
#
set tbl $f.tbl
tablelist::tablelist $tbl \
    -columns {0 "No."		  right
	      0 "Available"	  center
	      0 "Name"		  left
	      0 "Baud Rate"	  right
	      0 "Data Bits"	  center
	      0 "Parity"	  left
	      0 "Stop Bits"	  center
	      0 "Handshake"	  left
	      0 "Activation Date" center
	      0 "Activation Time" center} \
    -editstartcommand editStartCmd -editendcommand editEndCmd \
    -height 0 -width 0
if {[$tbl cget -selectborderwidth] == 0} {
    $tbl configure -spacing 1
}
$tbl columnconfigure 0 -sortmode integer
$tbl columnconfigure 1 -name available -editable yes -editwindow checkbutton \
    -formatcommand emptyStr
$tbl columnconfigure 2 -name lineName  -editable yes -editwindow entry \
    -sortmode dictionary
$tbl columnconfigure 3 -name baudRate  -editable yes -editwindow combobox \
    -sortmode integer
$tbl columnconfigure 4 -name dataBits  -editable yes -editwindow spinbox
$tbl columnconfigure 5 -name parity    -editable yes -editwindow combobox
$tbl columnconfigure 6 -name stopBits  -editable yes -editwindow combobox
$tbl columnconfigure 7 -name handshake -editable yes -editwindow combobox
$tbl columnconfigure 8 -name actDate   -editable yes -editwindow dateMentry \
    -formatcommand formatDate -sortmode integer
$tbl columnconfigure 9 -name actTime   -editable yes -editwindow timeMentry \
    -formatcommand formatTime -sortmode integer

proc emptyStr   val { return "" }
proc formatDate val { return [clock format $val -format "%Y-%m-%d"] }
proc formatTime val { return [clock format $val -format "%H:%M:%S"] }

#
# Populate the tablelist widget; set the activation
# date & time to 10 minutes past the current clock value
#
set clock [clock seconds]
incr clock 600
for {set n 1} {$n <= 8} {incr n} {
    $tbl insert end [list $n 1 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $checkedImg
}
for {set n 9} {$n <= 16} {incr n} {
    $tbl insert end [list $n 0 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $uncheckedImg
}

set btn [ttk::button $f.btn -text "Close" -command exit]

#
# Manage the widgets
#
pack $btn -side bottom -pady 10
pack $tbl -side top -expand yes -fill both
pack $f -expand yes -fill both

#------------------------------------------------------------------------------
# editStartCmd
#
# Applies some configuration options to the edit window; if the latter is a
# combobox, the procedure populates it.
#------------------------------------------------------------------------------
proc editStartCmd {tbl row col text} {
    set w [$tbl editwinpath]

    switch [$tbl columncget $col -name] {
	lineName {
	    #
	    # Set an upper limit of 20 for the number of characters
	    #
	    wcb::callback $w before insert {wcb::checkEntryLen 20}
	}

	baudRate {
	    #
	    # Populate the combobox and allow no more
	    # than 6 digits in its entry component
	    #
	    $w list insert end 50 75 110 300 1200 2400 4800 9600 19200 38400 \
			       57600 115200 230400 460800 921600
	    wcb::callback [$tbl entrypath] before insert \
		{wcb::checkEntryLen 6} {wcb::checkStrForRegExp {^[0-9]*$}}
	}

	dataBits {
	    #
	    # Configure the spinbox
	    #
	    $w configure -from 5 -to 8 -state readonly
	}

	parity {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w list insert end None Even Odd Mark Space
	    $w configure -editable no
	}

	stopBits {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w list insert end 1 1.5 2
	    $w configure -editable no
	}

	handshake {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w list insert end XON/XOFF RTS/CTS None
	    $w configure -editable no
	}

	actDate -
	actTime {
	    #
	    # Configure the mentry widget
	    #
	    $w configure -justify center
	}
    }

    return $text
}

#
# Message strings corresponding to the values
# returned by mentry::getClockVal on failure
#
array set msgs {
    EMPTY	"Field value missing"
    BAD		"Invalid field value"
    BAD_DATE	"Invalid date"
    BAD_YEAR	"Unsupported year"
}

#------------------------------------------------------------------------------
# editEndCmd
#
# Performs a final validation of the text contained in the edit window and gets
# the cell's internal contents.
#------------------------------------------------------------------------------
proc editEndCmd {tbl row col text} {
    switch [$tbl columncget $col -name] {
	available {
	    #
	    # Update the image contained in the cell
	    #
	    set img [expr {$text ? $::checkedImg : $::uncheckedImg}]
	    $tbl cellconfigure $row,$col -image $img
	}

	baudRate {
	    #
	    # Check whether the baud rate is an integer in the range 50..921600
	    #
	    if {![regexp {^[0-9]+$} $text] || $text < 50 || $text > 921600} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The baud rate must be an integer in the range 50..921600"
		$tbl rejectinput
	    }
	}

	actDate {
	    #
	    # Check whether the last argument is a clock value in seconds
	    #
	    if {![string is digit $text]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    $::msgs($text)
		$tbl rejectinput
		return ""
	    }

	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actTime [$tbl cellcget $row,actTime -text]
	    set actClock [clock scan [formatTime $actTime] -base $text]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actTime -text $actClock
		return $actClock
	    }
	}

	actTime {
	    #
	    # Check whether the last argument is a clock value in seconds
	    #
	    if {![string is digit $text]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    $::msgs($text)
		$tbl rejectinput
		return ""
	    }

	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actDate [$tbl cellcget $row,actDate -text]
	    set actClock [clock scan [formatTime $text] -base $actDate]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actDate -text $actClock
		return $actClock
	    }
	}
    }

    return $text
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/open.gif.

cannot compute difference between binary files

Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/option.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
#==============================================================================
# Contains some Tk option database settings.
#
# Copyright (c) 2004-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

#
# Get the current windowing system ("x11", "win32", "classic", or "aqua")
#
if {[catch {tk windowingsystem} winSys] != 0} {
    switch $::tcl_platform(platform) {
	unix      { set winSys x11 }
	windows   { set winSys win32 }
	macintosh { set winSys classic }
    }
}

#
# Add some entries to the Tk option database
#
switch $winSys {
    x11 {
	#
	# Create the font TkDefaultFont if not yet present
	#
	catch {font create TkDefaultFont -family Helvetica -size -12}

	option add *Font		TkDefaultFont
	option add *selectBackground	#678db2
	option add *selectForeground	white
    }
    classic {
	option add *background		#dedede
    }
}
option add *Tablelist.background	gray98
option add *Tablelist.stripeBackground	#e0e8f0
option add *Tablelist.setGrid		yes
option add *Tablelist.movableColumns	yes
option add *Tablelist.labelCommand	tablelist::sortByColumn
option add *Tablelist.labelCommand2	tablelist::addToSortColumns
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/option_tile.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
#==============================================================================
# Contains some Tk option database settings.
#
# Copyright (c) 2004-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

#
# Get the current windowing system ("x11", "win32", or
# "aqua") and add some entries to the Tk option database
#
if {[tk windowingsystem] eq "x11"} {
    tablelist::setTheme alt
    option add *Font		  TkDefaultFont
}
tablelist::setThemeDefaults
if {[tablelist::getCurrentTheme] eq "aqua"} {
    option add *Listbox.selectBackground \
	       $tablelist::themeDefaults(-selectbackground)
    option add *Listbox.selectForeground \
	       $tablelist::themeDefaults(-selectforeground)
} else {
    option add *selectBackground  $tablelist::themeDefaults(-selectbackground)
    option add *selectForeground  $tablelist::themeDefaults(-selectforeground)
}
option add *selectBorderWidth     $tablelist::themeDefaults(-selectborderwidth)
option add *Tablelist.background	gray98
option add *Tablelist.stripeBackground	#e0e8f0
option add *Tablelist.setGrid		yes
option add *Tablelist.movableColumns	yes
option add *Tablelist.labelCommand	tablelist::sortByColumn
option add *Tablelist.labelCommand2	tablelist::addToSortColumns
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/styles.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates some ways of improving the look & feel of a tablelist widget.
#
# Copyright (c) 2002-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist

wm title . "Tablelist Styles"

#
# Get the current windowing system ("x11", "win32", "classic",
# or "aqua") and add some entries to the Tk option database
#
if {[catch {tk windowingsystem} winSys] != 0} {
    switch $::tcl_platform(platform) {
	unix      { set winSys x11 }
	windows   { set winSys win32 }
	macintosh { set winSys classic }
    }
}
switch $winSys {
    x11 {
	#
	# Create the font TkDefaultFont if not yet present
	#
	catch {font create TkDefaultFont -family Helvetica -size -12}

	option add *Font		TkDefaultFont
	option add *selectBackground	#678db2
	option add *selectForeground	white
    }
    classic {
	option add *background		#dedede
    }
}

#
# Create, configure, and populate 8 tablelist widgets
#
frame .f
for {set n 0} { $n < 8} {incr n} {
    set tbl .f.tbl$n
    tablelist::tablelist $tbl \
    	-columns {0 "Label 0"  0 "Label 1"  0 "Label 2"  0 "Label 3"} \
	-background gray98 -height 4 -width 40 -stretch all
    if {[$tbl cget -selectborderwidth] == 0} {
	$tbl configure -spacing 1
    }

    switch $n {
	1 {
	    $tbl configure -showseparators yes
	}
	2 {
	    $tbl configure -stripebackground #e0e8f0
	}
	3 {
	    $tbl configure -stripebackground #e0e8f0 -showseparators yes
	}
	4 {
	    foreach col {1 3} {
		$tbl columnconfigure $col -background ivory
	    }
	}
	5 {
	    $tbl configure -showseparators yes
	    foreach col {1 3} {
		$tbl columnconfigure $col -background ivory
	    }
	}
	6 {
	    $tbl configure -stripebackground #e0e8f0
	    foreach col {1 3} {
		$tbl columnconfigure $col -background ivory
	    }
	}
	7 {
	    $tbl configure -stripebackground #e0e8f0 -showseparators yes
	    foreach col {1 3} {
		$tbl columnconfigure $col -background ivory
	    }
	}
    }

    foreach row {0 1 2 3} {
	$tbl insert end \
	     [list "Cell $row,0" "Cell $row,1" "Cell $row,2" "Cell $row,3"]
    }
}

button .close -text "Close" -command exit
frame .bottom -height 10

#
# Manage the widgets
#
grid .f.tbl0 .f.tbl1 -sticky news -padx 5 -pady 5
grid .f.tbl2 .f.tbl3 -sticky news -padx 5 -pady 5
grid .f.tbl4 .f.tbl5 -sticky news -padx 5 -pady 5
grid .f.tbl6 .f.tbl7 -sticky news -padx 5 -pady 5
grid rowconfigure    .f {0 1 2 3} -weight 1
grid columnconfigure .f {0 1}     -weight 1
pack .bottom .close -side bottom
pack .f -side top -expand yes -fill both -padx 5 -pady 5
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/styles_tile.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates some ways of improving the look & feel of a tablelist widget.
#
# Copyright (c) 2002-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist_tile

wm title . "Tablelist Styles"

#
# Get the current windowing system ("x11", "win32", or
# "aqua") and add some entries to the Tk option database
#
if {[tk windowingsystem] eq "x11"} {
    tablelist::setTheme alt
}
tablelist::setThemeDefaults
if {[tablelist::getCurrentTheme] ne "aqua"} {
    option add *selectBackground  $tablelist::themeDefaults(-selectbackground)
    option add *selectForeground  $tablelist::themeDefaults(-selectforeground)
    option add *selectBorderWidth $tablelist::themeDefaults(-selectborderwidth)
}

#
# Improve the window's appearance by using a tile
# frame as a container for the other widgets
#
set f [ttk::frame .f]

#
# Create, configure, and populate 8 tablelist widgets
#
ttk::frame $f.f
for {set n 0} { $n < 8} {incr n} {
    set tbl $f.f.tbl$n
    tablelist::tablelist $tbl \
    	-columns {0 "Label 0"  0 "Label 1"  0 "Label 2"  0 "Label 3"} \
	-background gray98 -height 4 -width 40 -stretch all
    if {[$tbl cget -selectborderwidth] == 0} {
	$tbl configure -spacing 1
    }

    switch $n {
	1 {
	    $tbl configure -showseparators yes
	}
	2 {
	    $tbl configure -stripebackground #e0e8f0
	}
	3 {
	    $tbl configure -stripebackground #e0e8f0 -showseparators yes
	}
	4 {
	    foreach col {1 3} {
		$tbl columnconfigure $col -background ivory
	    }
	}
	5 {
	    $tbl configure -showseparators yes
	    foreach col {1 3} {
		$tbl columnconfigure $col -background ivory
	    }
	}
	6 {
	    $tbl configure -stripebackground #e0e8f0
	    foreach col {1 3} {
		$tbl columnconfigure $col -background ivory
	    }
	}
	7 {
	    $tbl configure -stripebackground #e0e8f0 -showseparators yes
	    foreach col {1 3} {
		$tbl columnconfigure $col -background ivory
	    }
	}
    }

    foreach row {0 1 2 3} {
	$tbl insert end \
	     [list "Cell $row,0" "Cell $row,1" "Cell $row,2" "Cell $row,3"]
    }
}

ttk::button $f.close -text "Close" -command exit
frame $f.bottom -height 10

#
# Manage the widgets
#
grid $f.f.tbl0 $f.f.tbl1 -sticky news -padx 5 -pady 5
grid $f.f.tbl2 $f.f.tbl3 -sticky news -padx 5 -pady 5
grid $f.f.tbl4 $f.f.tbl5 -sticky news -padx 5 -pady 5
grid $f.f.tbl6 $f.f.tbl7 -sticky news -padx 5 -pady 5
grid rowconfigure    $f.f {0 1 2 3} -weight 1
grid columnconfigure $f.f {0 1}     -weight 1
pack $f.bottom $f.close -side bottom
pack $f.f -side top -expand yes -fill both -padx 5 -pady 5
pack $f -expand yes -fill both
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/tileWidgets.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}

#==============================================================================
# Demonstrates the interactive tablelist cell editing with the aid of some
# widgets from the tile package and of the Tk core spinbox widget.
#
# Copyright (c) 2005-2009  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================

package require tablelist_tile

wm title . "Serial Line Configuration"

#
# Add some entries to the Tk option database
#
set dir [file dirname [info script]]
source [file join $dir option_tile.tcl]
option add *Tablelist*Spinbox.background		white
option add *Tablelist*Spinbox.readonlyBackground	white

#
# Create two images, to be displayed in tablelist cells with boolean values
#
set checkedImg   [image create photo -file [file join $dir checked.gif]]
set uncheckedImg [image create photo -file [file join $dir unchecked.gif]]

#
# Improve the window's appearance by using a tile
# frame as a container for the other widgets
#
set f [ttk::frame .f]

#
# Work around the improper appearance of the tile scrollbars in the aqua theme
#
if {[tablelist::getCurrentTheme] eq "aqua"} {
    interp alias {} ttk::scrollbar {} ::scrollbar
}

#
# Create a tablelist widget with editable columns (except the first one)
#
set tbl $f.tbl
tablelist::tablelist $tbl \
    -columns {0 "No."		  right
	      0 "Available"	  center
	      0 "Name"		  left
	      0 "Baud Rate"	  right
	      0 "Data Bits"	  center
	      0 "Parity"	  left
	      0 "Stop Bits"	  center
	      0 "Handshake"	  left
	      0 "Activation Date" center
	      0 "Activation Time" center} \
    -editstartcommand editStartCmd -editendcommand editEndCmd \
    -height 0 -width 0
if {[$tbl cget -selectborderwidth] == 0} {
    $tbl configure -spacing 1
}
$tbl columnconfigure 0 -sortmode integer
$tbl columnconfigure 1 -name available -editable yes \
    -editwindow ttk::checkbutton -formatcommand emptyStr
$tbl columnconfigure 2 -name lineName  -editable yes -editwindow ttk::entry \
    -sortmode dictionary
$tbl columnconfigure 3 -name baudRate  -editable yes -editwindow ttk::combobox \
    -sortmode integer
$tbl columnconfigure 4 -name dataBits  -editable yes -editwindow spinbox
$tbl columnconfigure 5 -name parity    -editable yes -editwindow ttk::combobox
$tbl columnconfigure 6 -name stopBits  -editable yes -editwindow ttk::combobox
$tbl columnconfigure 7 -name handshake -editable yes -editwindow ttk::combobox
$tbl columnconfigure 8 -name actDate   -editable yes -editwindow ttk::entry \
    -formatcommand formatDate -sortmode integer
$tbl columnconfigure 9 -name actTime   -editable yes -editwindow ttk::entry \
    -formatcommand formatTime -sortmode integer

proc emptyStr   val { return "" }
proc formatDate val { return [clock format $val -format "%Y-%m-%d"] }
proc formatTime val { return [clock format $val -format "%H:%M:%S"] }

#
# Populate the tablelist widget; set the activation
# date & time to 10 minutes past the current clock value
#
set clock [clock seconds]
incr clock 600
for {set n 1} {$n <= 8} {incr n} {
    $tbl insert end [list $n 1 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $checkedImg
}
for {set n 9} {$n <= 16} {incr n} {
    $tbl insert end [list $n 0 "Line $n" 9600 8 None 1 XON/XOFF $clock $clock]
    $tbl cellconfigure end,available -image $uncheckedImg
}

set btn [ttk::button $f.btn -text "Close" -command exit]

#
# Manage the widgets
#
pack $btn -side bottom -pady 10
pack $tbl -side top -expand yes -fill both
pack $f -expand yes -fill both

#------------------------------------------------------------------------------
# editStartCmd
#
# Applies some configuration options to the edit window; if the latter is a
# combobox, the procedure populates it.
#------------------------------------------------------------------------------
proc editStartCmd {tbl row col text} {
    set w [$tbl editwinpath]

    switch [$tbl columncget $col -name] {
	lineName {
	    #
	    # Set an upper limit of 20 for the number of characters
	    #
	    $w configure -invalidcommand bell -validate key \
			 -validatecommand {expr {[string length %P] <= 20}}
	}

	baudRate {
	    #
	    # Populate the combobox and allow no more
	    # than 6 digits in its entry component
	    #
	    $w configure -values {50 75 110 300 1200 2400 4800 9600 19200 38400
				  57600 115200 230400 460800 921600}
	    $w configure -invalidcommand bell -validate key -validatecommand \
		{expr {[string length %P] <= 6 && [regexp {^[0-9]*$} %S]}}
	}

	dataBits {
	    #
	    # Configure the spinbox
	    #
	    $w configure -from 5 -to 8 -state readonly
	}

	parity {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w configure -values {None Even Odd Mark Space} -state readonly
	}

	stopBits {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w configure -values {1 1.5 2} -state readonly
	}

	handshake {
	    #
	    # Populate the combobox and make it non-editable
	    #
	    $w configure -values {XON/XOFF RTS/CTS None} -state readonly
	}

	actDate {
	    #
	    # Set an upper limit of 10 for the number of characters
	    # and allow only digits and the "-" character in it
	    #
	    $w configure -invalidcommand bell -validate key -validatecommand \
		{expr {[string length %P] <= 10 && [regexp {^[0-9-]*$} %S]}}
	}

	actTime {
	    #
	    # Set an upper limit of 8 for the number of characters
	    # and allow only digits and the ":" character in it
	    #
	    $w configure -invalidcommand bell -validate key -validatecommand \
		{expr {[string length %P] <= 8 && [regexp {^[0-9:]*$} %S]}}
	}
    }

    return $text
}

#------------------------------------------------------------------------------
# editEndCmd
#
# Performs a final validation of the text contained in the edit window and gets
# the cell's internal contents.
#------------------------------------------------------------------------------
proc editEndCmd {tbl row col text} {
    switch [$tbl columncget $col -name] {
	available {
	    #
	    # Update the image contained in the cell
	    #
	    set img [expr {$text ? $::checkedImg : $::uncheckedImg}]
	    $tbl cellconfigure $row,$col -image $img
	}

	baudRate {
	    #
	    # Check whether the baud rate is an integer in the range 50..921600
	    #
	    if {![regexp {^[0-9]+$} $text] || $text < 50 || $text > 921600} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The baud rate must be an integer in the range 50..921600"
		$tbl rejectinput
	    }
	}

	actDate {
	    #
	    # Get the activation date in seconds from the last argument 
	    #
	    if {[catch {clock scan $text} actDate] != 0} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "Invalid date"
		$tbl rejectinput
		return ""
	    }

	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    set actTime [$tbl cellcget $row,actTime -text]
	    set actClock [clock scan [formatTime $actTime] -base $actDate]
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actTime -text $actClock
		return $actClock
	    }
	}

	actTime {
	    #
	    # Get the activation clock value in seconds from the last argument 
	    #
	    set actDate [$tbl cellcget $row,actDate -text]
	    if {[catch {clock scan $text -base $actDate} actClock] != 0} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "Invalid time"
		$tbl rejectinput
		return ""
	    }

	    #
	    # Check whether the activation clock value is later than the
	    # current one; if this is the case then make sure the cells
	    # "actDate" and "actTime" will have the same internal value
	    #
	    if {$actClock <= [clock seconds]} {
		bell
		tk_messageBox -title Error -icon error -type ok -message \
		    "The activation date & time must be in the future"
		$tbl rejectinput
	    } else {
		$tbl cellconfigure $row,actDate -text $actClock
		return $actClock
	    }
	}
    }

    return $text
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tklib_examples0.5/tablelist/unchecked.gif.

cannot compute difference between binary files

Deleted scriptlibs/tklib0.5/tklib_examples0.5/widget/screenruler.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
#!/usr/bin/env tclsh

package require Tk 8.4
set noimg [catch {package require img::png}] ; # for saving images

# We are the main script being run - show ourselves
wm withdraw .

package require widget::screenruler
set dlg [widget::screenruler .r -title "Screen Ruler" -width 250 -height 100]

if {[tk windowingsystem] eq "aqua"} {
    set CTRL    "Command-"
    set CONTROL Command
} else {
    set CTRL    Ctrl+
    set CONTROL Control
}

upvar \#0 [$dlg info vars reflect] reflect
if {[lsearch -exact [image names] $reflect(image)] != -1} {
    # We have a reflectable desktop

    $dlg menu add separator
    $dlg menu add command -label "Save Image" -accelerator ${CTRL}s \
	-underline 0 -command [list save $dlg]
    bind $dlg <$CONTROL-s> [list save $dlg]
}

if {[tk windowingsystem] eq "x11"} {
    # Add hack to control overrideredirect as some wms (eg KDE) have focus
    # issues on the overrideredirect window
    set override [expr {![wm overrideredirect $dlg]}]
    $dlg menu add separator
    $dlg menu add checkbutton -label "Window Decoration" -variable ::override \
	-command [list override $dlg]
    proc override {w} {
	wm withdraw $w
	wm overrideredirect $w [expr {! $::override}]
	wm deiconify $w
    }
    wm protocol $dlg WM_DELETE_WINDOW exit
}

$dlg menu add separator
$dlg menu add command -label "Exit" \
    -underline 1 -accelerator ${CTRL}q -command { exit }
bind $dlg <$CONTROL-q> { exit }

package require comm
$dlg menu add separator
$dlg menu add command -label "COMM: [comm::comm self]" -state disabled

focus -force $dlg
$dlg display
$dlg configure -alpha 0.8

if {$::argc} {
    eval [linsert $argv 0 $dlg configure]
}

set LASTDIR  [pwd]

proc save {dlg} {
    global LASTDIR
    variable [$dlg info vars reflect]
    after cancel $reflect(id)

    if {$::noimg} {
	set filetypes {
	    {"All Image Files" {.gif .ppm}}
	}
	set re {\.(gif|ppm)$}
    } else {
	set filetypes {
	    {"All Image Files" {.gif .png .ppm}}
	    {"PNG Images" .png}
	}
	set re {\.(gif|ppm|png)$}
    }
    lappend filetypes {"GIF Images" .gif} {"PPM Images" .ppm} {"All Files" *}
    set file [tk_getSaveFile -parent $dlg -title "Save Image to File" \
		  -initialdir $LASTDIR -filetypes $filetypes]

    if {$file ne ""} {
	set LASTDIR [file dirname $file]
	if {![regexp -nocase $re $file -> ext]} {
	    tk_messageBox -title "Unrecognized Extension" \
		-parent $dlg -icon error -type ok \
		-message "Unknown file type to save for file\
		\"[file tail $file]\"\nPlease use .gif, .ppm or .png."
	} elseif {[catch {$reflect(image) write $file \
			      -format [string tolower $ext]} err]} {
	    tk_messageBox -title "Error Writing File" \
		-parent $dlg -icon error -type ok \
		-message "Error writing to file \"$file\":\n$err"
	}
    }

    $dlg configure -reflect [$dlg cget -reflect]
}

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












































































































































































































Deleted scriptlibs/tklib0.5/tkpiechart/boxlabel.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
# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)

package require Tk 8.3
package require stooop


::stooop::class pieBoxLabeler {

    proc pieBoxLabeler {this canvas args} pieLabeler {$canvas $args} switched {
        $args
    } {
        ::set ($this,array) [::stooop::new canvasLabelsArray $canvas]
        switched::complete $this
    }

    proc ~pieBoxLabeler {this} {
        ::stooop::delete $($this,array)
    }

    proc options {this} {
        # font and justify options are used when creating a new canvas label
        # justify option is used for both the labels array and the labels
        return [list\
            [list -font\
                $pieLabeler::(default,font) $pieLabeler::(default,font)\
            ]\
            [list -justify left left]\
            [list -offset 5 5]\
            [list -xoffset 0 0]\
        ]
    }

    foreach option {-font -justify -offset -xoffset} {
        # no dynamic options allowed
        proc set$option {this value} "
            if {\$switched::(\$this,complete)} {
                error {option $option cannot be set dynamically}
            }
        "
    }

    proc new {this slice args} {
        # variable arguments are for the created canvas label object
        ::set label [eval ::stooop::new canvasLabel\
            $pieLabeler::($this,canvas) $args\
            [list\
                -justify $switched::($this,-justify)\
                -font $switched::($this,-font) -selectrelief sunken\
            ]\
        ]
        canvasLabelsArray::manage $($this,array) $label
        # refresh our tags
        $pieLabeler::($this,canvas) addtag pieLabeler($this)\
            withtag canvasLabelsArray($($this,array))
        # always append semi-column to label:
        switched::configure $label -text [switched::cget $label -text]:
        ::set ($this,selected,$label) 0
        return $label
    }

    proc delete {this label} {
        canvasLabelsArray::delete $($this,array) $label
        unset ($this,selected,$label)
    }

    proc set {this label value} {
        # update string part after last semi-column
        regsub {:[^:]*$} [switched::cget $label -text] ": $value" text
        switched::configure $label -text $text
    }

    proc label {this label args} {
        ::set text [switched::cget $label -text]
        if {[llength $args] == 0} {
            regexp {^(.*):} $text dummy text
            return $text
        } else {                   ;# update string part before last semi-column
            regsub {^.*:} $text [lindex $args 0]: text
            switched::configure $label -text $text
        }
    }

    proc labelBackground {this label args} {
        if {[llength $args] == 0} {
            return [switched::cget $label -background]
        } else {
            switched::configure $label -background [lindex $args 0]
        }
    }

    proc labelTextBackground {this label args} {
        if {[llength $args] == 0} {
            return [switched::cget $label -textbackground]
        } else {
            switched::configure $label -textbackground [lindex $args 0]
        }
    }

    proc selectState {this label {selected {}}} {
        if {[string length $selected] == 0} {
            # return current state if no argument
            return $($this,selected,$label)
        }
        switched::configure $label -select $selected
        ::set ($this,selected,$label) $selected
    }

    proc update {this left top right bottom} {
        # whole pie coordinates, includings labeler labels
        ::set canvas $pieLabeler::($this,canvas)
        # first reposition labels array below pie graphics
        ::set array $($this,array)
        ::set width [expr {$right - $left}]
        if {$width != [switched::cget $array -width]} {
            switched::configure $array -width $width            ;# fit pie width
        } else {
            canvasLabelsArray::update $array
        }
        foreach {x y} [$canvas coords canvasLabelsArray($array)] {}
        $canvas move canvasLabelsArray($array) [expr {$left - $x}]\
            [expr {$bottom - [canvasLabelsArray::height $array] - $y}]
    }

    proc room {this arrayName} {
        upvar 1 $arrayName data

        ::set data(left) 0                        ;# no room taken around slices
        ::set data(right) 0
        ::set data(top) 0
        ::set box\
            [$pieLabeler::($this,canvas) bbox canvasLabelsArray($($this,array))]
        if {[llength $box] == 0} {                              ;# no labels yet
            ::set data(bottom) 0
        } else {                    ;# room taken by all labels including offset
            ::set data(bottom) [expr {\
                [lindex $box 3] - [lindex $box 1] + $switched::($this,-offset)\
            }]
        }
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































Deleted scriptlibs/tklib0.5/tkpiechart/canlabel.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
# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)

package require Tk 8.3
package require stooop


::stooop::class canvasLabel {

    proc canvasLabel {this canvas args} switched {$args} {
        set ($this,canvas) $canvas
        # use an empty image as an origin marker with only 2 coordinates
        set ($this,origin) [$canvas create image 0 0 -tags canvasLabel($this)]
        set ($this,selectRectangle)\
            [$canvas create rectangle 0 0 0 0 -tags canvasLabel($this)]
        set ($this,rectangle)\
            [$canvas create rectangle 0 0 0 0 -tags canvasLabel($this)]
        set ($this,text) [$canvas create text 0 0 -tags canvasLabel($this)]
        switched::complete $this
    }

    proc ~canvasLabel {this} {
        eventuallyDeleteRelief $this
        $($this,canvas) delete canvasLabel($this)
    }

    proc options {this} {                ;# force font for proper initialization
        return [list\
            [list -anchor center center]\
            [list -background {} {}]\
            [list -bordercolor black black]\
            [list -borderwidth 1 1]\
            [list -bulletwidth 10 10]\
            [list -font {Helvetica -12}]\
            [list -foreground black black]\
            [list -justify left left]\
            [list -minimumwidth 0 0]\
            [list -padding 2 2]\
            [list -scale {1 1} {1 1}]\
            [list -select 0 0]\
            [list -selectrelief flat flat]\
            [list -stipple {} {}]\
            [list -text {} {}]\
            [list -textbackground {} {}]\
            [list -width 0 0]\
        ]
    }

    proc set-background {this value} {
        $($this,canvas) itemconfigure $($this,rectangle) -fill $value
    }

    proc set-bordercolor {this value} {
        $($this,canvas) itemconfigure $($this,rectangle) -outline $value
    }

    proc set-borderwidth {this value} {
        if {\
            ![string equal $switched::($this,-selectrelief) flat] &&\
            ($value > 1)\
        } {
            error "border width greater than 1 is not supported with $switched::($this,-selectrelief) select relief"
        }
        $($this,canvas) itemconfigure $($this,selectRectangle) -width $value
        $($this,canvas) itemconfigure $($this,rectangle) -width $value
        update $this
    }

    proc set-foreground {this value} {
        $($this,canvas) itemconfigure $($this,text) -fill $value
    }

    proc set-scale {this value} {
        # value is a list of ratios of the horizontal and vertical axis
        update $this       ;# refresh display which takes new scale into account
    }

    proc set-stipple {this value} {
        $($this,canvas) itemconfigure $($this,rectangle) -stipple $value
    }

    foreach option {\
        -anchor -bulletwidth -minimumwidth -padding -select -textbackground\
    } {
        proc set$option {this value} {update $this}
    }

    foreach option {-font -justify -text -width} {
        proc set$option {this value} "
            \$(\$this,canvas) itemconfigure \$(\$this,text) $option \$value
            update \$this
        "
    }

    proc set-selectrelief {this value} {
        if {![regexp {^(flat|raised|sunken)$} $value]} {
            error "bad relief value \"$value\": must be flat, raised or sunken"
        }
        if {[string equal $value flat]} {
            eventuallyDeleteRelief $this
        } else {
            if {$switched::($this,-borderwidth) > 1} {
                error "border width greater than 1 is not supported with $value select relief"
            }
        }
        update $this
    }

    proc eventuallyDeleteRelief {this} {
        if {[info exists ($this,relief)]} {
            ::stooop::delete $($this,relief)
            unset ($this,relief)
        }
    }

    proc updateRelief {this coordinates} {
        if {$switched::($this,-select)} {
            set relief $switched::($this,-selectrelief)
            if {[string equal $relief flat]} {
                eventuallyDeleteRelief $this
            } else {
                set canvas $($this,canvas)
                if {![info exists ($this,relief)]} {
                    set ($this,relief) [::stooop::new canvasReliefRectangle\
                        $canvas -relief $relief\
                    ]
                    set reliefTag canvasReliefRectangle($($this,relief))
                    foreach tag [$canvas gettags canvasLabel($this)] {
                        # adopt all label tags so moving along works
                        $canvas addtag $tag withtag $reliefTag
                    }
                }
                set background $switched::($this,-textbackground)
                if {[string length $background] == 0} {
                    # emulate transparent background
                    set background [$canvas cget -background]
                }
                switched::configure $($this,relief)\
                    -background $background -coordinates {0 0 0 0}
                switched::configure $($this,relief) -coordinates $coordinates
            }
        } else {
            eventuallyDeleteRelief $this
        }
    }

    proc update {this} {
        set canvas $($this,canvas)
        set rectangle $($this,rectangle)
        set selectRectangle $($this,selectRectangle)
        set text $($this,text)

        foreach {x y} [$canvas coords $($this,origin)] {}

        set border [$canvas itemcget $rectangle -width]
        set textBox [$canvas bbox $text]
        set textWidth [expr {[lindex $textBox 2] - [lindex $textBox 0]}]
        set padding [winfo fpixels $canvas $switched::($this,-padding)]
        set bulletWidth [winfo fpixels $canvas $switched::($this,-bulletwidth)]

        $canvas itemconfigure $selectRectangle -fill {} -outline {}

        # position rectangle and text as if anchor was center (the default)
        set width [expr {$bulletWidth + $border + $padding + $textWidth}]
        set halfHeight [expr {\
            (([lindex $textBox 3] - [lindex $textBox 1]) / 2.0) + $border\
        }]
        if {$width < $switched::($this,-minimumwidth)} {
            set width $switched::($this,-minimumwidth)
        }
        set halfWidth [expr {$width / 2.0}]
        set left [expr {$x - $halfWidth}]
        set top [expr {$y - $halfHeight}]
        set right [expr {$x + $halfWidth}]
        set bottom [expr {$y + $halfHeight}]
        $canvas coords $text [expr {\
            $left + $bulletWidth + $border + $padding + ($textWidth / 2.0)\
        }] $y
        $canvas coords $selectRectangle $left $top $right $bottom
        $canvas coords $rectangle $left $top\
            [expr {$left + $bulletWidth}] $bottom
        $canvas itemconfigure $selectRectangle\
            -fill $switched::($this,-textbackground)\
            -outline $switched::($this,-textbackground)
        updateRelief $this\
            [list [expr {$left + $bulletWidth + 1}] $top $right $bottom]
        # now move rectangle and text according to anchor
        set anchor $switched::($this,-anchor)
        set xDelta [expr {\
            ([string match *w $anchor] - [string match *e $anchor]) *\
            $halfWidth\
        }]
        set yDelta [expr {\
            ([string match n* $anchor] - [string match s* $anchor]) *\
            $halfHeight\
        }]
        $canvas move $rectangle $xDelta $yDelta
        $canvas move $selectRectangle $xDelta $yDelta
        $canvas move $text $xDelta $yDelta
        if {[info exists ($this,relief)]} {
            $canvas move canvasReliefRectangle($($this,relief)) $xDelta $yDelta
        }
        # finally apply scale
        eval $canvas scale canvasLabel($this) $x $y $switched::($this,-scale)
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tkpiechart/labarray.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
# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)

package require Tk 8.3
package require stooop


::stooop::class canvasLabelsArray {

    proc canvasLabelsArray {this canvas args} switched {$args} {
        set ($this,canvas) $canvas
        # use an empty image as an origin marker with only 2 coordinates
        set ($this,origin)\
            [$canvas create image 0 0 -tags canvasLabelsArray($this)]
        set ($this,labels) {}
        switched::complete $this
    }

    proc ~canvasLabelsArray {this} {
        eval ::stooop::delete $($this,labels)
        # delete remaining items
        $($this,canvas) delete canvasLabelsArray($this)
    }

    proc options {this} {
        # force width initialization for internals initialization:
        return [list\
            [list -justify left left]\
            [list -width 100]\
        ]
    }

    proc set-justify {this value} {
        if {$switched::($this,complete)} {
            error {option -justify cannot be set dynamically}
        }
    }

    proc set-width {this value} {
        set ($this,width) [winfo fpixels $($this,canvas) $value]
        update $this
    }

    proc manage {this label} {                          ;# must be a canvasLabel
        $($this,canvas) addtag canvasLabelsArray($this)\
            withtag canvasLabel($label)
        lappend ($this,labels) $label
        update $this
    }

    proc delete {this label} {
        set index [lsearch -exact $($this,labels) $label]
        if {$index < 0} {
            error "invalid label $label for canvas labels array $this"
        }
        set ($this,labels) [lreplace $($this,labels) $index $index]
        ::stooop::delete $label
        update $this
    }

    proc update {this} {
        set canvas $($this,canvas)
        set halfWidth [expr {round($($this,width) / 2.0)}]
        foreach {xOrigin yOrigin} [$canvas coords $($this,origin)] {}
        set x 0; set y 0
        set height 0
        set column 0
        foreach label $($this,labels) {
            foreach {left top right bottom}\
                [$canvas bbox canvasLabel($label)] {}
            set wide [expr {($right - $left) > $halfWidth}]
            if {$wide} {
                # label does not fit in a half width so open a new line
                set x 0; incr y $height; set height 0
            }
            switched::configure $label -anchor nw
            # do an absolute positioning using label tag:
            foreach {xDelta yDelta} [$canvas coords canvasLabel($label)] {}
            $canvas move canvasLabel($label) [expr {$xOrigin + $x - $xDelta}]\
                [expr {$yOrigin + $y - $yDelta}]
            set value [expr {$bottom - $top}]
            if {$value > $height} {         ;# keep track of current line height
                set height $value
            }
            if {([incr x $halfWidth] > $halfWidth) || $wide} {
                set x 0; incr y $height; set height 0
            }
        }
    }

    proc labels {this} {
        return $($this,labels)
    }

    proc height {this} {
        set list [$($this,canvas) bbox canvasLabelsArray($this)]
        if {[llength $list] == 0} {
            return 0
        }
        foreach {left top right bottom} $list {}
        return [expr {$bottom - $top}]
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































Deleted scriptlibs/tklib0.5/tkpiechart/objselec.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
# copyright (C) 1997-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this
# package or use the Help Copyright menu

package require Tk 8.3
package require stooop

# $Id: objselec.tcl,v 1.13 2006/01/27 19:05:52 andreas_kupries Exp $

# implements selection on a list of object identifiers (sortable list of
# integers), for a listbox implementation, for example

::stooop::class objectSelector {

    proc objectSelector {this args} selector {$args} {}

    proc ~objectSelector {this} {}

    ### public procedures follow:

    proc extend {this id} {
        if {[info exists selector::($this,lastSelected)]} {
            set list [lsort -integer [selector::list $this]]
            set last [lsearch -exact $list $selector::($this,lastSelected)]
            set index [lsearch -exact $list $id]
            selector::clear $this
            if {$index > $last} {
                selector::set $this [lrange $list $last $index] 1
            } else {
                selector::set $this [lrange $list $index $last] 1
            }
        } else {
            selector::select $this $id
        }
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































Deleted scriptlibs/tklib0.5/tkpiechart/perilabel.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
# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)

package require Tk 8.3
package require stooop


::stooop::class piePeripheralLabeler {

    variable PI 3.14159265358979323846

    proc piePeripheralLabeler {this canvas args} pieLabeler {$canvas $args}\
        switched {$args} {
        switched::complete $this
        ::set ($this,array) [::stooop::new canvasLabelsArray $canvas\
            -justify $switched::($this,-justify)\
        ]
        ::set ($this,valueWidth) [font measure\
            $switched::($this,-smallfont) $switched::($this,-widestvaluetext)\
        ]
        ::set ($this,valueHeight)\
            [font metrics $switched::($this,-smallfont) -ascent]
    }

    proc ~piePeripheralLabeler {this} {
        ::stooop::delete $($this,array)
        # delete remaining items (should be in pieLabeler destructor)
        $pieLabeler::($this,canvas) delete pieLabeler($this)
    }

    proc options {this} {
        # bullet width, font and justify options are used when creating a new
        # canvas label
        # justify option is used for both the labels array and the labels
        return [list\
            [list -bulletwidth 20 20]\
            [list -font\
                $pieLabeler::(default,font) $pieLabeler::(default,font)\
            ]\
            [list -justify left left]\
            [list -offset 5 5]\
            [list -smallfont {Helvetica -10} {Helvetica -10}]\
            [list -widestvaluetext 0.00 0.00]\
        ]
    }

    foreach option {\
        -bulletwidth -font -justify -offset -smallfont -widestvaluetext\
    } {                                            ;# no dynamic options allowed
        proc set$option {this value} "
            if {\$switched::(\$this,complete)} {
                error {option $option cannot be set dynamically}
            }
        "
    }

    proc set-smallfont {this value} {
        if {$switched::($this,complete)} {
            error {option -smallfont cannot be set dynamically}
        }
    }

    proc new {this slice args} {
        # variable arguments are for the created canvas label object
        ::set canvas $pieLabeler::($this,canvas)
        ::set text [$canvas create text 0 0\
            -font $switched::($this,-smallfont) -tags pieLabeler($this)\
        ]                                                  ;# create value label
        ::set label [eval ::stooop::new canvasLabel\
            $pieLabeler::($this,canvas) $args\
            [list\
                -justify $switched::($this,-justify)\
                -bulletwidth $switched::($this,-bulletwidth)\
                -font $switched::($this,-font) -selectrelief sunken\
            ]\
        ]
        canvasLabelsArray::manage $($this,array) $label
        $canvas addtag pieLabeler($this)\
            withtag canvasLabelsArray($($this,array))        ;# refresh our tags
        # value text item is the only one to update
        ::set ($this,textItem,$label) $text
        ::set ($this,slice,$label) $slice
        ::set ($this,selected,$label) 0
        return $label
    }

    proc anglePosition {degrees} {
        # quadrant specific index with added value for exact quarters
        return [expr {(2 * ($degrees / 90)) + (($degrees % 90) != 0)}]
    }

    ::set index 0     ;# build angle position / value label anchor mapping array
    foreach anchor {w sw s se e ne n nw} {
        ::set (anchor,[anglePosition [expr {$index * 45}]]) $anchor
        incr index
    }
    unset index anchor

    proc set {this label value} {
        ::set text $($this,textItem,$label)
        position $this $text $($this,slice,$label)
        $pieLabeler::($this,canvas) itemconfigure $text -text $value
    }

    proc label {this label args} {
        if {[llength $args] == 0} {
            return [switched::cget $label -text]
        } else {
            switched::configure $label -text [lindex $args 0]
        }
    }

    proc labelBackground {this label args} {
        if {[llength $args] == 0} {
            return [switched::cget $label -background]
        } else {
            switched::configure $label -background [lindex $args 0]
        }
    }

    proc labelTextBackground {this label args} {
        if {[llength $args] == 0} {
            return [switched::cget $label -textbackground]
        } else {
            switched::configure $label -textbackground [lindex $args 0]
        }
    }

    proc position {this text slice} {
        # place the value text item next to the outter border of the
        # corresponding slice
        variable PI

        # retrieve current slice position and dimensions
        slice::data $slice data
        # calculate text closest point coordinates in normal coordinates system
        # (y increasing in north direction)
        ::set midAngle [expr {$data(start) + ($data(extent) / 2.0)}]
        ::set radians [expr {$midAngle * $PI / 180}]
        ::set x [expr {\
            ($data(xRadius) + $switched::($this,-offset)) * cos($radians)\
        }]
        ::set y [expr {\
            ($data(yRadius) + $switched::($this,-offset)) * sin($radians)\
        }]
        ::set angle [expr {round($midAngle) % 360}]
        if {$angle > 180} {
            ::set y [expr {$y - $data(height)}]     ;# account for pie thickness
        }

        ::set canvas $pieLabeler::($this,canvas)
        # now transform coordinates according to canvas coordinates system
        ::set coordinates [$canvas coords $text]
        $canvas move $text\
            [expr {$data(xCenter) + $x - [lindex $coordinates 0]}]\
            [expr {$data(yCenter) - $y - [lindex $coordinates 1]}]
        # finally set anchor according to which point of the text is closest to
        # pie graphics
        $canvas itemconfigure $text -anchor $(anchor,[anglePosition $angle])
    }

    proc delete {this label} {
        canvasLabelsArray::delete $($this,array) $label
        $pieLabeler::($this,canvas) delete $($this,textItem,$label)
        unset\
            ($this,textItem,$label) ($this,slice,$label) ($this,selected,$label)
        # finally reposition the remaining value text items next to their slices
        foreach label [canvasLabelsArray::labels $($this,array)] {
            position $this $($this,textItem,$label) $($this,slice,$label)
        }
    }

    proc selectState {this label {selected {}}} {
        if {[string length $selected] == 0} {
            # return current state if no argument
            return $($this,selected,$label)
        }
        switched::configure $label -select $selected
        ::set ($this,selected,$label) $selected
    }

    proc update {this left top right bottom} {
        # arguments: whole pie coordinates, includings labeler labels
        ::set canvas $pieLabeler::($this,canvas)
        # first reposition labels array below pie graphics
        ::set array $($this,array)
        ::set width [expr {$right - $left}]
        if {$width != [switched::cget $array -width]} {
            switched::configure $array -width $width            ;# fit pie width
        } else {
            canvasLabelsArray::update $array
        }
        foreach {x y} [$canvas coords canvasLabelsArray($array)] {}
        $canvas move canvasLabelsArray($array) [expr {$left - $x}]\
            [expr {$bottom - [canvasLabelsArray::height $array] - $y}]
    }

    proc updateSlices {this left top right bottom} {
        foreach label [canvasLabelsArray::labels $($this,array)] {
            # position peripheral labels
            position $this $($this,textItem,$label) $($this,slice,$label)
        }
    }

    proc room {this arrayName} {
        upvar 1 $arrayName data

        ::set data(left)\
            [expr {$($this,valueWidth) + $switched::($this,-offset)}]
        ::set data(right) $data(left)
        ::set data(top)\
            [expr {$switched::($this,-offset) + $($this,valueHeight)}]
        ::set box\
            [$pieLabeler::($this,canvas) bbox canvasLabelsArray($($this,array))]
        if {[llength $box] == 0} {                              ;# no labels yet
            ::set data(bottom) $data(top)
        } else {                    ;# room taken by all labels including offset
            ::set data(bottom)\
                [expr {$data(top) + [lindex $box 3] - [lindex $box 1]}]
        }
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tkpiechart/pie.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
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
# $Id: pie.tcl,v 2.25 2006/01/27 19:05:52 andreas_kupries Exp $

package require Tk 8.3
package require stooop


::stooop::class pie {
    set (colors) [list\
        #7FFFFF #FFFF7F #FF7F7F #7FFF7F #7F7FFF #FFBF00 #BFBFBF #FF7FFF #FFFFFF\
    ]
}

proc pie::pie {this canvas x y args} switched {$args} {
    # note: all pie elements are tagged with pie($this)
    set ($this,canvas) $canvas
    set ($this,colorIndex) 0
    set ($this,slices) {}
    # use an empty image as an origin marker with only 2 coordinates
    set ($this,origin) [$canvas create image $x $y -tags pie($this)]
    switched::complete $this
    # wait till all options have been set for initial configuration
    complete $this
}

proc pie::~pie {this} {
    if {[info exists ($this,title)]} {                    ;# title may not exist
        $($this,canvas) delete $($this,title)
    }
    ::stooop::delete $($this,labeler)
    eval ::stooop::delete $($this,slices) $($this,backgroundSlice)
    if {[info exists ($this,selector)]} {              ;# selector may not exist
        ::stooop::delete $($this,selector)
    }
    $($this,canvas) delete $($this,origin)
}

proc pie::options {this} {
    # force height, thickness title font and width options so that corresponding
    # members are properly initialized
    return [list\
        [list -autoupdate 1 1]\
        [list -background {} {}]\
        [list -colors $(colors) $(colors)]\
        [list -height 200]\
        [list -labeler 0 0]\
        [list -selectable 0 0]\
        [list -thickness 0]\
        [list -title {} {}]\
        [list -titlefont {Helvetica -12 bold} {Helvetica -12 bold}]\
        [list -titleoffset 2 2]\
        [list -width 200]\
    ]
}

proc pie::set-autoupdate {this value} {}

# no dynamic options allowed: see complete
foreach option {\
    -background -colors -labeler -selectable -title -titlefont -titleoffset\
} {
    proc pie::set$option {this value} "
        if {\$switched::(\$this,complete)} {
            error {option $option cannot be set dynamically}
        }
    "
}

proc pie::set-thickness {this value} {
    if {$switched::($this,complete)} {
        error {option -thickness cannot be set dynamically}
    }
    # convert to pixels
    set ($this,thickness) [winfo fpixels $($this,canvas) $value]
}

# size is first converted to pixels, then 1 pixel is subtracted since slice size
# is half the pie size and pie center takes 1 pixel
proc pie::set-height {this value} {
    # value is height is slices height not counting thickness
    set ($this,height) [expr {[winfo fpixels $($this,canvas) $value] - 1}]
    if {$switched::($this,complete)} {
        update $this
    } else {      ;# keep track of initial value for latter scaling calculations
        set ($this,initialHeight) $($this,height)
    }
}
proc pie::set-width {this value} {
    set ($this,width) [expr {[winfo fpixels $($this,canvas) $value] - 1}]
    if {$switched::($this,complete)} {
        update $this
    } else {      ;# keep track of initial value for latter scaling calculations
        set ($this,initialWidth) $($this,width)
    }
}

proc pie::complete {this} {                          ;# no user slices exist yet
    set canvas $($this,canvas)

    if {$switched::($this,-labeler) == 0} {
        # use default labeler if user defined none
        set ($this,labeler) [::stooop::new pieBoxLabeler $canvas]
    } else {                                         ;# use user defined labeler
        set ($this,labeler) $switched::($this,-labeler)
    }
    $canvas addtag pie($this) withtag pieLabeler($($this,labeler))
    if {[string length $switched::($this,-background)] == 0} {
        set bottomColor {}
    } else {
        set bottomColor [darken $switched::($this,-background) 60]
    }
    set slice [::stooop::new slice\
        $canvas [expr {$($this,initialWidth) / 2}]\
        [expr {$($this,initialHeight) / 2}]\
        -startandextent {90 360} -height $($this,thickness)\
        -topcolor $switched::($this,-background) -bottomcolor $bottomColor\
    ]
    $canvas addtag pie($this) withtag slice($slice)
    $canvas addtag pieSlices($this) withtag slice($slice)
    set ($this,backgroundSlice) $slice
    if {[string length $switched::($this,-title)] == 0} {
        set ($this,titleRoom) 0
    } else {
        set ($this,title) [$canvas create text 0 0\
            -anchor n -text $switched::($this,-title)\
            -font $switched::($this,-titlefont) -tags pie($this)\
        ]
        set ($this,titleRoom) [expr {\
            [font metrics $switched::($this,-titlefont) -ascent] +\
            [winfo fpixels $canvas $switched::($this,-titleoffset)]\
        }]
    }
    update $this
}

proc pie::newSlice {this {text {}} {color {}}} {
    set canvas $($this,canvas)

    # calculate start radian for new slice
    # (slices grow clockwise from 12 o'clock)
    set start 90
    foreach slice $($this,slices) {
        set start [expr {$start - $slice::($slice,extent)}]
    }
    if {[string length $color] == 0} {
        # get a new color
        set color [lindex $switched::($this,-colors) $($this,colorIndex)]
        set ($this,colorIndex) [expr {\
            ($($this,colorIndex) + 1) % [llength $switched::($this,-colors)]\
        }]                                              ;# circle through colors
    }
    # darken slice top color by 40% to obtain bottom color, as it is done for
    # Tk buttons shadow, for example
    set slice [::stooop::new slice\
        $canvas [expr {$($this,initialWidth) / 2}]\
        [expr {$($this,initialHeight) / 2}] -startandextent "$start 0"\
        -height $($this,thickness) -topcolor $color\
        -bottomcolor [darken $color 60]\
    ]
    # place slice at other slices position in case pie was moved
    eval $canvas move slice($slice) [$canvas coords pieSlices($this)]
    $canvas addtag pie($this) withtag slice($slice)
    $canvas addtag pieSlices($this) withtag slice($slice)
    lappend ($this,slices) $slice
    if {[string length $text] == 0} {     ;# generate label text if not provided
        set text "slice [llength $($this,slices)]"
    }
    set labeler $($this,labeler)
    set label [pieLabeler::new $labeler $slice -text $text -background $color]
    set ($this,sliceLabel,$slice) $label
    # update tags which canvas does not automatically do
    $canvas addtag pie($this) withtag pieLabeler($labeler)
    update $this
    if {$switched::($this,-selectable)} {
        # toggle select state at every button release
        if {![info exists ($this,selector)]} {   ;# create selector if necessary
            set ($this,selector) [::stooop::new objectSelector\
                -selectcommand "pie::setLabelsState $this"\
            ]
        }
        set selector $($this,selector)
        selector::add $selector $label
        $canvas bind canvasLabel($label) <ButtonPress-1>\
            "pie::buttonPress $selector $label"
        $canvas bind slice($slice) <ButtonPress-1>\
            "selector::select $selector $label"
        $canvas bind canvasLabel($label) <Control-ButtonPress-1>\
            "selector::toggle $selector $label"
        $canvas bind slice($slice) <Control-ButtonPress-1>\
            "selector::toggle $selector $label"
        $canvas bind canvasLabel($label) <Shift-ButtonPress-1>\
            "selector::extend $selector $label"
        $canvas bind slice($slice) <Shift-ButtonPress-1>\
            "selector::extend $selector $label"
        $canvas bind canvasLabel($label) <ButtonRelease-1>\
            "pie::buttonRelease $selector $label 0"
        $canvas bind slice($slice) <ButtonRelease-1>\
            "pie::buttonRelease $selector $label 0"
        $canvas bind canvasLabel($label) <Control-ButtonRelease-1>\
            "pie::buttonRelease $selector $label 1"
        $canvas bind slice($slice) <Control-ButtonRelease-1>\
            "pie::buttonRelease $selector $label 1"
        $canvas bind canvasLabel($label) <Shift-ButtonRelease-1>\
            "pie::buttonRelease $selector $label 1"
        $canvas bind slice($slice) <Shift-ButtonRelease-1>\
            "pie::buttonRelease $selector $label 1"
    }
    return $slice
}

proc pie::deleteSlice {this slice} {
    set index [lsearch -exact $($this,slices) $slice]
    if {$index < 0} {
        error "invalid slice $slice for pie $this"
    }
    set ($this,slices) [lreplace $($this,slices) $index $index]
    set extent $slice::($slice,extent)
    ::stooop::delete $slice
    foreach following [lrange $($this,slices) $index end] {
        # rotate the following slices counterclockwise
        slice::rotate $following $extent
    }
    # finally delete label last so that other labels may eventually be
    # repositionned according to remaining slices placement
    pieLabeler::delete $($this,labeler) $($this,sliceLabel,$slice)
    if {$switched::($this,-selectable)} {
        selector::remove $($this,selector) $($this,sliceLabel,$slice)
    }
    unset ($this,sliceLabel,$slice)
    update $this
}

proc pie::sizeSlice {this slice unitShare {valueToDisplay {}}} {
    set index [lsearch -exact $($this,slices) $slice]
    if {$index < 0} {
        error "invalid slice $slice for pie $this"
    }
    # cannot display slices that occupy more than whole pie and less than zero
    set newExtent [expr {[maximum [minimum $unitShare 1] 0] * 360}]
    set growth [expr {$newExtent - $slice::($slice,extent)}]
    switched::configure $slice -startandextent\
        "[expr {$slice::($slice,start) - $growth}] $newExtent" ;# grow clockwise
    if {[string length $valueToDisplay] > 0} {
        # update label after slice for it may need slice latest configuration
        pieLabeler::set $($this,labeler) $($this,sliceLabel,$slice)\
            $valueToDisplay
    } else {
        pieLabeler::set $($this,labeler) $($this,sliceLabel,$slice) $unitShare
    }
    set value [expr {-1 * $growth}]         ;# finally move the following slices
    foreach slice [lrange $($this,slices) [incr index] end] {
        slice::rotate $slice $value
    }
    if {$switched::($this,-autoupdate)} {
        # since label was changed, labeler may need to reorganize labels,
        # for example
        update $this
    }
}

proc pie::labelSlice {this slice text} {
    pieLabeler::label $($this,labeler) $($this,sliceLabel,$slice) $text
    update $this                ;# necessary if number of lines in label changes
}

proc pie::sliceLabelTag {this slice} {
    return canvasLabel($($this,sliceLabel,$slice))
}

proc pie::setSliceBackground {this slice color} {
    switched::configure $slice -topcolor $color -bottomcolor [darken $color 60]
    pieLabeler::labelBackground $($this,labeler) $($this,sliceLabel,$slice)\
        $color
}

proc pie::setSliceLabelBackground {this slice color} {
    pieLabeler::labelTextBackground $($this,labeler) $($this,sliceLabel,$slice)\
        $color
}

proc pie::selectedSlices {this} {  ;# return a list of currently selected slices
    set list {}
    foreach slice $($this,slices) {
        if {[pieLabeler::selectState $($this,labeler)\
            $($this,sliceLabel,$slice)\
        ]} {
            lappend list $slice
        }
    }
    return $list
}

proc pie::setLabelsState {this labels selected} {
    set labeler $($this,labeler)
    foreach label $labels {
        pieLabeler::selectState $labeler $label $selected
    }
}

proc pie::currentSlice {this} {
    # return current slice (slice or its label under the mouse cursor) if any
    set tags [$($this,canvas) gettags current]
    if {\
        ([scan $tags slice(%u) slice] > 0) &&\
        ($slice != $($this,backgroundSlice))\
    } {                                               ;# ignore background slice
        return $slice                                     ;# found current slice
    }
    if {[scan $tags canvasLabel(%u) label] > 0} {
        foreach slice $($this,slices) {
            if {$($this,sliceLabel,$slice) == $label} {
                return $slice              ;# slice is current through its label
            }
        }
    }
    return 0                                                 ;# no current slice
}

proc pie::update {this} {
    # place and scale slices along and with labels array in its current
    # configuration
    set canvas $($this,canvas)
    # retrieve current pie coordinates
    foreach {x y} [$canvas coords $($this,origin)] {}
    set right [expr {$x + $($this,width)}]
    set bottom [expr {$y + $($this,height)}]
    # update labels so that the room that they take can be exactly calculated:
    pieLabeler::update $($this,labeler) $x $y $right $bottom
    pieLabeler::room $($this,labeler) room      ;# take labels room into account
    # move slices in order to leave room for labels
    foreach {xSlices ySlices} [$canvas coords pieSlices($this)] {}
    $canvas move pieSlices($this) [expr {$x + $room(left) - $xSlices}]\
        [expr {$y + $room(top) + $($this,titleRoom) - $ySlices}]
    set scale [list\
        [expr {\
            ($($this,width) - $room(left) - $room(right)) /\
            $($this,initialWidth)\
        }]\
        [expr {\
            (\
                $($this,height) - $room(top) - $room(bottom) -\
                $($this,titleRoom)\
            ) / ($($this,initialHeight) + $($this,thickness))\
        }]\
    ]
    # update scale of background slice
    switched::configure $($this,backgroundSlice) -scale $scale
    foreach slice $($this,slices) {
        switched::configure $slice -scale $scale             ;# and other slices
    }
    # some labelers place labels around slices
    pieLabeler::updateSlices $($this,labeler) $x $y $right $bottom
    if {$($this,titleRoom) > 0} {                                ;# title exists
        # place text above pie and centered
        $canvas coords $($this,title) [expr {$x + ($($this,width) / 2)}] $y
    }
}

proc pie::buttonPress {selector label} {
    foreach selected [selector::selected $selector] {
        # in an already selected label, do not change selection
        if {$selected == $label} return
    }
    selector::select $selector $label
}

proc pie::buttonRelease {selector label extended} {
    # extended means that there is an extended selection in process
    if {$extended} return
    set list [selector::selected $selector]
    if {[llength $list] <= 1} {
        return                ;# nothing to do if there is no multiple selection
    }
    foreach selected $list {
        if {$selected == $label} {               ;# in an already selected label
            selector::select $selector $label     ;# set selection to sole label
            return
        }
    }
}

::stooop::class pie {                       ;# define various utility procedures
    proc maximum {a b} {return [expr {$a > $b? $a: $b}]}
    proc minimum {a b} {return [expr {$a < $b? $a: $b}]}

    catch ::tk::Darken                                  ;# force package loading
    if {[llength [info procs ::tk::Darken]] > 0} {                     ;# Tk 8.4
        proc darken {color percent} {::tk::Darken $color $percent}
    } else {
        proc darken {color percent} {::tkDarken $color $percent}
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tkpiechart/pielabel.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
# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)

package require Tk 8.3
package require stooop


::stooop::class pieLabeler {

    set (default,font) {Helvetica -12}

    proc pieLabeler {this canvas args} {
        ::set ($this,canvas) $canvas
    }

    proc ~pieLabeler {this} {}

    ::stooop::virtual proc new {this slice args}    ;# must return a canvasLabel

    ::stooop::virtual proc delete {this label}

    ::stooop::virtual proc set {this label value}

    ::stooop::virtual proc label {this args} ;# set or get label if no arguments

    # set or get label background if no arguments
    ::stooop::virtual proc labelBackground {this args}

    # set or get text label background if no arguments
    ::stooop::virtual proc labelTextBackground {this args}

    ::stooop::virtual proc selectState {this label {state {}}}

    # must be invoked only by pie, which knows when it is necessary to update
    # (new or deleted label, resizing, ...):
    ::stooop::virtual proc update {this left top right bottom}
    # for the labelers that need to know when slices are updated:
    ::stooop::virtual proc updateSlices {this left top right bottom} {}

    ::stooop::virtual proc room {this arrayName}

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted scriptlibs/tklib0.5/tkpiechart/pkgIndex.tcl.

1
2
3
# Package index file created with stooop version 4.4.1 for stooop packages

package ifneeded tkpiechart 6.6 [list source [file join $dir tkpiechart.tcl]]
<
<
<






Deleted scriptlibs/tklib0.5/tkpiechart/relirect.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
# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)

package require Tk 8.3
package require stooop


::stooop::class canvasReliefRectangle {

    proc canvasReliefRectangle {this canvas args} switched {$args} {
        set ($this,topLeft)\
            [$canvas create line 0 0 0 0 0 0 -tags canvasReliefRectangle($this)]
        set ($this,bottomRight)\
            [$canvas create line 0 0 0 0 0 0 -tags canvasReliefRectangle($this)]
        set ($this,canvas) $canvas
        switched::complete $this
    }

    proc ~canvasReliefRectangle {this} {
        $($this,canvas) delete canvasReliefRectangle($this)
    }

    proc options {this} {
        # force background initialization for color calculations
        return [list\
            [list -background white]\
            [list -coordinates {0 0 0 0} {0 0 0 0}]\
            [list -relief flat flat]\
        ]
    }

    proc set-background {this value} {       ;# algorithm stolen from tkUnix3d.c
        set intensity 65535                                 ;# maximum intensity
        foreach {red green blue} [winfo rgb $($this,canvas) $value] {}
        if {\
            (\
                ($red * 0.5 * $red) + ($green * 1.0 * $green) +\
                ($blue * 0.28 * $blue)\
            ) < ($intensity * 0.05 * $intensity)\
        } {
            set ($this,dark) [format {#%04X%04X%04X}\
                [expr {($intensity + (3 * $red)) / 4}]\
                [expr {($intensity + (3 * $green)) / 4}]\
                [expr {($intensity + (3 * $blue)) / 4}]\
            ]
        } else {
            set ($this,dark) [format {#%04X%04X%04X}\
                [expr {(60 * $red) / 100}] [expr {(60 * $green) / 100}]\
                [expr {(60 * $blue) / 100}]\
            ]
        }
        if {$green > ($intensity * 0.95)} {
            set ($this,light) [format {#%04X%04X%04X}\
                [expr {(90 * $red) / 100}] [expr {(90 * $green) / 100}]\
                [expr {(90 * $blue) / 100}]\
        ]
        } else {
            set tmp1 [expr {(14 * $red) / 10}]
            if {$tmp1 > $intensity} {set tmp1 $intensity}
            set tmp2 [expr {($intensity + $red) / 2}]
            set lightRed [expr {$tmp1 > $tmp2? $tmp1: $tmp2}]
            set tmp1 [expr {(14 * $green) / 10}]
            if {$tmp1 > $intensity} {set tmp1 $intensity}
            set tmp2 [expr {($intensity + $green) / 2}]
            set lightGreen [expr {$tmp1 > $tmp2? $tmp1: $tmp2}]
            set tmp1 [expr {(14 * $blue) / 10}]
            if {$tmp1 > $intensity} {set tmp1 $intensity}
            set tmp2 [expr {($intensity + $blue) / 2}]
            set lightBlue [expr {$tmp1 > $tmp2? $tmp1: $tmp2}]
            set ($this,light)\
                [format {#%04X%04X%04X} $lightRed $lightGreen $lightBlue]
        }
        update $this
    }

    proc set-coordinates {this value} {
        foreach {left top right bottom} $value {}
        $($this,canvas) coords $($this,topLeft)\
            $left $bottom $left $top $right $top
        $($this,canvas) coords $($this,bottomRight)\
            $right $top $right $bottom $left $bottom
    }

    proc set-relief {this value} {
        if {![info exists ($this,dark)]} return     ;# colors not yet calculated
        update $this
    }

    proc update {this} {
        switch $switched::($this,-relief) {
            flat {
                $($this,canvas) itemconfigure canvasReliefRectangle($this)\
                    -fill $switched::($this,-background)
            }
            raised {
                $($this,canvas) itemconfigure $($this,topLeft)\
                    -fill $($this,light)
                $($this,canvas) itemconfigure $($this,bottomRight)\
                    -fill $($this,dark)
            }
            sunken {
                $($this,canvas) itemconfigure $($this,topLeft)\
                    -fill $($this,dark)
                $($this,canvas) itemconfigure $($this,bottomRight)\
                    -fill $($this,light)
            }
            default {
                error "bad relief value \"$value\": must be flat, raised or sunken"
            }
        }
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































Deleted scriptlibs/tklib0.5/tkpiechart/selector.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
# $Id: selector.tcl,v 2.8 2006/01/27 19:05:52 andreas_kupries Exp $

package require Tk 8.3
package require stooop

# implements generic selection on a list of unique identifiers

::stooop::class selector {

    proc selector {this args} switched {$args} {
        ::set ($this,order) 0
        switched::complete $this
    }

    proc ~selector {this} {
        variable ${this}selected
        variable ${this}order

        catch {::unset ${this}selected ${this}order}
    }

    proc options {this} {
        return [::list\
            [::list -selectcommand {} {}]\
        ]
    }

    # nothing to do as value is stored at the switched level
    proc set-selectcommand {this value} {}

    proc set {this indices selected} {
        variable ${this}selected
        variable ${this}order

        ::set select {}
        ::set deselect {}
        foreach index $indices {
            if {\
                [info exists ${this}selected($index)] &&\
                ($selected == [::set ${this}selected($index)])\
            } continue                                              ;# no change
            if {$selected} {
                lappend select $index
                ::set ${this}selected($index) 1
            } else {
                lappend deselect $index
                ::set ${this}selected($index) 0
            }
            # keep track of action order
            ::set ${this}order($index) $($this,order)
            incr ($this,order)
        }
        update $this $select $deselect
    }

    proc update {this selected deselected} {
        if {[string length $switched::($this,-selectcommand)] == 0} return
        if {[llength $selected] > 0} {
            uplevel #0 $switched::($this,-selectcommand) [::list $selected] 1
        }
        if {[llength $deselected] > 0} {
            uplevel #0 $switched::($this,-selectcommand) [::list $deselected] 0
        }
    }

    proc unset {this indices} {
        variable ${this}selected
        variable ${this}order

        foreach index $indices {
            ::unset ${this}selected($index) ${this}order($index)
        }
    }

    proc ordered {this index1 index2} {
        # used for sorting with lsort command according to order
        variable ${this}order

        return [expr {\
            [::set ${this}order($index1)] - [::set ${this}order($index2)]\
        }]
    }

    ### public procedures follow:

    proc add {this indices} {
        set $this $indices 0
    }

    proc remove {this indices} {
        unset $this $indices
    }

    proc select {this indices} {
        clear $this
        set $this $indices 1
        # keep track of last selected object for extension
        ::set ($this,lastSelected) [lindex $indices end]
    }

    proc deselect {this indices} {
        set $this $indices 0
    }

    proc toggle {this indices} {
        variable ${this}selected
        variable ${this}order

        ::set select {}
        ::set deselect {}
        foreach index $indices {
            if {[::set ${this}selected($index)]} {
                lappend deselect $index
                ::set ${this}selected($index) 0
                if {\
                    [info exists ($this,lastSelected)] &&\
                    ($index == $($this,lastSelected))\
                } {
                    # too complicated to find out what was selected last
                    ::unset ($this,lastSelected)
                }
            } else {
                lappend select $index
                ::set ${this}selected($index) 1
                # keep track of last selected object for extension
                ::set ($this,lastSelected) $index
            }
            # keep track of action order
            ::set ${this}order($index) $($this,order)
            incr ($this,order)
        }
        update $this $select $deselect
    }

    ::stooop::virtual proc extend {this index} {}

    proc clear {this} {
        variable ${this}selected

        set $this [array names ${this}selected] 0
    }

    ::stooop::virtual proc selected {this} {
        # derived class may want to do some additional processing,
        # such as sorting, ...
        variable ${this}selected

        ::set list {}
        foreach {index value} [array get ${this}selected] {
            if {$value} {
                lappend list $index
            }
        }
        return [lsort -command "ordered $this" $list]                 ;# ordered
    }

    ::stooop::virtual proc list {this} {
        # derived class may want to do some additional processing,
        # such as sorting, ...
        variable ${this}selected

        # ordered:
        return [lsort -command "ordered $this" [array names ${this}selected]]
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































Deleted scriptlibs/tklib0.5/tkpiechart/slice.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
# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)

package require Tk 8.3
package require stooop


::stooop::class slice {
    variable PI 3.14159265358979323846
}

proc slice::slice {this canvas xRadius yRadius args} switched {$args} {
    # all parameter dimensions must be in pixels
    # note: all slice elements are tagged with slice($this)
    set ($this,canvas) $canvas
    set ($this,xRadius) $xRadius
    set ($this,yRadius) $yRadius
    switched::complete $this
    # wait till all options have been set for initial configuration
    complete $this
    update $this
}

proc slice::~slice {this} {
    if {[string length $switched::($this,-deletecommand)] > 0} {
        # always invoke command at global level
        uplevel #0 $switched::($this,-deletecommand)
    }
    $($this,canvas) delete slice($this)
}

proc slice::options {this} {
    return [list\
        [list -bottomcolor {} {}]\
        [list -deletecommand {} {}]\
        [list -height 0 0]\
        [list -scale {1 1} {1 1}]\
        [list -startandextent {0 0} {0 0}]\
        [list -topcolor {} {}]\
    ]
}

proc slice::set-height {this value} {      ;# not a dynamic option: see complete
    if {$switched::($this,complete)} {
        error {option -height cannot be set dynamically}
    }
}

proc slice::set-bottomcolor {this value} {
    if {![info exists ($this,startBottomArcFill)]} return
    set canvas $($this,canvas)
    $canvas itemconfigure $($this,startBottomArcFill)\
        -fill $value -outline $value
    $canvas itemconfigure $($this,startPolygon) -fill $value
    $canvas itemconfigure $($this,endBottomArcFill) -fill $value -outline $value
    $canvas itemconfigure $($this,endPolygon) -fill $value
}

proc slice::set-topcolor {this value} {
    if {![info exists ($this,topArc)]} return
    $($this,canvas) itemconfigure $($this,topArc) -fill $value
}

# data is stored at switched level
proc slice::set-deletecommand {this value} {}

proc slice::set-scale {this value} {
    if {$switched::($this,complete) && ($value > 0)} {
        # check for valid value following a non reproducible bug report
        update $this                   ;# requires initialization to be complete
    }
}

proc slice::set-startandextent {this value} {
    foreach {start extent} $value {}
    set ($this,start) [normalizedAngle $start]
    if {$extent < 0} {
        set ($this,extent) 0                 ;# a negative extent is meaningless
    } elseif {$extent >= 360} {
        # get as close as possible to 360, which would not work as it is
        # equivalent to 0
        set ($this,extent) [expr {360 - pow(10, -$::tcl_precision + 3)}]
    } else {
        set ($this,extent) $extent
    }
    if {$switched::($this,complete)} {
        update $this                   ;# requires initialization to be complete
    }
}

proc slice::normalizedAngle {value} {
    # normalize value between -180 and 180 degrees (not included)
    while {$value >= 180} {
        set value [expr {$value - 360}]
    }
    while {$value < -180} {
        set value [expr {$value + 360}]
    }
    return $value
}

proc slice::complete {this} {
    set canvas $($this,canvas)
    set xRadius $($this,xRadius)
    set yRadius $($this,yRadius)
    set bottomColor $switched::($this,-bottomcolor)
    # use an empty image as an origin marker with only 2 coordinates
    set ($this,origin)\
        [$canvas create image -$xRadius -$yRadius -tags slice($this)]
    if {$switched::($this,-height) > 0} {                                  ;# 3D
        set ($this,startBottomArcFill) [$canvas create arc\
            0 0 0 0 -style chord -extent 0 -fill $bottomColor\
            -outline $bottomColor -tags slice($this)\
        ]
        set ($this,startPolygon) [$canvas create polygon 0 0 0 0 0 0\
            -fill $bottomColor -tags slice($this)\
        ]
        set ($this,startBottomArc) [$canvas create arc 0 0 0 0\
            -style arc -extent 0 -fill black -tags slice($this)\
        ]
        set ($this,endBottomArcFill) [$canvas create arc 0 0 0 0\
            -style chord -extent 0 -fill $bottomColor\
            -outline $bottomColor -tags slice($this)\
        ]
        set ($this,endPolygon) [$canvas create polygon 0 0 0 0 0 0\
            -fill $bottomColor -tags slice($this)\
        ]
        set ($this,endBottomArc) [$canvas create arc 0 0 0 0\
            -style arc -extent 0 -fill black -tags slice($this)\
        ]
        set ($this,startLeftLine)\
            [$canvas create line 0 0 0 0 -tags slice($this)]
        set ($this,startRightLine)\
            [$canvas create line 0 0 0 0 -tags slice($this)]
        set ($this,endLeftLine) [$canvas create line 0 0 0 0 -tags slice($this)]
        set ($this,endRightLine)\
            [$canvas create line 0 0 0 0 -tags slice($this)]
    }
    set ($this,topArc) [$canvas create arc\
        -$xRadius -$yRadius $xRadius $yRadius\
        -fill $switched::($this,-topcolor) -tags slice($this)\
    ]
    # move slice so upper-left corner is at requested coordinates
    $canvas move slice($this) $xRadius $yRadius
}

proc slice::update {this} {
    set canvas $($this,canvas)
    # first store slice position in case it was moved as a whole
    set coordinates [$canvas coords $($this,origin)]
    set xRadius $($this,xRadius)
    set yRadius $($this,yRadius)
    $canvas coords $($this,origin) -$xRadius -$yRadius
    $canvas coords $($this,topArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas itemconfigure $($this,topArc)\
        -start $($this,start) -extent $($this,extent)
    if {$switched::($this,-height) > 0} {                                  ;# 3D
        updateBottom $this
    }
    # now position slice at the correct coordinates
    $canvas move slice($this) [expr {[lindex $coordinates 0] + $xRadius}]\
        [expr {[lindex $coordinates 1] + $yRadius}]
    # finally apply scale
    eval $canvas scale slice($this) $coordinates $switched::($this,-scale)
}

proc slice::updateBottom {this} {
    variable PI

    set start $($this,start)
    set extent $($this,extent)

    set canvas $($this,canvas)
    set xRadius $($this,xRadius)
    set yRadius $($this,yRadius)
    set height $switched::($this,-height)

    # first make all bottom parts invisible
    $canvas itemconfigure $($this,startBottomArcFill) -extent 0
    $canvas coords $($this,startBottomArcFill)\
        -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,startBottomArcFill) 0 $height
    $canvas itemconfigure $($this,startBottomArc) -extent 0
    $canvas coords $($this,startBottomArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,startBottomArc) 0 $height
    $canvas coords $($this,startLeftLine) 0 0 0 0
    $canvas coords $($this,startRightLine) 0 0 0 0
    $canvas itemconfigure $($this,endBottomArcFill) -extent 0
    $canvas coords $($this,endBottomArcFill)\
        -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,endBottomArcFill) 0 $height
    $canvas itemconfigure $($this,endBottomArc) -extent 0
    $canvas coords $($this,endBottomArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,endBottomArc) 0 $height
    $canvas coords $($this,endLeftLine) 0 0 0 0
    $canvas coords $($this,endRightLine) 0 0 0 0
    $canvas coords $($this,startPolygon) 0 0 0 0 0 0 0 0
    $canvas coords $($this,endPolygon) 0 0 0 0 0 0 0 0

    set startX [expr {$xRadius * cos($start * $PI / 180)}]
    set startY [expr {-$yRadius * sin($start * $PI / 180)}]
    set end [normalizedAngle [expr {$start + $extent}]]
    set endX [expr {$xRadius * cos($end * $PI / 180)}]
    set endY [expr {-$yRadius * sin($end * $PI / 180)}]

    set startBottom [expr {$startY + $height}]
    set endBottom [expr {$endY + $height}]

    if {(($start >= 0) && ($end >= 0)) || (($start < 0) && ($end < 0))} {
        # start and end angles are on the same side of the 0 abscissa
        if {$extent <= 180} {                ;# slice size is less than half pie
            if {$start < 0} {    ;# slice is facing viewer, so bottom is visible
                $canvas itemconfigure $($this,startBottomArcFill)\
                    -start $start -extent $extent
                $canvas itemconfigure $($this,startBottomArc)\
                    -start $start -extent $extent
                # only one polygon is needed
                $canvas coords $($this,startPolygon)\
                    $startX $startY $endX $endY\
                    $endX $endBottom $startX $startBottom
                $canvas coords $($this,startLeftLine)\
                    $startX $startY $startX $startBottom
                $canvas coords $($this,startRightLine)\
                    $endX $endY $endX $endBottom
            }                                        ;# else only top is visible
        } else {                             ;# slice size is more than half pie
            if {$start < 0} {
                # slice opening is facing viewer, so bottom is in 2 parts
                $canvas itemconfigure $($this,startBottomArcFill)\
                    -start 0 -extent $start
                $canvas itemconfigure $($this,startBottomArc)\
                    -start 0 -extent $start
                $canvas coords $($this,startPolygon)\
                    $startX $startY $xRadius 0\
                    $xRadius $height $startX $startBottom
                $canvas coords $($this,startLeftLine)\
                    $startX $startY $startX $startBottom
                $canvas coords $($this,startRightLine)\
                    $xRadius 0 $xRadius $height

                set bottomArcExtent [expr {$end + 180}]
                $canvas itemconfigure $($this,endBottomArcFill)\
                    -start -180 -extent $bottomArcExtent
                $canvas itemconfigure $($this,endBottomArc)\
                    -start -180 -extent $bottomArcExtent
                $canvas coords $($this,endPolygon)\
                    -$xRadius 0 $endX $endY $endX $endBottom -$xRadius $height
                $canvas coords $($this,endLeftLine)\
                    -$xRadius 0 -$xRadius $height
                $canvas coords $($this,endRightLine)\
                    $endX $endY $endX $endBottom
            } else {
                # slice back is facing viewer, so bottom occupies half the pie
                $canvas itemconfigure $($this,startBottomArcFill)\
                    -start 0 -extent -180
                $canvas itemconfigure $($this,startBottomArc)\
                    -start 0 -extent -180
                # only one polygon is needed
                $canvas coords $($this,startPolygon)\
                    -$xRadius 0 $xRadius 0 $xRadius $height -$xRadius $height
                $canvas coords $($this,startLeftLine)\
                    -$xRadius 0 -$xRadius $height
                $canvas coords $($this,startRightLine)\
                    $xRadius 0 $xRadius $height
            }
        }
    } else {     ;# start and end angles are on opposite sides of the 0 abscissa
        if {$start < 0} {                        ;# slice start is facing viewer
            $canvas itemconfigure $($this,startBottomArcFill)\
                -start 0 -extent $start
            $canvas itemconfigure $($this,startBottomArc)\
                -start 0 -extent $start
            # only one polygon is needed
            $canvas coords $($this,startPolygon) $startX $startY $xRadius 0\
                $xRadius $height $startX $startBottom
            $canvas coords $($this,startLeftLine)\
                $startX $startY $startX $startBottom
            $canvas coords $($this,startRightLine) $xRadius 0 $xRadius $height
        } else {                                   ;# slice end is facing viewer
            set bottomArcExtent [expr {$end + 180}]
            $canvas itemconfigure $($this,endBottomArcFill)\
                -start -180 -extent $bottomArcExtent
            $canvas itemconfigure $($this,endBottomArc)\
                -start -180 -extent $bottomArcExtent
            # only one polygon is needed
            $canvas coords $($this,endPolygon)\
                -$xRadius 0 $endX $endY $endX $endBottom -$xRadius $height
            $canvas coords $($this,startLeftLine) -$xRadius 0 -$xRadius $height
            $canvas coords $($this,startRightLine) $endX $endY $endX $endBottom
        }
    }
}

proc slice::rotate {this angle} {
    if {$angle == 0} return
    set ($this,start) [normalizedAngle [expr {$($this,start) + $angle}]]
    update $this
}

# return actual sizes and positions after scaling
proc slice::data {this arrayName} {
    upvar 1 $arrayName data

    set data(start) $($this,start)
    set data(extent) $($this,extent)
    foreach {x y} $switched::($this,-scale) {}
    set data(xRadius) [expr {$x * $($this,xRadius)}]
    set data(yRadius) [expr {$y * $($this,yRadius)}]
    set data(height) [expr {$y * $switched::($this,-height)}]
    foreach {x y} [$($this,canvas) coords $($this,origin)] {}
    set data(xCenter) [expr {$x + $data(xRadius)}]
    set data(yCenter) [expr {$y + $data(yRadius)}]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/tkpiechart/tkpiechart.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
# -*- tcl -*-
tclPkgSetup [file dirname [file join [pwd] [info script]]] tkpiechart 6.6 {
    {pie.tcl source {::pie::_copy ::pie::buttonPress ::pie::buttonRelease ::pie::complete ::pie::currentSlice ::pie::darken ::pie::deleteSlice ::pie::labelSlice ::pie::maximum ::pie::minimum ::pie::newSlice ::pie::options ::pie::pie ::pie::selectedSlices ::pie::set-autoupdate ::pie::set-background ::pie::set-colors ::pie::set-height ::pie::set-labeler ::pie::set-selectable ::pie::set-thickness ::pie::set-title ::pie::set-titlefont ::pie::set-titleoffset ::pie::set-width ::pie::setLabelsState ::pie::setSliceBackground ::pie::setSliceLabelBackground ::pie::sizeSlice ::pie::sliceLabelTag ::pie::update ::pie::~pie}}
    {slice.tcl source {::slice::_copy ::slice::complete ::slice::data ::slice::normalizedAngle ::slice::options ::slice::rotate ::slice::set-bottomcolor ::slice::set-deletecommand ::slice::set-height ::slice::set-scale ::slice::set-startandextent ::slice::set-topcolor ::slice::slice ::slice::update ::slice::updateBottom ::slice::~slice}}
    {pielabel.tcl source {::pieLabeler::_copy ::pieLabeler::_updateSlices ::pieLabeler::delete ::pieLabeler::label ::pieLabeler::labelBackground ::pieLabeler::labelTextBackground ::pieLabeler::new ::pieLabeler::pieLabeler ::pieLabeler::room ::pieLabeler::selectState ::pieLabeler::set ::pieLabeler::update ::pieLabeler::updateSlices ::pieLabeler::~pieLabeler}}
    {boxlabel.tcl source {::pieBoxLabeler::_copy ::pieBoxLabeler::delete ::pieBoxLabeler::label ::pieBoxLabeler::labelBackground ::pieBoxLabeler::labelTextBackground ::pieBoxLabeler::new ::pieBoxLabeler::options ::pieBoxLabeler::pieBoxLabeler ::pieBoxLabeler::room ::pieBoxLabeler::selectState ::pieBoxLabeler::set ::pieBoxLabeler::set-font ::pieBoxLabeler::set-justify ::pieBoxLabeler::set-offset ::pieBoxLabeler::set-xoffset ::pieBoxLabeler::update ::pieBoxLabeler::~pieBoxLabeler}}
    {canlabel.tcl source {::canvasLabel::_copy ::canvasLabel::canvasLabel ::canvasLabel::eventuallyDeleteRelief ::canvasLabel::options ::canvasLabel::set-anchor ::canvasLabel::set-background ::canvasLabel::set-bordercolor ::canvasLabel::set-borderwidth ::canvasLabel::set-bulletwidth ::canvasLabel::set-font ::canvasLabel::set-foreground ::canvasLabel::set-justify ::canvasLabel::set-minimumwidth ::canvasLabel::set-padding ::canvasLabel::set-scale ::canvasLabel::set-select ::canvasLabel::set-selectrelief ::canvasLabel::set-stipple ::canvasLabel::set-text ::canvasLabel::set-textbackground ::canvasLabel::set-width ::canvasLabel::update ::canvasLabel::updateRelief ::canvasLabel::~canvasLabel}}
    {perilabel.tcl source {::piePeripheralLabeler::_copy ::piePeripheralLabeler::anglePosition ::piePeripheralLabeler::delete ::piePeripheralLabeler::label ::piePeripheralLabeler::labelBackground ::piePeripheralLabeler::labelTextBackground ::piePeripheralLabeler::new ::piePeripheralLabeler::options ::piePeripheralLabeler::piePeripheralLabeler ::piePeripheralLabeler::position ::piePeripheralLabeler::room ::piePeripheralLabeler::selectState ::piePeripheralLabeler::set ::piePeripheralLabeler::set-bulletwidth ::piePeripheralLabeler::set-font ::piePeripheralLabeler::set-justify ::piePeripheralLabeler::set-offset ::piePeripheralLabeler::set-smallfont ::piePeripheralLabeler::set-widestvaluetext ::piePeripheralLabeler::update ::piePeripheralLabeler::updateSlices ::piePeripheralLabeler::~piePeripheralLabeler}}
    {labarray.tcl source {::canvasLabelsArray::_copy ::canvasLabelsArray::canvasLabelsArray ::canvasLabelsArray::delete ::canvasLabelsArray::height ::canvasLabelsArray::labels ::canvasLabelsArray::manage ::canvasLabelsArray::options ::canvasLabelsArray::set-justify ::canvasLabelsArray::set-width ::canvasLabelsArray::update ::canvasLabelsArray::~canvasLabelsArray}}
    {selector.tcl source {::selector::_copy ::selector::_extend ::selector::_list ::selector::_selected ::selector::add ::selector::clear ::selector::deselect ::selector::extend ::selector::list ::selector::options ::selector::ordered ::selector::remove ::selector::select ::selector::selected ::selector::selector ::selector::set ::selector::set-selectcommand ::selector::toggle ::selector::unset ::selector::update ::selector::~selector}}
    {objselec.tcl source {::objectSelector::_copy ::objectSelector::extend ::objectSelector::objectSelector ::objectSelector::~objectSelector}}
    {relirect.tcl source {::canvasReliefRectangle::_copy ::canvasReliefRectangle::canvasReliefRectangle ::canvasReliefRectangle::options ::canvasReliefRectangle::set-background ::canvasReliefRectangle::set-coordinates ::canvasReliefRectangle::set-relief ::canvasReliefRectangle::update ::canvasReliefRectangle::~canvasReliefRectangle}}
}
<
<
<
<
<
<
<
<
<
<
<
<
<


























Deleted scriptlibs/tklib0.5/tooltip/pkgIndex.tcl.

1
2
3
4
# -*- tcl -*-

package ifneeded tooltip  1.4.4 [list source [file join $dir tooltip.tcl]]
package ifneeded tipstack 1.0.1 [list source [file join $dir tipstack.tcl]]
<
<
<
<








Deleted scriptlibs/tklib0.5/tooltip/tipstack.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
# tipstack.tcl --
#
#	Based on 'tooltip', provides a dynamic stack of tip texts per
#	widget. This allows dynamic transient changes to the tips, for
#	example to temporarily replace a standard epxlanation with an
#	error message.
#
# Copyright (c) 2003 ActiveState Corporation.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tipstack.tcl,v 1.4 2009/01/09 05:46:12 andreas_kupries Exp $
#

# ### ######### ###########################
# Requisites

package require tooltip
namespace eval ::tipstack {}

# ### ######### ###########################
# Public API
#
## Basic syntax for all commands having a widget reference:
#
## tipstack::command .w ...
## tipstack::command .m -index foo ...

# ### ######### ###########################
## Push new text for a widget (or menu)

proc ::tipstack::push {args} {
    if {([llength $args] != 2) && (([llength $args] != 4))} {
	return -code error "wrong#args: expected w ?-index index? text"
    }

    # Extract valueable parts.

    set text [lindex $args end]
    set wref [lrange $args 0 end-1]

    # Remember new data (setup/extend db)

    variable db
    if {![info exists db($wref)]} {
	set db($wref) [list $text]
    } else {
	lappend db($wref) $text
    }

    # Forward to standard tooltip package.

    eval [linsert [linsert $wref end $text] 0 tooltip::tooltip]
    return
}

# ### ######### ###########################
## Pop text from stack of tip for widget.
## ! Keeps the bottom-most entry.

proc ::tipstack::pop {args} {
    if {([llength $args] != 1) && (([llength $args] != 3))} {
	return -code error "wrong#args: expected w ?-index index?"
    }
    # args == wref (see 'push').
    set wref $args

    # Pop top information form the database. Except if the
    # text is the last in the stack. Then we will keep it, it
    # is the baseline for the widget.

    variable db
    if {![info exists db($wref)]} {
	set text ""
    } else {
	set data $db($wref)

	if {[llength $data] == 1} {
	    set text [lindex $data 0]
	} else {
	    set data [lrange $data 0 end-1]
	    set text [lindex $data end]

	    set db($wref) $data
	}
    }

    # Forward to standard tooltip package.

    eval [linsert [linsert $wref end $text] 0 tooltip::tooltip]
    return
}

# ### ######### ###########################
## Clears out all data about a widget (or menu).

proc ::tipstack::clear {args} {

    if {([llength $args] != 1) && (([llength $args] != 3))} {
	return -code error "wrong#args: expected w ?-index index?"
    }
    # args == wref (see 'push').
    set wref $args

    # Remove data about widget.

    variable db
    catch {unset db($wref)}

    eval [linsert [linsert $wref end ""] 0 tooltip::tooltip]
    return
}

# ### ######### ###########################
## Convenient definition of tooltips for multiple
## independent widgets. No menus possible

proc ::tipstack::def {defs} {
    foreach {path text} $defs {
	push $path $text
    }
    return
}

# ### ######### ###########################
## Convenient definition of tooltips for multiple
## widgets in a containing widget. No menus possible.
## This is for megawidgets.

proc ::tipstack::defsub {base defs} {
    foreach {subpath text} $defs {
	push $base$subpath $text
    }
    return
}

# ### ######### ###########################
## Convenient clearage of tooltips for multiple
## widgets in a containing widget. No menus possible.
## This is for megawidgets.

proc ::tipstack::clearsub {base} {
    variable db

    foreach k [array names db ${base}*] {
	# Danger. Will fail if 'base' matches a menu reference.
	clear $k
    }
    return
}

# ### ######### ###########################
# Internal commands -- None

# ### ######### ###########################
## Data structures

namespace eval ::tipstack {
    # Map from widget references to stack of tooltips.

    variable  db
    array set db {}
}

# ### ######### ###########################
# Ready

package provide tipstack 1.0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































Deleted scriptlibs/tklib0.5/tooltip/tooltip.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
# tooltip.tcl --
#
#       Balloon help
#
# Copyright (c) 1996-2007 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tooltip.tcl,v 1.16 2008/12/01 23:37:16 hobbs Exp $
#
# Initiated: 28 October 1996


package require Tk 8.4
package require msgcat

#------------------------------------------------------------------------
# PROCEDURE
#	tooltip::tooltip
#
# DESCRIPTION
#	Implements a tooltip (balloon help) system
#
# ARGUMENTS
#	tooltip <option> ?arg?
#
# clear ?pattern?
#	Stops the specified widgets (defaults to all) from showing tooltips
#
# delay ?millisecs?
#	Query or set the delay.  The delay is in milliseconds and must
#	be at least 50.  Returns the delay.
#
# disable OR off
#	Disables all tooltips.
#
# enable OR on
#	Enables tooltips for defined widgets.
#
# <widget> ?-index index? ?-items id? ?-tag tag? ?message?
#	If -index is specified, then <widget> is assumed to be a menu
#	and the index represents what index into the menu (either the
#	numerical index or the label) to associate the tooltip message with.
#	Tooltips do not appear for disabled menu items.
#	If -item is specified, then <widget> is assumed to be a listbox
#	or canvas and the itemId specifies one or more items.
#	If -tag is specified, then <widget> is assumed to be a text
#	and the tagId specifies a tag.
#	If message is {}, then the tooltip for that widget is removed.
#	The widget must exist prior to calling tooltip.  The current
#	tooltip message for <widget> is returned, if any.
#
# RETURNS: varies (see methods above)
#
# NAMESPACE & STATE
#	The namespace tooltip is used.
#	Control toplevel name via ::tooltip::wname.
#
# EXAMPLE USAGE:
#	tooltip .button "A Button"
#	tooltip .menu -index "Load" "Loads a file"
#
#------------------------------------------------------------------------

namespace eval ::tooltip {
    namespace export -clear tooltip
    variable labelOpts
    variable tooltip
    variable G

    if {![info exists G]} {
        array set G {
            enabled     1
            fade        1
            FADESTEP    0.2
            FADEID      {}
            DELAY       500
            AFTERID     {}
            LAST        -1
            TOPLEVEL    .__tooltip__
        }
        if {[tk windowingsystem] eq "x11"} {
            set G(fade) 0 ; # don't fade by default on X11
        }
    }
    if {![info exists labelOpts]} {
	# Undocumented variable that allows users to extend / override
	# label creation options.  Must be set prior to first registry
	# of a tooltip, or destroy $::tooltip::G(TOPLEVEL) first.
	set labelOpts [list -highlightthickness 0 -relief solid -bd 1 \
			   -background lightyellow -fg black]
    }

    # The extra ::hide call in <Enter> is necessary to catch moving to
    # child widgets where the <Leave> event won't be generated
    bind Tooltip <Enter> [namespace code {
	#tooltip::hide
	variable tooltip
	variable G
	set G(LAST) -1
	if {$G(enabled) && [info exists tooltip(%W)]} {
	    set G(AFTERID) \
		[after $G(DELAY) [namespace code [list show %W $tooltip(%W) cursor]]]
	}
    }]

    bind Menu <<MenuSelect>>	[namespace code { menuMotion %W }]
    bind Tooltip <Leave>	[namespace code [list hide 1]] ; # fade ok
    bind Tooltip <Any-KeyPress>	[namespace code hide]
    bind Tooltip <Any-Button>	[namespace code hide]
}

proc ::tooltip::tooltip {w args} {
    variable tooltip
    variable G
    switch -- $w {
	clear	{
	    if {[llength $args]==0} { set args .* }
	    clear $args
	}
	delay	{
	    if {[llength $args]} {
		if {![string is integer -strict $args] || $args<50} {
		    return -code error "tooltip delay must be an\
			    integer greater than 50 (delay is in millisecs)"
		}
		return [set G(DELAY) $args]
	    } else {
		return $G(DELAY)
	    }
	}
	fade	{
	    if {[llength $args]} {
		set G(fade) [string is true -strict [lindex $args 0]]
	    }
	    return $G(fade)
	}
	off - disable	{
	    set G(enabled) 0
	    hide
	}
	on - enable	{
	    set G(enabled) 1
	}
	default {
	    set i $w
	    if {[llength $args]} {
		set i [uplevel 1 [namespace code "register [list $w] $args"]]
	    }
	    set b $G(TOPLEVEL)
	    if {![winfo exists $b]} {
		variable labelOpts

		toplevel $b -class Tooltip
		if {[tk windowingsystem] eq "aqua"} {
		    ::tk::unsupported::MacWindowStyle style $b help none
		} else {
		    wm overrideredirect $b 1
		}
		catch {wm attributes $b -topmost 1}
		# avoid the blink issue with 1 to <1 alpha on Windows
		catch {wm attributes $b -alpha 0.99}
		wm positionfrom $b program
		wm withdraw $b
		eval [linsert $labelOpts 0 label $b.label]
		pack $b.label -ipadx 1
	    }
	    if {[info exists tooltip($i)]} { return $tooltip($i) }
	}
    }
}

proc ::tooltip::register {w args} {
    variable tooltip
    set key [lindex $args 0]
    while {[string match -* $key]} {
	switch -- $key {
	    -index	{
		if {[catch {$w entrycget 1 -label}]} {
		    return -code error "widget \"$w\" does not seem to be a\
			    menu, which is required for the -index switch"
		}
		set index [lindex $args 1]
		set args [lreplace $args 0 1]
	    }
	    -item - -items {
                if {[winfo class $w] eq "Listbox"} {
                    set items [lindex $args 1]
                } else {
                    set namedItem [lindex $args 1]
                    if {[catch {$w find withtag $namedItem} items]} {
                        return -code error "widget \"$w\" is not a canvas, or\
			    item \"$namedItem\" does not exist in the canvas"
                    }
                }
		set args [lreplace $args 0 1]
	    }
            -tag {
                set tag [lindex $args 1]
                set r [catch {lsearch -exact [$w tag names] $tag} ndx]
                if {$r || $ndx == -1} {
                    return -code error "widget \"$w\" is not a text widget or\
                        \"$tag\" is not a text tag"
                }
                set args [lreplace $args 0 1]
            }
	    default	{
		return -code error "unknown option \"$key\":\
			should be -index, -items or -tag"
	    }
	}
	set key [lindex $args 0]
    }
    if {[llength $args] != 1} {
	return -code error "wrong # args: should be \"tooltip widget\
		?-index index? ?-items item? ?-tag tag? message\""
    }
    if {$key eq ""} {
	clear $w
    } else {
	if {![winfo exists $w]} {
	    return -code error "bad window path name \"$w\""
	}
	if {[info exists index]} {
	    set tooltip($w,$index) $key
	    return $w,$index
	} elseif {[info exists items]} {
	    foreach item $items {
		set tooltip($w,$item) $key
		if {[winfo class $w] eq "Listbox"} {
		    enableListbox $w $item
		} else {
		    enableCanvas $w $item
		}
	    }
	    # Only need to return the first item for the purposes of
	    # how this is called
	    return $w,[lindex $items 0]
        } elseif {[info exists tag]} {
            set tooltip($w,t_$tag) $key
            enableTag $w $tag
            return $w,$tag
	} else {
	    set tooltip($w) $key
	    bindtags $w [linsert [bindtags $w] end "Tooltip"]
	    return $w
	}
    }
}

proc ::tooltip::clear {{pattern .*}} {
    variable tooltip
    # cache the current widget at pointer
    set ptrw [winfo containing [winfo pointerx .] [winfo pointery .]]
    foreach w [array names tooltip $pattern] {
	unset tooltip($w)
	if {[winfo exists $w]} {
	    set tags [bindtags $w]
	    if {[set i [lsearch -exact $tags "Tooltip"]] != -1} {
		bindtags $w [lreplace $tags $i $i]
	    }
	    ## We don't remove TooltipMenu because there
	    ## might be other indices that use it

	    # Withdraw the tooltip if we clear the current contained item
	    if {$ptrw eq $w} { hide }
	}
    }
}

proc ::tooltip::show {w msg {i {}}} {
    if {![winfo exists $w]} { return }

    # Use string match to allow that the help will be shown when
    # the pointer is in any child of the desired widget
    if {([winfo class $w] ne "Menu")
	&& ![string match $w* [eval [list winfo containing] \
				   [winfo pointerxy $w]]]} {
	return
    }

    variable G

    after cancel $G(FADEID)
    set b $G(TOPLEVEL)
    # Use late-binding msgcat (lazy translation) to support programs
    # that allow on-the-fly l10n changes
    $b.label configure -text [::msgcat::mc $msg] -justify left
    update idletasks
    set screenw [winfo screenwidth $w]
    set screenh [winfo screenheight $w]
    set reqw [winfo reqwidth $b]
    set reqh [winfo reqheight $b]
    # When adjusting for being on the screen boundary, check that we are
    # near the "edge" already, as Tk handles multiple monitors oddly
    if {$i eq "cursor"} {
	set y [expr {[winfo pointery $w]+20}]
	if {($y < $screenh) && ($y+$reqh) > $screenh} {
	    set y [expr {[winfo pointery $w]-$reqh-5}]
	}
    } elseif {$i ne ""} {
	set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}]
	if {($y < $screenh) && ($y+$reqh) > $screenh} {
	    # show above if we would be offscreen
	    set y [expr {[winfo rooty $w]+[$w yposition $i]-$reqh-5}]
	}
    } else {
	set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}]
	if {($y < $screenh) && ($y+$reqh) > $screenh} {
	    # show above if we would be offscreen
	    set y [expr {[winfo rooty $w]-$reqh-5}]
	}
    }
    if {$i eq "cursor"} {
	set x [winfo pointerx $w]
    } else {
	set x [expr {[winfo rootx $w]+[winfo vrootx $w]+
		     ([winfo width $w]-$reqw)/2}]
    }
    # only readjust when we would appear right on the screen edge
    if {$x<0 && ($x+$reqw)>0} {
	set x 0
    } elseif {($x < $screenw) && ($x+$reqw) > $screenw} {
	set x [expr {$screenw-$reqw}]
    }
    if {[tk windowingsystem] eq "aqua"} {
	set focus [focus]
    }
    # avoid the blink issue with 1 to <1 alpha on Windows, watch half-fading
    catch {wm attributes $b -alpha 0.99}
    wm geometry $b +$x+$y
    wm deiconify $b
    raise $b
    if {[tk windowingsystem] eq "aqua" && $focus ne ""} {
	# Aqua's help window steals focus on display
	after idle [list focus -force $focus]
    }
}

proc ::tooltip::menuMotion {w} {
    variable G

    if {$G(enabled)} {
	variable tooltip

        # Menu events come from a funny path, map to the real path.
        set m [string map {"#" "."} [winfo name $w]]
	set cur [$w index active]

	# The next two lines (all uses of LAST) are necessary until the
	# <<MenuSelect>> event is properly coded for Unix/(Windows)?
	if {$cur == $G(LAST)} return
	set G(LAST) $cur
	# a little inlining - this is :hide
	after cancel $G(AFTERID)
	catch {wm withdraw $G(TOPLEVEL)}
	if {[info exists tooltip($m,$cur)] || \
		(![catch {$w entrycget $cur -label} cur] && \
		[info exists tooltip($m,$cur)])} {
	    set G(AFTERID) [after $G(DELAY) \
		    [namespace code [list show $w $tooltip($m,$cur) cursor]]]
	}
    }
}

proc ::tooltip::hide {{fadeOk 0}} {
    variable G

    after cancel $G(AFTERID)
    after cancel $G(FADEID)
    if {$fadeOk && $G(fade)} {
	fade $G(TOPLEVEL) $G(FADESTEP)
    } else {
	catch {wm withdraw $G(TOPLEVEL)}
    }
}

proc ::tooltip::fade {w step} {
    if {[catch {wm attributes $w -alpha} alpha] || $alpha <= 0.0} {
        catch { wm withdraw $w }
        catch { wm attributes $w -alpha 0.99 }
    } else {
	variable G
        wm attributes $w -alpha [expr {$alpha-$step}]
        set G(FADEID) [after 50 [namespace code [list fade $w $step]]]
    }
}

proc ::tooltip::wname {{w {}}} {
    variable G
    if {[llength [info level 0]] > 1} {
	# $w specified
	if {$w ne $G(TOPLEVEL)} {
	    hide
	    destroy $G(TOPLEVEL)
	    set G(TOPLEVEL) $w
	}
    }
    return $G(TOPLEVEL)
}

proc ::tooltip::listitemTip {w x y} {
    variable tooltip
    variable G

    set G(LAST) -1
    set item [$w index @$x,$y]
    if {$G(enabled) && [info exists tooltip($w,$item)]} {
	set G(AFTERID) [after $G(DELAY) \
		[namespace code [list show $w $tooltip($w,$item) cursor]]]
    }
}

# Handle the lack of <Enter>/<Leave> between listbox items using <Motion>
proc ::tooltip::listitemMotion {w x y} {
    variable tooltip
    variable G
    if {$G(enabled)} {
        set item [$w index @$x,$y]
        if {$item ne $G(LAST)} {
            set G(LAST) $item
            after cancel $G(AFTERID)
            catch {wm withdraw $G(TOPLEVEL)}
            if {[info exists tooltip($w,$item)]} {
                set G(AFTERID) [after $G(DELAY) \
                   [namespace code [list show $w $tooltip($w,$item) cursor]]]
            }
        }
    }
}

# Initialize tooltip events for Listbox widgets
proc ::tooltip::enableListbox {w args} {
    if {[string match *listitemTip* [bind $w <Enter>]]} { return }
    bind $w <Enter> +[namespace code [list listitemTip %W %x %y]]
    bind $w <Motion> +[namespace code [list listitemMotion %W %x %y]]
    bind $w <Leave> +[namespace code [list hide 1]] ; # fade ok
    bind $w <Any-KeyPress> +[namespace code hide]
    bind $w <Any-Button> +[namespace code hide]
}

proc ::tooltip::itemTip {w args} {
    variable tooltip
    variable G

    set G(LAST) -1
    set item [$w find withtag current]
    if {$G(enabled) && [info exists tooltip($w,$item)]} {
	set G(AFTERID) [after $G(DELAY) \
		[namespace code [list show $w $tooltip($w,$item) cursor]]]
    }
}

proc ::tooltip::enableCanvas {w args} {
    if {[string match *itemTip* [$w bind all <Enter>]]} { return }
    $w bind all <Enter> +[namespace code [list itemTip $w]]
    $w bind all <Leave>	+[namespace code [list hide 1]] ; # fade ok
    $w bind all <Any-KeyPress> +[namespace code hide]
    $w bind all <Any-Button> +[namespace code hide]
}

proc ::tooltip::tagTip {w tag} {
    variable tooltip
    variable G
    set G(LAST) -1
    if {$G(enabled) && [info exists tooltip($w,t_$tag)]} {
        if {[info exists G(AFTERID)]} { after cancel $G(AFTERID) }
        set G(AFTERID) [after $G(DELAY) \
            [namespace code [list show $w $tooltip($w,t_$tag) cursor]]]
    }
}

proc ::tooltip::enableTag {w tag} {
    if {[string match *tagTip* [$w tag bind $tag]]} { return }
    $w tag bind $tag <Enter> +[namespace code [list tagTip $w $tag]]
    $w tag bind $tag <Leave> +[namespace code [list hide 1]] ; # fade ok
    $w tag bind $tag <Any-KeyPress> +[namespace code hide]
    $w tag bind $tag <Any-Button> +[namespace code hide]
}

package provide tooltip 1.4.4
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/CVS/Entries.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/ruler.tcl/1.13/Fri Feb 19 19:04:03 2010//
/stext.tcl/1.2/Fri Feb 19 19:04:03 2010//
/widget.man/1.9/Fri Feb 19 19:04:03 2010//
/widget_calendar.man/1.3/Fri Feb 19 19:04:03 2010//
/widget_toolbar.man/1.3/Fri Feb 19 19:04:03 2010//
/dialog.tcl/1.23/Wed Jun  2 06:02:31 2010//
/mentry.tcl/1.7/Wed Jun  2 06:02:31 2010//
/panelframe.tcl/1.6/Wed Jun  2 06:02:31 2010//
/scrollw.tcl/1.15/Wed Jun  2 06:02:31 2010//
/statusbar.tcl/1.8/Wed Jun  2 06:02:31 2010//
/superframe.tcl/1.4/Wed Jun  2 06:02:31 2010//
/toolbar.tcl/1.12/Wed Jun  2 06:02:31 2010//
/widget.tcl/1.6/Wed Jun  2 06:02:31 2010//
/arrowb.tcl/1.1/Fri Jul  9 20:44:50 2010//
/dateentry.tcl/1.5/Thu Sep 30 06:02:23 2010//
/ChangeLog/1.76/Fri Oct  1 06:02:26 2010//
/calendar.tcl/1.10/Fri Oct  1 06:02:26 2010//
/pkgIndex.tcl/1.37/Fri Oct  1 06:02:26 2010//
D
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted scriptlibs/tklib0.5/widget/CVS/Repository.

1
tklib/modules/widget
<


Deleted scriptlibs/tklib0.5/widget/CVS/Root.

1
:pserver:anonymous@tcllib.cvs.sourceforge.net:/cvsroot/tcllib
<


Deleted scriptlibs/tklib0.5/widget/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
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
2010-09-30  Ruediger Haertel <r_haertel@gmx.de>

	* calendar.tcl: allow a -textvariable also from the dateentry
                         namespace. This was a misconception from their
                         beginning.
	* pkgIndex.tcl: bump calendar to v0.96

2010-09-28  Jeff Hobbs  <jeffh@ActiveState.com>

	* pkgIndex.tcl:  Bump dateentry to 0.93
	* dateentry.tcl: address aqua issues causing selection not to
	work, following ttk::combobox.  Do grab/release on popdown
	Map/Unmap and focus on calendar Map.  Set wm transient/group only
	on non-aqua wms.

2010-07-15  Jeff Hobbs  <jeffh@ActiveState.com>

	* pkgIndex.tcl: bump calendar to 0.95
	* calendar.tcl (Refresh): use correct last day, as 8.4 doesn't
	handle going over on days in month for clock scan.

2010-07-09  Andreas Kupries  <andreask@activestate.com>

	* arrowb.tcl: Added arrowbutton widgets using Keith Vetter's
	* pkgIndex.tcl: bitmaps (see http://wiki.tcl.tk/8554). Bumped
	  widget::all version to 1.2.2.

2010-06-02  Andreas Kupries  <andreask@activestate.com>

	* pkgIndex.tcl: Meh, typo'd my update. screenruler is unchanged,
	  scrolledwindow isn't. Fixed.

2010-06-01  Andreas Kupries  <andreask@activestate.com>

	* pkgIndex.tcl: Updated with the actual package versions.

2010-06-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* dateentry.tcl: v0.92
	* dialog.tcl: v1.3.1
	* mentry.tcl: v1.0.1
	* statusbar.tcl: v1.2.1
	* superframe.tcl: v1.0.1
	* scrollw.tcl: v1.2.1
	* toolbar.tcl: v1.2.1 rely on widget to provide tile
	* widget.tcl: v3.1 conditionally require tile (8.4 only)

2009-09-25  Ruediger Haertel <r_haertel@gmx.de>

	* calendar.tcl: handle -textvariable option correctly also
	                  for variables in namespaces
	* pkgIndex.tcl: bump calendar to v0.94

2009-09-25  Ruediger Haertel <r_haertel@gmx.de>

	* calendar.tcl: uninstall trace handler whenever a new
	                  textvariable is assigned
	     . remove bugfix in key bindings which resulted in an Tcl Error
	* pkgIndex.tcl: really bump calendar to v0.93

2009-09-25  Ruediger Haertel <r_haertel@gmx.de>

	* calendar.tcl: uninstall trace handler with dtor
	     . create key bindings to move within the calendar.
	     . changing the language immediately refreshes the widget.
	     . for english and german the string "Today is"
	           is displayed, other languages don't have this.

	* widget_calendar.tcl: added section with key bindings
	* pkgIndex.tcl: bump calendar to v0.93

2009-09-25  Ruediger Haertel <r_haertel@gmx.de>

	* calendar.tcl: install/uninstall trace handler when
	                -textvariable is set/unset
	* pkgIndex.tcl: bump calendar to v0.92

2009-08-17  Jeff Hobbs  <jeffh@ActiveState.com>

	* calendar.tcl: correct leading 0-month issues.
	Make 8.4-friendly by not needing clock scan -format.
	* pkgIndex.tcl: bump calendar to v0.91

2009-01-21  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tklib 0.5 ========================
	*

2008-11-23  Ruediger Haertel <r_haertel@gmx.de>

	* widget_calendar.man: added documentation to widget::calendar

2008-11-23  Ruediger Haertel <r_haertel@gmx.de>

	* widget.man: added widget::calendar and widget::dateentry
	to the overview of snidgets in this package

2008-11-13  Jeff Hobbs  <jeffh@ActiveState.com>

	* pkgIndex.tcl: widget::calendar 0.9 ; widget::dataentry 0.91
	* calendar.tcl: new widget::calendar adapted from the dateentry
	dropbox pieces.  Now can be used as a stand-alone widget.
	* dateentry.tcl: update to use calendar widget in dropbox.

2008-11-12  Jeff Hobbs  <jeffh@ActiveState.com>

	* pkgIndex.tcl: add widget::dateentry 0.9
	* dateentry.tcl: first pass at a dateentry dropbox, by Ruediger
	Haertel with updates from JH.

2008-06-17  Jeff Hobbs  <jeffh@ActiveState.com>

	* pkgIndex.tcl: bump panelframe to 1.1.
	* panelframe.tcl: handle the case of empty color names (occurs on
	OS X) for use of fg/bg.

2008-02-21  Jeff Hobbs  <jeffh@ActiveState.com>

	* pkgIndex.tcl: bump widget::screenruler to 1.2
	* ruler.tcl (C-showgeometry): prevent entry input from triggering
	the toplevel bindings.

2007-06-20  Jeff Hobbs  <jeffh@ActiveState.com>

	* statusbar.tcl: update to 1.2, actual API changes (matched closer
	to toolbar), but they were not documented previously.  The core
	API remains and should be compatible with most standard use cases.
	Remove fallback sizegrip image usage, requires ttk::sizegrip now.
	update option handling with latest snit features.

	* toolbar.tcl (add): update to 1.2
	update option handling with latest snit features.
	Pass -pad to frame.
	Rename 'itemidentify' to 'itemid'.

	* stext.tcl (new): example adaptation of scrolledwindow to create
	a scrolledtext widget.

	* ruler.tcl: update to 1.1
	Correct zoom menu to show proper label.
	update option handling with latest snit features.

	* scrollw.tcl: update to 1.2
	update option handling with latest snit features.
	Use ttk::scrollbar on Windows (just not on Aqua).
	Correctly handle widgets with 1-dim scrolling.
	rework auto-handling of scrollbars.

2007-04-10  Jeff Hobbs  <jeffh@ActiveState.com>

	* scrollw.tcl: cancel pending timer in case we are destroyed

	* mentry.tcl (::widget::createMenuEntryLayout): handle variant
	style cmd usage for 8.4 and 8.5+.

2007-03-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl (C-transient, C-parent): ensure we unset parent
	transient and group when not both are set.

2007-01-30  Andreas Kupries  <andreask@activestate.com>

	* toolbar.tcl (itemidentify): New method, converting symbolic
	  button names to their actual widget path.
	* toolbar.tcl (items): Simplified the code.

2007-01-21  Jeff Hobbs  <jeffh@ActiveState.com>

	* scrollw.tcl (_set_scroll): move loop lock detection to include
	removal of scrollbar

2006-12-05  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl (PlaceWindow): handle unmapped anchor

2006-11-27  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl (PlaceWindow): always raise after deiconify

2006-11-15  Jeff Hobbs  <jeffh@ActiveState.com>

	* ruler.tcl: add screenruler menu bindings and underlines

2006-11-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl (display): init lastFocusGrab properly
	don't restore focus/grab if we weren't mapped

2006-11-02  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl: add -focus option to set desired subwindow focus,
	and make sure we don't restore focus/grab to a subwindow on withdraw

2006-10-27  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl (display): don't tkwait, as it will just hang for an
	already displayed window (a Tk misfeature ... but oh well).

2006-10-19  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl: handle -separator changed with option default

2006-10-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl (withdraw): fix grab handling to properly release

2006-09-29  Jeff Hobbs  <jeffh@ActiveState.com>

	* scrollw.tcl: fix error gridding scrollbar from 2006-09-25 change
	to handle the variant options for vsb vs. hsb correctly.

2006-09-26  Jeff Hobbs  <jeffh@ActiveState.com>

	* toolbar.tcl (add): separator item should have no pady by default
	(add): add label and radiobutton item support

2006-09-25  Jeff Hobbs  <jeffh@ActiveState.com>

	* scrollw.tcl: consolidate scroll handling to one method.
	Add extra check for loop condition (last min/max).

2006-09-22  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl (display): correct handling of -modal == local

2006-09-07  Andreas Kupries  <andreask@activestate.com>

	* widget_toolbar.man: Fixed missing closing bracket.

	* pkgIndex.tcl (::tcl::pkgindex): Reworked the 'pkindex' command
	  to make it more general, and more susceptible to programmatic
	  analysis (meta data extraction).

2006-09-07  Jeff Hobbs  <jeffh@ActiveState.com>

	* widget.tcl (::widget::isa): correct error result for 'isa list'

	* widget.man: include all current widgets
	* widget_toolbar.man: man page for widget::toolbar

	* pkgIndex.tcl (::widget::pkgindex): made pkgindex to consolidate
	commands for widget::all more easily

	* toolbar.tcl: allow for '$tbar add separator'.
	allow for %AUTO% as name in special-purpose add types.
	ensure we only delete toolbar-created widgets on add error.
	check for item existence in itemcget.
	add '$tbar add space' for a spacer item.

2006-08-24  Jeff Hobbs  <jeffh@ActiveState.com>

	* statusbar.tcl: use ttk::sizegrip if available.
	* pkgIndex.tcl:  update statusbar to 1.1.

2006-08-02  Jeff Hobbs  <jeffh@ActiveState.com>

	* panelframe.tcl (add): correct call to _padval. [Bug #1522881]

2006-07-05  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl (setwidget): configure frame resizability only if we
	setwidget into it.  It confuses use with getframe.

2006-06-29  Jeff Hobbs  <jeffh@ActiveState.com>

	* mentry.tcl: update the icon with a better drop arrow
	(::widget::createMenuEntryLayout): simplify theme settings

	* statusbar.tcl (add): remove neighboring separator when removing
	the first item.

	* dialog.tcl (PlaceWindow): add a raise after deiconify.

2006-06-22  Jeff Hobbs  <jeffh@ActiveState.com>

	* mentry.tcl: use Ctrl-space for popdown key (was Key-Space).

	* statusbar.tcl (C-ipad): allow 4-int -(i)pad, make default -ipad 2.
	Ensure minimum separator spacing and adjust item padding for sep.

	* toolbar.tcl (C-ipad): allow 4-int -(i)pad, make default -ipad 2.
	Ensure minimum separator spacing and adjust item padding for sep.
	Correct adding of typed items.

	* widget.tcl (::widget::isa): correct listofint range handling

2006-06-21  Jeff Hobbs  <jeffh@ActiveState.com>

	* mentry.tcl: new image with drop-arrow and improved padding

2006-06-20  Jeff Hobbs  <jeffh@ActiveState.com>

	* mentry.tcl:   prototype menuentry widget (entry with associated
	* pkgIndex.tcl: menu under an icon).

	* pkgIndex.tcl:
	* toolbar.tcl: add widget::toolbar that eases toolbar handling

	* statusbar.tcl: s/-show/-/ in option names.  Make -separator
	default to 0 for add items.

2006-06-19  Jeff Hobbs  <jeffh@ActiveState.com>

	* statusbar.tcl: add widget::statusbar, equivalent to BWidget
	* pkgIndex.tcl:  StatusBar widget.

	* scrollw.tcl: remove widget::tscrolledwindow, make
	widget::scrolledwindow use a ttk::frame, bump to 1.1.

2006-06-15  Jeff Hobbs  <jeffh@ActiveState.com>

	* scrollw.tcl: support scrollbar actually being a ttk::scrollbar.

2006-06-06  Andreas Kupries <andreask@activestate.com>

	* scrollw.tcl: Added provide statement for 'tscrolledwindow'.

2006-06-05  Jeff Hobbs  <jeffh@ActiveState.com>

	* ruler.tcl: make sure reflect(id) gets cancelled

	* scrollw.tcl: added ttk scrolledwindow variant
	* pkgIndex.tcl: added widget::tscrolledwindow

2005-11-10  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tklib 0.4.1 ========================
	*

2005-11-02  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tklib 0.4 ========================
	*

2005-10-12  Jeff Hobbs  <jeffh@ActiveState.com>

	* pkgIndex.tcl: Bumped widget::dialog to v1.2.
	* dialog.tcl: allow -type custom dialogs to be synchronous, add an
	example showing user how to use it properly.

2005-09-26  Jeff Hobbs  <jeffh@ActiveState.com>

	* pkgIndex.tcl: bumped widget::screenruler to 1.1
	* ruler.tcl: fix off-by-one drawing in ruler and let the loupe
	auto-center around the pointer for us.

2005-09-25  Jeff Hobbs  <jeffh@ActiveState.com>

	* ruler.tcl: add -zoom option, add proper destructors, make
	-measure work, add -reflect option to screenruler.
	Add -showgeometry to control geometry strictly.

	* dialog.tcl: add docs
	* scrollw.tcl: change non-working -padding to working -ipad

2005-09-21  Jeff Hobbs  <jeffh@ActiveState.com>

	* widget.man, pkgIndex.tcl, ruler.tcl: add widget::ruler widget
	and widget::screenruler dialog

2005-09-12  Jeff Hobbs  <jeffh@ActiveState.com>

	* scrollw.tcl: move tk call after 'package require widget'

2005-09-08  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl: add -timeout ms option to dialog

	* scrollw.tcl: use ttk::scrollbar on x11

2005-08-25  Jeff Hobbs  <jeffh@ActiveState.com>

	* dialog.tcl: don't require 'name' in dialog button add, allow
	widget pathnames to be inserted, up to v1.1

2005-08-22  Jeff Hobbs  <jeffh@ActiveState.com>

	* widget.tcl: add widget::tkresource to get default class options.
	add widget::propagate snit macro to do multi-component propagation.
	* panelframe.tcl: widget::panelframe to create color-bordered
	frames.  This could be part of superframe, but then superframe
	would need extra widgets

	* widget.tcl:   new megawidget package, based on snit (snidgets)
	* widget.man:
	* pkgIndex.tcl:
	* dialog.tcl:     widget::dialog megawidget dialog
	* superframe.tcl: widget::superframe enhanced frame types
	* scrollw.tcl:    widget::scrolledwindow BWidget::ScrolledWindow port
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/arrowb.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
##+##########################################################################
#
# Reference
#    http://wiki.tcl.tk/8554
#
# arrows.tcl -- bitmaps for eight directional arrows
# by Keith Vetter, Mar 12, 2003
# by Keith Vetter, July 2, 2010  added diagonal arrows
# snit class by Andreas Kupries
#

package require widget

snit::widgetadaptor widget::arrowbutton {
    delegate option * to hull except -image
    delegate method * to hull

    option -orientation \
	-configuremethod C-orientation \
	-validatemethod  V-orientation

    constructor {args} {
        installhull using ttk::button
        $self configurelist $args
	return
    }

    method C-orientation {o value} {
	set options($o) $value
	$hull configure -image ::widget::arrowbutton::bit::$value
	return
    }

    method V-orientation {o value} {
	if {$value in $ourorientation} return
	return -code error "Expected one of [linsert [join $ourorientation {, }] end-1 or], got \"$value\""
    }

    typevariable ourorientation {
	down
	downleft
	downright
	left
	right
	star
	up
	upleft
	upright
    }
}

image create bitmap ::widget::arrowbutton::bit::up -data {
    #define up_width 11
    #define up_height 11
    static char up_bits = {
        0x00, 0x00, 0x20, 0x00, 0x70, 0x00, 0xf8, 0x00, 0xfc, 0x01, 0xfe,
        0x03, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x00, 0x00, 0x00, 0x00
    }
}
image create bitmap ::widget::arrowbutton::bit::down -data {
    #define down_width 11
    #define down_height 11
    static char down_bits = {
        0x00, 0x00, 0x00, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0xfe,
        0x03, 0xfc, 0x01, 0xf8, 0x00, 0x70, 0x00, 0x20, 0x00, 0x00, 0x00
    }
}
image create bitmap ::widget::arrowbutton::bit::left -data {
    #define left_width 11
    #define left_height 11
    static char left_bits = {
        0x00, 0x00, 0x20, 0x00, 0x30, 0x00, 0x38, 0x00, 0xfc, 0x01, 0xfe,
        0x01, 0xfc, 0x01, 0x38, 0x00, 0x30, 0x00, 0x20, 0x00, 0x00, 0x00
    }
}
image create bitmap ::widget::arrowbutton::bit::right -data {
    #define right_width 11
    #define right_height 11
    static char right_bits = {
        0x00, 0x00, 0x20, 0x00, 0x60, 0x00, 0xe0, 0x00, 0xfc, 0x01, 0xfc,
        0x03, 0xfc, 0x01, 0xe0, 0x00, 0x60, 0x00, 0x20, 0x00, 0x00, 0x00
    }
}
image create bitmap ::widget::arrowbutton::bit::upleft -data {
    #define upleft_width 11
    #define upleft_height 11
    static char upleft_bits = {
        0x00, 0x00, 0x7e, 0x00, 0x3e, 0x00, 0x3e, 0x00, 0x7e, 0x00, 0xfe,
        0x00, 0xf2, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00
    }    
}
image create bitmap ::widget::arrowbutton::bit::upright -data {
    #define upright_width 11
    #define upright_height 11
    static char upright_bits = {
        0x00, 0x00, 0xf0, 0x03, 0xe0, 0x03, 0xe0, 0x03, 0xf0, 0x03, 0xf8,
        0x03, 0x7c, 0x02, 0x38, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00
    }
}
image create bitmap ::widget::arrowbutton::bit::downleft -data {
    #define downleft_width 11
    #define downleft_height 11
    static char downleft_bits = {
        0x00, 0x00, 0x00, 0x00, 0x40, 0x00, 0xe0, 0x00, 0xf2, 0x01, 0xfe,
        0x00, 0x7e, 0x00, 0x3e, 0x00, 0x3e, 0x00, 0x7e, 0x00, 0x00, 0x00
    }
}
image create bitmap ::widget::arrowbutton::bit::downright -data {
    #define downright_width 11
    #define downright_height 11
    static char downright_bits = {
        0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x02, 0xf8,
        0x03, 0xf0, 0x03, 0xe0, 0x03, 0xe0, 0x03, 0xf0, 0x03, 0x00, 0x00
    }
}
image create bitmap ::widget::arrowbutton::bit::star -data {
    #define plus_width 11
    #define plus_height 11
    static char plus_bits = {
        0x00, 0x00, 0x22, 0x02, 0x24, 0x01, 0xa8, 0x00, 0x70, 0x00, 0xfe,
        0x03, 0x70, 0x00, 0xa8, 0x00, 0x24, 0x01, 0x22, 0x02, 0x00, 0x00
    }
}

package provide widget::arrowbutton 1
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































Deleted scriptlibs/tklib0.5/widget/calendar.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
# -*- tcl -*-
#
# calendar.tcl -
#
#	Calendar widget drawn on a canvas.
#	Adapted from Suchenwirth code on the wiki.
#
# Copyright (c) 2008 Rüdiger Härtel
#
# RCS: @(#) $Id: calendar.tcl,v 1.10 2010/09/30 18:57:23 haertel Exp $
#

#
# Creation and Options - widget::calendar $path ...
# -command        -default {}
# -dateformat     -default "%m/%d/%Y"
# -font           -default {Helvetica 9}
# -textvariable   -default {}
# -firstday       -default "monday"
# -highlightcolor -default "#FFCC00"
# -shadecolor     -default "#888888"
# -language       -default en   Supported languages: de, en, es, fr, gr,
#                                he, it, ja, sv, pt, zh, fi ,tr, nl, ru,
#                                crk, crx-nak, crx-lhe
#
#  All other options to canvas
#
# Methods
#  $path get <part>   => selected date, part can be
#                              day,month,year, all
#                         default is all
#  All other methods to canvas
#
# Bindings
#  NONE
#

if 0 {
    # Samples
    package require widget::calendar
    #set db [widget::calendar .db]
    #pack $sw -fill both -expand 1
}

###

package require widget

snit::widgetadaptor widget::calendar {
    delegate option * to hull
    delegate method * to hull

    option -firstday       -default monday        -configuremethod C-refresh \
					      -type [list snit::enum -values [list sunday monday]]
    option -textvariable   -default {}            -configuremethod C-textvariable

    option -command        -default {}
    option -dateformat     -default "%m/%d/%Y"    -configuremethod C-refresh
    option -font           -default {Helvetica 9} -configuremethod C-font
    option -highlightcolor -default "#FFCC00"     -configuremethod C-refresh
    option -shadecolor     -default "#888888"     -configuremethod C-refresh
    option -language       -default en            -configuremethod C-language
    option -showpast       -default 1             -configuremethod C-refresh \
						  -type {snit::boolean}


    variable fullrefresh 1
    variable pending "" ; # pending after id for refresh
    variable data -array {
	day 01 month 01 year 2007
	linespace 0 cellspace 0
	selday {} selmonth {} selyear {}
    }

    constructor args {
	installhull using canvas -highlightthickness 0 -borderwidth 0 \
	    -background white
	bindtags $win [linsert [bindtags $win] 1 Calendar]

	set now [clock scan "today 00:00:00"]

	foreach {data(day) data(month) data(year)} \
	    [clock format $now -format "%e %m %Y"] { break }
	scan $data(month) %d data(month) ; # avoid leading 0 issues

	set data(selday)   $data(day)
	set data(selmonth) $data(month)
	set data(selyear)  $data(year)

	# Binding for the 'day' tagged items
	$win bind day <1>           [mymethod invoke]

	    # move days
	bind $win <Left>            [mymethod adjust -1  0  0]
	bind $win <Right>           [mymethod adjust  1  0  0]
	    # move weeks
	bind $win <Up>              [mymethod adjust -7  0  0]
	bind $win <Down>            [mymethod adjust  7  0  0]
	    # move months
	bind $win <Control-Left>    [mymethod adjust  0 -1  0]
	bind $win <Control-Right>   [mymethod adjust  0  1  0]
	    # move years
	bind $win <Control-Up>      [mymethod adjust  0  0 -1]
	bind $win <Control-Down>    [mymethod adjust  0  0  1]

	$self configurelist $args

	$self reconfigure
	$self refresh
    }

    destructor {
	if { $options(-textvariable) ne "" } {
	    trace remove variable $options(-textvariable) write [mymethod DoUpdate]
	}
    }

    #
    # C-font --
    #
    #  Configure the font of the widget
    #
    ##
    method C-font {option value} {
	set options($option) $value
	$self reconfigure
	set fullrefresh 1
	$self refresh
    }

    #
    # C-refresh --
    #
    #  Place holder for all options that need a refresh after
    #  takeing over the new option.
    #
    ##
    method C-refresh {option value} {
	set options($option) $value
	$self refresh
    }

    #
    # C-textvariable --
    #
    #  Configure the textvariable for the widget. Installs a
    #  trace handler for the variable.
    #  If an empty textvariable is given the trace handler is
    #  uninstalled.
    #
    ##
    method C-textvariable {option value} {

	if {![string match ::* $value]} {
	    set value ::$value
	}
	set options($option) $value

	if {$value ne "" } {
	    trace remove variable $options(-textvariable) write [mymethod DoUpdate]

	    if { ![info exists $options($option)] } {
	        set now [clock seconds]
	        set $options($option) [clock format $now -format $options(-dateformat)]
	    }

	    trace add variable ::$value write [mymethod DoUpdate]
	    if { [info exists $value] } {
		$self DoUpdate
	    }
	}
    }

    #
    # C-language --
    #
    #  Configure the language of the calendar.
    #
    ##
    method C-language {option value} {

	set langs [list \
		    de en es fr gr he it ja sv pt zh fi tr nl ru \
		    crk  \
		    crx-nak \
		    crx-lhe \
	]
	if { $value ni $langs } {
	    return -code error "Unsupported language. Choose one of: $langs"
	}

	set options($option) $value

	$self refresh
    }

    #
    # DoUpdate --
    #
    #  Update the internal values of day, month and year when the
    #  textvariable is written to (trace callback).
    #
    ##
    method DoUpdate { args } {

	set value $options(-textvariable)
	set tmp [set $value]
	if {$tmp eq ""} { return }
	if {$::tcl_version < 8.5} {
	    # Prior to 8.4, users must use [clock]-recognized dateformat
	    set date [clock scan $tmp]
	} else {
	    set date [clock scan $tmp -format $options(-dateformat)]
	}

	foreach {data(day) data(month) data(year)} \
	    [clock format $date -format "%e %m %Y"] { break }
	scan $data(month) %d data(month) ; # avoid leading 0 issues

	set data(selday)   $data(day)
	set data(selmonth) $data(month)
	set data(selyear)  $data(year)

	$self refresh
    }

    #
    # get --
    #   Return parts of the selected date or the complete date.
    #
    # Arguments:
    #   what  - Selects the part of the date or the complete date.
    #            values <day,month,year, all>, default is all
    #
    ##
    method get {{what all}} {
	switch -exact -- $what {
	    "day"   { return $data(selday) }
	    "month" { return $data(selmonth) }
	    "year"  { return $data(selyear) }
	    "all"   {
		if {$data(selday) ne ""} {
		    set date [clock scan $data(selmonth)/$data(selday)/$data(selyear)]
		    set fmtdate [clock format $date -format $options(-dateformat)]
		    return $fmtdate
		}
	    }
	    default {
		return -code error "unknown component to retrieve \"$what\",\
			must be one of day, month or year"
	    }
	}
    }

    #
    # adjust --
    #
    #   Adjust internal values of the calendar and update the contents
    #   of the widget. This function is invoked by pressing the arrows
    #   in the widget and on key bindings.
    #
    # Arguments:
    #   dday    - Difference in days
    #   dmonth  - Difference in months
    #   dyear   - Difference in years
    #
    ##
    method adjust {dday dmonth dyear} {
	incr data(year)  $dyear
	incr data(month) $dmonth

	set maxday [$self numberofdays $data(month) $data(year)]

	if { ($data(day) + $dday) < 1}  {
	    incr data(month) -1

	    set maxday [$self numberofdays $data(month) $data(year)]
	    set  data(day) [expr {($data(day) + $dday) % $maxday}]

	} else {

	    if { ($data(day) + $dday) > $maxday } {

		incr data(month) 1
		set  data(day)   [expr {($data(day) + $dday) % $maxday}]

	    } else {
		incr data(day) $dday
	    }
	}


	if { $data(month) > 12} {
	    set  data(month) 1
	    incr data(year)
	}

	if { $data(month) < 1}  {
	    set  data(month) 12
	    incr data(year)  -1
	}


	set maxday [$self numberofdays $data(month) $data(year)]
	if { $maxday < $data(day) } {
	    set data(day) $maxday
	}
	set data(selday)   $data(day)
	set data(selmonth) $data(month)
	set data(selyear)  $data(year)

	$self refresh
    }

    method cbutton {x y w command} {
	# Draw simple arrowbutton using Tk's line arrows
	set wd [expr {abs($w)}]
	set wd2 [expr {$wd/2. - ((abs($w) < 10) ? 1 : 2)}]
	set poly [$hull create line $x $y [expr {$x+$w}] $y -arrow last \
		      -arrowshape [list $wd $wd $wd2] \
		      -tags [list cbutton shadetext]]
	$hull bind $poly <1> $command
    }

    method reconfigure {} {
	set data(cellspace) [expr {[font measure $options(-font) "30"] * 2}]
	set w [expr {$data(cellspace) * 8}]
	set data(linespace) [font metrics $options(-font) -linespace]
	set h [expr {int($data(linespace) * 9.25)}]
	$hull configure -width $w -height $h
    }

    method refresh { } {
	# Idle deferred refresh
	after cancel $pending
	set pending [after idle [mymethod Refresh ]]
    }

    method Refresh { } {
	# Set up coords based on font spacing
	set x  [expr {$data(cellspace) / 2}]; set x0 $x
	set dx $data(cellspace)

	set y [expr {int($data(linespace) * 1.75)}]
	set dy $data(linespace)
	set pad [expr {$data(linespace) / 2}]

	set xmax [expr {$x0+$dx*6}]
	set winw [$hull cget -width]
	set winh [$hull cget -height]

	if {$fullrefresh} {
	    set fullrefresh 0
	    $hull delete all

	    # Left and Right buttons
	    set xs [expr {$data(cellspace) / 2}]
	    $self cbutton [expr {$xs+2}] $pad -$xs              [mymethod adjust 0  0 -1]; # <<
	    $self cbutton [expr {$xs*2}] $pad [expr {-$xs/1.5}] [mymethod adjust 0 -1  0]; # <
	    set lxs [expr {$winw - $xs - 2}]
	    $self cbutton $lxs $pad $xs                         [mymethod adjust 0  0  1]; # >>
	    incr lxs -$xs
	    $self cbutton $lxs $pad [expr {$xs/1.5}]            [mymethod adjust 0  1  0]; # >

	    # day (row) and weeknum (col) headers
	    $hull create rect 0 [expr {$y - $pad}] $winw [expr {$y + $pad}] \
		-tags shade
	    $hull create rect 0 [expr {$y - $pad}] $dx $winh -tags shade
	} else {
	    foreach tag {title otherday day highlight week} {
		$hull delete $tag
	    }
	}

	# Title "Month Year"
	set title [$self formatMY $data(month) $data(year)]
	$hull create text [expr {$winw/2}] $pad -text $title -tag title \
	    -font $options(-font) -fill blue

	# weekdays - could be drawn on fullrefresh, watch -firstday change
	set weekdays $LANGS(weekdays,$options(-language))
	if {$options(-firstday) eq "monday"} { $self lcycle weekdays }
	foreach i $weekdays {
	    incr x $dx
	    $hull create text $x $y -text $i -fill white \
		-font $options(-font) -tag title
	}

	# place out the days
	set first $data(month)/1/$data(year)
	set weekday [clock format [clock scan $first] -format %w]
	if {$options(-firstday) eq "monday"} {
	    set weekday [expr {($weekday+6)%7}]
	}

	# Print days preceding the 1st of the month
	set x [expr {$x0+$weekday*$dx}]
	set x1 $x; set offset 0
	incr y $dy
	while {$weekday} {
	    set t [clock scan "$first [incr offset] days ago"]
	    set day [clock format $t -format "%e"] ; # %d w/o leading 0
	    $hull create text $x1 $y -text $day \
		-font $options(-font) -tags [list otherday shadetext]
	    incr weekday -1
	    incr x1 -$dx
	}
	set dmax [$self numberofdays $data(month) $data(year)]

	for {set d 1} {$d <= $dmax} {incr d} {
	    incr x $dx
	    if {($options(-showpast) == 0)
		&& ($d < $data(selday))
		&& ($data(month) <= $data(selmonth))
		&& ($data(year) <= $data(selyear))} {
		# XXX day in the past - above condition currently broken
		set id [$hull create text $x $y -text $d \
			    -tags [list otherday shadetext] \
			    -font $options(-font)]
	    } else {
		# current month day
		set id [$hull create text $x $y -text $d -tag day \
			    -font $options(-font)]
	    }
	    if {$d == $data(selday) && ($data(month) == $data(selmonth))} {
		# selected day
		$hull create rect [$hull bbox $id] -tags [list day highlight]
	    }
	    $hull raise $id
	    if {$x > $xmax} {
		# Week of the year
		set x $x0
		set week [$self getweek $d $data(month) $data(year)]
		$hull create text [expr {$x0}] $y -text $week -tag week \
		    -font $options(-font) -fill white
		incr y $dy
	    }
	}
	# Week of year (last day)
	if {$x != $x0} {
	    set week [$self getweek $dmax $data(month) $data(year)]
	    $hull create text [expr {$x0}] $y -text $week -tag week \
		-font $options(-font) -fill white
	    for {set d 1} {$x <= $xmax} {incr d} {
		incr x $dx
		$hull create text $x $y -text $d \
		    -tags [list otherday shadetext] \
		    -font $options(-font)
	    }
	}

	# Display Today line
	set now [clock seconds]
	set today "$LANGS(today,$options(-language)) [clock format $now -format $options(-dateformat)]"
	$hull create text [expr {$winw/2}] [expr {$winh - $pad}] -text $today \
	    -tag week -font $options(-font) -fill black

	# Make sure options-based items are set
	$hull itemconfigure highlight \
	    -fill $options(-highlightcolor) \
	    -outline $options(-highlightcolor)
	$hull itemconfigure shadetext -fill $options(-shadecolor)
	$hull itemconfigure shade -fill $options(-shadecolor) \
	    -outline $options(-shadecolor)
    }

    method getweek {day month year} {
	set _date [clock scan $month/$day/$year]
	return [clock format $_date -format %V]
    }

    method invoke {} {

	catch {focus -force $win} msg
	if { $msg ne "" } {
	#    puts $msg
	}
	set item [$hull find withtag current]
	set data(day) [$hull itemcget $item -text]

	set data(selday) $data(day)
	set data(selmonth) $data(month)
	set data(selyear) $data(year)
	set date    [clock scan   $data(month)/$data(day)/$data(year)]
	set fmtdate [clock format $date -format $options(-dateformat)]

	if {$options(-textvariable) ne {}} {
	    set $options(-textvariable) $fmtdate
	}

	if {$options(-command) ne {}} {
	    # pass single arg of formatted date chosen
	    uplevel \#0 $options(-command) [list $fmtdate]
	}

	$self refresh
    }

    method formatMY {month year} {
	set lang $options(-language)
	if {[info exists LANGS(mn,$lang)]} {
	    set month [lindex $LANGS(mn,$lang) $month]
	} else {
	    set _date [clock scan $month/1/$year]
	    set month [clock format $_date -format %B] ; # full month name
	}
	if {[info exists LANGS(format,$lang)]} {
	    set format $LANGS(format,$lang)
	} else {
	    set format "%m %Y" ;# default
	}
	# Replace month/year and do any necessary substs
	return [subst [string map [list %m $month %Y $year] $format]]
    }

    method numberofdays {month year} {
	if {$month == 12} {set month 0; incr year}
	clock format [clock scan "[incr month]/1/$year	1 day ago"] -format %d
    }

    method lcycle _list {
	upvar $_list list
	set list [concat [lrange $list 1 end] [list [lindex $list 0]]]
    }

    typevariable LANGS -array {
	mn,crk {
	    . Kis\u01E3p\u012Bsim Mikisiwip\u012Bsim Niskip\u012Bsim Ay\u012Bkip\u012Bsim
	    S\u0101kipak\u0101wip\u012Bsim
	    P\u0101sk\u0101wihowip\u012Bsim Paskowip\u012Bsim Ohpahowip\u012Bsim
	    N\u014Dcihitowip\u012Bsim Pin\u0101skowip\u012Bsim Ihkopiwip\u012Bsim
	    Paw\u0101cakinas\u012Bsip\u012Bsim
	}
	weekdays,crk {P\u01E3 N\u01E3s Nis N\u01E3 Niy Nik Ay}
	today,crk {}

	mn,crx-nak {
	    . {Sacho Ooza'} {Chuzsul Ooza'} {Chuzcho Ooza'} {Shin Ooza'} {Dugoos Ooza'} {Dang Ooza'}\
		{Talo Ooza'} {Gesul Ooza'} {Bit Ooza'} {Lhoh Ooza'} {Banghan Nuts'ukih} {Sacho Din'ai}
	}
	weekdays,crx-nak {Ji Jh WN WT WD Ts Sa}
	today,crx-nak {}

	mn,crx-lhe {
	    . {'Elhdzichonun} {Yussulnun} {Datsannadulhnun} {Dulats'eknun} {Dugoosnun} {Daingnun}\
		{Gesnun} {Nadlehcho} {Nadlehyaz} {Lhewhnandelnun} {Benats'ukuihnun} {'Elhdziyaznun}
	}
	weekdays,crx-lhe {Ji Jh WN WT WD Ts Sa}
	today,crx-lhe {}

	mn,de {
	    . Januar Februar März April Mai Juni Juli August
	    September Oktober November Dezember
	}
	weekdays,de {So Mo Di Mi Do Fr Sa}
	today,de {Heute ist der}

	mn,en {
	    . January February March April May June July August
	    September October November December
	}
	weekdays,en {Su Mo Tu We Th Fr Sa}
	today,en {Today is}

	mn,es {
	    . Enero Febrero Marzo Abril Mayo Junio Julio Agosto
	    Septiembre Octubre Noviembre Diciembre
	}
	weekdays,es {Do Lu Ma Mi Ju Vi Sa}
	today,es {}

	mn,fr {
	    . Janvier Février Mars Avril Mai Juin Juillet Août
	    Septembre Octobre Novembre Décembre
	}
	weekdays,fr {Di Lu Ma Me Je Ve Sa}
	today,fr {}

	mn,gr {
	    . Îýý???Ïýý?Ïýý??Ïýý ???Ïýý?Ïýý?Ïýý??Ïýý Îýý?ÏýýÏýý??Ïýý ÎýýÏýýÏýý????Ïýý Îýý?Îýý?Ïýý Îýý?Ïýý???Ïýý Îýý?Ïýý???Ïýý ÎýýÏýý??ÏýýÏýýÏýý?Ïýý
	    ??ÏýýÏýýÎýý??Ïýý??Ïýý Îýý?ÏýýÏýý??Ïýý??Ïýý Îýý?Îýý??Ïýý??Ïýý Îýý??Îýý??Ïýý??Ïýý
	}
	weekdays,gr {ÎýýÏýýÏýý Îýý?Ïýý TÏýý? ??Ïýý Î ?? Î ?Ïýý ???}
	today,gr {}

	mn,he {
	    . ×ýý× ×ýý×ýý? ?×ýý?×ýý×ýý? ×ýý?? ×ýý??×ýý×ýý ×ýý×ýý×ýý ×ýý×ýý× ×ýý ×ýý×ýý×ýý×ýý ×ýý×ýý×ýý×ýý?×ýý ??×ýý×ýý×ýý? ×ýý×ýý?×ýý×ýý×ýý? × ×ýý×ýý×ýý×ýý? ×ýý?×ýý×ýý?
	}
	weekdays,he {?×ýý?×ýý×ýý ?× ×ýý ?×ýý×ýý?×ýý ?×ýý×ýý?×ýý ×ýý×ýý×ýý?×ýý ?×ýý?×ýý ?×ýý?}
	today,he {}

	mn,it {
	    . Gennaio Febraio Marte Aprile Maggio Giugno Luglio Agosto
	    Settembre Ottobre Novembre Dicembre
	}
	weekdays,it {Do Lu Ma Me Gi Ve Sa}
	today,it {}

	format,ja {%Y\u5e74 %m\u6708}
	weekdays,ja {\u65e5 \u6708 \u706b \u6c34 \u6728 \u91d1 \u571f}
	today,ja {}

	mn,nl {
	    . januari februari maart april mei juni juli augustus
	    september oktober november december
	}
	weekdays,nl {Zo Ma Di Wo Do Vr Za}
	today,nl {}

	mn,ru {
	    . \u042F\u043D\u0432\u0430\u0440\u044C
	    \u0424\u0435\u0432\u0440\u0430\u043B\u044C \u041C\u0430\u0440\u0442
	    \u0410\u043F\u0440\u0435\u043B\u044C \u041C\u0430\u0439
	    \u0418\u044E\u043D\u044C \u0418\u044E\u043B\u044C
	    \u0410\u0432\u0433\u0443\u0441\u0442
	    \u0421\u0435\u043D\u0442\u044F\u0431\u0440\u044C
	    \u041E\u043A\u0442\u044F\u0431\u0440\u044C \u041D\u043E\u044F\u0431\u0440\u044C
	    \u0414\u0435\u043A\u0430\u0431\u0440\u044C
	}
	weekdays,ru {
	    \u432\u43e\u441 \u43f\u43e\u43d \u432\u442\u43e \u441\u440\u435
	    \u447\u435\u442 \u43f\u44f\u442 \u441\u443\u431
	}
	today,ru {}

	mn,sv {
	    . januari februari mars april maj juni juli augusti
	    september oktober november december
	}
	weekdays,sv {s\u00F6n m\u00E5n tis ons tor fre l\u00F6r}
	today,sv {}

	mn,pt {
	    . Janeiro Fevereiro Mar\u00E7o Abril Maio Junho
	    Julho Agosto Setembro Outubro Novembro Dezembro
	}
	weekdays,pt {Dom Seg Ter Qua Qui Sex Sab}
	today,pt {}

	format,zh {%Y\u5e74 %m\u6708}
	mn,zh {
	    . \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d \u4e03
	    \u516b \u4e5d \u5341 \u5341\u4e00 \u5341\u4e8c
	}
	weekdays,zh {\u65e5 \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d}
	today,zh {}

	mn,fi {
	    . Tammikuu Helmikuu Maaliskuu Huhtikuu Toukokuu Kesäkuu
	    Heinäkuu Elokuu Syyskuu Lokakuu Marraskuu Joulukuu
	}
	weekdays,fi {Ma Ti Ke To Pe La Su}
	today,fi {}

	mn,tr {
	    . ocak \u015fubat mart nisan may\u0131s haziran temmuz a\u011fustos eyl\u00FCl ekim kas\u0131m aral\u0131k
	}
	weekdays,tr {pa'tesi sa \u00e7a pe cu cu'tesi pa}
	today,tr {}
    }
}

package provide widget::calendar 0.96
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/dateentry.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
315
316
317
318
319
320
321
322
323
324
325
326
# -*- tcl -*-
#
# dateentry.tcl -
#
#       dateentry widget
#
# This widget provides an entry with a visual calendar for
# choosing a date. It is mostly a gathering compoments.
#
# The basics for the entry were taken from the "MenuEntry widget"
# of the widget package in the tklib.
# The visual calendar is taken from http://wiki.tcl.tk/1816.
#
# So many thanks to Richard Suchenwirth for visual calendar
# and to Jeff Hobbs for the widget package in tklib.
#
# See the example at the bottom.
#
# RCS: @(#) $Id: dateentry.tcl,v 1.5 2010/09/29 06:43:44 hobbs Exp $
#

# Creation and Options - widget::dateentry $path ...
#  -command        -default {}
#  -dateformat     -default "%m/%d/%Y"
#  -font           -default {Helvetica 9}
#  -background     -default white
#  -textvariable   -default {}  -configuremethod C-textvariable
#
# Following are passed to widget::calendar component:
#  -firstday
#  -highlightcolor
#
# Methods
#  $widget post   - display calendar dropdown
#  $widget unpost - remove calendar dropdown
#  All other methods to entry
#
# Bindings
#  NONE
#

###

package require widget
package require widget::calendar

namespace eval ::widget {
    # http://www.famfamfam.com/lab/icons/mini/
    # ?Mini? is a set of 144 GIF icons available for free use for any purpose.
    variable dateentry_gifdata {
	R0lGODlhEAAQAMQAANnq+K7T5HiUsMHb+v/vlOXs9IyzzHWs1/T5/1ZtjUlVa+z1/+3
	x9uTx/6a2ysng+FFhe0NLXIDG/fD4/ykxQz5FVf/41vr8/6TI3MvM0XHG/vbHQPn8//
	b8/4PL/f///yH5BAAAAAAALAAAAAAQABAAAAWV4Cdam2h+5AkExCYYsCC0iSAGTisAP
	JC7kNvicPBIjkeiIyHCMDzQaFRTYH4wBY6W0+kgvpNC8GNgXLhd8CQ8Lp8f3od8sSgo
	RIasHPGY0AcNdiIHBV0PfHQNgAURIgKFfBMPCw2KAIyOkH0LA509FY4TXn6UDT0MoB8
	JDwwFDK+wrxkUjgm2EBAKChERFRUUYyfCwyEAOw==
    }
    # http://www.famfamfam.com/lab/icons/silk/
    # ?Silk? is a smooth, free icon set,
    variable dateentry_gifdata {
	R0lGODlhEAAQAPZ8AP99O/9/PWmrYmytZW6uaHOxbP+EQv+LR/+QTf+UUv+VVP+WVP+
	YV/+ZWP+aWv+dXP+eXf+fX/+nVP+rWv+gYP+hYf+iYv+jZP+kZP+kZf+wYf+zaP+4bf
	+5cf+7df+9eUJ3u1KEw1SGxFWGxlaHx12KxVyKxl+MxlmKyFuKyV+NyF6Oy1+Py2OSz
	mSTzmiW0WqX0W6Z02+b1HKe1nSg13Wh13qj2nqk2X2l3H6o3ZHBjJvHlqXNoa/Sq4Cp
	3YOr3IKq34mu2Yyw24mw3pG03Za434Ss4Ieu4Yiv4oyx44+14Yyy5I+05ZC15pO355S
	355W445294Zq75p++5pa66Zi66Zq865u9652+656/7KG/55/A7aTB5KTB56vG5abD6a
	HB7qLB76rG6a7J6rLL6rfO6rrQ67zQ68PdwNfp1dji8Nvk8d7n8t7n8+Lq9Obt9urw9
	+vx9+3y+O7z+e/z+fD0+vH2+vL2+vT3+/n8+f7+/v7//v///wAAAAAAAAAAACH5BAEA
	AH0ALAAAAAAQABAAAAfMgH2Cg4SFg2FbWFZUTk1LSEY+ODaCYHiXmJmXNIJZeBkXFBA
	NCwgHBgF4MoJXeBgfHh0cGxoTEgB4MIJVnxcWFREPDgwKCXgugk94X3zNzs1ecSyCTH
	difD0FaT0DPXxcbCiCSXZjzQJpO3kFfFFqI4JHdWTnaTp8AnxFaiKCQHRl+KARwKMHA
	W9E1KgQlIOOGT569uyB2EyIGhOCbsw500XLFClQlAz5EUTNCUE15MB546bNGjUwY5YQ
	NCPGixYrUpAIwbMnCENACQUCADs=
    }
}

proc ::widget::createdateentryLayout {} {
    variable dateentry
    if {[info exists dateentry]} { return }
    set dateentry 1
    variable dateentry_pngdata
    variable dateentry_gifdata
    set img ::widget::img_dateentry
    image create photo $img -format GIF -data $dateentry_gifdata
    namespace eval ::ttk [list set dateimg $img] ; # namespace resolved
    namespace eval ::ttk {
	# Create -padding for space on left and right of icon
	set pad [expr {[image width $dateimg] + 6}]
	style theme settings "default" {
	    style layout dateentry {
		Entry.field -children {
		    dateentry.icon -side left
		    Entry.padding -children {
			Entry.textarea
		    }
		}
	    }
	    # center icon in padded cell
	    style element create dateentry.icon image $dateimg \
		-sticky "" -padding [list $pad 0 0 0]
	}
	if 0 {
	    # Some mappings would be required per-theme to adapt to theme
	    # changes
	    foreach theme [style theme names] {
		style theme settings $theme {
		    # Could have disabled, pressed, ... state images
		    #style map dateentry -image [list disabled $img]
		}
	    }
	}
    }
}

snit::widgetadaptor widget::dateentry {
    delegate option * to hull
    delegate method * to hull

    option -command -default {}
    option -dateformat -default "%m/%d/%Y" -configuremethod C-passtocalendar
    option -font -default {Helvetica 9} -configuremethod C-passtocalendar
    option -textvariable -default {}

    delegate option -highlightcolor to calendar
    delegate option -firstday to calendar

    component dropbox
    component calendar

    variable waitVar
    variable formattedDate
    variable rawDate
    variable startOnMonday 1

    constructor args {
	::widget::createdateentryLayout

	installhull using ttk::entry -style dateentry

	bindtags $win [linsert [bindtags $win] 1 TDateEntry]

	$self MakeCalendar

	$self configurelist $args

	set now [clock seconds]
	set x [clock format $now -format "%d/%m%/%Y"]
	set rawDate [clock scan "$x 00:00:00" -format "%d/%m%/%Y %H:%M:%S"]
	set formattedDate [clock format $rawDate -format $options(-dateformat)]

	$hull configure -state normal
	$hull delete 0 end
	$hull insert end $formattedDate
	$hull configure -state readonly
    }

    method C-passtocalendar {option value} {
	set options($option) $value
	$calendar configure $option $value
    }

    method MakeCalendar {args} {
	set dropbox $win.__drop
	destroy $dropbox
	toplevel $dropbox -takefocus 0
	wm withdraw $dropbox

	if {[tk windowingsystem] ne "aqua"} {
	    wm overrideredirect $dropbox 1
	    wm transient $dropbox [winfo toplevel $win]
	    wm group     $dropbox [winfo parent $win]
	} else {
	    tk::unsupported::MacWindowStyle style $dropbox \
		help {noActivates hideOnSuspend}
	}
	wm resizable $dropbox 0 0

	# Unpost on Escape or whenever user clicks outside the dropdown
	bind $dropbox <Escape> [list $win unpost]
	bind $dropbox <ButtonPress> [subst -nocommands {
	    if {[string first "$dropbox" [winfo containing %X %Y]] != 0} {
		$win unpost
	    }
	}]
	bindtags $dropbox [linsert [bindtags $dropbox] 1 TDateEntryPopdown]

	set calendar $dropbox.calendar
	widget::calendar $calendar -command [mymethod DateChosen] \
	    -textvariable [myvar formattedDate] \
	    -dateformat $options(-dateformat) \
	    -font $options(-font) \
	    -borderwidth 1 -relief solid
	bind $calendar <Map> [list focus -force $calendar]

	pack $calendar -expand 1 -fill both

	return $dropbox
    }

    method post { args } {
	# XXX should we reset date on each display?
	if {![winfo exists $dropbox]} { $self MakeCalendar }
	set waitVar 0

	foreach {x y} [$self PostPosition] { break }
	wm geometry $dropbox "+$x+$y"
	wm deiconify $dropbox
	raise $dropbox

	if {[tk windowingsystem] ne "aqua"} {
	    tkwait visibility $dropbox
	}
	focus -force $calendar
	return

	tkwait variable [myvar waitVar]

	$self unpost
    }

    method unpost {args} {
	if {[winfo exists $dropbox]} {
	    wm withdraw $dropbox
	    grab release $dropbox ; # just in case
	}
    }

    method PostPosition {} {
	# PostPosition --
	#	Returns the x and y coordinates where the menu
	#	should be posted, based on the dateentry and menu size
	#	and -direction option.
	#
	# TODO: adjust menu width to be at least as wide as the button
	#	for -direction above, below.
	#
	set x [winfo rootx $win]
	set y [winfo rooty $win]
	set dir "below" ; #[$win cget -direction]

	set bw [winfo width $win]
	set bh [winfo height $win]
	set mw [winfo reqwidth $dropbox]
	set mh [winfo reqheight $dropbox]
	set sw [expr {[winfo screenwidth  $dropbox] - $bw - $mw}]
	set sh [expr {[winfo screenheight $dropbox] - $bh - $mh}]

	switch -- $dir {
	    above { if {$y >= $mh} { incr y -$mh } { incr y  $bh } }
	    below { if {$y <= $sh} { incr y  $bh } { incr y -$mh } }
	    left  { if {$x >= $mw} { incr x -$mw } { incr x  $bw } }
	    right { if {$x <= $sw} { incr x  $bw } { incr x -$mw } }
	}

	return [list $x $y]
    }

    method DateChosen { args } {
	upvar 0 $options(-textvariable) date

	set waitVar 1
	set date $formattedDate
	set rawDate [clock scan $formattedDate -format $options(-dateformat)]
	if { $options(-command) ne "" } {
	    uplevel \#0 $options(-command) $formattedDate $rawDate
	}
	$self unpost

	$hull configure -state normal
	$hull delete 0 end
	$hull insert end $formattedDate
	$hull configure -state readonly
    }
}

# Bindings for menu portion.
#
# This is a variant of the ttk menubutton.tcl bindings.
# See menubutton.tcl for detailed behavior info.
#

bind TDateEntry <Enter>     { %W state active }
bind TDateEntry <Leave>     { %W state !active }
bind TDateEntry <<Invoke>>  { %W post }
bind TDateEntry <Control-space> { %W post }
bind TDateEntry <Escape>        { %W unpost }

bind TDateEntry <ButtonPress-1> { %W state pressed ; %W post }
bind TDateEntry <ButtonRelease-1> { %W state !pressed }

# These are to get around issues on aqua (see ttk::combobox bindings)
bind TDateEntryPopdown <Map> { ttk::globalGrab %W }
bind TDateEntryPopdown <Unmap> { ttk::releaseGrab %W }

package provide widget::dateentry 0.93

##############
# TEST CODE ##
##############

if { [info script] eq $argv0 } {
    set auto_path [linsert $auto_path 0 [file dirname [info script]]]
    package require widget::dateentry 0.93
    destroy {*}[winfo children .]
    proc getDate { args } {
	puts [info level 0]
	puts "DATE $::DATE"
	update idle
    }

    # Samples
    # package require widget::dateentry
    set ::DATE ""
    set start [widget::dateentry .s -textvariable ::DATE \
		   -dateformat "%d.%m.%Y %H:%M" \
		   -command [list getDate .s]]
    set end [widget::dateentry .e \
		 -command [list getDate .e] \
		 -highlightcolor dimgrey \
		 -font {Courier 10} \
		 -firstday sunday]
    grid [label .sl -text "Start:"] $start  -padx 4 -pady 4
    grid [label .el -text "End:"  ] $end    -padx 4 -pady 4

    puts [$end get]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/dialog.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
# -*- tcl -*-
#
# dialog.tcl -
#
#	Generic dialog widget (themed)
#
# RCS: @(#) $Id: dialog.tcl,v 1.23 2010/06/01 18:06:52 hobbs Exp $
#

# Creation and Options - widget::dialog $path ...
#    -command	-default {} ; # gets appended: $win $reason
#    -focus     -default {} ; # subwindow to set focus on display
#    -modal	-default none
#    -padding	-default 0
#    -parent	-default ""
#    -place	-default center
#    -separator	-default 1
#    -synchronous -default 1
#    -title	-default ""
#    -transient -default 1
#    -type	-default custom ; # {ok okcancel okcancelapply custom}
#    -timeout	-default 0 ; # only active with -synchronous
#
# Methods
#  $path add $what $args... => $id
#  $path getframe           => $frame
#  $path setwidget $widget  => ""
#  $path display
#  $path cancel
#  $path withdraw
#
# Bindings
#  Escape            => invokes [$dlg close cancel]
#  WM_DELETE_WINDOW  => invokes [$dlg close cancel]
#

if 0 {
    # Samples
    package require widget::dialog
    set dlg [widget::dialog .pkgerr -modal local -separator 1 \
		 -place right -parent . -type okcancel \
		 -title "Dialog Title"]
    set frame [frame $dlg.f]
    label $frame.lbl -text "Type Something In:"
    entry $frame.ent
    grid $frame.lbl $frame.ent -sticky ew
    grid columnconfigure $frame 1 -weight 1
    $dlg setwidget $frame
    puts [$dlg display]
    destroy $dlg

    # Using -synchronous with a -type custom dialog requires that the
    # custom buttons call [$dlg close $reason] to trigger the close
    set dlg [widget::dialog .pkgerr -title "Yes/No Dialog" -separator 1 \
		 -parent . -type custom]
    set frame [frame $dlg.f]
    label $frame.lbl -text "Type Something In:"
    entry $frame.ent
    grid $frame.lbl $frame.ent -sticky ew
    grid columnconfigure $frame 1 -weight 1
    $dlg setwidget $frame
    $dlg add button -text "Yes" -command [list $dlg close yes]
    $dlg add button -text "No" -command [list $dlg close no]
    puts [$dlg display]
}

# ### ######### ###########################
## Prerequisites

#package require image   ; # bitmaps
package require snit    ; # object system
package require msgcat

# ### ######### ###########################
## Implementation

snit::widget widget::dialog {
    # ### ######### ###########################
    hulltype toplevel

    component frame
    component separator
    component buttonbox

    delegate option -padding to frame;
    delegate option * to hull
    delegate method * to hull

    option -command	-default {};
    # {none local global}
    option -modal	-default none -configuremethod C-modal;
    #option -padding	-default 0 -configuremethod C-padding;
    option -parent	-default "" -configuremethod C-parent;
    # {none center left right above below over}
    option -place	-default center -configuremethod C-place;
    option -separator	-default 1 -configuremethod C-separator;
    option -synchronous -default 1;
    option -title	-default "" -configuremethod C-title;
    option -transient	-default 1 -configuremethod C-transient;
    option -type	-default custom -configuremethod C-type;
    option -timeout	-default 0;
    option -focus	-default "";

    # We may make this an easier customizable messagebox, but not yet
    #option -anchor      c; # {n e w s c}
    #option -text	"";
    #option -bitmap	"";
    #option -image	"";

    # ### ######### ###########################
    ## Public API. Construction

    constructor {args} {
	wm withdraw $win

	install frame using ttk::frame $win._frame
	install separator using ttk::separator $win._separator \
	    -orient horizontal
	if {[tk windowingsystem] eq "aqua"} {
	    # left top right bottom - Aqua corner resize control padding
	    set btnpad [list 0 6 14 4]
	} else {
	    # left top right bottom
	    set btnpad [list 0 6 0 4]
	}
	install buttonbox using ttk::frame $win._buttonbox -padding $btnpad

	grid $frame     -row 0 -column 0 -sticky news
	grid $separator -row 1 -column 0 -sticky ew
	# Should padding effect the buttonbox?
	grid $buttonbox -row 2 -column 0 -sticky ew

	grid columnconfigure $win 0 -weight 1
	grid rowconfigure    $win 0 -weight 1

	# Default to invoking no/cancel/withdraw
	wm protocol $win WM_DELETE_WINDOW [mymethod close cancel]
	bind $win <Key-Escape> [mymethod close cancel]
	# Ensure grab release on unmap?
	#bind $win <Unmap> [list grab release $win]

	# Handle defaults
	if {!$options(-separator)} {
	    grid remove $separator
	}

	$self configurelist $args
    }

    # ### ######### ###########################
    ## Public API. Extend container by application specific content.

    # getframe and setwidget are somewhat mutually exlusive.
    # Use one or the other.
    method getframe {} {
	return $frame
    }

    method setwidget {w} {
	if {[winfo exists $setwidget]} {
	    grid remove $setwidget
	    set setwidget {}
	}
	if {[winfo exists $w]} {
	    grid $w -in $frame -row 0 -column 0 -sticky news
	    grid columnconfigure $frame 0 -weight 1
	    grid rowconfigure    $frame 0 -weight 1
	    set setwidget $w
	}
    }

    variable uid 0
    method add {what args} {
	if {$what eq "button"} {
	    set w [eval [linsert $args 0 ttk::button $buttonbox._b[incr uid]]]
	} elseif {[winfo exists $what]} {
	    set w $what
	} else {
	    return -code error "unknown add type \"$what\", must be:\
		button or a pathname"
	}
	set col [lindex [grid size $buttonbox] 0]; # get last column
	if {$col == 0} {
	    # ensure weighted 0 column
	    grid columnconfigure $buttonbox 0 -weight 1
	    incr col
	}
	grid $w -row 0 -column $col -sticky ew -padx 4
	return $w
    }

    method display {} {
	set lastFocusGrab [focus]
	set last [grab current $win]
	lappend lastFocusGrab $last
	if {[winfo exists $last]} {
	    lappend lastFocusGrab [grab status $last]
	}

	$self PlaceWindow $win $options(-place) $options(-parent)
	if {$options(-modal) ne "none"} {
	    if {$options(-modal) eq "global"} {
		catch {grab -global $win}
	    } else {
		catch {grab $win}
	    }
	}
	if {[winfo exists $options(-focus)]} {
	    catch { focus $options(-focus) }
	}
	# In order to allow !custom synchronous, we need to allow
	# custom dialogs to set [myvar result].  They do that through
	# [$dlg close $reason]
	if {$options(-synchronous)} {
	    if {$options(-timeout) > 0} {
		# set var after specified timeout
		set timeout_id [after $options(-timeout) \
				    [list set [myvar result] timeout]]
	    }
	    vwait [myvar result]
	    catch {after cancel $timeout_id}
	    # A synchronous dialog will always withdraw, even if a -command
	    # tries to return a break code.
	    return [$self withdraw $result]
	}
    }

    method close {{reason {}}} {
	set code 0
	if {$options(-command) ne ""} {
	    set cmd $options(-command)
	    lappend cmd $win $reason
	    set code [catch {uplevel \#0 $cmd} result]
	} else {
	    # set result to trigger any possible vwait
	    set result $reason
	}
	if {$code == 3} {
	    # 'break' return code - don't withdraw
	    return $result
	} else {
	    # Withdraw on anything but 'break' return code
	    $self withdraw $result
	}
	return -code $code $result
    }

    method withdraw {{reason "withdraw"}} {
	set result $reason
	catch {grab release $win}
	# Let's avoid focus/grab restore if we don't think we were showing
	if {![winfo ismapped $win]} { return $reason }
	wm withdraw $win
	foreach {oldFocus oldGrab oldStatus} $lastFocusGrab { break }
	# Ensure last focus/grab wasn't a child of this window
	if {[winfo exists $oldFocus] && ![string match $win* $oldFocus]} {
	    catch {focus $oldFocus}
	}
	if {[winfo exists $oldGrab] && ![string match $win* $oldGrab]} {
	    if {$oldStatus eq "global"} {
		catch {grab -global $oldGrab}
	    } elseif {$oldStatus eq "local"} {
		catch {grab $oldGrab}
	    }
	}
	return $result
    }

    # ### ######### ###########################
    ## Internal. State variable for close-button (X)

    variable lastFocusGrab {};
    variable isPlaced 0;
    variable result {};
    variable setwidget {};

    # ### ######### ###########################
    ## Internal. Handle changes to the options.

    method C-title {option value} {
	wm title $win $value
	wm iconname $win $value
        set options($option) $value
    }
    method C-modal {option value} {
	set values [list none local global]
	if {[lsearch -exact $values $value] == -1} {
	    return -code error "unknown $option option \"$value\":\
		must be one of [join $values {, }]"
	}
        set options($option) $value
    }
    method C-separator {option value} {
	if {$value} {
	    grid $separator
	} else {
	    grid remove $separator
	}
        set options($option) $value
    }
    method C-parent {option value} {
	if {$options(-transient) && [winfo exists $value]} {
	    wm transient $win [winfo toplevel $value]
	    wm group $win [winfo toplevel $value]
	} else {
	    wm transient $win ""
	    wm group $win ""
	}
        set options($option) $value
    }
    method C-transient {option value} {
	if {$value && [winfo exists $options(-parent)]} {
	    wm transient $win [winfo toplevel $options(-parent)]
	    wm group $win [winfo toplevel $options(-parent)]
	} else {
	    wm transient $win ""
	    wm group $win ""
	}
        set options($option) $value
    }
    method C-place {option value} {
	set values [list none center left right over above below pointer]
	if {[lsearch -exact $values $value] == -1} {
	    return -code error "unknown $option option \"$value\":\
		must be one of [join $values {, }]"
	}
	set isPlaced 0
        set options($option) $value
    }
    method C-type {option value} {
	set types [list ok okcancel okcancelapply custom]
	# ok
	# okcancel
	# okcancelapply
	# custom
	# msgcat

	if {$options(-type) eq $value} { return }
	if {[lsearch -exact $types $value] == -1} {
	    return -code error "invalid type \"$value\", must be one of:\
		[join $types {, }]"
	}
	if {$options(-type) ne "custom"} {
	    # Just trash whatever we had
	    eval [list destroy] [winfo children $buttonbox]
	}

	set ok     [msgcat::mc "OK"]
	set cancel [msgcat::mc "Cancel"]
	set apply  [msgcat::mc "Apply"]
	set okBtn  [ttk::button $buttonbox.ok -text $ok -default active \
			-command [mymethod close ok]]
	set canBtn [ttk::button $buttonbox.cancel -text $cancel \
			-command [mymethod close cancel]]
	set appBtn [ttk::button $buttonbox.apply -text $apply \
			-command [mymethod close apply]]

	# [OK] [Cancel] [Apply]
	grid x $okBtn $canBtn $appBtn -padx 4
	grid columnconfigure $buttonbox 0 -weight 1
	#bind $win <Return> [list $okBtn invoke]
	#bind $win <Escape> [list $canBtn invoke]
	if {$value eq "ok"} {
	    grid remove $canBtn $appBtn
	} elseif {$value eq "okcancel"} {
	    grid remove $appBtn
	}
        set options($option) $value
    }

    # ### ######### ###########################
    ## Internal.

    method PlaceWindow {w place anchor} {
	# Variation of tk::PlaceWindow
	if {$isPlaced || $place eq "none"} {
	    # For most options, we place once and then just deiconify
	    wm deiconify $w
	    raise $w
	    return
	}
	set isPlaced 1
	if {$place eq "pointer"} {
	    # pointer placement occurs each time, centered
	    set anchor center
	    set isPlaced 0
	} elseif {![winfo exists $anchor]} {
	    set anchor [winfo toplevel [winfo parent $w]]
	    if {![winfo ismapped $anchor]} {
		set place center
	    }
	}
	wm withdraw $w
	update idletasks
	set checkBounds 1
	if {$place eq "center"} {
	    set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
	    set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
	    set checkBounds 0
	} elseif {$place eq "pointer"} {
	    ## place at POINTER (centered)
	    if {$anchor eq "center"} {
		set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
		set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
	    } else {
		set x [winfo pointerx $w]
		set y [winfo pointery $w]
	    }
	} elseif {![winfo ismapped $anchor]} {
	    ## All the rest require the anchor to be mapped
	    ## If the anchor isn't mapped, use center
	    set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
	    set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
	    set checkBounds 0
	} elseif {$place eq "over"} {
	    ## center about WIDGET $anchor
	    set x [expr {[winfo rootx $anchor] + \
			     ([winfo width $anchor]-[winfo reqwidth $w])/2}]
	    set y [expr {[winfo rooty $anchor] + \
			     ([winfo height $anchor]-[winfo reqheight $w])/2}]
	} elseif {$place eq "above"} {
	    ## above (north of) WIDGET $anchor, centered
	    set x [expr {[winfo rootx $anchor] + \
			     ([winfo width $anchor]-[winfo reqwidth $w])/2}]
	    set y [expr {[winfo rooty $anchor] - [winfo reqheight $w]}]
	} elseif {$place eq "below"} {
	    ## below WIDGET $anchor, centered
	    set x [expr {[winfo rootx $anchor] + \
			     ([winfo width $anchor]-[winfo reqwidth $w])/2}]
	    set y [expr {[winfo rooty $anchor] + [winfo height $anchor]}]
	} elseif {$place eq "left"} {
	    ## left of WIDGET $anchor, top-aligned
	    set x [expr {[winfo rootx $anchor] - [winfo reqwidth $w]}]
	    set y [winfo rooty $anchor]
	} elseif {$place eq "right"} {
	    ## right of WIDGET $anchor, top-aligned
	    set x [expr {[winfo rootx $anchor] + [winfo width $anchor]}]
	    set y [winfo rooty $anchor]
	} else {
	    return -code error "unknown place type \"$place\""
	}
	if {[tk windowingsystem] eq "win32"} {
	    # win32 multiple desktops may produce negative geometry - avoid.
	    set checkBounds -1
	}
	if {$checkBounds} {
	    if {$x < 0 && $checkBounds > 0} {
		set x 0
	    } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} {
		set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}]
	    }
	    if {$y < 0 && $checkBounds > 0} {
		set y 0
	    } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} {
		set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}]
	    }
	    if {[tk windowingsystem] eq "aqua"} {
		# Avoid the native menu bar which sits on top of everything.
		if {$y < 20} { set y 20 }
	    }
	}
	wm geometry $w +$x+$y
	wm deiconify $w
	raise $w
    }

    # ### ######### ###########################
}

# ### ######### ###########################
## Ready for use

package provide widget::dialog 1.3.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/mentry.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
# -*- tcl -*-
#
# mentry.tcl -
#
#	MenuEntry widget
#
# RCS: @(#) $Id: mentry.tcl,v 1.7 2010/06/01 18:06:52 hobbs Exp $
#

# Creation and Options - widget::menuentry $path ...
#  -menu -default "" ; menu to associate with entry
#  -image -default "default"
#  All other options to entry
#
# Methods
#  All other methods to entry
#
# Bindings
#  NONE
#

if 0 {
    # Samples
    package require widget::menuentry
    set me [widget::menuentry .me]
    set menu [menu .me.menu -tearoff 0]
    $menu add radiobutton -label "Name" -variable foo -value name
    $menu add radiobutton -label "Abstract" -variable foo -value abstract
    $menu add separator
    $menu add radiobutton -label "Name and Abstract" \
	-variable foo -value [list name abstract]
    $me configure -menu $menu
    pack $me -fill x -expand 1 -padx 4 -pady 4
}

###

package require widget

namespace eval ::widget {
    # PNG version has partial alpha transparency for better look
    variable menuentry_pngdata {
	iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAACXBIWXMAAAs6
	AAALOgFkf1cNAAACkklEQVR4nHWSXUhTYRjHdxnRVQTeCElXp7vS6BCZFGlO
	nc2vbdrccrbhR9IKI7KOXzQniikzUvyIlNoHrZgXmYrbas6cg3keKFKoqHiC
	VowgeC6C4PB24RmlRy/+Nw/v7/c+/5dXxRhTMcZUoqeWF73mgOi1pMBnlURP
	vZSYNqVWJw2BlZFKPn1uezZhr8kGPktS9JjFxPQFIf7AwK1O6LnVcZ0QGzeI
	sVFDcslVZttRIHpqefBZkmuPjU5AOgxIVYBkB6QWQCoFpENRV5kz6qpMhvs0
	ik1Uax5zYM1tFgGJA6QmQGoDpBuAdB2QrgGSEZCyIoNaMdSnCeywQV0qMVUj
	AFIFIN2U4VYZbgGkZkDKDzlLhHBfaUohAG+9FJ80cIB0+b9b0xWaAKkBkIyL
	3Wou3K+VlBXcFik2puPkg3ZAuiLLGuWZFZAM8x0FXMipUQriD42p2GiVAEhq
	GWyWYRsgXQKkOkDKm7tdIMx3FiorrIzpAysjOhGQsgBJL4NWQLLIsBaQMhe6
	i36/aDsbVwiiw+X88n1dMjKkdQLSQUA6A0gGQNIBUi4gZUaHdX/e+O0s3Hqa
	zdhzaxQf6dXAedvSUFky3F8qBh1FwkLnOW6uvYCbu5UvRAYqpPXnbexrYox9
	Wr7Lgne07GnjiYwtAsaYKthTzAd7igNBpyYVcmqkoKNEmuso/LXYrWEfXvay
	7+8esR8bbvZ+sYv5rackX/3xjC2C3TJzNc8UGaxmn18PseTbKfYldo/FJyys
	V8199FzM2bu5hkrFtud/ybPmk6ago5xtzLaz9dlOFnXpmb+B/+k2Z+/79xi7
	wOk8sfEmd20OW+hSM7+V/+Y2Zx9QVNgNTsdbd2z/RPURh9t8dE969hckF6c1
	n3C8ywAAAABJRU5ErkJggg==
    }
    variable menuentry_gifdata {
	R0lGODlhEAAQAPcAAAQEBIREJJpaL6RaL6RkL6RkOq9kOq9vOrpvRLp6RLqE
	T7qPT8SPT8SaT8SaWsSaZM+kWs+kZM+vb8/k79qvetq6etq6hNrEj+TPmuTP
	pOTapPr6+gAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
	AAAAAAAAAAAAAAAAAP///yH5BAEAAP8ALAAAAAAQABAAQAh4AP8JhBChIAQH
	AhMKdIBQYcIECRRGcOhQAcWLDi5kuPAggMAIECgyYOBw4kWBFh0yWKCQAQUM
	F1ImBECT4oAEBiSGTMiQIoSdImX+M3mSJc+TAiMqdEDSoQMJCC4qmKoggQIL
	GjRYyCmQpleFCipUcMC160kBCQMCADs=
    }
}

proc ::widget::createMenuEntryLayout {} {
    variable MENUENTRY
    if {[info exists MENUENTRY]} { return }
    set MENUENTRY 1
    variable menuentry_pngdata
    variable menuentry_gifdata
    set img ::widget::img_menuentry
    if {[package provide img::png] != ""} {
	image create photo $img -format PNG -data $menuentry_pngdata
    } else {
	image create photo $img -format GIF -data $menuentry_gifdata
    }
    namespace eval ::ttk [list set img $img] ; # namespace resolved
    namespace eval ::ttk {
	# Create -padding for space on left and right of icon
	set pad [expr {[image width $img] + 4}]
	style theme settings "default" {
	    style layout MenuEntry {
		Entry.field -children {
		    MenuEntry.icon -side left
		    Entry.padding -children {
			Entry.textarea
		    }
		}
	    }
	    # center icon in padded cell
	    style element create MenuEntry.icon image $img \
		-sticky "" -padding [list $pad 0 0 0]
	}
	if 0 {
	    # Some mappings would be required per-theme to adapt to theme
	    # changes
	    foreach theme [style theme names] {
		style theme settings $theme {
		    # Could have disabled, pressed, ... state images
		    #style map MenuEntry -image [list disabled $img]
		}
	    }
	}
    }
}

snit::widgetadaptor widget::menuentry {
    delegate option * to hull
    delegate method * to hull

    option -image -default "default" -configuremethod C-image
    option -menu -default "" -configuremethod C-menu

    constructor args {
	::widget::createMenuEntryLayout

	installhull using ttk::entry -style MenuEntry

	bindtags $win [linsert [bindtags $win] 1 TMenuEntry]

	$self configurelist $args
    }

    method C-menu {option value} {
	if {$value ne "" && ![winfo exists $value]} {
	    return -code error "invalid widget \"$value\""
	}
	set options($option) $value
    }

    method C-image {option value} {
	set options($option) $value
	if {$value eq "default"} {
	}
    }
}

# Bindings for menu portion.
#
# This is a variant of the ttk menubutton.tcl bindings.
# See menubutton.tcl for detailed behavior info.
#

namespace eval ttk {
    bind TMenuEntry <Enter>	{ %W state active }
    bind TMenuEntry <Leave>	{ %W state !active }
    bind TMenuEntry <<Invoke>> 	{ ttk::menuentry::Popdown %W %x %y }
    bind TMenuEntry <Control-space> { ttk::menuentry::Popdown %W 10 10 }

    if {[tk windowingsystem] eq "x11"} {
	bind TMenuEntry <ButtonPress-1>   { ttk::menuentry::Pulldown %W %x %y }
	bind TMenuEntry <ButtonRelease-1> { ttk::menuentry::TransferGrab %W }
	bind TMenuEntry <B1-Leave>  	  { ttk::menuentry::TransferGrab %W }
    } else {
    	bind TMenuEntry <ButtonPress-1>  \
	    { %W state pressed ; ttk::menuentry::Popdown %W %x %y }
	bind TMenuEntry <ButtonRelease-1> { %W state !pressed }
    }

    namespace eval menuentry {
	variable State

	array set State {
	    pulldown	0
	    oldcursor	{}
	}
    }
}

# PostPosition --
#	Returns the x and y coordinates where the menu 
#	should be posted, based on the menuentry and menu size
#	and -direction option.
#
# TODO: adjust menu width to be at least as wide as the button
#	for -direction above, below.
#
proc ttk::menuentry::PostPosition {mb menu} {
    set x [winfo rootx $mb]
    set y [winfo rooty $mb]
    set dir "below" ; #[$mb cget -direction]

    set bw [winfo width $mb]
    set bh [winfo height $mb]
    set mw [winfo reqwidth $menu]
    set mh [winfo reqheight $menu]
    set sw [expr {[winfo screenwidth  $menu] - $bw - $mw}]
    set sh [expr {[winfo screenheight $menu] - $bh - $mh}]

    switch -- $dir {
	above { if {$y >= $mh} { incr y -$mh } { incr y  $bh } }
	below { if {$y <= $sh} { incr y  $bh } { incr y -$mh } }
	left  { if {$x >= $mw} { incr x -$mw } { incr x  $bw } }
	right { if {$x <= $sw} { incr x  $bw } { incr x -$mw } }
	flush {
	    # post menu atop menuentry.
	    # If there's a menu entry whose label matches the
	    # menuentry -text, assume this is an optionmenu
	    # and place that entry over the menuentry.
	    set index [FindMenuEntry $menu [$mb cget -text]]
	    if {$index ne ""} {
		incr y -[$menu yposition $index]
	    }
	}
    }

    return [list $x $y]
}

# Popdown --
#	Post the menu and set a grab on the menu.
#
proc ttk::menuentry::Popdown {me x y} {
    if {[$me instate disabled] || [set menu [$me cget -menu]] eq ""
	|| [$me identify $x $y] ne "MenuEntry.icon"} {
	return
    }
    foreach {x y} [PostPosition $me $menu] { break }
    tk_popup $menu $x $y
}

# Pulldown (X11 only) --
#	Called when Button1 is pressed on a menuentry.
#	Posts the menu; a subsequent ButtonRelease 
#	or Leave event will set a grab on the menu.
#
proc ttk::menuentry::Pulldown {mb x y} {
    variable State
    if {[$mb instate disabled] || [set menu [$mb cget -menu]] eq ""
	|| [$mb identify $x $y] ne "MenuEntry.icon"} {
	return
    }
    foreach {x y} [PostPosition $mb $menu] { break }
    set State(pulldown) 1
    set State(oldcursor) [$mb cget -cursor]

    $mb state pressed
    $mb configure -cursor [$menu cget -cursor]
    $menu post $x $y
    tk_menuSetFocus $menu
}

# TransferGrab (X11 only) --
#	Switch from pulldown mode (menuentry has an implicit grab)
#	to popdown mode (menu has an explicit grab).
#
proc ttk::menuentry::TransferGrab {mb} {
    variable State
    if {$State(pulldown)} {
	$mb configure -cursor $State(oldcursor)
	$mb state {!pressed !active}
	set State(pulldown) 0
	grab -global [$mb cget -menu]
    }
}

# FindMenuEntry --
#	Hack to support tk_optionMenus.
#	Returns the index of the menu entry with a matching -label,
#	-1 if not found.
#
proc ttk::menuentry::FindMenuEntry {menu s} {
    set last [$menu index last]
    if {$last eq "none"} {
	return ""
    }
    for {set i 0} {$i <= $last} {incr i} {
	if {![catch {$menu entrycget $i -label} label]
	    && ($label eq $s)} {
	    return $i
	}
    }
    return ""
}

package provide widget::menuentry 1.0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/panelframe.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
# -*- tcl -*-
#
#  panelframe.tcl
#	Create PanelFrame widgets.
#	A PanelFrame is a boxed frame that allows you to place items
#	in the label area (liked combined frame+toolbar).  It uses the
#	highlight colors the default frame color.
#
#	Scrolled widget
#
# Copyright 2005 Jeffrey Hobbs
#
# RCS: @(#) $Id: panelframe.tcl,v 1.6 2010/06/01 18:06:52 hobbs Exp $
#

if 0 {
    # Samples
    lappend auto_path ~/cvs/tcllib/tklib/modules/widget

    package require widget::panelframe
    set f [widget::panelframe .pf -text "My Panel"]
    set sf [frame $f.f -padx 4 -pady 4]
    pack [text $sf.text] -fill both -expand 1
    $f setwidget $sf
    pack $f -fill both -expand 1 -padx 4 -pady 4
}

###

package require widget

namespace eval widget {
    variable entry_selbg
    variable entry_selfg
    if {![info exists entry_selbg]} {
	set entry_selbg [widget::tkresource entry -selectbackground]
	if {$entry_selbg eq ""} { set entry_selbg "black" }
	set entry_selfg [widget::tkresource entry -selectforeground]
	if {$entry_selfg eq ""} { set entry_selfg "black" }
    }
    snit::macro widget::entry-selectbackground {} [list return $entry_selbg]
    snit::macro widget::entry-selectforeground {} [list return $entry_selfg]

    variable imgdata {
	#define close_width 16
	#define close_height 16
	static char close_bits[] = {
	    0x00, 0x00, 0x00, 0x00,
	    0x00, 0x00, 0x10, 0x08,
	    0x38, 0x1c, 0x70, 0x0e,
	    0xe0, 0x07, 0xc0, 0x03,
	    0xc0, 0x03, 0xe0, 0x07,
	    0x70, 0x0e, 0x38, 0x1c,
	    0x10, 0x08, 0x00, 0x00,
	    0x00, 0x00, 0x00, 0x00};
    }
    # We use the same -foreground as the default
    image create bitmap ::widget::X -data $imgdata -foreground $entry_selfg
}

snit::widget widget::panelframe {
    hulltype frame ; # not themed

    component title
    component tframe
    #component frame
    #component close

    delegate option * to hull
    delegate method * to hull

    widget::propagate {-panelbackground panelBackground Background} \
	-default [widget::entry-selectbackground] to {hull title tframe} \
	as -background
    widget::propagate {-panelforeground panelForeground Foreground} \
	-default [widget::entry-selectforeground] to {title} \
	as -foreground

    # type listof 1..4 int
    option -ipad -default 1 -configuremethod C-ipad

    # should we use this instead of setwidget?
    #option -window -default "" -configuremethod C-window ; # -isa window

    # The use of a bold font by default would be better
    delegate option -font to title
    delegate option -text to title
    delegate option -textvariable to title

    # Should we have automatic state handling?
    #option -state -default normal

    if 0 {
	# This would be code to have an automated close button
	option -closebutton -default 0 -configuremethod C-closebutton
    }

    variable items {} ; # items user has added

    constructor args {
	$hull configure -borderwidth 1 -relief flat \
	    -background $options(-panelbackground)
	install tframe using frame $win.title \
	    -background $options(-panelbackground)
	install title using label $win.title.label -anchor w -bd 0 \
	    -background $options(-panelbackground) \
	    -foreground $options(-panelforeground)
	# does it need to be a ttk::frame ?
	#install frame using ttk::frame $win.frame

	foreach {ipadx ipady} [$self _padval $options(-ipad)] { break }

	if 0 {
	    install close using button $tframe.close -image ::widget::X \
		-padx 0 -pady 0 -relief flat -overrelief raised \
		-bd 1 -highlightthickness 0 \
		-background $options(-panelbackground) \
		-foreground $options(-panelforeground)
	    #$close configure -font "Marlett -14" -text \u0072
	    if {$options(-closebutton)} {
		pack $close -side right -padx $ipadx -pady $ipady
	    }
	}

	grid $tframe -row 0 -column 0 -sticky ew
	#grid $frame  -row 1 -column 0 -sticky news
	grid columnconfigure $win 0 -weight 1
	grid rowconfigure    $win 1 -weight 1
	#grid columnconfigure $frame 0 -weight 1
	#grid rowconfigure    $frame 0 -weight 1

	pack $title -side left -fill x -anchor w -padx $ipadx -pady $ipady

	$self configurelist $args
    }

    method C-ipad {option value} {
	set len [llength $value]
	foreach {a b} $value { break }
	if {$len == 0 || $len > 2} {
	    return -code error \
		"invalid pad value \"$value\", must be 1 or 2 pixel values"
	}
	pack configure $title -padx $ipadx -pady $ipady
	set options($option) $value
    }

    if 0 {
	method C-closebutton {option value} {
	    if {$value} {
		foreach {ipadx ipady} [$self _padval $options(-ipad)] { break }
		pack $close -side right -padx $ipadx -pady $ipady
	    } else {
		pack forget $close
	    }
	    set options($option) $value
	}
    }

    # We could create and extra frame and return it, but in order to
    # not decide whether that is a ttk or regular frame, just force
    # the user to use setwidget instead
    #method getframe {} { return $frame }

    variable setwidget {}
    method setwidget {w} {
	if {[winfo exists $setwidget]} {
	    grid remove $setwidget
	    set setwidget {}
	}
	if {[winfo exists $w]} {
	    grid $w -in $win -row 1 -column 0 -sticky news
	    set setwidget $w
	}
    }

    method add {w args} {
	array set opts [list \
			    -side   right \
			    -fill   none \
			    -expand 0 \
			    -pad    $options(-ipad) \
			   ]
	foreach {key val} $args {
	    if {[info exists opts($key)]} {
		set opts($key) $val
	    } else {
		set msg "unknown option \"$key\", must be one of: "
		append msg [join [lsort [array names opts]] {, }]
		return -code error $msg
	    }
	}
	foreach {ipadx ipady} [$self _padval $opts(-pad)] { break }

	lappend items $w
	pack $w -in $tframe -padx $ipadx -pady $ipady -side $opts(-side) \
	    -fill $opts(-fill) -expand $opts(-expand)

	return $w
    }

    method remove {args} {
	set destroy [string equal [lindex $args 0] "-destroy"]
	if {$destroy} {
	    set args [lrange $args 1 end]
	}
	foreach w $args {
	    set idx [lsearch -exact $items $w]
	    if {$idx == -1} {
		# ignore unknown
		continue
	    }
	    if {$destroy} {
		destroy $w
	    } elseif {[winfo exists $w]} {
		pack forget $w
	    }
	    set items [lreplace $items $idx $idx]
	}
    }

    method delete {args} {
	return [$self remove -destroy $args]
    }

    method items {} {
	return $items
    }

    method _padval {padval} {
	set len [llength $padval]
	foreach {a b} $padval { break }
	if {$len == 0 || $len > 2} {
	    return -code error \
		"invalid pad value \"$padval\", must be 1 or 2 pixel values"
	} elseif {$len == 1} {
	    return [list $a $a]
	} elseif {$len == 2} {
	    return $padval
	}
    }
}

package provide widget::panelframe 1.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/pkgIndex.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
# Tcl Package Index File 1.0
if {![llength [info commands ::tcl::pkgindex]]} {
    proc ::tcl::pkgindex {dir bundle bundlev packages} {
	set allpkgs [list]
	foreach {pkg ver file} $packages {
	    lappend allpkgs [list package require $pkg $ver]
	    package ifneeded $pkg $ver [list source [file join $dir $file]]
	}
	if {$bundle != ""} {
	    lappend allpkgs [list package provide $bundle $bundlev]
	    package ifneeded $bundle $bundlev [join $allpkgs \n]
	}
	return
    }
}
if {![package vsatisfies [package provide Tcl] 8.4]} {return}
::tcl::pkgindex $dir widget::all 1.2.3 {
    widget			3.1	widget.tcl
    widget::arrowbutton	        1.0	arrowb.tcl
    widget::calendar		0.96	calendar.tcl
    widget::dateentry		0.93	dateentry.tcl
    widget::dialog		1.3.1	dialog.tcl
    widget::menuentry		1.0.1	mentry.tcl
    widget::panelframe		1.1	panelframe.tcl
    widget::ruler		1.1	ruler.tcl
    widget::screenruler		1.2	ruler.tcl
    widget::scrolledtext	1.0	stext.tcl
    widget::scrolledwindow	1.2.1	scrollw.tcl
    widget::statusbar		1.2.1	statusbar.tcl
    widget::superframe		1.0.1	superframe.tcl
    widget::toolbar		1.2.1	toolbar.tcl
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































Deleted scriptlibs/tklib0.5/widget/ruler.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
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
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
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
# -*- tcl -*-
#
# ruler.tcl
#
#	ruler widget and screenruler dialog
#
# Copyright (c) 2005 Jeffrey Hobbs.  All Rights Reserved.
#
# RCS: @(#) $Id: ruler.tcl,v 1.13 2008/02/21 20:11:16 hobbs Exp $
#

###
# Creation and Options - widget::ruler $path ...
#    -foreground	-default black
#    -font		-default {Helvetica 14}
#    -interval		-default [list 5 25 100]
#    -sizes		-default [list 4 8 12]
#    -showvalues	-default 1
#    -outline		-default 1
#    -grid		-default 0
#    -measure		-default pixels ; {pixels points inches mm cm}
#    -zoom		-default 1
#    all other options inherited from canvas
#
# Methods
#  All methods passed to canvas
#
# Bindings
#  <Configure> redraws
#

###
# Creation and Options - widget::screenruler $path ...
#    -alpha	-default 0.8
#    -title	-default ""
#    -topmost	-default 0
#    -reflect	-default 0 ; reflect desktop screen
#    -zoom	-default 1
#
# Methods
#  $path display
#  $path hide
#  All
#
# Bindings
#

if 0 {
    # Samples
    package require widget::screenruler
    set dlg [widget::screenruler .r -grid 1 -title "Screen Ruler"]
    $dlg menu add separator
    $dlg menu add command -label "Exit" -command { exit }
    $dlg display
}

package require widget 3

snit::widgetadaptor widget::ruler {
    delegate option * to hull
    delegate method * to hull

    option -foreground	-default black -configuremethod C-redraw
    option -font	-default {Helvetica 14}
    option -interval	-default [list 5 25 100] -configuremethod C-redraw \
	-type [list snit::listtype -type {snit::double} -minlen 3 -maxlen 3]
    option -sizes	-default [list 4 8 12] -configuremethod C-redraw \
	-type [list snit::listtype -type {snit::double} -minlen 3 -maxlen 3]
    option -showvalues	-default 1 -configuremethod C-redraw \
	-type [list snit::boolean]
    option -outline	-default 1 -configuremethod C-redraw \
	-type [list snit::boolean]
    option -grid	-default 0 -configuremethod C-redraw \
	-type [list snit::boolean]
    option -measure	-default pixels -configuremethod C-measure \
	-type [list snit::enum -values [list pixels points inches mm cm]]
    option -zoom	-default 1 -configuremethod C-redraw \
	-type [list snit::integer -min 1]

    variable shade -array {small gray medium gray large gray}

    constructor {args} {
	installhull using canvas -width 200 -height 50 \
	    -relief flat -bd 0 -background white -highlightthickness 0

	$hull xview moveto 0
	$hull yview moveto 0

	$self _reshade

	bind $win <Configure> [mymethod _resize %W %X %Y]

	#bind $win <Key-minus> [mymethod _adjustinterval -1]
	#bind $win <Key-plus>  [mymethod _adjustinterval 1]
	#bind $win <Key-equal> [mymethod _adjustinterval 1]

	$self configurelist $args

	$self redraw
    }

    destructor {
	catch {after cancel $redrawID}
    }

    ########################################
    ## public methods

    ########################################
    ## configure methods

    variable width    0
    variable height   0
    variable measure  -array {
	what ""
	valid {pixels points inches mm cm}
	cm c mm m inches i points p pixels ""
    }
    variable redrawID {}

    method C-redraw {option value} {
	if {$value ne $options($option)} {
	    set options($option) $value
	    if {$option eq "-foreground"} { $self _reshade }
	    $self redraw
	}
    }

    method C-measure {option value} {
	if {[set idx [lsearch -glob $measure(valid) $value*]] == -1} {
	    return -code error "invalid $option value \"$value\":\
		must be one of [join $measure(valid) {, }]"
	}
	set value [lindex $measure(valid) $idx]
	set measure(what) $measure($value)
	set options($option) $value
	$self redraw
    }

    ########################################
    ## private methods

    method _reshade {} {
	set bg [$hull cget -bg]
	set fg $options(-foreground)
	set shade(small)  [$self shade $bg $fg 0.15]
	set shade(medium) [$self shade $bg $fg 0.4]
	set shade(large)  [$self shade $bg $fg 0.8]
    }

    method redraw {} {
	after cancel $redrawID
	set redrawID [after idle [mymethod _redraw]]
    }

    method _redraw {} {
	$hull delete ruler
	set width  [winfo width $win]
	set height [winfo height $win]
	$self _redraw_x
	$self _redraw_y
	if {$options(-outline) || $options(-grid)} {
	    if {[tk windowingsystem] eq "aqua"} {
		# Aqua has an odd off-by-one drawing
		set coords [list 0 0 $width $height]
	    } else {
		set coords [list 0 0 [expr {$width-1}] [expr {$height-1}]]
	    }
	    $hull create rect $coords -width 1 -outline $options(-foreground) \
		-tags [list ruler outline]
	}
	if {$options(-showvalues) && $height > 20} {
	    if {$measure(what) ne ""} {
		set m   [winfo fpixels $win 1$measure(what)]
		set txt "[format %.2f [expr {$width / $m}]] x\
			[format %.2f [expr {$height / $m}]] $options(-measure)"
	    } else {
		set txt "$width x $height"
	    }
	    if {$options(-zoom) > 1} {
		append txt " (x$options(-zoom))"
	    }
	    $hull create text 15 [expr {$height/2.}] \
		-text $txt \
		-anchor w -tags [list ruler value label] \
		-fill $options(-foreground)
	}
	$hull raise large
	$hull raise value
    }

    method _redraw_x {} {
 	foreach {sms meds lgs} $options(-sizes) { break }
	foreach {smi medi lgi} $options(-interval) { break }
 	for {set x 0} {$x < $width} {set x [expr {$x + $smi}]} {
	    set dx [winfo fpixels $win \
			[expr {$x * $options(-zoom)}]$measure(what)]
	    if {fmod($x, $lgi) == 0.0} {
		# draw large tick
		set h $lgs
		set tags [list ruler tick large]
		if {$x && $options(-showvalues) && $height > $lgs} {
		    $hull create text [expr {$dx+1}] $h -anchor nw \
			-text [format %g $x]$measure(what) \
			-tags [list ruler value]
		}
		set fill $shade(large)
	    } elseif {fmod($x, $medi) == 0.0} {
		set h $meds
		set tags [list ruler tick medium]
		set fill $shade(medium)
	    } else {
		set h $sms
		set tags [list ruler tick small]
		set fill $shade(small)
	    }
	    if {$options(-grid)} {
		$hull create line $dx 0 $dx $height -width 1 -tags $tags \
		    -fill $fill
	    } else {
		$hull create line $dx 0 $dx $h -width 1 -tags $tags \
		    -fill $options(-foreground)
		$hull create line $dx $height $dx [expr {$height - $h}] \
		    -width 1 -tags $tags -fill $options(-foreground)
	    }
	}
    }

    method _redraw_y {} {
 	foreach {sms meds lgs} $options(-sizes) { break }
	foreach {smi medi lgi} $options(-interval) { break }
 	for {set y 0} {$y < $height} {set y [expr {$y + $smi}]} {
	    set dy [winfo fpixels $win \
			[expr {$y * $options(-zoom)}]$measure(what)]
	    if {fmod($y, $lgi) == 0.0} {
		# draw large tick
		set w $lgs
		set tags [list ruler tick large]
		if {$y && $options(-showvalues) && $width > $lgs} {
		    $hull create text $w [expr {$dy+1}] -anchor nw \
			-text [format %g $y]$measure(what) \
			-tags [list ruler value]
		}
		set fill $shade(large)
	    } elseif {fmod($y, $medi) == 0.0} {
		set w $meds
		set tags [list ruler tick medium]
		set fill $shade(medium)
	    } else {
		set w $sms
		set tags [list ruler tick small]
		set fill $shade(small)
	    }
	    if {$options(-grid)} {
		$hull create line 0 $dy $width $dy -width 1 -tags $tags \
		    -fill $fill
	    } else {
		$hull create line 0 $dy $w $dy -width 1 -tags $tags \
		    -fill $options(-foreground)
		$hull create line $width $dy [expr {$width - $w}] $dy \
		    -width 1 -tags $tags -fill $options(-foreground)
	    }
	}
    }

    method _resize {w X Y} {
	if {$w ne $win} { return }
	$self redraw
    }

    method _adjustinterval {dir} {
	set newint {}
	foreach i $options(-interval) {
	    if {$dir < 0} {
		lappend newint [expr {$i/2.0}]
	    } else {
		lappend newint [expr {$i*2.0}]
	    }
	}
	set options(-interval) $newint
	$self redraw
    }

    method shade {orig dest frac} {
	if {$frac >= 1.0} {return $dest} elseif {$frac <= 0.0} {return $orig}
	foreach {oR oG oB} [winfo rgb $win $orig] \
	    {dR dG dB} [winfo rgb $win $dest] {
	    set color [format "\#%02x%02x%02x" \
			   [expr {int($oR+double($dR-$oR)*$frac)}] \
			   [expr {int($oG+double($dG-$oG)*$frac)}] \
			   [expr {int($oB+double($dB-$oB)*$frac)}]]
	    return $color
	}
    }

}

snit::widget widget::screenruler {
    hulltype toplevel

    component ruler -public ruler
    component menu -public menu

    delegate option * to ruler
    delegate method * to ruler

    option -alpha	-default 0.8 -configuremethod C-alpha;
    option -title	-default "" -configuremethod C-title;
    option -topmost	-default 0 -configuremethod C-topmost;
    option -reflect	-default 0 -configuremethod C-reflect;
    # override ruler zoom for reflection control as well
    option -zoom	-default 1 -configuremethod C-zoom;
    option -showgeometry	-default 0 -configuremethod C-showgeometry;

    variable alpha 0.8 ; # internal opacity value
    variable curinterval 5;
    variable curmeasure "";
    variable grid 0;
    variable reflect -array {ok 0 image "" id ""}
    variable curdim -array {x 0 y 0 w 0 h 0}

    constructor {args} {
	wm withdraw $win
	wm overrideredirect $win 1
	$hull configure -bg white

	install ruler using widget::ruler $win.ruler -width 200 -height 50 \
	    -relief flat -bd 0 -background white -highlightthickness 0
	install menu using menu $win.menu -tearoff 0

	# avoid 1.0 because we want to maintain layered class
	if {$::tcl_platform(platform) eq "windows" && $alpha >= 1.0} {
	    set alpha 0.999
	}
	catch {wm attributes $win -alpha $alpha}
	catch {wm attributes $win -topmost $options(-topmost)}

	grid $ruler -sticky news
	grid columnconfigure $win 0 -weight 1
	grid rowconfigure    $win 0 -weight 1

	set reflect(ok) [expr {![catch {package require treectrl}]
			       && [llength [info commands loupe]]}]
	if {$reflect(ok)} {
	    set reflect(do) 0
	    set reflect(x) -1
	    set reflect(y) -1
	    set reflect(w) [winfo width $win]
	    set reflect(h) [winfo height $win]
	    set reflect(image) [image create photo [myvar reflect] \
				    -width  $reflect(w) -height $reflect(h)]
	    $ruler create image 0 0 -anchor nw -image $reflect(image)

	    # Don't use options(-reflect) because it isn't 0/1
	    $menu add checkbutton -label "Reflect Desktop" \
		-accelerator "r" -underline 0 \
		-variable [myvar reflect(do)] \
		-command "[list $win configure -reflect] \$[myvar reflect(do)]"
	    bind $win <Key-r> [list $menu invoke "Reflect Desktop"]
	}
	$menu add checkbutton -label "Show Grid" \
	    -accelerator "d" -underline 8 \
	    -variable [myvar grid] \
	    -command "[list $ruler configure -grid] \$[myvar grid]"
	bind $win <Key-d> [list $menu invoke "Show Grid"]
	$menu add checkbutton -label "Show Geometry" \
	    -accelerator "g" -underline 5 \
	    -variable [myvar options(-showgeometry)] \
	    -command "[list $win configure -showgeometry] \$[myvar options(-showgeometry)]"
	bind $win <Key-g> [list $menu invoke "Show Geometry"]
	if {[tk windowingsystem] ne "x11"} {
	    $menu add checkbutton -label "Keep on Top" \
		-underline 8 -accelerator "t" \
		-variable [myvar options(-topmost)] \
		-command "[list $win configure -topmost] \$[myvar options(-topmost)]"
	    bind $win <Key-t> [list $menu invoke "Keep on Top"]
	}
	set m [menu $menu.interval -tearoff 0]
	$menu add cascade -label "Interval" -menu $m -underline 0
	foreach interval {
	    {2 10 50} {4 20 100} {5 25 100} {10 50 100}
	} {
	    $m add radiobutton -label [lindex $interval 0] \
		-variable [myvar curinterval] -value [lindex $interval 0] \
		-command [list $ruler configure -interval $interval]
	}
	set m [menu $menu.zoom -tearoff 0]
	$menu add cascade -label "Zoom" -menu $m -underline 0
	foreach zoom {1 2 3 4 5 8 10} {
	    set lbl ${zoom}x
	    $m add radiobutton -label $lbl \
		-underline 0 \
		-variable [myvar options(-zoom)] -value $zoom \
		-command "[list $win configure -zoom] \$[myvar options(-zoom)]"
	    bind $win <Key-[string index $zoom end]> \
		[list $m invoke [string map {% %%} $lbl]]
	}
	set m [menu $menu.measure -tearoff 0]
	$menu add cascade -label "Measurement" -menu $m -underline 0
	foreach {val und} {pixels 0 points 1 inches 0 mm 0 cm 0} {
	    $m add radiobutton -label $val \
		-underline $und \
		-variable [myvar curmeasure] -value $val \
		-command [list $ruler configure -measure $val]
	}
	set m [menu $menu.opacity -tearoff 0]
	$menu add cascade -label "Opacity" -menu $m -underline 0
	for {set i 10} {$i <= 100} {incr i 10} {
	    set aval [expr {$i/100.}]
	    $m add radiobutton -label "${i}%" \
		-variable [myvar alpha] -value $aval \
		-command [list $win configure -alpha $aval]
	}

	if {[tk windowingsystem] eq "aqua"} {
	    bind $win <Control-ButtonPress-1> [list tk_popup $menu %X %Y]
	    # Aqua switches 2 and 3 ...
	    bind $win <ButtonPress-2>         [list tk_popup $menu %X %Y]
	} else {
	    bind $win <ButtonPress-3>         [list tk_popup $menu %X %Y]
	}
	bind $win <Configure>     [mymethod _resize %W %x %y %w %h]
	bind $win <ButtonPress-1> [mymethod _dragstart %W %X %Y]
	bind $win <B1-Motion>     [mymethod _drag %W %X %Y]
	bind $win <Motion>        [mymethod _edgecheck %W %x %y]

	#$hull configure -menu $menu

	$self configurelist $args

	set grid [$ruler cget -grid]
	set curinterval [lindex [$ruler cget -interval] 0]
	set curmeasure  [$ruler cget -measure]
    }

    destructor {
	catch {
	    after cancel $reflect(id)
	    image delete $reflect(image)
	}
    }

    ########################################
    ## public methods

    method display {} {
	wm deiconify $win
	raise $win
	focus $win
    }

    method hide {} {
	wm withdraw $win
    }

    ########################################
    ## configure methods

    method C-alpha {option value} {
	if {![string is double -strict $value]
	    || $value < 0.0 || $value > 1.0} {
	    return -code error "invalid $option value \"$value\":\
		must be a double between 0 and 1"
	}
        set options($option) $value
	set alpha $value
	# avoid 1.0 because we want to maintain layered class
	if {$::tcl_platform(platform) eq "windows" && $alpha >= 1.0} {
	    set alpha 0.999
	}
	catch {wm attributes $win -alpha $alpha}
    }
    method C-title {option value} {
	wm title $win $value
	wm iconname $win $value
        set options($option) $value
    }
    method C-topmost {option value} {
        set options($option) $value
	catch {wm attributes $win -topmost $value}
    }

    method C-reflect {option value} {
	if {($value > 0) && !$reflect(ok)} {
	    return -code error "no reflection possible"
	}
	after cancel $reflect(id)
	if {$value > 0} {
	    if {$value < 50} {
		set value 50
	    }
	    set reflect(id) [after idle [mymethod _reflect]]
	} else {
	    catch {$reflect(image) blank}
	}
        set options($option) $value
    }

    method C-zoom {option value} {
	if {![string is integer -strict $value] || $value < 1} {
	    return -code error "invalid $option value \"$value\":\
		must be a valid integer >= 1"
	}
	$ruler configure -zoom $value
	set options($option) $value
    }

    method C-showgeometry {option value} {
	if {![string is boolean -strict $value]} {
	    return -code error "invalid $option value \"$value\":\
		must be a valid boolean"
	}
	set options($option) $value
	$ruler delete geoinfo
	if {$value} {
	    set opts [list -borderwidth 1 -highlightthickness 1 -width 4]
	    set x 20
	    set y 20
	    foreach d {x y w h} {
		set w $win._$d
		destroy $w
		eval [linsert $opts 0 entry $w -textvar [myvar curdim($d)]]
		$ruler create window $x $y -window $w -tags geoinfo
		bind $w <Return> [mymethod _placecmd]
		# Avoid toplevel bindings
		bindtags $w [list $w Entry all]
		incr x [winfo reqwidth $w]
	    }
	}
    }

    ########################################
    ## private methods

    method _placecmd {} {
	wm geometry $win $curdim(w)x$curdim(h)+$curdim(x)+$curdim(y)
    }

    method _resize {W x y w h} {
	if {$W ne $win} { return }
	set curdim(x) $x
	set curdim(y) $y
	set curdim(w) $w
	set curdim(h) $h
    }

    method _reflect {} {
	if {!$reflect(ok)} { return }
	set w [winfo width $win]
	set h [winfo height $win]
	set x [winfo pointerx $win]
	set y [winfo pointery $win]
	if {($reflect(w) != $w) || ($reflect(h) != $h)} {
	    $reflect(image) configure -width $w -height $h
	    set reflect(w) $w
	    set reflect(h) $h
	}
	if {($reflect(x) != $x) || ($reflect(y) != $y)} {
	    loupe $reflect(image) $x $y $w $h $options(-zoom)
	    set reflect(x) $x
	    set reflect(y) $y
	}
	if {$options(-reflect)} {
	    set reflect(id) [after $options(-reflect) [mymethod _reflect]]
	}
    }

    variable edge -array {
	at 0
	left   1
	right  2
	top    3
	bottom 4
    }
    method _edgecheck {w x y} {
	if {$w ne $ruler} { return }
	set edge(at) 0
	set cursor ""
	if {$x < 4 || $x > ([winfo width $win] - 4)} {
	    set cursor sb_h_double_arrow
	    set edge(at) [expr {$x < 4 ? $edge(left) : $edge(right)}]
	} elseif {$y < 4 || $y > ([winfo height $win] - 4)} {
	    set cursor sb_v_double_arrow
	    set edge(at) [expr {$y < 4 ? $edge(top) : $edge(bottom)}]
	}
	$win configure -cursor $cursor
    }

    variable drag -array {}
    method _dragstart {w X Y} {
	set drag(X) [expr {$X - [winfo rootx $win]}]
	set drag(Y) [expr {$Y - [winfo rooty $win]}]
	set drag(w) [winfo width $win]
	set drag(h) [winfo height $win]
	$self _edgecheck $ruler $drag(X) $drag(Y)
	raise $win
	focus $ruler
    }
    method _drag {w X Y} {
	if {$edge(at) == 0} {
	    set dx [expr {$X - $drag(X)}]
	    set dy [expr {$Y - $drag(Y)}]
	    wm geometry $win +$dx+$dy
	} elseif {$edge(at) == $edge(left)} {
	    # need to handle moving root - currently just moves
	    set dx [expr {$X - $drag(X)}]
	    set dy [expr {$Y - $drag(Y)}]
	    wm geometry $win +$dx+$dy
	} elseif {$edge(at) == $edge(right)} {
	    set relx   [expr {$X - [winfo rootx $win]}]
	    set width  [expr {$relx - $drag(X) + $drag(w)}]
	    set height $drag(h)
	    if {$width > 5} {
		wm geometry $win ${width}x${height}
	    }
	} elseif {$edge(at) == $edge(top)} {
	    # need to handle moving root - currently just moves
	    set dx [expr {$X - $drag(X)}]
	    set dy [expr {$Y - $drag(Y)}]
	    wm geometry $win +$dx+$dy
	} elseif {$edge(at) == $edge(bottom)} {
	    set rely   [expr {$Y - [winfo rooty $win]}]
	    set width  $drag(w)
	    set height [expr {$rely - $drag(Y) + $drag(h)}]
	    if {$height > 5} {
		wm geometry $win ${width}x${height}
	    }
	}
    }
}

########################################
## Ready for use

package provide widget::ruler 1.1
package provide widget::screenruler 1.2

if {[info exist ::argv0] && $::argv0 eq [info script]} {
    # We are the main script being run - show ourselves
    wm withdraw .
    set dlg [widget::screenruler .r -grid 1 -title "Screen Ruler"]
    $dlg menu add separator
    $dlg menu add command -label "Exit" -command { exit }
    $dlg display
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/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
257
258
# -*- tcl -*-
#
# scrollw.tcl -
#
#	Scrolled widget
#
# RCS: @(#) $Id: scrollw.tcl,v 1.15 2010/06/01 18:06:52 hobbs Exp $
#

# Creation and Options - widget::scrolledwindow $path ...
#  -scrollbar -default "both" ; vertical horizontal none
#  -auto      -default "both" ; vertical horizontal none
#  -sides     -default "se"   ;
#  -size      -default 0      ; scrollbar -width (not recommended to change)
#  -ipad      -default {0 0}  ; represents internal {x y} padding between
#			      ; scrollbar and given widget
#  All other options to frame
#
# Methods
#  $path getframe           => $frame
#  $path setwidget $widget  => $widget
#  All other methods to frame
#
# Bindings
#  NONE
#

if 0 {
    # Samples
    package require widget::scrolledwindow
    #set sw [widget::scrolledwindow .sw -scrollbar vertical]
    #set text [text .sw.text -wrap word]
    #$sw setwidget $text
    #pack $sw -fill both -expand 1

    set sw [widget::scrolledwindow .sw -borderwidth 1 -relief sunken]
    set text [text $sw.text -borderwidth 0 -height 4 -width 20]
    $sw setwidget $text
    pack $sw -fill both -expand 1 -padx 4 -pady 4

    set sw [widget::scrolledwindow .ssw -borderwidth 2 -relief solid]
    set text [text $sw.text -borderwidth 0 -height 4 -width 20]
    $sw setwidget $text
    pack $sw -fill both -expand 1 -padx 4 -pady 4
}

###

package require widget

snit::widget widget::scrolledwindow {
    hulltype ttk::frame

    component hscroll
    component vscroll

    delegate option * to hull
    delegate method * to hull
    #delegate option -size to {hscroll vscroll} as -width

    option -scrollbar -default "both" -configuremethod C-scrollbar \
	-type [list snit::enum -values [list none horizontal vertical both]]
    option -auto      -default "both" -configuremethod C-scrollbar \
	-type [list snit::enum -values [list none horizontal vertical both]]
    option -sides     -default "se" -configuremethod C-scrollbar \
	-type [list snit::enum -values [list ne en nw wn se es sw ws]]
    option -size      -default 0 -configuremethod C-size \
	-type [list  snit::integer -min 0 -max 30]
    option -ipad      -default 0 -configuremethod C-ipad \
	-type [list snit::listtype -type {snit::integer} -minlen 1 -maxlen 2]

    typevariable scrollopts {none horizontal vertical both}

    variable realized 0    ; # set when first Configure'd
    variable hsb -array {
	packed 0 present 0 auto 0 row 2 col 1 lastmin -1 lastmax -1 lock 0
	sticky "ew" padx 0 pady 0
    }
    variable vsb -array {
	packed 0 present 0 auto 0 row 1 col 2 lastmin -1 lastmax -1 lock 0
	sticky "ns" padx 0 pady 0
    }
    variable pending {}    ; # pending after id for scrollbar mgmt

    constructor args {
	if {[tk windowingsystem] ne "aqua"} {
	    # ttk scrollbars on aqua are a bit wonky still
	    install hscroll using ttk::scrollbar $win.hscroll \
		-orient horizontal -takefocus 0
	    install vscroll using ttk::scrollbar $win.vscroll \
		-orient vertical -takefocus 0
	} else {
	    install hscroll using scrollbar $win.hscroll \
		-orient horizontal -takefocus 0
	    install vscroll using scrollbar $win.vscroll \
		-orient vertical -takefocus 0
	    # in case the scrollbar has been overridden ...
	    catch {$hscroll configure -highlightthickness 0}
	    catch {$vscroll configure -highlightthickness 0}
	}

	set hsb(bar) $hscroll
	set vsb(bar) $vscroll
	bind $win <Configure> [mymethod _realize $win]

	grid columnconfigure $win 1 -weight 1
	grid rowconfigure    $win 1 -weight 1

	set pending [after idle [mymethod _setdata]]
	$self configurelist $args
    }

    destructor {
	after cancel $pending
	set pending {}
    }

    # Do we need this ??
    method getframe {} { return $win }

    variable setwidget {}
    method setwidget {widget} {
	if {$setwidget eq $widget} { return }
	if {[winfo exists $setwidget]} {
	    grid remove $setwidget
	    # in case we only scroll in one direction
	    catch {$setwidget configure -xscrollcommand ""}
	    catch {$setwidget configure -yscrollcommand ""}
	    $hscroll configure -command {}
	    $vscroll configure -command {}
	    set setwidget {}
	}
	if {$pending ne {}} {
	    # ensure we have called most recent _setdata
	    after cancel $pending
	    $self _setdata
	}
	if {[winfo exists $widget]} {
	    set setwidget $widget
	    grid $widget -in $win -row 1 -column 1 -sticky news

	    # in case we only scroll in one direction
	    if {$hsb(present)} {
		$widget configure -xscrollcommand [mymethod _set_scroll hsb]
		$hscroll configure -command [list $widget xview]
	    }
	    if {$vsb(present)} {
		$widget configure -yscrollcommand [mymethod _set_scroll vsb]
		$vscroll configure -command [list $widget yview]
	    }
	}
	return $widget
    }

    method C-size {option value} {
	set options($option) $value
	$vscroll configure -width $value
	$hscroll configure -width $value
    }

    method C-scrollbar {option value} {
	set options($option) $value
	after cancel $pending
	set pending [after idle [mymethod _setdata]]
    }

    method C-ipad {option value} {
	set options($option) $value
	# double value to ensure a single int value covers pad x and y
	foreach {padx pady} [concat $value $value] { break }
	set vsb(padx) [list $padx 0] ; set vsb(pady) 0
	set hsb(padx) 0              ; set vsb(pady) [list $pady 0]
	if {$vsb(present) && $vsb(packed)} {
	    grid configure $vsb(bar) -padx $vsb(padx) -pady $vsb(pady)
	}
	if {$hsb(present) && $hsb(packed)} {
	    grid configure $hsb(bar) -padx $hsb(padx) -pady $hsb(pady)
	}
    }

    method _set_scroll {varname vmin vmax} {
	if {!$realized} { return }
	# This is only called if the scrollbar is attached properly
	upvar 0 $varname sb
	if {$sb(auto)} {
	    if {!$sb(lock)} {
		# One last check to avoid loops when not locked
		if {$vmin == $sb(lastmin) && $vmax == $sb(lastmax)} {
		    return
		}
		set sb(lastmin) $vmin
		set sb(lastmax) $vmax
	    }
	    if {$sb(packed) && $vmin == 0 && $vmax == 1} {
		if {!$sb(lock)} {
		    set sb(packed) 0
		    grid remove $sb(bar)
		}
	    } elseif {!$sb(packed) && ($vmin != 0 || $vmax != 1)} {
		set sb(packed) 1
		grid $sb(bar) -column $sb(col) -row $sb(row) \
		    -sticky $sb(sticky) -padx $sb(padx) -pady $sb(pady)
	    }
	    set sb(lock) 1
	    update idletasks
	    set sb(lock) 0
	}
	$sb(bar) set $vmin $vmax
    }

    method _setdata {} {
	set pending {}
	set bar   [lsearch -exact $scrollopts $options(-scrollbar)]
	set auto  [lsearch -exact $scrollopts $options(-auto)]

	set hsb(present) [expr {$bar & 1}]  ; # idx 1 or 3
	set hsb(auto)    [expr {$auto & 1}] ; # idx 1 or 3
	set hsb(row)     [expr {[string match *n* $options(-sides)] ? 0 : 2}]
	set hsb(col)     1
	set hsb(sticky)  "ew"

	set vsb(present) [expr {$bar & 2}]  ; # idx 2
	set vsb(auto)    [expr {$auto & 2}] ; # idx 2
	set vsb(row)     1
	set vsb(col)     [expr {[string match *w* $options(-sides)] ? 0 : 2}]
	set vsb(sticky)	 "ns"

	if {$setwidget eq ""} {
	    grid remove $hsb(bar)
	    grid remove $vsb(bar)
	    set hsb(packed) 0
	    set vsb(packed) 0
	    return
	}

	foreach varname {hsb vsb} {
	    upvar 0 $varname sb
	    foreach {vmin vmax} [$sb(bar) get] { break }
	    set sb(packed) [expr {$sb(present) &&
				   (!$sb(auto) || ($vmin != 0 || $vmax != 1))}]
	    if {$sb(packed)} {
		grid $sb(bar) -column $sb(col) -row $sb(row) \
		    -sticky $sb(sticky) -padx $sb(padx) -pady $sb(pady)
	    } else {
		grid remove $sb(bar)
	    }
	}
    }

    method _realize {w} {
	if {$w eq $win} {
	    bind $win <Configure> {}
	    set realized 1
	}
    }
}

package provide widget::scrolledwindow 1.2.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/statusbar.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
# -*- tcl -*-
#
#  statusbar.tcl -
#	Create a status bar Tk widget
#
# RCS: @(#) $Id: statusbar.tcl,v 1.8 2010/06/01 18:06:52 hobbs Exp $
#

# Creation and Options - widget::scrolledwindow $path ...
#
#  -separator -default 1 ; show horizontal separator on top of statusbar
#  -resize    -default 1 ; show resize control on bottom right
#  -resizeseparator -default 1 ; show separator for resize control
#  ## Padding can be a list of {padx pady}
#  -ipad -default 1 ; provides padding around each status bar item
#  -pad  -default 0 ; provides general padding around the status bar
#
#  All other options to frame
#
# Methods
#  $path getframe           => $frame
#  $path add $widget ?args? => $widget
#  All other methods to frame
#
# Bindings
#  NONE
#
#  Provides a status bar to be placed at the bottom of a toplevel.
#  Currently does not support being placed in a toplevel that has
#  gridding applied (via widget -setgrid or wm grid).
#
#  Ensure that the widget is placed at the very bottom of the toplevel,
#  otherwise the resize behavior may behave oddly.
#

package require widget

if {0} {
    proc sample {} {
    # sample usage
    eval destroy [winfo children .]
    pack [text .t -width 0 -height 0] -fill both -expand 1

    set sbar .s
    widget::statusbar $sbar
    pack $sbar -side bottom -fill x
    set f [$sbar getframe]

    # Specify -width 1 for the label widget so it truncates nicely
    # instead of requesting large sizes for long messages
    set w [label $f.status -width 1 -anchor w -textvariable ::STATUS]
    set ::STATUS "This is a status message"
    # give the entry weight, as we want it to be the one that expands
    $sbar add $w -weight 1

    # BWidget's progressbar
    set w [ProgressBar $f.bpbar -orient horizontal \
	       -variable ::PROGRESS -bd 1 -relief sunken]
    set ::PROGRESS 50
    $sbar add $w
    }
}

snit::widget widget::statusbar {
    hulltype ttk::frame

    component resizer
    component separator
    component sepresize
    component frame

    # -background, -borderwidth and -relief apply to outer frame, but relief
    # should be left flat for proper look
    delegate option * to hull
    delegate method * to hull

    option -separator       -default 1 -configuremethod C-separator \
	-type [list snit::boolean]
    option -resize          -default 1 -configuremethod C-resize \
	-type [list snit::boolean]
    option -resizeseparator -default 1 -configuremethod C-resize \
	-type [list snit::boolean]
    # -pad provides general padding around the status bar
    # -ipad provides padding around each status bar item
    # Padding can be a list of {padx pady}
    option -ipad -default 2 -configuremethod C-ipad \
	-type [list snit::listtype -type {snit::integer} -minlen 1 -maxlen 4]
    delegate option -pad to frame as -padding

    variable ITEMS -array {}
    variable uid 0

    constructor args {
	$hull configure -height 18

	install frame using ttk::frame $win.frame

	install resizer using ttk::sizegrip $win.resizer

	install separator using ttk::separator $win.separator \
	    -orient horizontal

	install sepresize using ttk::separator $win.sepresize \
	    -orient vertical

	grid $separator -row 0 -column 0 -columnspan 3 -sticky ew
	grid $frame     -row 1 -column 0 -sticky news
	grid $sepresize -row 1 -column 1 -sticky ns;# -padx $ipadx -pady $ipady
	grid $resizer   -row 1 -column 2 -sticky se
	grid columnconfigure $win 0 -weight 1

	$self configurelist $args
    }

    method C-ipad {option value} {
	set options($option) $value
	# returns pad values - each will be a list of 2 ints
	foreach {px py} [$self _padval $value] { break }
	foreach w [grid slaves $frame] {
	    if {[string match _sep* $w]} {
		grid configure $w -padx $px -pady 0
	    } else {
		grid configure $w -padx $px -pady $py
	    }
	}
    }

    method C-separator {option value} {
	set options($option) $value
	if {$value} {
	    grid $separator
	} else {
	    grid remove $separator
	}
    }

    method C-resize {option value} {
	set options($option) $value
	if {$options(-resize)} {
	    if {$options(-resizeseparator)} {
		grid $sepresize
	    }
	    grid $resizer
	} else {
	    grid remove $sepresize $resizer
	}
    }

    # Use this or 'add' - but not both
    method getframe {} { return $frame }

    method add {what args} {
	if {[winfo exists $what]} {
	    set w $what
	    set symbol $w
	    set ours 0
	} else {
	    set w $frame._$what[incr uid]
	    set symbol [lindex $args 0]
	    set args [lrange $args 1 end]
	    if {![llength $args] || $symbol eq "%AUTO%"} {
		# Autogenerate symbol name
		set symbol _$what$uid
	    }
	    if {[info exists ITEMS($symbol)]} {
		return -code error "item '$symbol' already exists"
	    }
	    if {$what eq "label" || $what eq "button"
		|| $what eq "checkbutton" || $what eq "radiobutton"} {
		set w [ttk::$what $w -style Toolbutton -takefocus 0]
	    } elseif {$what eq "separator"} {
		set w [ttk::separator $w -orient vertical]
	    } elseif {$what eq "space"} {
		set w [ttk::frame $w]
	    } else {
		return -code error "unknown item type '$what'"
	    }
	    set ours 1
	}
	set opts(-weight)	[string equal $what "space"]
	set opts(-separator)	0
	set opts(-sticky)	news
	set opts(-pad)		$options(-ipad)
	if {$what eq "separator"} {
	    # separators should not have pady by default
	    lappend opts(-pad) 0
	}
	set cmdargs [list]
	set len [llength $args]
	for {set i 0} {$i < $len} {incr i} {
	    set key [lindex $args $i]
	    set val [lindex $args [incr i]]
	    if {$key eq "--"} {
		eval [list lappend cmdargs] [lrange $args $i end]
		break
	    }
	    if {[info exists opts($key)]} {
		set opts($key) $val
	    } else {
		# no error - pass to command
		lappend cmdargs $key $val
	    }
	}
	if {[catch {eval [linsert $cmdargs 0 $w configure]} err]} {
	    # we only want to destroy widgets we created
	    if {$ours} { destroy $w }
	    return -code error $err
	}
	set ITEMS($symbol) $w
	widget::isa listofint 4 -pad $opts(-pad)
	# returns pad values - each will be a list of 2 ints
	foreach {px py} [$self _padval $opts(-pad)] { break }

	# get cols,rows extent
	foreach {cols rows} [grid size $frame] break
	# Add separator if requested, and we aren't the first element
	if {$opts(-separator) && $cols != 0} {
	    set sep [ttk::separator $frame._sep[winfo name $w] \
			 -orient vertical]
	    # No pady for separators, and adjust padx for separator space
	    set sx $px
	    if {[lindex $sx 0] < 2} { lset sx 0 2 }
	    lset px 1 0
	    grid $sep -row 0 -column $cols -sticky ns -padx $sx -pady 0
	    incr cols
	}

	grid $w -in $frame -row 0 -column $cols -sticky $opts(-sticky) \
	    -padx $px -pady $py
	grid columnconfigure $frame $cols -weight $opts(-weight)

	return $symbol
    }

    method remove {args} {
	set destroy [string equal [lindex $args 0] "-destroy"]
	if {$destroy} {
	    set args [lrange $args 1 end]
	}
	foreach sym $args {
	    # Should we ignore unknown (possibly already removed) items?
	    #if {![info exists ITEMS($sym)]} { continue }
	    set w $ITEMS($sym)
	    # separator name is based off item name
	    set sep $frame._sep[winfo name $w]
	    # destroy separator for remove or destroy case
	    destroy $sep
	    if {$destroy} {
		destroy $w
	    } else {
		grid forget $w
	    }
	    unset ITEMS($sym)
	}
    }

    method delete {args} {
	eval [linsert $args 0 $self remove -destroy]
    }

    method items {{ptn *}} {
	# return from ordered list
	if {$ptn ne "*"} {
	    return [array names ITEMS $ptn]
	}
	return [array names ITEMS]
    }

    method _padval {val} {
	set len [llength $val]
	if {$len == 0} {
	    return [list 0 0 0 0]
	} elseif {$len == 1} {
	    return [list [list $val $val] [list $val $val]]
	} elseif {$len == 2} {
	    set x [lindex $val 0] ; set y [lindex $val 1]
	    return [list [list $x $x] [list $y $y]]
	} elseif {$len == 3} {
	    return [list [list [lindex $val 0] [lindex $val 2]] \
			[list [lindex $val 1] [lindex $val 1]]]
	} else {
	    return $val
	}
    }
}

package provide widget::statusbar 1.2.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/stext.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
# -*- tcl -*-
#
# stext.tcl -
#
#	Scrolled text widget.  A blend of the text widget with the
#	scrolledwindow.
#
#	While I do not recommend making scrolledXXX versions of widgets
#	(instead, use the 3 line wrapper), this is an example of how one
#	would do that.
#
# RCS: @(#) $Id: stext.tcl,v 1.2 2008/12/11 18:07:20 hobbs Exp $
#

if 0 {
    # Samples
    package require widget::scrolledwindow
    #set sw [widget::scrolledwindow .sw -scrollbar vertical]
    #set text [text .sw.text -wrap word]
    #$sw setwidget $text
    #pack $sw -fill both -expand 1

    proc test {{root .f}} {
	destroy $root
	set f   [ttk::frame $root]
	set lbl [ttk::label $f.lbl -text "Scrolled Text snidget:" -anchor w]
	set st  [widget::scrolledtext $f.sw -borderwidth 1 -relief sunken]
	pack $lbl -fill x
	pack $st -fill both -expand 1
	pack $f -fill both -expand 1 -padx 4 -pady 4
    }
}

###

package require widget
package require widget::scrolledwindow

snit::widgetadaptor widget::scrolledtext {
    # based on widget::scrolledwindow
    component text

    delegate option * to text
    delegate method * to text

    delegate option -scrollbar to hull
    delegate option -auto to hull
    delegate option -sides to hull
    delegate option -borderwidth to hull
    delegate option -relief to hull

    constructor args {
	# You want the outer scrolledwindow to display bd/relief
	installhull using widget::scrolledwindow
	install text using text $win.text \
	    -borderwidth 0 -relief flat -highlightthickness 1
	$hull setwidget $text

	# Enable with the bits below to have a fancy override for text
	# widget commands (like insert/delete)
	#rename $text ${selfns}::$text.
	#interp alias {} $text {} {*}[mymethod _text]

	# Use Ttk TraverseIn event to handle megawidget focus properly
	bind $win <<TraverseIn>> [list focus -force $text]

	$self configurelist $args
    }

    #destructor { rename $text {} }
    #method _text {cmd args} {
    #	# Here you could override insert or delete ...
    #	uplevel 1 [linsert $args 0 ${selfns}::$text. $cmd]
    #}
}

package provide widget::scrolledtext 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































Deleted scriptlibs/tklib0.5/widget/superframe.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
# -*- tcl -*-
#
# superframe.tcl -
#
#	Superframe widget - enhanced labelframe widget
#
# RCS: @(#) $Id: superframe.tcl,v 1.4 2010/06/01 18:06:52 hobbs Exp $
#

# Allows 3 styles of labelframes:
#  border        standard labelframe
#  whitespace    labelframe with inset contents, no border
#  separator     labelframe with inset contents, topright separator
#
# Based on OS X grouping types:
#   http://developer.apple.com/documentation/UserExperience/Conceptual/OSXHIGuidelines/XHIGLayout/chapter_19_section_4.html
#

# ### ######### ###########################
## Prerequisites

package require widget

# ### ######### ###########################
## Implementation

snit::widgetadaptor widget::superframe {
    # ### ######### ###########################
    delegate option * to hull except {-style -labelwidget -text -font}
    delegate method * to hull

    option -style -default border -readonly 1;
    option -labelwidget -default "" -configuremethod C-labelwidget;
    option -text        -default "" -configuremethod C-text;
    option -font        -default "" -configuremethod C-font;

    # ### ######### ###########################
    ## Public API. Construction

    constructor {args} {
	set wtype ttk::labelframe
	# Grab -style option for processing - do not pass through
	set idx [lsearch -exact $args "-style"]
	if {$idx != -1} {
	    set options(-style) [lindex $args [expr {$idx + 1}]]
	    set args [lreplace $args $idx [expr {$idx + 1}]]
	}
	set styles [list border whitespace separator]
	if {[lsearch -exact $styles $options(-style)] == -1} {
	    return -code error \
		"style must be one of: border, whitespace or separator"
	}
	parray options
	if {$options(-style) ne "border"} {
	    set wtype labelframe
	}
	installhull using $wtype
	if {$options(-style) ne "border"} {
	    set args [linsert $args 0 -relief flat -borderwidth 0]
	}
	if {$options(-style) eq "separator"} {
	    set sf [ttk::frame $win._labelwidget]
	    ttk::label $sf.lbl -text $options(-text)
	    ttk::separator $sf.sep -orient horizontal

	    grid $sf.lbl -row 0 -column 0 -stick sew
	    grid $sf.sep -row 0 -column 1 -stick sew -pady 2 -padx 2
	    grid columnconfigure $sf 1 -weight 1
	    grid rowconfigure    $sf 0 -weight 1

	    $hull configure -labelwidget $sf
	    bind $win <Configure> \
		[subst { if {"%W" eq "$win"} { $self SepSize } }]
	}
	$self configurelist $args
	return
    }

    # ### ######### ###########################
    ## Public API. Retrieve components

    method labelwidget {} {
	if {$options(-style) ne "separator"} {
	    return [$hull cget -labelwidget]
	} else {
	    return $win._labelwidget
	}
    }

    method SepSize {} {
	if {$options(-style) ne "separator"} { return 0 }

	set lw $win._labelwidget
	set rw  [winfo width $win]
	set lrw [winfo width $lw.lbl]
	set width [expr {$rw - $lrw - 10}]

	grid columnconfigure $lw 1 -minsize $width
    }

    # ### ######### ###########################
    ## Internal. Handling option changes.

    method C-labelwidget {option value} {
	if {$options(-style) ne "separator"} {
	    $hull configure -labelwidget $value
	} else {
	    set oldw [$hull cget -labelwidget]
	    if {$oldw ne ""} { grid forget $oldw }
	    if {$oldw eq $value || $value eq ""} { return }
	    grid $value -in $win._labelwidget -row 0 -column 0 -sticky ew
	}
	set options($option) $value
    }

    method C-text {option value} {
	if {$options(-style) ne "separator"} {
	    $hull configure -text $value
	} else {
	    $win._labelwidget.lbl configure -text $value
	}
	set options($option) $value
    }

    method C-font {option value} {
	if {$options(-style) ne "separator"} {
	    $hull configure -font $value
	} else {
	    $win._labelwidget.lbl configure -font $value
	}
	set options($option) $value
    }

    # ### ######### ###########################
}

# ### ######### ###########################
## Ready for use

package provide widget::superframe 1.0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































Deleted scriptlibs/tklib0.5/widget/toolbar.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
# -*- tcl -*-
#
# toolbar - /snit::widget
#	Manage items in a toolbar.
#
# RCS: @(#) $Id: toolbar.tcl,v 1.12 2010/06/01 18:06:52 hobbs Exp $
#

#  ## Padding can be a list of {padx pady}
#  -ipad -default 1 ; provides padding around each status bar item
#  -pad  -default 0 ; provides general padding around the status bar
#  -separator -default {} ; one of {top left bottom right {}}
#
#  All other options to frame
#
# Methods
#  $path getframe           => $frame
#  $path add $widget ?args? => $widget
#  All other methods to frame
#
# Bindings
#  NONE
#

if 0 {
    # Example
    lappend auto_path ~/cvs/tcllib/tklib/modules/widget

    package require widget::toolbar
    set f [ttk::frame .f -padding 4]
    pack $f -fill both -expand 1
    set tb [widget::toolbar .f.tb]
    pack $tb -fill both -expand 1
    $tb add button foo -text Foo
    $tb add button bar -text Bar -separator 1
    $tb add button baz -text Baz
    set b [ttk::button $tb.zippy -text Zippy -state disabled]
    $tb add $b
}

package require widget
#package require tooltip

snit::widget widget::toolbar {
    hulltype ttk::frame

    component separator
    component frame

    delegate option * to hull
    delegate method * to hull

    option -wrap -default 0 -type [list snit::boolean]
    option -separator -default {} -configuremethod C-separator \
	-type [list snit::enum -values [list top left bottom right {}]]
    # -pad provides general padding around the status bar
    # -ipad provides padding around each status bar item
    # Padding can be a list of {padx pady}
    option -ipad -default 2 -configuremethod C-ipad \
	-type [list snit::listtype -type {snit::integer} -minlen 1 -maxlen 4]
    delegate option -pad to frame as -padding

    variable ITEMS -array {}
    variable uid 0

    constructor {args} {
	$hull configure -height 18

	install frame using ttk::frame $win.frame

	install separator using ttk::separator $win.separator

	grid $frame -row 1 -column 1 -sticky news
	grid columnconfigure $win 1 -weight 1

	# we should have a <Configure> binding to wrap long toolbars
	#bind $win <Configure> [mymethod resize [list $win] %w]

	$self configurelist $args
    }

    method C-ipad {option value} {
	set options($option) $value
	# returns pad values - each will be a list of 2 ints
	foreach {px py} [$self _padval $value] { break }
	foreach w [grid slaves $frame] {
	    if {[string match _sep* $w]} {
		grid configure $w -padx $px -pady 0
	    } else {
		grid configure $w -padx $px -pady $py
	    }
	}
    }

    method C-separator {option value} {
	set options($option) $value
	switch -exact -- $value {
	    top {
		$separator configure -orient horizontal
		grid $separator -row 0 -column 1 -sticky ew
	    }
	    left {
		$separator configure -orient vertical
		grid $separator -row 1 -column 0 -sticky ns
	    }
	    bottom {
		$separator configure -orient horizontal
		grid $separator -row 2 -column 1 -sticky ew
	    }
	    right {
		$separator configure -orient vertical
		grid $separator -row 1 -column 2 -sticky ns
	    }
	    {} {
		grid remove $separator
	    }
	}
    }

    # Use this or 'add' - but not both
    method getframe {} { return $frame }

    method add {what args} {
	if {[winfo exists $what]} {
	    set w $what
	    set symbol $w
	    set ours 0
	} else {
	    set w $frame._$what[incr uid]
	    set symbol [lindex $args 0]
	    set args [lrange $args 1 end]
	    if {![llength $args] || $symbol eq "%AUTO%"} {
		# Autogenerate symbol name
		set symbol _$what$uid
	    }
	    if {[info exists ITEMS($symbol)]} {
		return -code error "item '$symbol' already exists"
	    }
	    if {$what eq "label" || $what eq "button"
		|| $what eq "checkbutton" || $what eq "radiobutton"} {
		set w [ttk::$what $w -style Toolbutton -takefocus 0]
	    } elseif {$what eq "separator"} {
		set w [ttk::separator $w -orient vertical]
	    } elseif {$what eq "space"} {
		set w [ttk::frame $w]
	    } else {
		return -code error "unknown item type '$what'"
	    }
	    set ours 1
	}
	set opts(-weight)	[string equal $what "space"]
	set opts(-separator)	0
	set opts(-sticky)	news
	set opts(-pad)		$options(-ipad)
	if {$what eq "separator"} {
	    # separators should not have pady by default
	    lappend opts(-pad) 0
	}
	set cmdargs [list]
	set len [llength $args]
	for {set i 0} {$i < $len} {incr i} {
	    set key [lindex $args $i]
	    set val [lindex $args [incr i]]
	    if {$key eq "--"} {
		eval [list lappend cmdargs] [lrange $args $i end]
		break
	    }
	    if {[info exists opts($key)]} {
		set opts($key) $val
	    } else {
		# no error - pass to command
		lappend cmdargs $key $val
	    }
	}
	if {[catch {eval [linsert $cmdargs 0 $w configure]} err]} {
	    # we only want to destroy widgets we created
	    if {$ours} { destroy $w }
	    return -code error $err
	}
	set ITEMS($symbol) $w
	widget::isa listofint 4 -pad $opts(-pad)
	# returns pad values - each will be a list of 2 ints
	foreach {px py} [$self _padval $opts(-pad)] { break }

	# get cols,rows extent
	foreach {cols rows} [grid size $frame] break
	# Add separator if requested, and we aren't the first element
	if {$opts(-separator) && $cols != 0} {
	    set sep [ttk::separator $frame._sep[winfo name $w] \
			 -orient vertical]
	    # No pady for separators, and adjust padx for separator space
	    set sx [lindex $px 0]
	    if {$sx < 2} { set sx 2 }
	    lset px 0 0
	    grid $sep -row 0 -column $cols -sticky ns -padx $sx -pady 0
	    incr cols
	}

	grid $w -in $frame -row 0 -column $cols -sticky $opts(-sticky) \
	    -pady $py -padx $px
	grid columnconfigure $frame $cols -weight $opts(-weight)

	return $symbol
    }

    method remove {args} {
	set destroy [string equal [lindex $args 0] "-destroy"]
	if {$destroy} {
	    set args [lrange $args 1 end]
	}
	foreach sym $args {
	    # Should we ignore unknown (possibly already removed) items?
	    #if {![info exists ITEMS($sym)]} { continue }
	    set w $ITEMS($sym)
	    # separator name is based off item name
	    set sep $frame._sep[winfo name $w]
	    # destroy separator for remove or destroy case
	    destroy $sep
	    if {$destroy} {
		destroy $w
	    } else {
		grid forget $w
	    }
	    unset ITEMS($sym)
	    # XXX separator of next item is no longer necessary, if it exists
	}
    }

    method delete {args} {
	eval [linsert $args 0 $self remove -destroy]
    }

    method itemconfigure {symbol args} {
	if {[info exists ITEMS($symbol)]} {
	    # configure exact item
	    return [eval [linsert $args 0 $ITEMS($symbol) configure]]
	}
	# configure based on $symbol as a glob pattern
	set res {}
	foreach sym [array names ITEMS -glob $symbol] {
	    lappend res \
		[catch { eval [linsert $args 0 $ITEMS($sym) configure] } msg] \
		$msg
	}
	# return something when we can figure out what is good to return
	#return $res
    }

    method itemcget {symbol option} {
	if {![info exists ITEMS($symbol)]} {
	    return -code error "unknown toolbar item '$symbol'"
	}
	return [$ITEMS($symbol) cget $option]
    }

    method itemid {symbol} {
	if {![info exists ITEMS($symbol)]} {
	    return -code error "unknown toolbar item '$symbol'"
	}
	return $ITEMS($symbol)
    }

    method items {{ptn *}} {
	if {$ptn ne "*"} {
	    return [array names ITEMS $ptn]
	}
	return [array names ITEMS]
    }

    method _padval {val} {
	set len [llength $val]
	if {$len == 0} {
	    return [list 0 0 0 0]
	} elseif {$len == 1} {
	    return [list [list $val $val] [list $val $val]]
	} elseif {$len == 2} {
	    set x [lindex $val 0] ; set y [lindex $val 1]
	    return [list [list $x $x] [list $y $y]]
	} elseif {$len == 3} {
	    return [list [list [lindex $val 0] [lindex $val 2]] \
			[list [lindex $val 1] [lindex $val 1]]]
	} else {
	    return $val
	}
    }

    method resize {w width} {
	if {$w ne $win} { return }
	if {$width < [winfo reqwidth $win]} {
	    # Take the last column item and move it down
	}
    }

}

package provide widget::toolbar 1.2.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/widget.man.

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
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin widget n 3.0]
[moddesc   {Megawidget package}]
[titledesc {Megawidget package}]
[require Tcl 8.4]
[require Tk 8.4]
[require widget [opt 3.0]] [require snit]
[description]

This package provides megawidgets based on the snit oo system (snidgets).
It makes use of the Tile/Ttk themed widget set.

[para]

[list_begin definitions]

[call [cmd widget::validate] [arg as] [opt options]]
commands:

[list_end]

[section WIDGETS]

[list_begin definitions]

[call [cmd widget::calendar] [arg pathname] [opt options]]
options:


[call [cmd widget::dateentry] [arg pathname] [opt options]]
options:



[call [cmd widget::dialog] [arg pathname] [opt options]]
options:

[call [cmd widget::menuentry] [arg pathname] [opt options]]
options:

[call [cmd widget::panelframe] [arg pathname] [opt options]]
options:

[call [cmd widget::ruler] [arg pathname] [opt options]]
options:

[call [cmd widget::screenruler] [arg pathname] [opt options]]
options:

[call [cmd widget::scrolledwindow] [arg pathname] [opt options]]
options:

[call [cmd widget::statusbar] [arg pathname] [opt options]]
options:

[call [cmd widget::superframe] [arg pathname] [opt options]]
options:

[call [cmd widget::toolbar] [arg pathname] [opt options]]
options:

[list_end]

[section EXAMPLE]

[example {
package require widget::superframe ; # or widget::all
pack [widget::superframe .f -type separator -text "SuperFrame:"]
}]

[keywords megawidget snit widget]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































Deleted scriptlibs/tklib0.5/widget/widget.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
# -*- tcl -*-
#
# widget.tcl --
#
# megawidget package that uses snit as the object system (snidgets)
#
# Copyright (c) 2005 Jeffrey Hobbs
#
# RCS: @(#) $Id: widget.tcl,v 1.6 2010/06/01 18:06:52 hobbs Exp $
#

package require Tk 8.4
package require snit

# As most widgets need tile, do the right conditional require here
if {![package vsatisfies [package provide Tk] 8.5]} { package require tile }

#package provide Widget 3.1 ; # at end

namespace eval ::widget {
    if 0 {
	variable HaveMarlett \
	    [expr {[lsearch -exact [font families] "Marlett"] != -1}]
	snit::macro widget::HaveMarlett {} [list return $::widget::HaveMarlett]
    }
}


# widget::propagate -- (snit macro)
#
#   Propagates an option to multiple components
#
# Arguments:
#   option  option definition
#   args
# Results:
#   Create method Propagate$option
#
snit::macro widget::propagate {option args} {
    # propagate option $optDefn ?-default ...? to $components ?as $realopt?
    set idx [lsearch -exact $args "to"]
    set cmd [linsert [lrange $args 0 [expr {$idx - 1}]] 0 option $option]
    foreach {components as what} [lrange $args [expr {$idx + 1}] end] {
	break
    }
    # ensure we have just the option name
    set option [lindex $option 0]
    set realopt [expr {$what eq "" ? $option : $what}]
    lappend cmd -configuremethod Propagate$option
    eval $cmd

    set body "\n"
    foreach comp $components {
        append body "\$[list $comp] configure [list $realopt] \$value\n"
    }
    append body "set [list options($option)] \$value\n"

    method Propagate$option {option value} $body
}

if {0} {
    # Currently not feasible due to snit's compiler-as-slave-interp
    snit::macro widget::tkoption {option args} {
	# XXX should support this
	# tkoption {-opt opt Opt} ?-default ""? from /wclass/ ?as $wopt?
    }

    snit::macro widget::tkresource {wclass wopt} {
	# XXX should support this
	# tkresource $wclass $wopt
	set w ".#widget#$wclass"
	if {![winfo exists $w]} {
	    set w [$wclass $w]
	}
	set value [$w cget $wopt]
	after idle [list destroy $w]
	return $value
    }
}

# widget::tkresource --
#
#   Get the default option value from a widget class
#
# Arguments:
#   wclass  widget class
#   wopt    widget option
# Results:
#   Returns default value of $wclass $wopt value
#
proc widget::tkresource {wclass wopt} {
    # XXX should support this
    # tkresource $wclass $wopt
    set w ".#widget#$wclass"
    if {![winfo exists $w]} {
	set w [$wclass $w]
    }
    set value [$w cget $wopt]
    after idle [list destroy $w]
    return $value
}

# ::widget::validate --
#
#   Used by widgets for option validate - *private* spec may change
#
# Arguments:
#   as     type to compare as
#   range  range/data info specific to $as
#   option option name
#   value  value being validated
#
# Results:
#   Returns error or empty
#
proc ::widget::isa {as args} {
    foreach {range option value} $args { break }
    if {$as eq "list"} {
	if {[lsearch -exact $range $value] == -1} {
	    return -code error "invalid $option option \"$value\",\
		must be one of [join $range {, }]"
	}
    } elseif {$as eq "boolean" || $as eq "bool"} {
	foreach {option value} $args { break }
	if {![string is boolean -strict $value]} {
	    return -code error "$option requires a boolean value"
	}
    } elseif {$as eq "integer" || $as eq "int"} {
	foreach {min max} $range { break }
	if {![string is integer -strict $value]
	    || ($value < $min) || ($value > $max)} {
	    return -code error "$option requires an integer in the\
		range \[$min .. $max\]"
	}
    } elseif {$as eq "listofinteger" || $as eq "listofint"} {
	if {$range eq ""} { set range [expr {1<<16}] }
	set i 0
	foreach val $value {
	    if {![string is integer -strict $val] || ([incr i] > $range)} {
		return -code error "$option requires an list of integers"
	    }
	}
    } elseif {$as eq "double"} {
	foreach {min max} $range { break }
	if {![string is double -strict $value]
	    || ($value < $min) || ($value > $max)} {
	    return -code error "$option requires a double in the\
		range \[$min .. $max\]"
	}
    } elseif {$as eq "window"} {
	foreach {option value} $args { break }
	if {$value eq ""} { return }
	if {![winfo exists $value]} {
	    return -code error "invalid window \"$value\""
	}
    } else {
	return -code error "unknown validate type \"$as\""
    }
    return
}

package provide widget 3.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































Deleted scriptlibs/tklib0.5/widget/widget_calendar.man.

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
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin widget_calendar n 0.93]
[moddesc   {widget::calendar Megawidget}]
[titledesc {widget::calendar Megawidget}]
[require Tcl 8.4]
[require Tk 8.4]
[require widget [opt 3.0]]
[description]

This package provides a calendar megawidget (snidget).

[para]

[list_begin definitions]

[call [cmd widget::calendar] [arg pathname] [opt options]]

[list_end]

[section "WIDGET OPTIONS"]

[para]
[list_begin options]

[opt_def -command]

A script to evaluate when a date was selected.

[opt_def -dateformat]

The format of the date that is returned. Default: %m/%d/%Y.

[opt_def -firstday]

Set first day the week, Either sunday or monday. It defaults to monday.

[opt_def -font]

Select the font used in the widget. It defaults to Helvetica 9.

[opt_def -highlightcolor]

Selects the background color for the day that has been selected. Default: #FFCC00

[opt_def -language]

Specify language of the calendar contents. The language is specified
by abbreviations of the languge, for example: en - english, de -
german ... 
It defaults to en.
[para]
Supported languages: en, de, fr, it, es, pt, ru, sv, zh, fi

[opt_def -shadecolor]

Selects the color of the parts that have a shaded background. Default: #888888

[opt_def -showpast]

Specify if the past shall be shown. It is a boolean value and defaults
to 1.

[opt_def -textvariable]

Specifies the name of a variable whose value is linked to the entry widget's contents.
Whenever the variable changes value, the widget's contents are updated, and
vice versa.


[list_end]

[section "WIDGET COMMAND"]

[arg pathname] [cmd get] [opt [arg what]]
[para]

Returns a part of the selected date or 'all'. The argument [arg what] selects
the part. Valid values for [arg what] are: day, month, year and all.
'all' is the default and returns the complete date in the format given
with -dateformat.

[section "DEFAULT BINDINGS"]

On creation of the calendar widget the following bindings are installed.
[list_begin itemized]
[item]
Up - Move to week before current date
[item]
Down - Move to week after current date
[item]
Left - Move to day before current date
[item]
Right - Move to day after current date
[item]
Control-Left - Move to month before current date
[item]
Control-Right - Move to month after current date
[item]
Control-Up - Move to year before current date
[item]
Control-Down - Move to year after current date
[list_end]

[section EXAMPLE]

[example {
    package require widget::calendar ; # or widget::all
    set t [widget::calendar .t]
    pack $t -fill x -expand 1
}]


[keywords megawidget snit widget]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































Deleted scriptlibs/tklib0.5/widget/widget_toolbar.man.

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
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin widget_toolbar n 3.0]
[moddesc   {widget::toolbar Megawidget}]
[titledesc {widget::toolbar Megawidget}]
[require Tcl 8.4]
[require Tk 8.4]
[require widget [opt 3.0]]
[require widget::toolbar [opt 1.0]]
[description]

This package provides a toolbar megawidget (snidget).
It makes use of the Tile/Ttk themed widget set.

[para]

[list_begin definitions]

[call [cmd widget::toolbar] [arg pathname] [opt options]]

[call getframe]
[call add [opt item] [opt args]]
[call delete item1 [opt item2] [opt ...]]
[call itemcget symbol option]
[call itemconfigure symbol [opt args]]
[call items [opt pattern]]
[call remove [opt -destroy] item1 [opt item2] [opt ...]]

[list_end]

[section "WIDGET OPTIONS"]

[list_begin options]

[opt_def -ipad]
[opt_def -pad]
[opt_def -separator]

[list_end]

[section "ITEM OPTIONS"]

[list_begin options]

[opt_def -pad]
[opt_def -separator]
[opt_def -sticky]
[opt_def -weight]

[list_end]

[section EXAMPLE]

[example {
package require widget::toolbar ; # or widget::all
set t [widget::toolbar .t]
pack $t -fill x -expand 1
$t add button [button .b -text foo]
$t add separator -pad {2 4}
$t add button [button .c -text bar]
}]

[keywords megawidget snit widget]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































Changes to stringscan.rb.

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
# coding: utf-8
#Stringscan: grep-like tool, written in Ruby-Tk. (c) 2019 Kevin Walzer/WordTech Communications LLC. License: MIT license.
#encoding: UTF-8

require 'tk'
#find additional Tcl libraries
Tk::AUTO_PATH.list <<= File.dirname(__FILE__)
require ‘rbconfig’
include Config
case CONFIG[‘host_os’]
when /mswin|windows/i
  if ENV["OCRA_EXECUTABLE"] != ""
    begin
    FileUtils.cp_r(File.dirname(__FILE__) + '/lib/tcl8.6/.', File.dirname(File.dirname(File.dirname(__FILE__))) + '/lib/tcl8.6', remove_destination: true)
    FileUtils.cp_r(File.dirname(__FILE__) + '/lib/tcl8/.', File.dirname(File.dirname(File.dirname(__FILE__))) + '/lib/tcl8', remove_destination: true)
    FileUtils.cp_r(File.dirname(__FILE__) + '/lib/tk8.6/.', File.dirname(File.dirname(File.dirname(__FILE__))) + '/lib/tk8.6', remove_destination: true)
rescue
    raise
    end
  end
end



require_relative 'tkballoonhelp'  
require 'tkextlib/tile'
require 'find'
require 'tkextlib/tkDND'
require 'fileutils'


$platform = Tk.windowingsystem
if $platform == 'aqua'
    require 'tk/tk_mac'

end
if $platform == 'win32'
	require 'tk/winpkg'
	Tk::WinDDE.servername('Stringscan')


end
TkPackage.require('regproc')
TkPackage.require('machelp')
TkPackage.require('softwareupdate')
TkPackage.require('xplat')


if $platform == 'aqua'
    $accelkey = 'Command'
else 
    $accelkey = 'Control'
end
class StringscanApp
    #here we initialize our app class
    def initialize
        $dirname = ""
        $searchterm = ""
        $appname = 'Stringscan'
        $appversion = '2.0'
        Tk.tk_call('machelp::setAppName', $appname, $appversion)
        Tk.tk_call('softwareupdate::setAppName', $appname)
        Tk.tk_call('softwareupdate::setVersion', $appname, $appversion)
        bgerror = Tk.install_cmd(proc{
            |*args|

             Tk::messageBox :type => 'ok', :message => args,
    :icon => 'error', :title => 'Error',
    :parent => $root

        })
        Tk.ip_eval("proc bgerror {args} {#{bgerror} $args}")
		
        set_dir = Tk.install_cmd(proc{
                |*args|
                filename=(args[0]).delete('{}')
                begin



>
|
<
<
<
|
|











>
>
>





>



|
>




<
<





>
>

















>
|
<
|
>







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
# coding: utf-8
#Stringscan: grep-like tool, written in Ruby-Tk. (c) 2019 Kevin Walzer/WordTech Communications LLC. License: MIT license.
#encoding: UTF-8

require 'rbconfig'



host_os = RbConfig::CONFIG['host_os']
case host_os
when /mswin|windows/i
  if ENV["OCRA_EXECUTABLE"] != ""
    begin
    FileUtils.cp_r(File.dirname(__FILE__) + '/lib/tcl8.6/.', File.dirname(File.dirname(File.dirname(__FILE__))) + '/lib/tcl8.6', remove_destination: true)
    FileUtils.cp_r(File.dirname(__FILE__) + '/lib/tcl8/.', File.dirname(File.dirname(File.dirname(__FILE__))) + '/lib/tcl8', remove_destination: true)
    FileUtils.cp_r(File.dirname(__FILE__) + '/lib/tk8.6/.', File.dirname(File.dirname(File.dirname(__FILE__))) + '/lib/tk8.6', remove_destination: true)
rescue
    raise
    end
  end
end
require 'tk'
#find additional Tcl libraries
Tk::AUTO_PATH.list <<= File.dirname(__FILE__)
require_relative 'tkballoonhelp'  
require 'tkextlib/tile'
require 'find'
require 'tkextlib/tkDND'
require 'fileutils'
require 'tempfile'

$platform = Tk.windowingsystem
if $platform == 'aqua'
  require 'tk/tk_mac'
  TkPackage.require('darkaqua')
end
if $platform == 'win32'
	require 'tk/winpkg'
	Tk::WinDDE.servername('Stringscan')


end
TkPackage.require('regproc')
TkPackage.require('machelp')
TkPackage.require('softwareupdate')
TkPackage.require('xplat')
TkPackage.require('notifywindow')

if $platform == 'aqua'
    $accelkey = 'Command'
else 
    $accelkey = 'Control'
end
class StringscanApp
    #here we initialize our app class
    def initialize
        $dirname = ""
        $searchterm = ""
        $appname = 'Stringscan'
        $appversion = '2.0'
        Tk.tk_call('machelp::setAppName', $appname, $appversion)
        Tk.tk_call('softwareupdate::setAppName', $appname)
        Tk.tk_call('softwareupdate::setVersion', $appname, $appversion)
        bgerror = Tk.install_cmd(proc{
            |*args|
            tmp = Tempfile.new('Stringscan_err')
            tmp << args

            tmp.flush
            tmp.close
        })
        Tk.ip_eval("proc bgerror {args} {#{bgerror} $args}")
		
        set_dir = Tk.install_cmd(proc{
                |*args|
                filename=(args[0]).delete('{}')
                begin
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
				
        if $platform == 'aqua'
		  Tk.ip_eval("proc ::tk::mac::OpenDocument {args} {#{set_dir} $args}")
		end
		Tk.ip_eval("proc set_search_term {args} {#{set_search_term} $args}")
		Tk.ip_eval("proc set_search_dir {args} {#{set_dir} $args}")
        Tk.ip_eval("proc execute_search {}  {#{execute_search}}")
        install = getInstall
        Tk.tk_call('softwareupdate::setInstall', install)
      
        drawgui
		if $platform == 'aqua' 
			Tk.tk_call('darkaqua::checkDarkMode')
		end  
	end
    #core method; here we search for a string in text files within a directory and  display a list of matching files in the listbox 
    def stringgrep
        $root.update
        $file_list = []
        $grep_list = []







        $bottomlabel.configure('text' => "Searching for \"#{$searchterm}\" in #{$dirname}...")
        $lbox.delete(0, 'end')
        $tbox.configure('state'=>'normal')
        $tbox.delete('1.0', 'end')
        $tbox.configure('state'=>'disabled')
        $root.update
        Find.find("#{$dirname}") do |path|







<
<











>
>
>
>
>
>
>







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
				
        if $platform == 'aqua'
		  Tk.ip_eval("proc ::tk::mac::OpenDocument {args} {#{set_dir} $args}")
		end
		Tk.ip_eval("proc set_search_term {args} {#{set_search_term} $args}")
		Tk.ip_eval("proc set_search_dir {args} {#{set_dir} $args}")
        Tk.ip_eval("proc execute_search {}  {#{execute_search}}")


      
        drawgui
		if $platform == 'aqua' 
			Tk.tk_call('darkaqua::checkDarkMode')
		end  
	end
    #core method; here we search for a string in text files within a directory and  display a list of matching files in the listbox 
    def stringgrep
        $root.update
        $file_list = []
        $grep_list = []
        if $termentry.get == ""
          return
        end
        if $direntry.get == ""
            return
         end
         
        $bottomlabel.configure('text' => "Searching for \"#{$searchterm}\" in #{$dirname}...")
        $lbox.delete(0, 'end')
        $tbox.configure('state'=>'normal')
        $tbox.delete('1.0', 'end')
        $tbox.configure('state'=>'disabled')
        $root.update
        Find.find("#{$dirname}") do |path|
132
133
134
135
136
137
138

139
140
141
142
143
144
145
                    end
            	end
            end
        end
        $grep_list = $lbox.get(0, 'end')
        num = $grep_list.count.to_s
        $bottomlabel.configure('text' => "Found #{num} matches for \"#{$searchterm}\" in #{$dirname}")

    rescue
      bgerror "Unable to locate any file matching the search term."		
    end
def drawgui 
    begin
        Tk.ip_eval("console hide")
    rescue







>







141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
                    end
            	end
            end
        end
        $grep_list = $lbox.get(0, 'end')
        num = $grep_list.count.to_s
        $bottomlabel.configure('text' => "Found #{num} matches for \"#{$searchterm}\" in #{$dirname}")
         Tk.tk_call('notifywindow::notifywindow', "Found #{num} matches for \"#{$searchterm}\" in #{$dirname}", $notifyicon)
    rescue
      bgerror "Unable to locate any file matching the search term."		
    end
def drawgui 
    begin
        Tk.ip_eval("console hide")
    rescue
175
176
177
178
179
180
181
182


183

184
185
186
187
188
189
190
	  0x00, 0x00, 0xF0, 0x1F, 0x00, 0x00, 0xE0, 0x3F, 0x00, 0x00, 0xC0, 0x3F,
	  0x00, 0x00, 0x80, 0x1F, 0x00, 0x00, 0x00, 0x0F, 0x00, 0x00, 0x00, 0x06,
	  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, };
	'
    $folderimage = TkBitmapImage.new(:data => $folderdata)
    $glassimage = TkBitmapImage.new(:data => $glassdata)
    $winicondata = 'R0lGODlhQABAAOf/AAABZAUCbwoIfAwPiBERkgkWnAQefYcAABIZnyEVoJIAC4UBPhscq2MLbBQesx4imiEhoSIhqDkcl54KABIxZC8ktS0nsSsqqh40dScsszAtpZsaAC0wmgBAlTQ4OjQykDg5NzE0tKgbNjc1vTg3pDk9v5knazpAqZswCEJIT0BExSRPrwJa0rYxQnM/noo6h0lMukxKx1BSX544f1ZTV1NVUgBj4ylZyMc2L0pQy789AGlLrw9j6jxayllbWFZUyzhd1EZaxTFhwVVWxjBg21BZxSdl1FxXwhto6VNZzjtj1H1TtlxczVVfzc5HSB1y7CRx4z1syK5SZmJh0jpt27laIGttan9iozJ26sRdJtxZAm1yfWBz21V50TWB81B72Eh+43d5dml6oc5lJ3V6fF59snV8hFOC5laE21aD7tRvEmiB0MtwP4CCf3+Ehm6Io8dyafhtAHyHl55+lliN8X2E1oSIkOt1ComLiIKIzpKIoPx3AIOOumuS8oyRk4qRq4WQ22aY9JGUkHqV3pKTn4eUyH2W1n2U8biMhP+CAHma75OatZmbmM2UPo6gsJ6gnf+OF5GnvpSk85ql2H+s+v+YIKWprKeppo+q9Iis/5mtv96jP6irvIyz5ayuq42y8f+jJ4u4/7K0sZ+44rG2uLC3v62146K3+f+sLai6x7W4yqu+1o7E/JzB/7u+u6TC5f+3M63A/77B1LTE1qjI/sPEzpvN//3APMPIysXIxLnH/bTL5OTDlqTR/8HN2svOyr7O/KvU/P/KP7PT/f7LYK7X/7vT/9zRpLXW+cPU5LXX9M/T1vTUU8LX/f7VRrfd/9XY1NPY4cvY/9TY79Ha+cDg9sfe9s3d7djc37/i/87e/P/fTcrh+v3gTcji/8Xk++Pfyt3g3Mrk//nflcjn/tHl+Nzj7PzlbNDn/9zm9eHm6Njq9+Pn/tfr/v/tVuLp8v3vX97t9Nru/+rs/eTu/N/x/ejw+O7z9vH08O71/vP4+/X49Pn7+Pj9//3//P///yH+EUNyZWF0ZWQgd2l0aCBHSU1QACH5BAEKAP8ALAAAAABAAEAAAAj+AP8JHEiwoMGDCBMqXMiwocOHECNKnEixosWLGDNq3Mixo0eCUJ6IHPmRIhRFmGIBk0aN3byX89hJi9XHiJE+p3QBA6Yr1ilFfZDY8AgAgAEjzfwpXcq0qapaTaPOo6ZLEpaMATTEUBIqX1N+YMMy/fUrqlmlxjKluUhgyhQqtPLx20d3X1iwdPHh4/crl96/gPHZXdqOHKUiRz4AkAhAg1sqw+TWnZyXLj9/uX7NDWwX79/Ch6f8CMA4hFsow/opBauPsr5+/fjpy3wX79x9gPnVIxcqiGgBjFW4xZJNn/HXsJP3M37vnj5cuJofv4ePevXOusm18p2EQPApTbD+WFvevLx58/1wLSuvDpt76cn33dvdqscUJt4jCsgBns545uedp889rqhnCRl4CMIIHmG4QQo25tEHhFv5QbQfeIGUMyByA5oH4D2WWPFILtCUaOIvorThBzav5UMOLRNOgcBiEA3wwxRFBHLNgPbYc489+QSZT489muPHIybKMgkgdeRRCCeuoGgFKT9+M0yMF9D4EAFJTBEEJRoSKeaY5rjhCjTYmHLIKcZoow01wEjCBR+i5IKHH+9UMwwRboWgpUMIuNUDJekIOaaYZf4SzjSK0OINOu20U8+k9bRzCheEuCKIHdbs2eefDAEQ6BRKfJLOoUIOaY8buSxKSTH+z3jzKKSRRooOMmnI4UobjiBjg1slgLoQABe4Veo7Pb4Tz7LLvqNsKZe4Ggyssc6KzrXoeJPNMGfYIYoPq/w6hQrCKgSAaW918g6l9dCzzjrpvLsOGdCoQ4ktvUz7zDPZZCPrv9nsO0wXjzCyhbgqkPYQACU8Nso767ArcSmihAMMK/jmS+2+/Qa8bzHFUCLGtyy4FQNwCws3BRSj2CPvy/K68Ys6odhicy8ab7zvMyAH04staCzYQRNT5ICyQwHEMFzLML98TRvQpIOvzTfnDHLPOP9MiRmPUED0DwNYyF94q+Qjz9lN+4JkMyD/THXWcGdNdShiXOLB1xU2ZCP+eF6sYk875ZRTazvytJOKJ+EME3AxOFPt+OOOl3FJDUdM0R1EXOJ4xiz2BO7556lUrPjiPkMOeb69lPFIDUXcN+OWTOBIxyyVfg56tMOQ843Hxfjc+Ns46xuM6jX4JmO5B4nqVhCB+LKO55F+Pgsj0MxKTr8f9x7M9tuDzHEvYjACgvEMIG8QABEIqogv5aBTDjfwc4NtMm3kkk4215Jzvcc7989vNt+gxRYEgQH7TMEC5ivIuYyliGigI37ws4Y1ImgGV2DjGe3IHzp017EOAlB/5OhEG9qwAgP6ySELnIIRBhENclzrGzDkRjWqIUFNXOIX1qBVBje4QRDqj4f+6HjGGwRRgzXEaAQJJAgAVEYFQ1xDhjOEoRRhWA0yWPAZhRsctrZ4rQyKEA8yGESMgoU0JhrCHDNMYxolOENHPMIV1/DG2QZHx8EFwwxE/IMhbuCWhDlEAEpbWSHSobtv0NAaNJwhIqthhku4IhnoqMfZ5kjHwiFDDoIIgxkWUQg+jetoCxkAf6aABT6koxpSLOQUYbgLMlxCFL7ghjzYNcmzoeMVmGzDFszBSU+ezCEEuFF4/kAPNRrTmK18hCce+Q1JUSqDyoiEGxghiBRcg5eFEFcO8qaQzDXBC3+ohyGNiUg2pnEXZsDDJS5hiVTMYhe7WEUqHJEgRiDOCpr+4CUftMlNhChPc5wQpw91WKsNjnMLYcADIxZKTUEoCA9WaIMnoPELODhhDn/ggVt+UICGAIABbinCGTjxDnNE46S1qIUsVMGJlj6lFtEwBz3MYA5CbMEKYchpGKxAgy2QggZvDAc4xoEDPdiAaEl43bAysDwvnOGpYIjqU5/6hapatapdEEIXtrrVKHi1C2sI6xUQ4YlfgOMcm5ACD4jGhAQk8R8pLEIQetCDINj1rnetK17zOle6+rUHNwjsC3hxjGOcoxvwGMMOiDaF8oUKXW6JrGQnG9khDAEGJ+AAB2BgWcq6ZQlsIMYtYCEMdzCjBZWbggPeKirOMoEJlr3rLAwwewISaJYEDyCABiAAgQtkwAEWyMAFIJBb25LgBLMdggm0sIdKwMIZ7tjEDO6z2oYIIAK85S0ChhuBDFjAAd5lAAMSgAAEEIAAAxBAUQIggAEQoLzdtYAFsCsBEcQhEaC4xTbgkQUXaKC6oQqAe8+LXgEYuCgIRnCoEmzgATRAB3uABCpKywwRVIAAby1JQhSghUQ4F7qbWECGNZyQCdw3v/utAokvAmEJU3gCK67IBDr8YXc0IsYV2cAe8HuLbmwCxxVpMSpugQIgU+QAWriDGops5CMf4ABNjrKUp0zlKlv5yljOMkMCAgA7'
	


    $winicon = TkPhotoImage.new(:data => $winicondata)

    #initialize variables for entry
    $dirname = TkVariable.new
    $searchterm = TkVariable.new
    #top window and frame
    Tk::TkDND::DND
    $root = TkRoot.new {
        title "Stringscan"







|
>
>

>







185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
	  0x00, 0x00, 0xF0, 0x1F, 0x00, 0x00, 0xE0, 0x3F, 0x00, 0x00, 0xC0, 0x3F,
	  0x00, 0x00, 0x80, 0x1F, 0x00, 0x00, 0x00, 0x0F, 0x00, 0x00, 0x00, 0x06,
	  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, };
	'
    $folderimage = TkBitmapImage.new(:data => $folderdata)
    $glassimage = TkBitmapImage.new(:data => $glassdata)
    $winicondata = 'R0lGODlhQABAAOf/AAABZAUCbwoIfAwPiBERkgkWnAQefYcAABIZnyEVoJIAC4UBPhscq2MLbBQesx4imiEhoSIhqDkcl54KABIxZC8ktS0nsSsqqh40dScsszAtpZsaAC0wmgBAlTQ4OjQykDg5NzE0tKgbNjc1vTg3pDk9v5knazpAqZswCEJIT0BExSRPrwJa0rYxQnM/noo6h0lMukxKx1BSX544f1ZTV1NVUgBj4ylZyMc2L0pQy789AGlLrw9j6jxayllbWFZUyzhd1EZaxTFhwVVWxjBg21BZxSdl1FxXwhto6VNZzjtj1H1TtlxczVVfzc5HSB1y7CRx4z1syK5SZmJh0jpt27laIGttan9iozJ26sRdJtxZAm1yfWBz21V50TWB81B72Eh+43d5dml6oc5lJ3V6fF59snV8hFOC5laE21aD7tRvEmiB0MtwP4CCf3+Ehm6Io8dyafhtAHyHl55+lliN8X2E1oSIkOt1ComLiIKIzpKIoPx3AIOOumuS8oyRk4qRq4WQ22aY9JGUkHqV3pKTn4eUyH2W1n2U8biMhP+CAHma75OatZmbmM2UPo6gsJ6gnf+OF5GnvpSk85ql2H+s+v+YIKWprKeppo+q9Iis/5mtv96jP6irvIyz5ayuq42y8f+jJ4u4/7K0sZ+44rG2uLC3v62146K3+f+sLai6x7W4yqu+1o7E/JzB/7u+u6TC5f+3M63A/77B1LTE1qjI/sPEzpvN//3APMPIysXIxLnH/bTL5OTDlqTR/8HN2svOyr7O/KvU/P/KP7PT/f7LYK7X/7vT/9zRpLXW+cPU5LXX9M/T1vTUU8LX/f7VRrfd/9XY1NPY4cvY/9TY79Ha+cDg9sfe9s3d7djc37/i/87e/P/fTcrh+v3gTcji/8Xk++Pfyt3g3Mrk//nflcjn/tHl+Nzj7PzlbNDn/9zm9eHm6Njq9+Pn/tfr/v/tVuLp8v3vX97t9Nru/+rs/eTu/N/x/ejw+O7z9vH08O71/vP4+/X49Pn7+Pj9//3//P///yH+EUNyZWF0ZWQgd2l0aCBHSU1QACH5BAEKAP8ALAAAAABAAEAAAAj+AP8JHEiwoMGDCBMqXMiwocOHECNKnEixosWLGDNq3Mixo0eCUJ6IHPmRIhRFmGIBk0aN3byX89hJi9XHiJE+p3QBA6Yr1ilFfZDY8AgAgAEjzfwpXcq0qapaTaPOo6ZLEpaMATTEUBIqX1N+YMMy/fUrqlmlxjKluUhgyhQqtPLx20d3X1iwdPHh4/crl96/gPHZXdqOHKUiRz4AkAhAg1sqw+TWnZyXLj9/uX7NDWwX79/Ch6f8CMA4hFsow/opBauPsr5+/fjpy3wX79x9gPnVIxcqiGgBjFW4xZJNn/HXsJP3M37vnj5cuJofv4ePevXOusm18p2EQPApTbD+WFvevLx58/1wLSuvDpt76cn33dvdqscUJt4jCsgBns545uedp889rqhnCRl4CMIIHmG4QQo25tEHhFv5QbQfeIGUMyByA5oH4D2WWPFILtCUaOIvorThBzav5UMOLRNOgcBiEA3wwxRFBHLNgPbYc489+QSZT489muPHIybKMgkgdeRRCCeuoGgFKT9+M0yMF9D4EAFJTBEEJRoSKeaY5rjhCjTYmHLIKcZoow01wEjCBR+i5IKHH+9UMwwRboWgpUMIuNUDJekIOaaYZf4SzjSK0OINOu20U8+k9bRzCheEuCKIHdbs2eefDAEQ6BRKfJLOoUIOaY8buSxKSTH+z3jzKKSRRooOMmnI4UobjiBjg1slgLoQABe4Veo7Pb4Tz7LLvqNsKZe4Ggyssc6KzrXoeJPNMGfYIYoPq/w6hQrCKgSAaW918g6l9dCzzjrpvLsOGdCoQ4ktvUz7zDPZZCPrv9nsO0wXjzCyhbgqkPYQACU8Nso767ArcSmihAMMK/jmS+2+/Qa8bzHFUCLGtyy4FQNwCws3BRSj2CPvy/K68Ys6odhicy8ab7zvMyAH04staCzYQRNT5ICyQwHEMFzLML98TRvQpIOvzTfnDHLPOP9MiRmPUED0DwNYyF94q+Qjz9lN+4JkMyD/THXWcGdNdShiXOLB1xU2ZCP+eF6sYk875ZRTazvytJOKJ+EME3AxOFPt+OOOl3FJDUdM0R1EXOJ4xiz2BO7556lUrPjiPkMOeb69lPFIDUXcN+OWTOBIxyyVfg56tMOQ843Hxfjc+Ns46xuM6jX4JmO5B4nqVhCB+LKO55F+Pgsj0MxKTr8f9x7M9tuDzHEvYjACgvEMIG8QABEIqogv5aBTDjfwc4NtMm3kkk4215Jzvcc7989vNt+gxRYEgQH7TMEC5ivIuYyliGigI37ws4Y1ImgGV2DjGe3IHzp017EOAlB/5OhEG9qwAgP6ySELnIIRBhENclzrGzDkRjWqIUFNXOIX1qBVBje4QRDqj4f+6HjGGwRRgzXEaAQJJAgAVEYFQ1xDhjOEoRRhWA0yWPAZhRsctrZ4rQyKEA8yGESMgoU0JhrCHDNMYxolOENHPMIV1/DG2QZHx8EFwwxE/IMhbuCWhDlEAEpbWSHSobtv0NAaNJwhIqthhku4IhnoqMfZ5kjHwiFDDoIIgxkWUQg+jetoCxkAf6aABT6koxpSLOQUYbgLMlxCFL7ghjzYNcmzoeMVmGzDFszBSU+ezCEEuFF4/kAPNRrTmK18hCce+Q1JUSqDyoiEGxghiBRcg5eFEFcO8qaQzDXBC3+ohyGNiUg2pnEXZsDDJS5hiVTMYhe7WEUqHJEgRiDOCpr+4CUftMlNhChPc5wQpw91WKsNjnMLYcADIxZKTUEoCA9WaIMnoPELODhhDn/ggVt+UICGAIABbinCGTjxDnNE46S1qIUsVMGJlj6lFtEwBz3MYA5CbMEKYchpGKxAgy2QggZvDAc4xoEDPdiAaEl43bAysDwvnOGpYIjqU5/6hapatapdEEIXtrrVKHi1C2sI6xUQ4YlfgOMcm5ACD4jGhAQk8R8pLEIQetCDINj1rnetK17zOle6+rUHNwjsC3hxjGOcoxvwGMMOiDaF8oUKXW6JrGQnG9khDAEGJ+AAB2BgWcq6ZQlsIMYtYCEMdzCjBZWbggPeKirOMoEJlr3rLAwwewISaJYEDyCABiAAgQtkwAEWyMAFIJBb25LgBLMdggm0sIdKwMIZ7tjEDO6z2oYIIAK85S0ChhuBDFjAAd5lAAMSgAAEEIAAAxBAUQIggAEQoLzdtYAFsCsBEcQhEaC4xTbgkQUXaKC6oQqAe8+LXgEYuCgIRnCoEmzgATRAB3uABCpKywwRVIAAby1JQhSghUQ4F7qbWECGNZyQCdw3v/utAokvAmEJU3gCK67IBDr8YXc0IsYV2cAe8HuLbmwCxxVpMSpugQIgU+QAWriDGops5CMf4ABNjrKUp0zlKlv5yljOMkMCAgA7'

    $notifydata = 'R0lGODlhIAAgAOf/AAMAYQADagoAawMFdgALgBAHggEOjBgIjQYYLToHVAkPlmgAHhoaFg8ToYQBABYTmhYVk5QAAiIWfx0hIx8VpaMAAREbpCcXsRodsgAvZxwinR8hrAMwb80AAyYhv8AHAisvMTAwLCclux8qvCwptmgjVTc2MZUZQa4cBLMbADIxqloriNEaCDU2w8EhA8AhHzRAkkRGQ7IpMD0/tTg/yg5RpABWw0dDyQFZzk5RVklKzVJUURFa1gZc4wBe4VNUUklMwSdYyCdZwsQ+BUpPzXlImzhYxGlRfUJYvldSzABp7zNc3CZi0RZm2+FAAl5eXEdayDVf0V1gY1NY0FpXyh5o5VVbzBJt4kxg0d1MA2Jd0WZnZGRoasxSE11i1D1wumViz2FtglVvlWhl0m5uayJ47bJdVEpw1mtxdUVy7Dt41Ed50D584Hd2dNFjKUx7ykF77Vl30S6C9HJ8hplxhn5+e+lqDlGA+HuAg3CAqkKI8lKH2EeJ7dF1LXOFvIKGiftxAH6Jmf1zAoeJhuJ3MoiMlYOPtI6QjY+Ppf9+DmCX93uUxoOTvnWV1I+Ulk6d/1ya9I2Tr26Z4v6GEpaYlZmYrJOdplen//+OGXig/J2fm2yk/oCm1Jijvf+YH52puaeppqqnuHuv/uqceXay/qqrr4iy2v6jJa6vq4uz75iw8rKvwIO3/pa16Zy43LS2s6O41P+vLbO4u7G5wre4wrS6zau+z5bA/43D/7u9uv+3M5zI/aXH/rDI2pjM//7CO8bEz8DF18XHxKzJ+8XKzKrP8qLR/6nP//nLUtbOoP7MQM7Oy7XT7azV/sHR8q/Y/77W6P/URs3T5tHW37jc/9XY1NTZ3MrZ+8Le9v/eTMre793ex8Lh/+Hc293e28bi+tDg9Nzh5Mzk9tni6vvhlsrm/v7pVOfj1P3pZ83p/9vn9dXp9tLq/drp/uLr9Nzs/9bu/9zw/enu8eTw/v75X+7w7efx+e3z9fP18u32//P4+/f59vr7+Pf9//7//P///yH+EUNyZWF0ZWQgd2l0aCBHSU1QACH5BAEKAP8ALAAAAAAgACAAAAj+AP8JHEiwoMGDCBMqXMiwoUOBVSI+TBhAkrNr7+zls8fOlKtr7K45czYMUkMVUbjxW8mSX7Vq/PbJ5OfPXzM2MxICAIKF3cp9+PDt47esmsyhQPGx4zNlAEIARLDE00e16j1i1vTJk3cP30p2krwUQDhgCht7VdMS04Tq1StQoLK2kwRm7MECWva4s8d3o7xppaa1GsypE9y5YhEW8CLJ3cZ8kKflYrarHLt48bg1AoWIExgNCCGAaczXnWlQ2nY948atnGtqjQ7F+YxQw2h379xhrlXtli9jz6ixpvZsFyIYXlQgVMF4Xrx169SV0mbM1+9jz54dM2asER4vOQ/+zrDCKR678+xAOeP2rPpv98Y41bES3uAMLK3aoWdnCVo5bsQ1c8wxzQRnSh1YAAGAQTth4Yo4EIrzzSfTlJOOa6xlWA4jXCS4YEENwvLNiCMyA8o38JyXzorpsIPNH2JgQcSHBJV1Ri/fYKOjjpYII0488AQZZDqRkMGIjE4VVMAUZwSDDYkjYuOILNDAE49z0FhSRzBHTmEXQQR4wUYwJIrjWo6WOALKLJ9YgocmwnCGxRQHGLSYGq7kyckifHLiCiOciCGoGHm0QQw5ZmCRWEEQeIHFo5BaYQUUUKgwAxJQTAqFGeREg0wRXtRZEAEzlKoCCSRs8MADCkDwAARGChzwwAYkrJDFKdkQAgQEBw1QQAEDDBAAAMQyCIAAA5yQiC7ZnJDkRAkNgYkyyEDLkB24umGtQhHYQci2CzkA7rjklvtQQAA7'
	
    $winicon = TkPhotoImage.new(:data => $winicondata)
    $notifyicon = TkPhotoImage.new(:data => $notifydata)
    #initialize variables for entry
    $dirname = TkVariable.new
    $searchterm = TkVariable.new
    #top window and frame
    Tk::TkDND::DND
    $root = TkRoot.new {
        title "Stringscan"
232
233
234
235
236
237
238

239
240
241
242
243
244
245
246

247
248
249
250
251
252
253
    #button frame and buttons
    $buttonframe = Tk::Tile::Frame.new($mainframe){padding 2}.pack('side' => 'top','fill' => 'both','expand' => 'no')
    choosedirproc = proc{choosedir}
    $choosebutton = Tk::Tile::Button.new($buttonframe) {
        image $folderimage
        takefocus 0
        padding 5

        command  choosedirproc
    }.pack('side' => 'left','fill' => 'both','expand' => 'no')
    Tk::RbWidget::BalloonHelp.new($choosebutton, 'text'=>'Select Directory', 'background'=>'lightyellow', 'relief'=>'solid', 'borderwidth'=>1)
    stringgrepProc = proc {stringgrep}
    $runbutton = Tk::Tile::Button.new($buttonframe) {
        image $glassimage
        takefocus 0
        padding 5

        command stringgrepProc
    }.pack('side' => 'left','fill' => 'both','expand' => 'no')
    Tk::RbWidget::BalloonHelp.new($runbutton, 'text'=>'Run Search', 'background'=>'lightyellow', 'relief'=>'solid', 'borderwidth'=>1)
    $sep = Tk::Tile::Separator.new($mainframe) { orient 'horizontal' }.pack('side'=> 'top', 'fill'=>'both')
    #labels and entries
    $topframe = Tk::Tile::Frame.new($mainframe){padding 5}.pack('side' => 'top','fill' => 'both','expand' => 'no')
    $chooselabel = Tk::Tile::Label.new($topframe) {text "Directory:"}.pack('side' => 'left','fill' => 'both','expand' => 'no')







>








>







245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
    #button frame and buttons
    $buttonframe = Tk::Tile::Frame.new($mainframe){padding 2}.pack('side' => 'top','fill' => 'both','expand' => 'no')
    choosedirproc = proc{choosedir}
    $choosebutton = Tk::Tile::Button.new($buttonframe) {
        image $folderimage
        takefocus 0
        padding 5
        style 'Toolbutton'
        command  choosedirproc
    }.pack('side' => 'left','fill' => 'both','expand' => 'no')
    Tk::RbWidget::BalloonHelp.new($choosebutton, 'text'=>'Select Directory', 'background'=>'lightyellow', 'relief'=>'solid', 'borderwidth'=>1)
    stringgrepProc = proc {stringgrep}
    $runbutton = Tk::Tile::Button.new($buttonframe) {
        image $glassimage
        takefocus 0
        padding 5
        style 'Toolbutton'
        command stringgrepProc
    }.pack('side' => 'left','fill' => 'both','expand' => 'no')
    Tk::RbWidget::BalloonHelp.new($runbutton, 'text'=>'Run Search', 'background'=>'lightyellow', 'relief'=>'solid', 'borderwidth'=>1)
    $sep = Tk::Tile::Separator.new($mainframe) { orient 'horizontal' }.pack('side'=> 'top', 'fill'=>'both')
    #labels and entries
    $topframe = Tk::Tile::Frame.new($mainframe){padding 5}.pack('side' => 'top','fill' => 'both','expand' => 'no')
    $chooselabel = Tk::Tile::Label.new($topframe) {text "Directory:"}.pack('side' => 'left','fill' => 'both','expand' => 'no')
312
313
314
315
316
317
318













319
320
321
322
323
324
325
    $tscroll = Tk::Tile::Scrollbar.new($tscrollframe).pack('side'=>'right','fill' => 'y', 'expand' => 'no')
    $tbox.yscrollbar($tscroll)   
    $bottomframe.add($bottomleftframe)
    $bottomframe.add($bottomrightframe)   
    $labelframe = Tk::Tile::Frame.new($root).pack('side'=>'bottom', 'fill'=>'both', 'expand' => 'no')
    $bottomlabel = Tk::Tile::Label.new($labelframe) {text "No data displayed"}.pack('side' => 'left','fill' => 'both','expand' => 'no')
    $bottomsep = Tk::Tile::Separator.new($root) { orient 'horizontal' }.pack('side'=> 'bottom', 'fill'=>'both')













    $root.bind("#{$accelkey}-Q", proc{Tk.tk_call('regproc::makePitch; exit')})
    $root.bind("#{$accelkey}-q", proc{Tk.tk_call('regproc::makePitch; exit')})
    $root.bind("#{$accelkey}-O", proc{choosedir})
    $root.bind("#{$accelkey}-o", proc{choosedir})
    $root.bind("#{$accelkey}-R", proc{stringgrep})
    $root.bind("#{$accelkey}-r", proc{stringgrep})
    $root.update







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







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
    $tscroll = Tk::Tile::Scrollbar.new($tscrollframe).pack('side'=>'right','fill' => 'y', 'expand' => 'no')
    $tbox.yscrollbar($tscroll)   
    $bottomframe.add($bottomleftframe)
    $bottomframe.add($bottomrightframe)   
    $labelframe = Tk::Tile::Frame.new($root).pack('side'=>'bottom', 'fill'=>'both', 'expand' => 'no')
    $bottomlabel = Tk::Tile::Label.new($labelframe) {text "No data displayed"}.pack('side' => 'left','fill' => 'both','expand' => 'no')
    $bottomsep = Tk::Tile::Separator.new($root) { orient 'horizontal' }.pack('side'=> 'bottom', 'fill'=>'both')

    if $platform == 'win32'
            $root.protocol(:WM_DELETE_WINDOW){
      proc{Tk.tk_call('regproc::makePitch; exit')}
      }
    end
      if $platform == 'aqua'
            $root.protocol(:WM_DELETE_WINDOW){
          $root['state'] = 'withdrawn'
        }
        $root.bind("#{$accelkey}-W", $root['state'] = 'withdrawn')
        $root.bind("#{$accelkey}-w", $root['state'] = 'withdrawn')
    end
    $root.bind("#{$accelkey}-Q", proc{Tk.tk_call('regproc::makePitch; exit')})
    $root.bind("#{$accelkey}-q", proc{Tk.tk_call('regproc::makePitch; exit')})
    $root.bind("#{$accelkey}-O", proc{choosedir})
    $root.bind("#{$accelkey}-o", proc{choosedir})
    $root.bind("#{$accelkey}-R", proc{stringgrep})
    $root.bind("#{$accelkey}-r", proc{stringgrep})
    $root.update
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
    $tbox.configure('state'=>'disabled')
end
#about window for app
def aboutWindow
    Tk::messageBox :type => 'ok',
    :message => 'Stringscan: Text Search Tool',
    :icon => 'info', :title => 'About Stringscan',
    :detail  => "Version 1.2\n(c) 2018 WordTech Communications LLC",
    :parent => $root
end
#check version of installed software
def checkUpdate 
    Tk.tk_call('softwareupdate::setIcon', $winicon)
    Tk.tk_call('softwareupdate::checkVersion', $appname, $appversion)
end







|







390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
    $tbox.configure('state'=>'disabled')
end
#about window for app
def aboutWindow
    Tk::messageBox :type => 'ok',
    :message => 'Stringscan: Text Search Tool',
    :icon => 'info', :title => 'About Stringscan',
    :detail  => "Version 2.0\n(c) 2020 WordTech Communications LLC",
    :parent => $root
end
#check version of installed software
def checkUpdate 
    Tk.tk_call('softwareupdate::setIcon', $winicon)
    Tk.tk_call('softwareupdate::checkVersion', $appname, $appversion)
end