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
..
78
79
80
81
82
83
84
85
86
87
88
89
90
91






92
93
94
95
96
97
98
...
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
<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>
................................................................................
	<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
................................................................................

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."










|






<
<

|









|







 







|






>
>
>
>
>
>







 







|

|



|

|

|




|






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
..
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
...
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
<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>
................................................................................
	<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
................................................................................

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 tegnflgen skal best af to tegn}

    ::msgcat::mcset da {Delete} {Slet}

    ::msgcat::mcset da {Help...} {Hjlp...}

    ::msgcat::mcset da HELPTEXT {

	Kevin's Hacky Input Method (KHIM)

	KHIM gr det muligt at indtaste internationale tegn med et tastatur
	som ikke understtter disse. Dette fungerer uafhngigt af en
	bestende indtast metode som styresystemet mtte understtte.
	Det er tnkt til at hjlpe, 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 gres, afhnger af
	dit program) og aktiver KHIM ved at afkrydse "Benyt KHIM". Du skal vlge
	en taste	der kun sjldent benyttes p dit tastatur og fastlgge denne som
	"Compose" taste for at stte tegn sammen med. Tryk dertil p knappen
	markeret med "Compose taste:" og tryk derefter p den taste du nsker at
	fastlgge. Generellt skulle det ikke vre den taste som normalt benyttes
	til at konstruere tegn med; denne taste vil fortsat oprbe din lokale
	systems indtast metode.

	Nr 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 tegnflger der str til rdighed. Hvis
	du trykker "Compose" tasten to gange kommer der et vindue frem hvor
	du kan vlge vilkrlige symboler fra en unicode tabel. Du kan navigere
	rundt i selve tabellen ved enten at benytte markren eller markrtasterne.
	Du kan udvlge det markerede tegn ved at doppelt-klikke p symbolet eller
	ved at trykke p mellemrums-, enter- eller returtasten.

	Ny tegnflger kan defineres ved at indtaste en flge af to tegn i feltet
	markeret med "Indtast tegnflge" og det nskede symbol i feltet markeret
	med "Tegn" og derefter trykke p "ndre". Du kan ogs kopiere og indstte
	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 tegnflge.

    }

    ::msgcat::mcset da {Input key sequence} {Indtast tegnflge}

    ::msgcat::mcset da {Insert Character} {Indtast et tegn}

    ::msgcat::mcset da {Invalid sequence} {Ugyldig tegnflge}

    ::msgcat::mcset da {Key sequences} {Tegnflger}

    ::msgcat::mcset da {KHIM Controls} {KHIM kontrolpanel}

    ::msgcat::mcset da {OK} {O.k.}

    ::msgcat::mcset da {Select code page:} {Vlg 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)