Stringscan

Check-in [8c0cb38f03]
Login

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

Overview
Comment:Add new tklib
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256:8c0cb38f03ecbad4f99ad5e64a261992fb45f06aff2fe496af6f65c52704e12b
User & Date: kevin 2020-05-09 18:47:28
Context
2020-05-09
18:50
Remove obsolete packages check-in: ee211b714f user: kevin tags: trunk
18:47
Add new tklib check-in: 8c0cb38f03 user: kevin tags: trunk
18:30
Updated Windows files check-in: 8eb6ed45eb user: kevin tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added scriptlibs/tklib0.7/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
}

Added scriptlibs/tklib0.7/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]]

Added scriptlibs/tklib0.7/canvas/canvas_drag.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
## -*- tcl -*-
# ### ### ### ######### ######### #########

# Canvas Behavior Module. Dragging items and groups of items.

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

package require Tcl 8.5
package require Tk

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

namespace eval ::canvas::drag {
    namespace export \
	item group on off
    namespace ensemble create
}

proc ::canvas::drag::item {c tag args} {
    # Set up dragging of single items identified by the <tag>
    on $c $tag [namespace code Item1] {*}$args
    return
}

proc ::canvas::drag::group {c tag cmdprefix args} {
    # Set up dragging a group of items, with each group's drag
    # handle(s) identified by <tag>, and the <cmdprefix> taking the
    # handle item which triggered the drag and returning a tag which
    # identifies the whole group to move.

    on $c $tag [namespace code [list ItemGroup $cmdprefix]] {*}$args
    return
}

proc ::canvas::drag::on {c tag cmdprefix args} {
    # Setting up a general drag, with the drag handles identified by
    # <tag> and <cmdprefix> providing start/move methods invoked to
    # initialize and perform the drag. The cmdprefix is fully
    # responsible for how the dragging of a particular handle is
    # handled.

    variable attached

    # Process options (-event)
    set events [dict get [Options {*}$args] event]

    # Save the (canvas, tag) combination for use by 'off'.
    set k [list $c $tag]
    set attached($k) $events

    # Install the bindings doing the drag
    lassign $events trigger motion untrigger
    $c bind $tag $trigger   [namespace code [list Start $c $cmdprefix %x %y]]
    $c bind $tag $motion    [namespace code [list Move  $c $cmdprefix %x %y]]
    $c bind $tag $untrigger [namespace code [list Done  $c $cmdprefix %x %y]]
    return
}

proc ::canvas::drag::off {c tag} {
    # Remove a drag identified by canvas and tag.

    variable attached

    # Find and remove the bindings for this particular canvas,tag
    # combination.
    set k [list $c $tag]
    foreach event $attached($k) {
	$c bind $tag $event {}
    }

    # Update our database
    unset attached($k)
    return
}

# ### ### ### ######### ######### #########
## Option processing.

proc ::canvas::drag::Options {args} {
    # Button 3 is default for dragging.
    set config [list event [Validate 3]]

    foreach {option value} $args {
	switch -exact -- $option {
	    -event {
		dict set config event [Validate $value]
	    }
	    default {
		return -code error "Unknown option \"$option\", expected -event"
	    }
	}
    }

    return $config
}

# ### ### ### ######### ######### #########
## Event parsing and transformation

proc ::canvas::drag::Validate {event} {
    # Assumes that events are specified in the forms
    # <modifier>-<button> and <button>, where <modifier> is in the set
    # {Control, Shift, Alt, ... } and <button> a number. Returns
    # button-press and related motion event, or throws an error.

    set xevent [split $event -]
    if {[llength $xevent] > 2} {
	return -code error "Bad event \"$event\""
    } elseif {[llength $xevent] == 2} {
	lassign $xevent modifier button

	set trigger   <${event}>
	set motion    <${modifier}-B${button}-Motion>
	set untrigger <${modifier}-ButtonRelease-${button}>

    } else {
	lassign $xevent button
	set modifier {}

	set trigger   <${button}>
	set motion    <B${button}-Motion>
	set untrigger <ButtonRelease-${button}>
    }

    return [list $trigger $motion $untrigger]
}

# ### ### ### ######### ######### #########
## Drag execution.

proc ::canvas::drag::Start {c cmdprefix x y} {
    # Start a drag operation.
    variable attached
    variable active
    variable clientdata
    variable lastx
    variable lasty

    # Clear drag state
    unset -nocomplain active clientdata lastx lasty

    # Get item under mouse, if any.
    set item [$c find withtag current]
    if {$item eq {}} return

    # Initialize the drag state, run the command to initialize
    # anything external to us. We remember the current location to
    # enable the delta calculations in 'Move'.

    set active     $cmdprefix
    set lastx      [$c canvasx $x]
    set lasty      [$c canvasy $y]
    set clientdata [{*}$active start $c $item]
    return
}

proc ::canvas::drag::Move {c cmdprefix x y} {
    # Check for active drag.
    variable active
    if {![info exists active]} return

    # Import remainder of the drag state
    variable clientdata
    variable lastx
    variable lasty

    # Get current location and compute delta.
    set x [$c canvasx $x]
    set y [$c canvasy $y]

    set dx [expr {$x - $lastx}]
    set dy [expr {$y - $lasty}]

    # Let the command process the movement as it sees fit.
    # This may include updated client data.
    set clientdata [{*}$active move $c $clientdata $dx $dy]

    # Save the new location , for the next movement and delta.
    set lastx $x
    set lasty $y
    return
}

proc ::canvas::drag::Done {c cmdprefix x y} {
    # Check for active drag.
    variable active
    if {![info exists active]} return

    # Import remainder of the drag state
    variable clientdata

    # Let the command process the end of the drag operation as it sees
    # fit.
    {*}$active done $c $clientdata
    return
}

# ### ### ### ######### ######### #########
## Convenience. Dragging a single item.

# This is trivial. We remember the item to be dragged, and forward
# move requests directly to the canvas.

namespace eval ::canvas::drag::Item1 {
    namespace export start move done
    namespace ensemble create
}

proc ::canvas::drag::Item1::start {c item} {
    return $item
}

proc ::canvas::drag::Item1::move {c item dx dy} {
    $c move $item $dx $dy
    return $item
}

proc ::canvas::drag::Item1::done {c item} {
    return
}

# ### ### ### ######### ######### #########
## Convenience. Dragging an item group.

# Also mostly trivial. The move requests are still simply forwarded to
# the canvas, using the tag identifying the group. The main point is
# during start, using the external callback to transform the handle
# item into the group tag.

proc ::canvas::drag::ItemGroup {cmd method c args} {
    return [ItemGroup::$method $cmd $c {*}$args]
}

namespace eval ::canvas::drag::ItemGroup {}

proc ::canvas::drag::ItemGroup::start {cmd c item} {
    return [{*}$cmd start $c $item]
}

proc ::canvas::drag::ItemGroup::move {cmd c grouptag dx dy} {
    $c move $grouptag $dx $dy
    return $grouptag
}

proc ::canvas::drag::ItemGroup::done {cmd c grouptag} {
    {*}$cmd done $c $grouptag
    return
}

# ### ### ### ######### ######### #########
## State.

namespace eval ::canvas::drag {
    # Database of canvas,tag combinations with active bindings
    # (allowing their removal, see --> 'off'). Value are the
    # events which have bindings.

    variable  attached
    array set attached {}

    # State of a drag in progress

    variable  active     ; # command prefix to invoke for 'start' / 'move'.
    variable  clientdata ; # Result of invoking 'start', data for 'move'.
    variable  lastx      ; # x coord of last position the drag was at.
    variable  lasty      ; # y coord of last position the drag was at.
}

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

package provide canvas::drag 0.1
return

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

Added scriptlibs/tklib0.7/canvas/canvas_epoints.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
## -*- tcl -*-
# # ## ### ##### ######## ############# #####################

# Canvas Behavior Module. Editing a point cloud.

# - Create    point - B1 (canvas global)
# - Remove    point - B2 (linked to -tag, current item)
# - Drag/Move point - B3 (linked to -tag, current item)
# - Auto-highlight points, to show ability of drag/move.

# Configurable:
# - Tag used to mark/identify the points of this cloud.
#   Default: POINT.
#
# - Callback used to create the item (group) representing the point.
#   Default: Single blue circle of radius 3 with center at point location.
#
# - Callback used to (un)highlight the item (group) of a point.
#   Default: Switch to red color.
#
# - Callback used to record editing activity (add, remove, move point)
#   Default: NONE.

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

package require Tcl 8.5
package require Tk
package require snit
package require canvas::drag
package require canvas::highlight
package require canvas::tag

namespace eval ::canvas::edit {
    namespace export points
    namespace ensemble create
}

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

snit::type ::canvas::edit::points {
    # # ## ### ##### ######## ############# #####################
    ## Life cycle, and configuration

    option -tag           -default POINT -readonly 1 ; # Tag identifying our points
    option -create-cmd    -default {}    -readonly 1 ; # Callback invoked to create new points.
    option -highlight-cmd -default {}    -readonly 1 ; # Callback to highlight a dragged point.
    option -data-cmd      -default {}    -readonly 1 ; # Callback for point edit operations

    constructor {c args} {
	set mycanvas $c
	set options(-create-cmd)    [mymethod DefaultCreate]
	set options(-highlight-cmd) [mymethod DefaultHighlight]

	$self configurelist $args

	# TODO :: Connect this to the option processing to allow me to
	# drop -readonly 1 from their definition. Note that this also
	# requires code to re-tag all the items on the fly.
	$self Bindings Add
	return
    }

    destructor {
	$self Bindings Remove
	return
    }

    # # ## ### ##### ######## ############# #####################
    ## API.

    method disable {} {
	$self Bindings Remove
	return
    }

    method enable {} {
	$self Bindings Add
	return
    }

    method active {} {
	return $myactive
    }

    method add {x y} {
	# Create a point marker programmatically. This enables users
	# to load an editor instance with existing point locations.
	$self Add $mycanvas $x $y
	return
    }

    ###### Destroy an existing point
    method clear {} {
	foreach item [$mycanvas find withtag $options(-tag)] {
	    lappend grouptags [GetId $mycanvas $item]
	}
	foreach grouptag [lsort -unique $grouptags] {
	    $mycanvas delete $grouptag
	    #puts "Remove|$x $y|$grouptag"
	    unset myloc($grouptag)
	    Note remove $grouptag
	}
	return
    }

    # # ## ### ##### ######## ############# #####################
    ## Manage the canvas bindings (point creation and removal,
    ## dragging, highlighting).

    method {Bindings Add} {} {
	if {$myactive} return
	set myactive 1

	canvas::highlight on $mycanvas $options(-tag) [mymethod Highlight]
	canvas::drag      on $mycanvas $options(-tag) [mymethod Drag]

	$mycanvas bind $options(-tag) <2> [mymethod Remove $mycanvas %x %y]
	bind $mycanvas                <1> [mymethod Add    $mycanvas %x %y]

	# NOTES:
	# 1. Is there a way to make 'Add' not canvas global ?
	# 2. If not, is there a way to ensure that 'Add' is not
	# triggered when a 'Remove' is done, even if the events for
	# the 2 actions basically overlap (B1=Add, Shift-B1=Remove,
	# for example) ?
	return
    }

    method {Bindings Remove} {} {
	if {!$myactive} return
	set myactive 0

	canvas::highlight off $mycanvas $options(-tag)
	canvas::drag      off $mycanvas $options(-tag)

	$mycanvas bind $options(-tag) <2> {}
	bind $mycanvas                <1> {}
	return
    }

    # # ## ### ##### ######## ############# #####################
    ## The actions invoked by the bindings managed in the previous
    ## section.

    ###### Place new point
    method Add {c x y} {
	$self CheckCanvas $c
	set grouptag [NewId]
	set items [{*}$options(-create-cmd) $c $x $y]
	# No visual representation of the point, no point. Vetoed.
	if {![llength $items]} return

	Tag $c $items $grouptag
	set myloc($grouptag) [list $x $y]
	#puts "Add|$x $y|$items"
	Note add $grouptag $x $y
	return
    }

    ###### Destroy an existing point
    method Remove {c x y} {
	$self CheckCanvas $c
	set grouptag [GetId $c [$c find withtag current]]
	$c delete $grouptag
	#puts "Remove|$x $y|$grouptag"
	unset myloc($grouptag)
	Note remove $grouptag
	return
    }

    ###### Drag management. On start of a drag ... Identify the group of items to move.
    method {Drag start} {c item} {
	$self CheckCanvas $c
	#puts "Drag Start|$item|"
	set mydragactive 1
	set grouptag [GetId $c $item]
	set mydbox [$c bbox $grouptag]
	Note {move start} $grouptag
	return $grouptag
    }

    ###### Drag management. During a drag ... Move the grouped items.
    method {Drag move} {c grouptag dx dy} {
	$self CheckCanvas $c
	#puts "Drag Move|$grouptag|$dx $dy|"
	$c move $grouptag $dx $dy
	lassign [Delta] px py dx dy
	Note {move delta} $grouptag $px $py $dx $dy
	return $grouptag
    }

    ###### Drag management. After a drag ...
    method {Drag done} {c grouptag} {
	$self CheckCanvas $c
	#puts "Drag Done|$grouptag|"
	set mydragactive 0
	set ok [Note {move done} $grouptag]
	lassign [Delta] px py dx dy
	if {$ok} {
	    # Commit to new location.
	    set myloc($grouptag) [list $px $py]
	} else {
	    # Vetoed. Undo the move.
	    set dx [expr {- $dx}]
	    set dy [expr {- $dy}]
	    $c move $grouptag $dx $dy
	}
	return
    }

    ###### Highlight management ... Start. Note! Not the user callback.
    method {Highlight on} {c item} {
	$self CheckCanvas $c
	return [{*}$options(-highlight-cmd) on $c $item]
    }

    ###### Highlight management ... Done. Vetoed during drag.
    method {Highlight off} {c state} {
	$self CheckCanvas $c
	if {$mydragactive} { return 0 }
	{*}$options(-highlight-cmd) off $c $state
	return 1
    }

    # # ## ### ##### ######## ############# #####################
    ## Class global commands for the actions in the previous section.

    #### Generate notification about changes to the point cloud.

    proc Note {cmd args} {
	upvar 1 options options self self
	if {![llength $options(-data-cmd)]} return
	return [{*}$options(-data-cmd) {*}$cmd $self {*}$args]
    }

    #### Generate a unique tag for a new point.
    #### The tag references editor instance and type

    proc NewId {} {
	upvar 1 mycounter mycounter self self type type
	return P[incr mycounter]/$self/$type
    }

    #### Link both the unique tag for a point marker and the overall
    #### tag identifying the markers managed by an editor to the
    #### canvas items visually representing the marker.

    proc Tag {c items grouptag} {
	upvar 1 options options
	foreach i $items {
	    canvas::tag append $c $i \
		$grouptag \
		$options(-tag)
	}
	return
    }

    #### Retrieve the tag of the point marker from any item which is
    #### part of its visual representation.

    proc GetId {c item} {
	upvar 1 self self type type
	return [lindex [canvas::tag match $c $item */$self/$type] 0]
    }

    #### Compute absolute location and full delta from current and
    #### saved bounding boxes for the items of the point.
    proc Delta {} {
	upvar 1 grouptag grouptag c c
	upvar 1 mydbox obox myloc($grouptag) p

	set nbox [$c bbox $grouptag]
	#puts |$myloc($grouptag)|$mydbox|$nbox|

	lassign $p    px py
	lassign $obox ox oy _ _
	lassign $nbox nx ny _ _

	# Full delta based between old and current location.
	set dx [expr {$nx - $ox}]
	set dy [expr {$ny - $oy}]

	# New absolute location based on the full delta.
	set px [expr {$px + $dx}]
	set py [expr {$py + $dy}]

	return [list $px $py $dx $dy]
    }

    # # ## ### ##### ######## ############# #####################
    ## Instance state

    variable mycanvas     {} ; # Instance command of the canvas widget
			       # the editor works with.
    variable mycounter     0 ; # Counter for NewId to generate
			       # identifiers for point markers.
    variable mydragactive  0 ; # Flag, true when a drag is running, to
			       # veto un-highlighting.
    variable mydbox       {} ; # The bounding box of the items dragged
			       # around, to compute full deltas and
			       # absolute location during the drag.
    variable myactive      0 ; # Flag, true when the editor bindings are
                               # set on the canvas, enabling editing.
    variable myloc -array {} ; # Internal data base mapping from point
			       # id to point location, for the
			       # calculation of absolute coordinates
			       # during dragging.

    # # ## ### ##### ######## ############# #####################
    ## Default implementations for the configurable callbacks to
    ## create and highlight the edited points.

    method DefaultCreate {c x y} {
	$self CheckCanvas $c
	# Create a circle centered on the chosen location, blue filled
	# with black border.
	set w [expr {$x - 3}]
	set n [expr {$y - 3}]
	set e [expr {$x + 3}]
	set s [expr {$y + 3}]
	lappend items [$c create oval $w $n $e $s \
			   -width   1            \
			   -outline black       \
			   -fill    SkyBlue2]
	return $items
    }

    method {DefaultHighlight on} {c item} {
	$self CheckCanvas $c
	# Highlight by refilling the item in red. Save its full state
	# for restoration at the end of the highlight.
	set previous [lindex [$c itemconfigure $item -fill] end]
	$c itemconfigure $item -fill red
	return [list $item $previous]
    }

    method {DefaultHighlight off} {c state} {
	$self CheckCanvas $c
	# To unhighlight get the saved item and state, restore them.
	lassign $state item previous
	$c itemconfigure $item -fill $previous
	return
    }

    method CheckCanvas {c} {
	if {$c eq $mycanvas} return
	return -code error "Canvas mismatch, ours is $mycanvas, called with $c"
    }

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

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

package provide canvas::edit::points 0.1
return

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

Added scriptlibs/tklib0.7/canvas/canvas_epolyline.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
## -*- tcl -*-
# # ## ### ##### ######## ############# #####################

# Canvas Behavior Module. Editing a point cloud representing a
# poly-line. I.e. we have to designated points which are start and end
# of the line, and points have an order, with a line-segment drawn
# between each pair of points adjacent in this order.

# - Create    point - B1 (canvas global)
# - Remove    point - B2 (linked to -tag, current item)
# - Drag/Move point - B3 (linked to -tag, current item)
# - Auto-highlight points, to show ability of drag/move.

# Configurable:
# - Tag used to mark/identify the points of this cloud.
#   Default: POLYLINE.
#
# - Callback used to create the item (group) representing the point.
#   Default: <Inherited from the subordinate point cloud editor>
#
# - Callback used to (un)highlight the item (group) of a point.
#   Default: <Inherited from the subordinate point cloud editor>
#
# - Callback used to report on line editing activity.
#   Default: NONE.

# # ## ### ##### ######## ############# #####################
# Notes:
#
# - The creation of a new point P uses the following heuristics to
#   insert the new point into the line:
#
#   If the nearest point N is the start or end of the line it compares
#   attaching P as new endpoint agains insertion between N and its
#   neighbour X, measuring the distance P-N-X, and N-P-X, choosing the
#   shorter.
#
#   Otherwise, with the nearest point in the middle of the line it
#   compares the two possible insertions with the two neighbours of N,
#   again choosing the possibility giving us a shorter line.
#
# - Removal of a point P either removes the single line-segment it is
#   part of (happens if P is the current start or end of the line), or
#   replaces the two segments adjacent to P with a single segment
#   joining the neighbours of P.

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

package require Tcl 8.5
package require Tk
package require snit
package require canvas::track::lines
package require canvas::edit::points

namespace eval ::canvas::edit {
    namespace export polyline
    namespace ensemble create
}

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

snit::type ::canvas::edit::polyline {
    option -tag           -default POLYLINE -readonly 1
    option -create-cmd    -default {}       -readonly 1
    option -highlight-cmd -default {}       -readonly 1
    option -data-cmd      -default {}       -readonly 1

    constructor {c args} {
	set mycanvas $c

	# Generate an internal point cloud editor, which will handle
	# the basic tasks regarding the line's vertices.

	lappend cmd canvas::edit points ${selfns}::P $c
	lappend cmd -tag      [from args -tag POLYLINE]
	lappend cmd -data-cmd [mymethod Point]

	set c [from args -create-cmd {}]
	if {$c ne {}} { lappend cmd -create-cmd $c }

	set c [from args -highlight-cmd {}]
	if {$c ne {}} { lappend cmd -highlight-cmd $c }

	set myeditor  [{*}$cmd]
	set mytracker [canvas::track lines ${selfns}::TRACK $mycanvas]

	$self configurelist $args

	# TODO :: Connect this to the option processing to alow me to
	# drop -readonly 1 from their definition. Note that this also
	# requires code to re-tag all the items on the fly.
	return
    }

    component mytracker
    component myeditor

    delegate method enable  to myeditor
    delegate method disable to myeditor
    delegate method active  to myeditor
    delegate method clear   to myeditor
    #delegate method add     to myeditor

    # This is not a straight-forward delegation. Because we have to
    # force 'appending the point' instead of using the heuristics.
    method add {x y} {
	set mydoappend 1
	$myeditor add $x $y
	set mydoappend 0
	return
    }

    # # ## ### ##### ######## ############# #####################
    ## Actions bound to events, as reported by the point cloud editor.

    method {Point add} {pe id x y} {
	$self ExtendLine $id $x $y
	Note
	return
    }

    method {Point remove} {pe id} {
	$self ShrinkLine $id
	Note
	return
    }

    method {Point move start} {pe id} {
	set mydloc $mycoords($id)

	set fix {}
	foreach s [array names myline [list * $id]] {
	    lassign $s p _
	    lappend fix $mycoords($p)
	}
	foreach s [array names myline [list $id *]] {
	    lassign $s _ n
	    lappend fix $mycoords($n)
	}

	$mytracker start $mydloc {*}$fix
	return
    }

    method {Point move delta} {pe id nx ny dx dy} {
	set mydloc [list $nx $ny]
	$mytracker move $mydloc
	return
    }

    method {Point move done} {pe id} {
	$self MoveVertex $id $mydloc
	$mytracker done
	Note
	return 1
    }

    # # ## ### ##### ######## ############# #####################
    ## Line management

    method ExtendLine {p x y} {
	set mycoords($p) [list $x $y]

	if {$mydoappend} {
	    lappend mypoints $p
	    if {[llength $mypoints] < 2} return
	    $self AddSegment {*}[lrange $mypoints end-1 end]
	    return
	}

	switch -exact -- [llength $mypoints] {
	    0 {
		# Remember the point, it is both start and end. No
		# need for a line item yet.
		lappend mypoints $p
	    }
	    1 {
		# Remember the point, and now we need the actual
		# polyline.
		lappend mypoints $p
		$self AddSegment {*}$mypoints
	    }
	    default {
		# The most complex case. The heuristics are trying to
		# add the point in a sensible position of the line.

		# We look at the point N nearest to P, and its neighbours.

		# a. With only one neighbour X compute the length of
		#    segments for both attachment of P to N (+
		#    distance to X), and the length if P is inserted
		#    between N and X. Choose which ever is shortest.

		# b. With 2 neighbours compute the lengths for
		#    insertion betweeen N and one of the neighbours,
		#    and choose the shortest.

		set pn  [Nearest $p $mypoints]
		set pos [lsearch -exact $mypoints $pn]

		set snext [lindex [array names myline [list $pn *]] 0]
		set sprev [lindex [array names myline [list * $pn]] 0]

		# Ad b.
		if {($snext ne {}) && ($sprev ne {})} {
		    set next [lindex $snext 1]
		    set prev [lindex $sprev 0]

		    # Compare              pn -- p -- next
		    # vs.     prev -- p -- pn

		    if {
			([Distance $pn   $p] + [Distance $p $next]) <
			([Distance $prev $p] + [Distance $p $pn])
		    } {
			# pn - p - next is shorter. Insert.
			$self MoveTarget $pn $next $p
			$self AddSegment $p  $next
			set mypoints [linsert $mypoints ${pos}+1 $p]
		    } else {
			# prev - p - pn is shorter. Insert.
			$self MoveTarget $prev $pn $p
			$self AddSegment $p    $pn
			set mypoints [linsert $mypoints $pos $p]
		    }

		    return
		}

		# Ad a.start
		if {$snext ne {}} {
		    set next [lindex $snext 1]

		    # Compare p --- pn ----- next
		    # vs            pn - p - next

		    if {
			([Distance $p $pn] + [Distance $pn $next]) <
			([Distance $p $pn] + [Distance $p  $next])
		    } {
			# p - pn - next is shorter. Attach/Prepend
			$self AddSegment  $p  $pn
			set mypoints [linsert $mypoints 0 $p]
		    } else {
			# pn - p - next is shorter. Insert.
			$self MoveTarget  $pn $next $p
			$self AddSegment  $p  $next
			set mypoints [linsert $mypoints ${pos}+1 $p]
		    }

		    return
		}

		# Ad a.end
		if {$sprev ne {}} {
		    set prev [lindex $sprev 0]

		    # Compare prev - p - pn
		    # vs      prev ----- pn --- p

		    if {
			([Distance $pn $prev] + [Distance $pn $p]) <
			([Distance $p  $prev] + [Distance $pn $p])
		    } {
			# prev - pn - p is shorter. Attach/Append.
			$self AddSegment  $pn $p
			lappend mypoints $p
		    } else {
			# prev - p - pn is shorter. Insert.
			$self MoveTarget $prev $pn $p
			$self AddSegment $p    $pn
			set mypoints [linsert $mypoints end-1 $p]
		    }

		    return
		}

		return -code error "Unable to insert new point"
	    }
	}
	return
    }

    method ShrinkLine {p} {
	# Remove point.
	switch -exact -- [llength $mypoints] {
	    1 {
		# Last point removed.
		set mypoints {}
	    }
	    2 {
		# Last segment going away, line has reduced to single
		# point.

		$self DropSegment {*}$mypoints

		lassign $mypoints s e
		if {$s eq $p} {
		    set mypoints [lreplace $mypoints 0 0]
		} else {
		    set mypoints [lreplace $mypoints 1 1]
		}
	    }
	    default {
		# Locate point in the line, then join the neighbours
		# as newly adjacent and drop the other segments.

		set pos [lsearch -exact $mypoints $p]

		if {$pos == 0} {
		    # Remove from start
		    set next [lindex $mypoints 1]
		    $self DropSegment $p $next
		} elseif {$pos == [llength $mypoints]-1} {
		    # Remove from end
		    set prev [lindex $mypoints end-1]
		    $self DropSegment $prev $p
		} else {
		    # Remove from the middle
		    set prev [lindex $mypoints ${pos}-1]
		    set next [lindex $mypoints ${pos}+1]

		    $self MoveTarget  $prev $p $next
		    $self DropSegment $p    $next
		}

		set mypoints [lreplace $mypoints $pos $pos]
	    }
	}

	unset mycoords($p)
	return
    }

    proc Nearest {p plist} {
	upvar 1 mycoords mycoords
	lassign $mycoords($p) x y
	set min Inf
	set pn {}
	foreach p $plist {
	    lassign $mycoords($p) xn yn
	    set delta [expr {hypot($xn-$x,$yn-$y)}]
	    if {$delta > $min} continue
	    set min $delta
	    set pn $p
	}
	return $pn
    }

    proc Distance {pa pb} {
	upvar 1 mycoords mycoords
	lassign $mycoords($pa) xa ya
	lassign $mycoords($pb) xb yb
	return [expr {hypot($xa-$xb,$ya-$yb)}]
    }

    ###### Move the specified vertex to new location, and refresh the
    ###### drawn location of the (at most) two lines using that vertex.

    method MoveVertex {p new} {
	# Move the reference location of the point, and ...
	set mycoords($p) $new

	# ... refresh the attached line segments, if any.
	foreach s [array names myline [list $p *]] {
	    $self MoveSegment {*}$s
	}
	foreach s [array names myline [list * $p]] {
	    $self MoveSegment {*}$s
	}
	return
    }

    ###### Create a line between the two specified vertices.

    method AddSegment {pa pb} {
	set ca $mycoords($pa)
	set cb $mycoords($pb)

	# TODO :: Add a callback/create command for the segments. At
	# which point the segment may consist of multiple canvas
	# items.

	set segment [$mycanvas create line {*}$ca {*}$cb -width 1 -fill black]
	set key     [list $pa $pb]

	$mycanvas lower $segment $options(-tag)

	set myline($key) $segment

	# NOTE :: Should we tag the segment ?
	return
    }

    ###### Remove the line between the two specified vertices.

    method DropSegment {pa pb} {
	set key     [list $pa $pb]
	set segment $myline($key)

	$mycanvas delete $segment
	unset myline($key)
	return
    }

    ###### Refresh drawn location of the line between the two
    ###### vertices.

    method MoveSegment {pa pb} {
	set key     [list $pa $pb]
	set segment $myline($key)

	# New coordinates.
	set ca $mycoords($pa)
	set cb $mycoords($pb)

	$mycanvas coords $segment {*}$ca {*}$cb
	return
    }

    ###### Switch the end-vertex line between the first two vertices
    ###### to the last vertex, and refresh the drawn location.

    method MoveTarget {pa pb pbnew} {
	set key     [list $pa $pb]
	set segment $myline($key)
	unset myline($key)

	set key [list $pa $pbnew]
	set myline($key) $segment

	$self MoveSegment $pa $pbnew
	return
    }

    #### Generate notification about changes to the point cloud.

    proc Note {} {
	upvar 1 options options
	if {![llength $options(-data-cmd)]} return
	upvar 1 mypoints mypoints mycoords mycoords self self
	set coords {}
	foreach p $mypoints {
	    lappend coords $mycoords($p)
	}
	return [{*}$options(-data-cmd) $self $coords]
    }

    # # ## ### ##### ######## ############# #####################
    ## STATE
    # - Saved handle of the canvas operated on.
    # - List of the points managed by the object, conveying their
    #   order.
    # - Canvas items for the line segments the poly line consists of.

    variable mycanvas        {} ; #
    variable mypoints        {} ; # list of the ids for the line's
				  # points.
    variable mycoords -array {} ; # Reference coordinates of the
				  # points. Keyed by point group tag.
    variable myline   -array {} ; # Canvas items for the polyline,
				  # actually its line segments, to
				  # make redrawing quicker as only the
				  # relevant segments have to be
				  # modified instead of the whole
				  # thing. Keyed by the pair of points
				  # connected by the segment,
				  # identified by group tag.

    variable mydloc {} ; # Drag state. Location of the moving vertex.
    variable mydoappend 0 ; # Flag. When set new points are always
                            # appended at the end of the line.

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

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

package provide canvas::edit::polyline 0.1
return

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

Added scriptlibs/tklib0.7/canvas/canvas_equad.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
## -*- tcl -*-
# # ## ### ##### ######## ############# #####################

## TODO : Optimize the use of AddLine/DropAdjacent to reduce the amount
## TODO : of item churn.

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

# Canvas Behavior Module. Editing 4 points/vertices describing a
# (convex) quadrilateral.

# - Create    point - B1 (canvas global)
# - Remove    point - B2 (linked to -tag, current item)
# - Drag/Move point - B3 (linked to -tag, current item)
# - Auto-highlight points, to show ability of drag/move.

# Configurable:
# - Tag used to mark/identify the points of this cloud.
#   Default: QUADRILATERAL.
#
# - Callback used to create the item (group) representing the point.
#   Default: <Inherited from the subordinate point cloud editor>
#
# - Callback used to (un)highlight the item (group) of a point.
#   Default: <Inherited from the subordinate point cloud editor>
#
# - Callback used to report on quadrilateral editing activity.
#   Default: NONE.

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

package require Tcl 8.5
package require Tk
package require snit
package require canvas::edit::points
package require canvas::track::lines

namespace eval ::canvas::edit {
    namespace export quadrilateral
    namespace ensemble create
}

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

snit::type ::canvas::edit::quadrilateral {
    option -tag           -default QUADRILATERAL -readonly 1
    option -create-cmd    -default {}       -readonly 1
    option -highlight-cmd -default {}       -readonly 1
    option -data-cmd      -default {}       -readonly 1

    option -convex -type snit::boolean -default 0 -readonly 1

    constructor {c args} {
	set mycanvas $c
	set myfreeref $ourrefs

	# Generate an internal point cloud editor, which will handle
	# the basic tasks regarding the quadrilaterals's vertices.

	lappend cmd canvas::edit points ${selfns}::P $c
	lappend cmd -tag        [from args -tag QUADRILATERAL]
	lappend cmd -data-cmd   [mymethod Point]
	lappend cmd -create-cmd [mymethod Create]

	set c [from args -highlight-cmd {}]
	if {$c ne {}} { lappend cmd -highlight-cmd $c }

	set myeditor  [{*}$cmd]
	set mytracker [canvas::track lines ${selfns}::TRACK $mycanvas]

	set c [from args -create-cmd [mymethod DefaultCreate]]
	set options(-create-cmd) $c

	$self configurelist $args

	# TODO :: Connect this to the option processing to alow me to
	# drop -readonly 1 from their definition. Note that this also
	# requires code to re-tag all the items on the fly.

	return
    }

    component mytracker
    component myeditor

    delegate method enable  to myeditor
    delegate method disable to myeditor
    delegate method active  to myeditor
    delegate method clear   to myeditor
    delegate method add     to myeditor

    # # ## ### ##### ######## ############# #####################
    ## Actions bound to events, as reported by the point cloud editor.

    method DefaultCreate {c x y} {
	# No vetoing, just item creation. The vertices of the
	# quadrilateral are uniquely colored and shaped, ensuring that
	# we not only see the shape of the quad, but its exact
	# orientation as well.

	set items {}
	set radius 5
	switch -exact -- [lindex $myfreeref 0] {
	    0 {
		# First vertex, top left.
		# A circle centered on the chosen location, blue
		# filled with black border.
		set w [expr {$x - $radius}]
		set n [expr {$y - $radius}]
		set e [expr {$x + $radius}]
		set s [expr {$y + $radius}]
		lappend items [$c create oval $w $n $e $s \
				   -width   1            \
				   -outline black       \
				   -fill    SkyBlue2]
	    }
	    1 {
		# Second vertex, clock-wise, top right
		# A circle centered on the chosen location, green
		# filled with black border.
		set w [expr {$x - $radius}]
		set n [expr {$y - $radius}]
		set e [expr {$x + $radius}]
		set s [expr {$y + $radius}]
		lappend items [$c create oval $w $n $e $s \
				   -width   1            \
				   -outline black       \
				   -fill    Green]
	    }
	    2 {
		# Third vertex, clock-wise, bottom right
		# A square centered on the chosen location, blue
		# filled with black border.
		set w [expr {$x - $radius}]
		set n [expr {$y - $radius}]
		set e [expr {$x + $radius}]
		set s [expr {$y + $radius}]
		lappend items [$c create rect $w $n $e $s \
				   -width   1            \
				   -outline black       \
				   -fill    SkyBlue2]
	    }
	    3 {
		# Fourth vertex, clock-wise, bottom left
		# A square centered on the chosen location, green
		# filled with black border.
		set w [expr {$x - $radius}]
		set n [expr {$y - $radius}]
		set e [expr {$x + $radius}]
		set s [expr {$y + $radius}]
		lappend items [$c create rect $w $n $e $s \
				   -width   1            \
				   -outline black       \
				   -fill    Green]
	    }
	}
	return $items
    }

    method Create {c x y} {
	if {![llength $myfreeref]} { return {} }

	if {$options(-convex)} {
	    set next [lindex $myfreeref 0]
	    set mydactive 1
	    set mydvertex $next
	    set mydloc [list $x $y]
	    set convex [$self Convex]
	    set mydactive 0
	    if {!$convex} { return {} }
	}
	# XXX Might be useful to have our own standard create method.
	# XXX To make the vertices of the quad visually unique
	# XXX (color, shape).
	return [{*}$options(-create-cmd) $c $x $y]
    }

    method {Point add} {pe id x y} {
	set ref [lindex $myfreeref 0]
	set myfreeref [lrange $myfreeref 1 end]
	set myvertex($ref) [list $x $y]
	set myvertex($id) $ref

	$self AddLine [expr {($ref-1)%4}] $ref
	$self AddLine $ref [expr {($ref+1)%4}]

	# Report only when the quad has become complete.
	if {[llength $myfreeref]} return
	Note
	return
    }

    method {Point remove} {pe id} {
	set ref $myvertex($id)
	unset myvertex($id) myvertex($ref)
	lappend myfreeref $ref

	$self DropAdjacent $ref

	# Report only when the quad just lost a vertex
	if {[llength $myfreeref] > 1} return
	Note
	return
    }

    method {Point move start} {pe id} {
	# Initialize local drag state.
	set ref $myvertex($id)
	set mydactive 1
	set mydid     $id
	set mydvertex $ref
	set mydloc    $myvertex($ref)

	$mytracker start $mydloc {*}[$self Trackpoints]
	return
    }

    method {Point move delta} {pe id nx ny dx dy} {
	# Track the movement.
	set mydloc [list $nx $ny]
	$mytracker move $mydloc
	return
    }

    method {Point move done} {pe id} {
	# Accept any move if the quad is not restrained.
	# Otherwise reject locations causing non-convexity.
	$mytracker done
	set ok [expr {!$options(-convex) || [$self Convex]}]
	set mydactive 0
	if {$ok} {
	    # Commit to the new location.
	    set myvertex($mydvertex) $mydloc
	    $self DropAdjacent $mydvertex
	    $self AddLine [expr {($mydvertex-1)%4}] $mydvertex
	    $self AddLine $mydvertex [expr {($mydvertex+1)%4}]

	    # Report only if the quad is complete.
	    if {![llength $myfreeref]} Note
	}
	return $ok
    }

    method Convex {} {
	# An incomplete quad is at most a triangle, and always convex.
	if {[llength $myfreeref] > 1} { return 1 }
	foreach triple [$self Triples] {
	    lassign $triple a b c
	    # Corner a --> b --> c
	    # Convex if the turn is right-hand
	    set o [Cross [Delta $b $a] [Delta $c $b]]
	    if {$o < 0} { return 0 }
	}
	return 1
    }

    proc Cross {a b} {
	lassign $a xa ya
	lassign $b xb yb
	return [expr {$xa*$yb - $ya*$xb}]
    }

    proc Delta {a b} {
	lassign $a xa ya
	lassign $b xb yb
	return [list [expr {$xb - $xa}] [expr {$yb - $ya}]]
    }

    method Triples {} {
	set plist [$self GetQuad 1]
	set triples {}
	foreach \
	    a [lrange $plist 0 end-2] \
	    b [lrange $plist 1 end-1] \
	    c [lrange $plist 2 end] {
		lappend triples [list $a $b $c]
	    }
	return $triples
    }

    method GetQuad {{extended 0}} {
	set res {}
	if {$extended} {
	    set idlist $ourerefs
	} else {
	    set idlist $ourrefs
	}
	foreach ref $idlist {
	    if {$mydactive && ($ref == $mydvertex)} {
		set p $mydloc
	    } else {
		if {![info exists myvertex($ref)]} continue
		set p $myvertex($ref)
	    }
	    lappend res $p
	}
	return $res
    }

    # # ## ### ##### ######## ############# #####################
    ## Line management

    method Trackpoints {} {
	set prev [expr {($mydvertex-1)%4}]
	set next [expr {($mydvertex+1)%4}]
	set res {}
	if {[info exists myvertex($prev)]} {
	    lappend res $myvertex($prev)
	}
	if {[info exists myvertex($next)]} {
	    lappend res $myvertex($next)
	}
	return $res
    }

    method AddLine {aref bref} {
	set key $aref$bref
	if {[info exists myline($key)]} { error "present already" }

	if {![info exists myvertex($aref)] ||
	    ![info exists myvertex($bref)]
	} return

	set a $myvertex($aref)
	set b $myvertex($bref)

	# TODO :: Add a callback/create command prefix for the helper
	# lines. At which point the 'line' may consist of multiple
	# items.

	set segment [$mycanvas create line {*}$a {*}$b -width 1 -fill black]
	$mycanvas lower $segment $options(-tag)

	set myline($key) $segment

	# NOTE :: Should we tag the segment ?
	return
    }

    method DropAdjacent {pref} {
	foreach key [array names myline *${pref}*] {
	    set segment $myline($key)
	    $mycanvas delete $segment
	    unset myline($key)
	}
	return
    }

    #### Generate notification about changes to the point cloud.

    proc Note {} {
	upvar 1 options options myfreeref myfreeref myvertex myvertex self self
	if {![llength $options(-data-cmd)]} return
	if {[llength $myfreeref]} {
	    # Incomplete quad. Report as 'no quad'.
	    set coords {}
	} else {
	    set coords [$self GetQuad]
	}
	return [{*}$options(-data-cmd) $self $coords]
    }

    # # ## ### ##### ######## ############# #####################
    ## STATE
    # - Saved handle of the canvas operated on.
    # - Counter for the generation of point identifiers
    # - List of the points managed by the object, conveying their
    #   order.
    # - Canvas items for the actual polyline

    typevariable ourrefs  {0 1 2 3}
    typevariable ourerefs {0 1 2 3 0 1}

    variable mycanvas        {} ; # The canvas we are working with.
    variable myfreeref          ; # Vertex ids which are free to fill.
    variable myvertex -array {} ; # Vertex information
                                  # editor id -> vertex id
                                  # vertex id -> vertex coordinates
    variable myline   -array {} ; # Canvas items for the quad helper lines connecting the points.
                                  # Keyed by the pair if vertex ids connected by the line.

    variable mydactive 0        ; # Drag state. Boolean flag. True when drag in progress.
    variable mydid              ; # Drag state. Editor point id of moving point.
    variable mydvertex          ; # Drag state. Vertex id of moving point.
    variable mydloc             ; # Drag state. Uncommitted location of the moving point.
    variable mydcrosshair       ; # Drag state. Crosshair / rubber band lines shown during dragging.

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

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

package provide canvas::edit::quadrilateral 0.1
return

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

Added scriptlibs/tklib0.7/canvas/canvas_gradient.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
# *- tcl -*-
# ### ### ### ######### ######### #########

# Copyright (c) 2013 Jarek Lewandowski (MaxJarek)
# Origin http://wiki.tcl.tk/6100
# Origin http://wiki.tcl.tk/37242
# Origin http://wiki.tcl.tk/9079
# OLL licensed (http://wiki.tcl.tk/10892)

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

package require Tcl 8.5
package require Tk  8.5

namespace eval ::canvas {}

# ### ### ### ######### ######### #########
## Implementation.

proc ::canvas::gradient {canvas args} {
    gradient::DrawGradient $canvas {*}$args
    bind $canvas <Configure> [list ::canvas::gradient::DrawGradient %W {*}$args]
    return
}

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

namespace eval ::canvas::gradient {}

# ### ### ### ######### ######### #########
## Helper commands.
## Recreate the entire gradient from scratch, as a series of (nested)
## items each filled with a piece of it. This command is called on
## *every* change to the canvas's geometry.

## TODO: Force redraw only on changes to width and height, not
## position.

proc ::canvas::gradient::DrawGradient {canvas args} {

    # Fill any holes in the user's specification with the defaults.
    set args [dict merge {
	-direction x
	-color1    red
	-color2    green
	-type      linear
    } $args]
    
    set color1 [dict get $args -color1]
    set color2 [dict get $args -color2]
    set direction [dict get $args -direction]
    
    ## Clear gradient. Destroys all canvas items the old gradient
    ## consisted of.
    $canvas delete canvas::gradient

    ## Get current canvas width and height.
    set canWidthPx  [winfo width  $canvas]
    set canHeightPx [winfo height $canvas]
    
    ## No gradient if the canvas' area is too small
    if {($canWidthPx < 10) ||
	($canHeightPx < 10)} return
    
    ## Get the distance 'distPx' (in pixels) over which
    ## the 2 colors are to be gradiated.

    switch -exact -- $direction {
	x {
	    set distPx $canWidthPx
	}
	y {
	    set distPx $canHeightPx
	}
	r {
	    set halfWidthPx  [expr {int($canWidthPx  / 2)}]
	    set halfHeightPx [expr {int($canHeightPx / 2)}]
	    set distPx       [expr {max($halfHeightPx,$halfWidthPx)}]

	    # Even with the radial gradient stopping at the farthest
	    # canvas border (see dist calculation above, max), we may
	    # have undefined pixels in the corners. The rectangle
	    # added below ensures that these have a defined color as
	    # well (the end color).
	    $canvas create rectangle 0 0 $canWidthPx $canHeightPx \
		-tags canvas::gradient -fill $color2
	}
	d1 -
	d2 {
	    # Hm. I wonder if that should be the length of the
	    # diagonal instead (hypot).
	    set distPx [expr {$canWidthPx + $canHeightPx}]
	}
	default {
	    return -code error "Invalid direction $direction"
	}
    }

    ## Translate whatever color specification came in into RGB triples
    ## we can then interpolate between.
    if {[catch {
	lassign [winfo rgb $canvas $color1] r1 g1 b1
	lassign [winfo rgb $canvas $color2] r2 g2 b2
    } err]} {
	return -code error $err
    }

    ## Calculate the data needed for the interpolation, i.e. color
    ## range and slope of the line (The ratio of RGB-color-ranges to
    ## distance 'across' the canvas).
    
    set rRange [expr {$r2 - $r1 + 0.0}]
    set gRange [expr {$g2 - $g1 + 0.0}]
    set bRange [expr {$b2 - $b1 + 0.0}]

    set rRatio [expr {$rRange / $distPx}]
    set gRatio [expr {$gRange / $distPx}]
    set bRatio [expr {$bRange / $distPx}]

    ## Increment 'across' the canvas, drawing colored lines, or ovals
    ## with canvas-'create line', 'create oval'. Computed jump to the
    ## actual drawing command.

    Draw_$direction

    ## Lower the newly created gradient items into the background
    $canvas lower canvas::gradient
    return
}

# ### ### ### ######### ######### #########
## Draw helpers, one per direction.

proc ::canvas::gradient::Draw_d1 {} {
    upvar 1 canvas canvas r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio
    upvar 1 canHeightPx canHeightPx canWidthPx canWidthPx

    # Drawing for diagonal direction, left+top to bottom+right

    # Two stages:
    # - First along y-axis (canHeightPx), top to bottom,
    # - Then  along x-axis (canWidthPx), left to right.

    # i 0 --> canHeight

    for {set i 0} {$i <= $canHeightPx} {incr i} {
	catch {
	    $canvas create line $i 0 0 $i \
		-tags canvas::gradient -fill [GetNextColor $i]
	}
    }

    # x canHeight --> canWidth + canHeight
    # i 0         --> canWidth

    for {
	set x $canHeightPx
	set i 0
    } {$i <= $canWidthPx} {
	incr i
	incr x
    } {
	catch {
	    $canvas create line $i $canHeightPx $x 0 \
		-tags canvas::gradient -fill [GetNextColor $x]
	}
    }
    return
}

proc ::canvas::gradient::Draw_d2 {} {
    upvar 1 canvas canvas r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio
    upvar 1 canHeightPx canHeightPx canWidthPx canWidthPx
    
    # Drawing for diagonal direction, bottom+left to top+right

    # Two stages:
    # - First along y-axis (canHeightPx), bottom to top.
    # - Then  along x-axis (canWidthPx), left to right.

    # x 0         --> canHeight
    # i canHeight --> 0

    for {
	set x 0
	set i $canHeightPx
    } {$i >= 0} {
	incr i -1
	incr x
    } {
	catch {
	    $canvas create line $x $canHeightPx 0 $i \
		-tags canvas::gradient -fill [GetNextColor $x]
	}
    }

    # x canHeight --> canWidth + canHeight
    # i 0         --> canWidth

    for {
	set x $canHeightPx
	set i 0
    } {$i <= $canWidthPx} {
	incr i
	incr x
    } {
	catch {
	    $canvas create line $i 0 $x $canHeightPx \
		-tags canvas::gradient -fill [GetNextColor $x]
	}
    }
    return
}

proc ::canvas::gradient::Draw_x {} {
    upvar 1 canvas canvas r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio
    upvar 1 canHeightPx canHeightPx distPx distPx

    for {set i $distPx} {$i >= 0} {incr i -1} {
	catch {
	    $canvas create line $i 0 $i $canHeightPx \
		-tags canvas::gradient -fill [GetNextColor $i]
	}
    }
    return
}

proc ::canvas::gradient::Draw_y {} {
    upvar 1 canvas canvas r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio
    upvar 1 canWidthPx canWidthPx distPx distPx

    for {set i $distPx} {$i >= 0} {incr i -1} {
	catch {
	    $canvas create line 0 $i $canWidthPx $i \
		-tags canvas::gradient -fill [GetNextColor $i]
	}
    }
    return
}

proc ::canvas::gradient::Draw_r {} {
    upvar 1 canvas canvas r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio
    upvar 1 halfWidthPx halfWidthPx halfHeightPx halfHeightPx distPx distPx

    for {set i $distPx} {$i >= 0} {incr i -1} {
	set xx1 [expr {$halfWidthPx  + $i}]
	set xx2 [expr {$halfHeightPx + $i}]
	set xx3 [expr {$halfWidthPx  - $i}]
	set xx4 [expr {$halfHeightPx - $i}]
	catch {
	    $canvas create oval $xx1 $xx2 $xx3 $xx4 \
		-outline {} -tags canvas::gradient -fill [GetNextColor $i]
	}
    }
    return
}

# ### ### ### ######### ######### #########
## Helper command. Compute the color for step i of the gradient.
## Linear interpolation from the start color.

proc ::canvas::gradient::GetNextColor {i} {
    upvar 1 r1 r1 g1 g1 b1 b1 rRatio rRatio gRatio gRatio bRatio bRatio

    set nR [expr {int ($r1 + ($rRatio * $i))}]
    set nG [expr {int ($g1 + ($gRatio * $i))}]
    set nB [expr {int ($b1 + ($bRatio * $i))}]

    return [format "#%04X%04X%04X" $nR $nG $nB]
}

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

package provide canvas::gradient 0.2
return

Added scriptlibs/tklib0.7/canvas/canvas_highlight.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
## -*- tcl -*-
# ### ### ### ######### ######### #########

# Canvas Behavior Module. Highlighting items and groups of items.

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

package require Tcl 8.5
package require Tk

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

namespace eval ::canvas::highlight {
    namespace export \
	on off
    namespace ensemble create
}

proc ::canvas::highlight::on {c tagOrId cmdprefix} {
    # Setting up a general highlight, with the items to highlight
    # identified by <tagOrId> and <cmdprefix> providing the 'on' and 'off'
    # methods invoked to (de)activate highlight. The cmdprefix is
    # fully responsible for how the highlightging of a particular
    # handle is handled.

    # Install the bindings doing the highlight
    $c bind $tagOrId <Any-Enter>  [namespace code [list Highlight   $c $cmdprefix %x %y]]
    $c bind $tagOrId <Any-Leave>  [namespace code [list Unhighlight $c $cmdprefix %x %y]]
    return
}

proc ::canvas::highlight::off {c tagOrId} {
    # Remove a highlight identified by canvas <c> and <tagOrId>.

    # Find and remove the bindings for this particular combination of
    # canvas and tagOrId.

    $c bind $tagOrId <Any-Enter>  {}
    $c bind $tagOrId <Any-Leave>  {}
    return
}

# ### ### ### ######### ######### #########
## Highlight execution.

proc ::canvas::highlight::Highlight {c cmdprefix x y} {
    # Check that highlight is not active
    variable active
    if {[info exists active]} return

    # Start a highlight operation, import remainder of state
    variable clientdata

    # Get item under mouse, if any.
    set item [$c find withtag current]
    if {$item eq {}} return

    # Initialize the highlight state, run the command to initialize
    # anything external to us. We remember the current location to
    # enable the delta calculations in 'Move'.

    set active     $cmdprefix
    set clientdata [{*}$active on $c $item]
    return
}

proc ::canvas::highlight::Unhighlight {c cmdprefix x y} {
    # Check for active highlight.
    variable active
    if {![info exists active]} return

    # Import remainder of the highlight state
    variable clientdata

    # Let the commnand process the movement as it sees fit.
    # Must return a boolean. False vetos the unhighlight.
    if {![{*}$active off $c $clientdata]} return

    # Clear highlight state
    unset -nocomplain active clientdata
    return
}

# ### ### ### ######### ######### #########
## Convenience. Highlightging via ...

# ### ### ### ######### ######### #########
## State.

namespace eval ::canvas::highlight {
    # State of a highlight in progress

    variable  active     ; # command prefix to invoke for 'on' / 'off'.
    variable  clientdata ; # Result of invoking 'on', data for 'off'.
}

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

package provide canvas::highlight 0.1
return

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

Added scriptlibs/tklib0.7/canvas/canvas_mvg.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
# *- tcl -*-
# ### ### ### ######### ######### #########

# Copyright (c) 2010 Wolf-Dieter Busch
# Origin http://wiki.tcl.tk/26859 [23-08-2010]
# OLL licensed (http://wiki.tcl.tk/10892).

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

package require Tcl 8.5
package require Tk  8.5

namespace eval ::canvas {}

# ### ### ### ######### ######### #########
## Implementation.

proc ::canvas::mvg {canvas} {

    #raise [winfo toplevel $canvas] 
    #update

    # Initialize drawing state... This array is keyed by the MVG
    # commands for the attribute, not by the canvas options, and not
    # by something third.
    array set mode {
	fill            {}
	stroke          {}
	stroke-width    {}
	stroke-linejoin {}
	stroke-linecap  {}
	font            {}
	font-size       {}
    }

    # Get the bounding box of all item, and compute the translation
    # required to put the lower-left corner at the origin.
    set dx 0
    set dy 0
    set box [$canvas bbox {*}[$canvas find all]]
    lassign $box zx zy ex ey
    if {$zx < 0} { set dx [expr {- $zx}] ; set ex [expr {$ex + $dx}] }
    if {$zy < 0} { set dy [expr {- $zy}] ; set ey [expr {$ey + $dy}] }
    set box [list 0 0 $ex $ey]

    # Standard prelude...
    mvg::Emit [list viewbox {*}$box]
    mvg::EmitChanged stroke none
    mvg::EmitChanged fill   [mvg::Col2Hex $canvas]
    mvg::Emit [list rectangle {*}$box]

    # Introspect the canvas, i.e. convert each item to MVG
    foreach item [$canvas find all] {
	set type [$canvas type $item]

	# Info to help debugging...
	mvg::Emit "# $type ... [$canvas gettags $item]"

	# Dump the item's attributes, as they are supported by it.
	# Note how the code is not sliced by item type which then
	# handles each of its attributes, but by attribute name, which
	# then checks if the type of the current item supports it.

	# Further note that the current attribute state is stored in
	# the mode array and actually emitted if and only if it is
	# different from the previously drawn state. This optimizes
	# the number of commands needed to set the drawing state for a
	# particular item.

	# outline width
	if {$type in {polygon oval arc rectangle line}} then {
	    mvg::EmitValue $item -width stroke-width
	}

	# fill, stroke
	if {$type in {polygon oval arc rectangle}} {
	    mvg::EmitColor $item -fill    fill
	    mvg::EmitColor $item -outline stroke
	}

	# joinstyle
	if {$type in {polygon}} then {
	    mvg::EmitValue $item -joinstyle stroke-linejoin
	}

	# line color, capstyle
	if {$type in {line}} then {
	    mvg::EmitChanged fill none
	    mvg::EmitColor $item -fill     stroke
	    mvg::EmitCap   $item -capstyle stroke-linecap
	}

	# text color, font, size
	if {$type in {text}} then {
	    # Compute font-family, font-size
	    set font [$canvas itemcget $item -font]
	    if {$font in [font names]} {
		set fontsize   [font configure $font -size]
		set fontfamily [font configure $font -family]
	    } else {
		if {[llength $font] == 1} then {
		    set fontsize 12
		} else {
		    set fontsize [lindex $font 1]
		}
		set fontfamily [lindex $font 0]
	    }
	    if {$fontsize < 0} {
		set fontsize [expr {int(-$fontsize / [tk scaling])}]
	    }

	    mvg::EmitChanged stroke none
	    mvg::EmitColor $item -fill fill
	    mvg::EmitChanged font-size $fontsize
	    mvg::EmitChanged font $fontfamily

	    #
	    # Attention! In some cases ImageMagick assumes 72dpi where
	    # 90dpi is necessary. If that happens use the switch
	    # -density to force the correct dpi setting, like %
	    # convert -density 90 test.mvg test.png
	    #
	    # Attention! Make sure that ImageMagick has access to the
	    # used fonts. If it has not, an error msg will be shown,
	    # and then switches silently to the default font.
	    #
	}

	# After the attributes we can emit the command actually
	# drawing the item, in the its place.

	set line {}
	set coords [mvg::Translate [$canvas coords $item]]

	switch -exact -- $type {
	    line {
		# start of path
		lappend line path 'M

		# smooth can be any boolean value, plus the name of a
		# line smoothing method. Core supports only 'raw'.
		# This however is extensible through packages.

		switch -exact -- [mvg::Smooth $item] {
		    0 {
			lappend line {*}[lrange $coords 0 1] L {*}[lrange $coords 2 end]
		    }
		    1 {
			if {[$canvas itemcget $item -arrow] eq "none"} {
			    lappend line {*}[mvg::Spline2MVG $coords]
			} else {
			    lappend line {*}[mvg::Spline2MVG $coords false]
			}
		    }
		    2 {
			lappend line {*}[lrange $coords 0 1] C {*}[lrange $coords 2 end]
		    }
		}

		append line '
		mvg::Emit $line
	    }
	    polygon {
		# start of path.
		lappend line path 'M

		switch -exact -- [mvg::Smooth $item] {
		    0 {
			lassign $coords x0 y0
			lassign [lrange $coords end-1 end] x1 y1
			set x [expr {($x0+$x1)/2.0}]
			set y [expr {($y0+$y1)/2.0}]
			lappend line $x $y L {*}$coords $x $y Z
		    }
		    1 {
			lassign $coords x0 y0
			lassign [lrange $coords end-1 end] x1 y1
			if {($x0 != $x1) || ($y0 != $y1)} {
			    lappend coords {*}[lrange $coords 0 1]
			}
			lappend line {*}[mvg::Spline2MVG $coords]
		    }
		    2 {
			lappend line {*}[lrange $coords 0 1] C {*}[lrange $coords 2 end]
		    }
		}

		append line '
		mvg::Emit $line
	    }
	    oval {
		lassign $coords x0 y0 x1 y1
		set xc [expr {($x0+$x1)/2.0}]
		set yc [expr {($y0+$y1)/2.0}]

		mvg::Emit [list ellipse $xc $yc [expr {$x1-$xc}] [expr {$y1-$yc}] 0 360]
	    }
	    arc {
		lassign $coords x0 y0 x1 y1

		set rx [expr {($x1-$x0)/2.0}]
		set ry [expr {($y1-$y0)/2.0}]
		set x  [expr {($x0+$x1)/2.0}]
		set y  [expr {($y0+$y1)/2.0}]
		set f  [expr {acos(0)/90}]

		set start  [$canvas itemcget $item -start]
		set startx [expr {cos($start*$f)*$rx+$x}]
		set starty [expr {sin(-$start*$f)*$ry+$y}]
		set angle  [expr {$start+[$canvas itemcget $item -extent]}]
		set endx   [expr {cos($angle*$f)*$rx+$x}]
		set endy   [expr {sin(-$angle*$f)*$ry+$y}]

		# start path
		lappend line path 'M
		# start point
		lappend line $startx $starty
		lappend line A
		# radiusx, radiusy
		lappend line $rx $ry
		# angle -- always 0
		lappend line 0
		# "big" or "small"?
		lappend line [expr {($angle-$start) > 180}]
		# right side (always)
		lappend line 0
		# end point
		lappend line $endx $endy
		# close path
		lappend line L $x $y Z
		append line '

		mvg::Emit $line
	    }
	    rectangle {
		mvg::Emit [list rectangle {*}$coords]
	    }
	    text {
		lassign [mvg::Translate [$canvas bbox $item]] x0 y0 x1 y1
		mvg::Emit "text $x0 $y1 '[$canvas itemcget $item -text]'"
	    }
	    image - bitmap {
		set img  [$canvas itemcget $item -image]
		set file [$img cget -file]
		lassign  [mvg::Translate [$canvas bbox $item]] x0 y0
		mvg::Emit "image over $x0 $y0 0 0 '$file'"
	    }
	    default {
		set    line "# not yet done:"
		append line " "  [$canvas type $item]
		append line " "  [mvg::Translate [$canvas coords $item]]
		append line " (" [$canvas gettags $item] ")"
		mvg::Emit $line
	    }
	}
    }

    # At last, return the fully assembled snapshot
    return [join $result \n]
}

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

namespace eval ::canvas::mvg {}

proc ::canvas::mvg::Translate {coords} {
    upvar 1 dx dx dy dy
    set tmp {}
    foreach {x y} $coords {
	lappend tmp [expr {$x + $dx}] [expr {$y + $dy}]
    }
    return $tmp
}


proc ::canvas::mvg::Smooth {item} {
    upvar 1 canvas canvas

    # Force smooth to canonical values we can then switch on.
    set smooth [$canvas itemcget $item -smooth]
    if {[string is boolean $smooth]} {
	if {$smooth} {
	    return 1
	} else {
	    return 0
	}
    } else {
	return 2
    }
}

proc ::canvas::mvg::EmitValue {item option cmd} {
    upvar 1 mode mode result result canvas canvas

    EmitChanged $cmd \
	[$canvas itemcget $item $option]
    return
}

proc ::canvas::mvg::EmitColor {item option cmd} {
    upvar 1 mode mode result result canvas canvas

    EmitChanged $cmd \
	[Col2Hex [$canvas itemcget $item $option]]
    return
}

proc ::canvas::mvg::EmitCap {item option cmd} {
    upvar 1 mode mode result result canvas canvas

    EmitChanged $cmd \
	[dict get {
	    butt       butt
	    projecting square
	    round      round
	} [$canvas itemcget $item $option]]
    return
}

proc ::canvas::mvg::EmitChanged {cmd value} {
    upvar 1 mode mode result result

    if {$mode($cmd) eq $value} return
    set mode($cmd) $value
    Emit [list $cmd $value]
    return
}

proc ::canvas::mvg::Emit {command} {
    upvar 1 result result
    lappend result $command
    return
}

proc ::canvas::mvg::Col2Hex {color} {
    # This command or similar functionality we might have somewhere
    # in tklib already ...

    # Special handling of canvas widgets, use their background color.
    if {[winfo exists $color] && [winfo class $color] eq "Canvas"} {
	set color [$color cget -bg]
    }
    if {$color eq ""} {
	return none
    }
    set result #
    foreach x [winfo rgb . $color] {
	append result [format %02x [expr {int($x / 256)}]]
    }
    return $result
}

proc ::canvas::mvg::Spline2MVG {coords {canBeClosed yes}} {
    set closed [expr {$canBeClosed &&
		      [lindex $coords 0] == [lindex $coords end-1] &&
		      [lindex $coords 1] == [lindex $coords end]}]

    if {$closed} {
	lassign [lrange $coords end-3 end] x0 y0 x1 y1

	set x [expr {($x0+$x1)/2.0}]
	set y [expr {($y0+$y1)/2.0}]

	lset coords end-1 $x
	lset coords end $y

	set coords [linsert $coords 0 $x $y]
    }

    if {[llength $coords] != 6} {
	lappend tmp {*}[lrange $coords 0 1]

	set co1 [lrange $coords 2 end-4]
	set co2 [lrange $coords 4 end-2]

	foreach {x1 y1} $co1 {x2 y2} $co2 {
	    lappend tmp $x1 $y1 [expr {($x1+$x2)/2.0}] [expr {($y1+$y2)/2.0}]
	}
	lappend tmp {*}[lrange $coords end-3 end]
	set coords $tmp
    }

    return [lreplace $coords 2 1 Q]
}

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

package provide canvas::mvg 1
return

Added scriptlibs/tklib0.7/canvas/canvas_snap.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
# *- tcl -*-
# ### ### ### ######### ######### #########

# Copyright (c) 2004 George Petasis
# Origin http://wiki.tcl.tk/1404 [24-10-2004]
# BSD licensed.

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

package require Tcl 8.5
package require Tk  8.5
package require img::window

namespace eval ::canvas {}

# ### ### ### ######### ######### #########
## Implementation.

proc ::canvas::snap {canvas} {

    # Ensure that the window is on top of everything else, so as not
    # to get white ranges in the image, due to overlapped portions of
    # the window with other windows...

    raise [winfo toplevel $canvas] 
    update

    # XXX: Undo the raise at the end ?!

    set border [expr {[$canvas cget -borderwidth] +
                      [$canvas cget -highlightthickness]}]

    set view_height [expr {[winfo height $canvas]-2*$border}]
    set view_width  [expr {[winfo width  $canvas]-2*$border}]

    lassign [$canvas bbox all] x1 y1 x2 y2
    #foreach {x1 y1 x2 y2} [$canvas bbox all] break

    set x1 [expr {int($x1-10)}]
    set y1 [expr {int($y1-10)}]
    set x2 [expr {int($x2+10)}]
    set y2 [expr {int($y2+10)}]

    set width  [expr {$x2-$x1}]
    set height [expr {$y2-$y1}]

    set image [image create photo -height $height -width $width]

    # Arrange the scrollregion of the canvas to get the whole window
    # visible, so as to grab it into an image...

    # Save the scrolling state, as this will be overidden in short order.
    set scrollregion   [$canvas cget -scrollregion]
    set xscrollcommand [$canvas cget -xscrollcommand]
    set yscrollcommand [$canvas cget -yscrollcommand]

    $canvas configure -xscrollcommand {}
    $canvas configure -yscrollcommand {}

    set grabbed_x $x1
    set grabbed_y $y1
    set image_x   0
    set image_y   0

    while {$grabbed_y < $y2} {
	while {$grabbed_x < $x2} {
	    set newregion [list \
			       $grabbed_x \
			       $grabbed_y \
			       [expr {$grabbed_x + $view_width}] \
			       [expr {$grabbed_y + $view_height}]]

	    $canvas configure -scrollregion $newregion
	    update

	    # Take a screenshot of the visible canvas part...
	    set tmp [image create photo -format window -data $canvas]

	    # Copy the screenshot to the target image...
	    $image copy $tmp -to $image_x $image_y -from $border $border

	    # And delete the temporary image (leak in original code)
	    image delete $tmp

	    incr grabbed_x $view_width
	    incr image_x   $view_width
	}

	set grabbed_x $x1
	set image_x 0

	incr grabbed_y $view_height
	incr image_y   $view_height
    }

    # Restore the previous scrolling state of the canvas.

    $canvas configure -scrollregion   $scrollregion
    $canvas configure -xscrollcommand $xscrollcommand
    $canvas configure -yscrollcommand $yscrollcommand

    # At last, return the fully assembled snapshot
    return $image
}

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

package provide canvas::snap 1.0.1
return

Added scriptlibs/tklib0.7/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
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
## -*- 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 Tk
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

    option -image-on-load  -default {}
    option -image-on-unset -default {}

    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} {
	# Show an image signaling that 'this tile is not valid/found' ...
	if {$options(-image-on-unset) ne {}} {
	    $self image set $at $options(-image-on-unset)
	    return
	}

	$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

		# Show an image signaling that 'we are loading this tile' ...
		if {$options(-image-on-load) ne {}} {
		    set theitem [$self GetItem [GridToPixel $at]]
		    set myvisible($at)  $theitem
		    $hull itemconfigure $theitem \
			-image $options(-image-on-load)
		}

		after 0 [list $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.3.1
return

Added scriptlibs/tklib0.7/canvas/canvas_tags.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
## -*- tcl -*-
# ### ### ### ######### ######### #########

## Canvas Utilities. Operations on item tags.

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

package require Tcl 8.5
package require Tk

namespace eval ::canvas::tag {
    namespace export \
	append prepend insert remove match
    namespace ensemble create
}

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

proc ::canvas::tag::append {c tagOrId args} {
    insert $c $tagOrId end {*}$args
    #$c addtag $newtag withtag $tagOrId
    return
}

proc ::canvas::tag::prepend {c tagOrId args} {
    insert $c $tagOrId 0 {*}$args
    return
}

proc ::canvas::tag::insert {c tagOrId index args} {
    foreach item [$c find withtag $tagOrId] {
	$c itemconfigure $item -tags [linsert [$c gettags $item] $index {*}$args]
    }
    return
}

proc ::canvas::tag::remove {c tagOrId args} {
    foreach item [$c find withtag $tagOrId] {
	set tags [$c gettags $item]
	foreach tagToRemove $args {
	    while {1} {
		set pos [lsearch -exact $tags $tagToRemove]
		if {$pos < 0} break
		set tags [lreplace $tags $pos $pos]
	    }
	}
	$c itemconfigure $item -tags $tags
    }
    return
}

proc ::canvas::tag::match {c tagOrId pattern} {
    set result {}
    foreach item [$c find withtag $tagOrId] {
	lappend result {*}[lsearch -inline -all -glob \
			       [$c gettags $item] $pattern]
    }
    return [lsort -unique $result]
}

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

package provide canvas::tag 0.1
return

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

Added scriptlibs/tklib0.7/canvas/canvas_trlines.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
## -*- tcl -*-
# # ## ### ##### ######## ############# #####################
##
# Canvas Behavior Module. Managing semi-crosshair rubber bands when
# dragging. Tracers are lines from fixed points to current location
# Purely visual. Driven from the outside. No bindings of its own.
##

## TODO : Callback to customize the rubberband lines.

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

package require Tcl 8.5
package require Tk
package require snit

namespace eval ::canvas::track {
    namespace export lines
    namespace ensemble create
}

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

snit::type ::canvas::track::lines {
    # # ## ### ##### ######## ############# #####################
    ## Lifecycle management

    constructor {c} {
	set mycanvas $c
	return
    }

    destructor {
	$self done
    }

    # # ## ### ##### ######## ############# #####################
    ## API.

    method start {center args} {
	if {![llength $args]} return
	$self done

	# args = list of pairs, each pair contains the x- and
	# y-coordinates of a fixed point.
	# center is current location.

	set mycoords $args
	set myitems  {}

	foreach p $mycoords {
	    lappend myitems [$mycanvas create line \
				 {*}$p {*}$center \
				 -width 0 -fill black -dash .]
	}
	return
    }

    method move {center} {
	if {![llength $myitems]} return
	foreach p $mycoords item $myitems {
	    $mycanvas coords $item {*}$p {*}$center
	}
	return
    }

    method done {} {
	if {![llength $myitems]} return
	$mycanvas delete {*}$myitems
	set myitems {}
	set mycoords {}
	return
    }

    # # ## ### ##### ######## ############# #####################
    ## STATE

    variable mycanvas {} ; # The canvas we are working with/on.
    variable mycoords {} ; # List of fixed points for the rubberbands.
    variable myitems  {} ; # Liust of the canvas items representing the rubberbands.

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

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

package provide canvas::track::lines 0.1
return

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

Added scriptlibs/tklib0.7/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
## -*- tcl -*-
# ### ### ### ######### ######### #########

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

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

package require Tcl 8.4        ; # No {*}-expansion :(
package require Tk
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 10}   -configuremethod O-levels \
	-type {snit::listtype -minlen 1 -maxlen 2 -type snit::integer}
    option -variable -default {}       -configuremethod O-variable
    option -command  -default {}       -configuremethod O-command

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

        set options(-variable) [myvar myzoomlevel] ;# Default value
	$self configurelist $args

	# Force redraw if it could not be triggered by options.
        if {![llength $args]} {
            $reconfigure request
        }
	return
    }

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

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

    method O-levels {o v} {
	# When only a single value was specified, we use it as
	# our maximum, and default the minimum to zero.
        if {[llength $v] == 1} {
            set v [linsert $v 0 0]
        }
	if {$options($o) == $v} return
	set  options($o) $v
	$reconfigure request
	return
    }

    method O-variable {o v} {
	# The handling of an attached variable is very simple, without
	# any of the trace management one would expect to be
	# here. That is because we are using an unmapped aka hidden
	# scale widget to do this for us, at the C level.

        if {$options($o) == $v} return
        set options($o) $v
        $reconfigure request
	return
    }

    method O-command {o v} {
	if {$v eq $options(-command)} return
	set options(-command) $v
	return
    }

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

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

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

        set side $options(-orient)
        set var  $options(-variable)
        foreach {lo hi} $options(-levels) break

        set vwidth [expr {max([string length $lo], [string length $hi])}]
        set pre    [expr {[info commands ::ttk::button] ne "" ? "::ttk" : "::tk"}]

        ${pre}::frame  $win.z       -relief solid -borderwidth 1
        ${pre}::button $win.z.plus  -image ::canvas::zoom::plus  -command [mymethod ZoomIn]
        ${pre}::label  $win.z.val   -textvariable $var -justify c -anchor c -width $vwidth
        ${pre}::button $win.z.minus -image ::canvas::zoom::minus -command [mymethod ZoomOut]

        # Use an unmapped scale to keep var between lo and hi and
        # avoid doing our own trace management
        scale $win.z.sc -from $lo -to $hi -variable $var
        
        pack $win.z -fill both -expand 1
        if {$side eq "vertical"} {
            pack $win.z.plus $win.z.val $win.z.minus -side top  -fill x
        } else {
            pack $win.z.plus $win.z.val $win.z.minus -side left -fill y
        }
	return
    }

    # ### ### ### ######### ######### #########
    ## Events which act on the zoomlevel.

    method ZoomIn {} {
        upvar #0 $options(-variable) zoomlevel
        foreach {lo hi} $options(-levels) break
        if {$zoomlevel >= $hi} return
        incr zoomlevel
        $self Callback
	return
    }

    method ZoomOut {} {
        upvar #0 $options(-variable) zoomlevel
        foreach {lo hi} $options(-levels) break
        if {$zoomlevel <= $lo} return
        incr zoomlevel -1
        $self Callback
	return
    }

    method Callback {} {
	if {![llength $options(-command)]} return

        upvar   #0 $options(-variable) zoomlevel
	uplevel #0 [linsert $options(-command) end $win $zoomlevel]
	return
    }

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

    variable myzoomlevel 0 ; # The variable to use if the user
                             # did not supply one to -variable.

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

# ### ### ### ######### ######### #########
## Images for the buttons

image create bitmap ::canvas::zoom::plus -data {
    #define plus_width 8
    #define plus_height 8
    static char bullet_bits = {
        0x18, 0x18, 0x18, 0xff, 0xff, 0x18, 0x18, 0x18
    }
}

image create bitmap ::canvas::zoom::minus -data {
    #define minus_width 8
    #define minus_height 8
    static char bullet_bits = {
        0x00, 0x00, 0x00, 0xff, 0xff, 0x00, 0x00, 0x00
    }
}

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

package provide canvas::zoom 0.2.1
return

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

Added scriptlibs/tklib0.7/canvas/pkgIndex.tcl.





























>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded canvas::sqmap 0.3.1 [list source [file join $dir canvas_sqmap.tcl]]
package ifneeded canvas::zoom  0.2.1 [list source [file join $dir canvas_zoom.tcl]]
if {![package vsatisfies [package provide Tcl] 8.5]} { return }
package ifneeded canvas::drag                0.1   [list source [file join $dir canvas_drag.tcl]]
package ifneeded canvas::edit::points        0.1   [list source [file join $dir canvas_epoints.tcl]]
package ifneeded canvas::edit::polyline      0.1   [list source [file join $dir canvas_epolyline.tcl]]
package ifneeded canvas::edit::quadrilateral 0.1   [list source [file join $dir canvas_equad.tcl]]
package ifneeded canvas::gradient            0.2   [list source [file join $dir canvas_gradient.tcl]]
package ifneeded canvas::highlight           0.1   [list source [file join $dir canvas_highlight.tcl]]
package ifneeded canvas::mvg                 1     [list source [file join $dir canvas_mvg.tcl]]
package ifneeded canvas::snap                1.0.1 [list source [file join $dir canvas_snap.tcl]]
package ifneeded canvas::tag                 0.1   [list source [file join $dir canvas_tags.tcl]]
package ifneeded canvas::track::lines        0.1   [list source [file join $dir canvas_trlines.tcl]]

Added scriptlibs/tklib0.7/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
738
# 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 Tcl 8.5
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

Added scriptlibs/tklib0.7/chatwidget/pkgIndex.tcl.



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

Added scriptlibs/tklib0.7/controlwidget/bindDown.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


#
#    This software is Copyright by the Board of Trustees of Michigan
#    State University (c) Copyright 2005.
#
#    You may use this software under the terms of the GNU public license
#    (GPL) ir the Tcl BSD derived license  The terms of these licenses
#     are described at:
#
#     GPL:  http://www.gnu.org/licenses/gpl.txt
#     Tcl:  http://www.tcl.tk/softare/tcltk/license.html
#     Start with the second paragraph under the Tcl/Tk License terms
#     as ownership is solely by Board of Trustees at Michigan State University.
#
#     Author:
#             Ron Fox
#	     NSCL
#	     Michigan State University
#	     East Lansing, MI 48824-1321
#

#
# bindDown is a simple package that allows the user to attach
# bind tags to a hieararchy of widgets starting with the top of
# a widget tree.  The most common use of this is in snit::widgets
# to allow a binding to be placed on the widget itself e.g:
#  bindDown $win $win
#
#   where the first item is the top of the widget tree, the second the
#   bindtag to add to each widget in the subtree.
#   This will allow bind $win <yada> yada to apply to the widget
#   children.
#
#
package provide bindDown 1.0

proc bindDown {top tag} {
    foreach widget [winfo children $top] {
	set wtags [bindtags $widget]
	lappend   wtags $tag
	bindtags $widget [lappend wtags $tag]
	bindDown $widget $tag
    }
}

Added scriptlibs/tklib0.7/controlwidget/controlwidget.tcl.



































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
# controlwidget.tcl --
#     Set up the requirements for the controlwidget module/package
#     and source the individual files
#

package require Tk 8.5
package require snit

package require bindDown
package require meter
package require led
package require rdial
package require tachometer
package require voltmeter
package require radioMatrix

package provide controlwidget 0.1

Added scriptlibs/tklib0.7/controlwidget/led.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
#
#    This software is Copyright by the Board of Trustees of Michigan
#    State University (c) Copyright 2005.
#
#    You may use this software under the terms of the GNU public license
#    (GPL) ir the Tcl BSD derived license  The terms of these licenses
#     are described at:
#
#     GPL:  http://www.gnu.org/licenses/gpl.txt
#     Tcl:  http://www.tcl.tk/softare/tcltk/license.html
#     Start with the second paragraph under the Tcl/Tk License terms
#     as ownership is solely by Board of Trustees at Michigan State University.
#
#     Author:
#            Ron Fox
#            NSCL
#            Michigan State University
#            East Lansing, MI 48824-1321
#
#     Adjusted by Arjen Markus
#
#
#   This package provides an LED
#   widget.  LED widgets are one color when on
#   and another when off.
#   Implementation is just a filled circle on a
#   canvas.
#   Options recognized:
#     (all standard options for a frame).
#     -size      - Radius of the led.
#     -on        - Color of on state.
#     -off       - Color of off state.
#     -variable  - on color when variable is nonzero else off.
#  Methods
#     on         - Turn led on.
#     off        - Turn led off.
#
#  TODO:
#     Add a label
#

package provide led 1.0
package require Tk
package require snit
package require bindDown

namespace eval controlwidget {
    namespace export led
}

snit::widget controlwidget::led {
    delegate option * to hull
    option   -size {17}
    option   -on   green
    option   -off  black
    option   -variable {}


    constructor args {
        $self configurelist $args

        canvas $win.led -width $options(-size) -height $options(-size)
        set border [expr [$win cget -borderwidth] + 2]
        set end [expr $options(-size) - $border]
        $win.led create oval $border $border $end $end -fill $options(-off)
        grid $win.led -sticky nsew

        bindDown $win $win
    }

    # Process the -variable configuration by killing off prior traces
    # and setting an new trace:
    #

    onconfigure -variable name {
        if {$options(-variable) ne ""} {
            trace remove variable ::$options(-variable) write [mymethod varTrace]
        }
        trace add variable ::$name  write [mymethod varTrace]
        set options(-variable) $name

        # set our initial state to the current value of the var:
        # the after is because we could be constructing an need to give
        # the widgets a chance to get built:

        after 10 [list $self varTrace $name "" write]

    }
    # Trace for the led variable..
    #
    method varTrace {name index op} {
        set name ::$name
        set value [set $name]
        if {[string is boolean -strict $value]} {
            $self setstate $value
        }
    }
    #
    # Set the led on.
    #
    method on {} {
        if {$options(-variable) ne ""} {
            set ::$options(-variable) 1
        } else {
            $self setstate 1
        }
    }
    # set the led off
    #
    method off {} {
        if {$options(-variable) ne ""} {
            set ::$options(-variable) 0
        } else {
            $self setstate 0
        }
    }
    #
    # Set the led state
    #
    method setstate {value} {
        if {$value} {
            $win.led itemconfigure 1 -fill $options(-on)
        } else {
            $win.led itemconfigure 1 -fill $options(-off)
        }
    }
}

Added scriptlibs/tklib0.7/controlwidget/pkgIndex.tcl.







































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# pkgIndex.tcl --
#     Index script for controlwidget package
#     Note:
#     We could split this into several parts. Now it is presented
#     as a single package.
#
if {![package vsatisfies [package provide Tcl] 8.5]} {
    # PRAGMA: returnok
    return
}

package ifneeded controlwidget 0.1 [list source [file join $dir controlwidget.tcl]]
package ifneeded meter         1.0 [list source [file join $dir vertical_meter.tcl]]
package ifneeded led           1.0 [list source [file join $dir led.tcl]]
package ifneeded rdial         0.7 [list source [file join $dir rdial.tcl]]
package ifneeded tachometer    0.1 [list source [file join $dir tachometer.tcl]]
package ifneeded voltmeter     0.1 [list source [file join $dir voltmeter.tcl]]
package ifneeded radioMatrix   1.0 [list source [file join $dir radioMatrix.tcl]]
package ifneeded bindDown      1.0 [list source [file join $dir bindDown.tcl]]

Added scriptlibs/tklib0.7/controlwidget/radioMatrix.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
#
#    This software is Copyright by the Board of Trustees of Michigan
#    State University (c) Copyright 2005.
#
#    You may use this software under the terms of the GNU public license
#    (GPL) ir the Tcl BSD derived license  The terms of these licenses
#     are described at:
#
#     GPL:  http://www.gnu.org/licenses/gpl.txt
#     Tcl:  http://www.tcl.tk/softare/tcltk/license.html
#     Start with the second paragraph under the Tcl/Tk License terms
#     as ownership is solely by Board of Trustees at Michigan State University.
#
#     Author:
#            Ron Fox
#            NSCL
#            Michigan State University
#            East Lansing, MI 48824-1321
#


#  Provide a megawidget that is a matrix of radio buttons
#  and a variable that is tracked.  The idea is that this
#  can be used to control a device that has an enumerable
#  set of values.
#
# OPTIONS:
#   -orient  Determines the order in which the radio buttons are
#            laid out:
#            vertical - buttons run from top to bottom then left to right.
#            horizontal - buttons run from left to right top to bottom.
#   -columns Number of columns.
#   -rows    Number of rows.
#   -values  Contains a list of values.  Each element of the list is either
#            a single element, which represents the value of the button or
#            is a pair of values that represent a name/value pair for the button.
#            If -values is provided, only one of -rows/-columns can be provided.
#            If -values is not provided, both -rows and -columns must be provided
#            and the label name/value pairs are 1,2,3,4,5...
#   -variable Variable to track in the widget.
#   -command  Script to run when a radio button is clicked.
#
# METHODS:
#    get   - Gets the current button value.
#    set   - Sets the current button value (-command is invoked if defined).
# NOTES:
#   1. See the constraints on the options described above.
#   2. If, on entry, the variable (either global or fully namespace qualified
#      is set and matches a radio button value, that radio button is initially
#      lit.
#   3. The geometric properties of the widget can only be established at
#      construction time, and are therefore static.

package provide radioMatrix 1.0
package require Tk
package require snit
package require bindDown

namespace eval controlwidget {
    namespace export radioMatrix
}

snit::widget  ::controlwidget::radioMatrix {

    delegate option -variable to label as -textvariable
    delegate option * to hull


    option -orient   horizontal
    option -rows     {1}
    option -columns  {}
    option -values   [list]
    option -command  [list]


    variable radioVariable;             # for the radio button.

    # Construct the widget.

    constructor args {

        # The buttons go in a frame just to make it easy to lay them out.:

        set bf [frame $win.buttons]
        install label using label $win.label

        # Process the configuration.

        $self configurelist $args


        # Ensure that the option constraints are met.

        $self errorIfConstraintsNotMet

        # If the values have not been provided, then use the rows/columns
        # to simluate them.

        if {$options(-values) eq ""}  {
            set totalValues [expr $options(-columns) * $options(-rows)]
            for {set i 0} {$i < $totalValues} {incr i} {
                lappend options(-values) $i
            }
        }

        # Top level layout decision based on orientation.

        if {$options(-orient) eq "horizontal"} {
            $self arrangeHorizontally
        } elseif {$options(-orient) eq "vertical"} {
            $self arrangeVertically
        } else {
            error "Invalid -orient value: $options(-orient)"
        }

        grid $bf
        grid $win.label

        # If the label has a text variable evaluate it to see
        # if we can do a set with it:

        set labelvar [$win.label cget -textvariable]
        if {$labelvar ne ""} {
            $self Set [set ::$labelvar]
        }
        bindDown $win $win
    }

    # Public methods:

    method get {} {
        return $radioVariable
    }
    method set value {

        set radioVariable $value

    }


    # Private methods and procs.

    # Ensure the constraints on the options are met.

    method errorIfConstraintsNotMet {} {
        if {$options(-values) eq "" &&
            ($options(-rows) eq "" || $options(-columns) eq "")} {
            error "If -values is not supplied, but -rows and -coumns must be."
        }
        if {($options(-rows) ne "" && $options(-columns) ne "") &&
            $options(-values) ne ""} {
            error "If both -rows and -coumns were supplied, -values cannot be"
        }
    }


    # Process radio button change.
    #
    method onChange {} {
        set script $options(-command)
        if {$script ne ""} {
            eval $script
        }
    }
    # Manage horizontal layout

    method arrangeHorizontally {} {
        #
        # Either both rows and columns are defined, or
        # one is defined and the other must be computed from the
        # length of the values list (which by god was defined).
        # If both are defined, values was computed from them.

        set rows $options(-rows)
        set cols $options(-columns)

        # Only really need # of cols.

        set len  [llength $options(-values)]
        if {$cols eq ""} {
            set cols [expr ($len + $rows  - 1)/$rows]
        }
        set index  0
        set rowNum 0

        while {$index < $len} {
            for {set i 0} {$i < $cols} {incr i} {
                if {$index >= $len} {
                    break
                }
                set item [lindex $options(-values) $index]

                if {[llength $item] > 1} {
                    set label [lindex $item 0]
                    set value [lindex $item 1]
                } else {
                    set value [lindex $item 0]
                    set label $value
                }
                radiobutton $win.buttons.cb$index \
                    -command [mymethod onChange]  \
                    -variable ${selfns}::radioVariable  \
                    -value $value -text $label
                grid $win.buttons.cb$index -row $rowNum -column $i
                incr index
            }
            incr rowNum
        }

    }


    # manage vertical layout

    method arrangeVertically {} {
        #
        # See arrangeHorizontally for the overall picture, just swap cols
        # and rows.

        set rows $options(-rows)
        set cols $options(-columns)

        set len [llength $options(-values)]
        if {$rows eq ""} {
            set rows [expr ($len + $cols -1)/$cols]
        }
        set index  0
        set colNum 0
        while {$index < $len} {
            for {set i 0} {$i < $rows} {incr i} {
                if {$index >= $len} {
                    break
                }
                set item [lindex $options(-values) $index]
                if {[llength $item] > 1} {
                    set label [lindex $item 0]
                    set value [lindex $item 1]
                } else {
                    set value [lindex $item 0]
                    set label $value
                }

                radiobutton $win.buttons.cb$index \
                    -command [mymethod onChange]  \
                    -variable ${selfns}::radioVariable \
                    -value $value -text $label
                grid $win.buttons.cb$index -row $i -column $colNum
                incr index
            }
            incr colNum
        }
    }
}

Added scriptlibs/tklib0.7/controlwidget/rdial.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
# rdial.tcl --
#     Rotated dial widget, part of controlwidget package
#
# Contents: a "rotated" dial widget or thumbnail "roller" dial
# Date: Son May 23, 2010
#
# Abstract
#   A mouse draggable "dial" widget from the side view - visible
#   is the knurled area - Shift & Ctrl changes the sensitivity
#
# Copyright (c) Gerhard Reithofer, Tech-EDV 2010-05
#
# Adjusted for Tklib (snitified) by Arjen Markus
#
# The author  hereby grant permission to use,  copy, modify, distribute,
# and  license this  software  and its  documentation  for any  purpose,
# provided that  existing copyright notices  are retained in  all copies
# and that  this notice  is included verbatim  in any  distributions. No
# written agreement, license, or royalty  fee is required for any of the
# authorized uses.  Modifications to this software may be copyrighted by
# their authors and need not  follow the licensing terms described here,
# provided that the new terms are clearly indicated on the first page of
# each file where they apply.
#
# IN NO  EVENT SHALL THE AUTHOR  OR DISTRIBUTORS BE LIABLE  TO ANY PARTY
# FOR  DIRECT, INDIRECT, SPECIAL,  INCIDENTAL, OR  CONSEQUENTIAL DAMAGES
# ARISING OUT  OF THE  USE OF THIS  SOFTWARE, ITS DOCUMENTATION,  OR ANY
# DERIVATIVES  THEREOF, EVEN  IF THE  AUTHOR  HAVE BEEN  ADVISED OF  THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE  AUTHOR  AND DISTRIBUTORS  SPECIFICALLY  DISCLAIM ANY  WARRANTIES,
# INCLUDING,   BUT   NOT  LIMITED   TO,   THE   IMPLIED  WARRANTIES   OF
# MERCHANTABILITY,    FITNESS   FOR    A    PARTICULAR    PURPOSE,   AND
# NON-INFRINGEMENT. THIS  SOFTWARE  IS  PROVIDED  ON AN "AS  IS"  BASIS,
# AND  THE  AUTHOR  AND  DISTRIBUTORS  HAVE  NO  OBLIGATION  TO  PROVIDE
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#
# Original syntax:
#
# Syntax:
#   rdial::create w ?-width wid? ?-height hgt?  ?-value floatval?
#        ?-bg|-background bcol? ?-fg|-foreground fcol? ?-step step?
#        ?-callback script? ?-scale "degrees"|"radians"|factor?
#        ?-slow sfact? ?-fast ffact? ?-orient "horizontal"|"vertical"?
#        ?-variable varname? ?-bindwheel step?
#
# History:
#  20100526: -scale option added
#  20100626: incorrect "rotation direction" in vertical mode repaired
#  20100704: added -variable option and methods get and set (AM)
#  20101020: bug {[info exists ...]<0} => {![info exists ...]} repaired
#  20101112: drag: set opt(-value) depending on scale - thank's Manfred R.
#  20101118: -variable option added
#  20170518: -bindwheel option added for scrollwheel input
#  20170523: boolean variable buttonwheel controls Button/Wheel binding.
#            if false the <BindWheel> event is used (by default in Windows),
#            the event <ButtonPress-4/5> if it is false (other systems).
#
# Todo:
#    option -variable -- conflicts with -value
#    methods get and set
#

package require Tk 8.5
package require snit

namespace eval controlwidget {
    namespace export rdial
}

# rdial --
#     Rotated dial widget
#
snit::widget controlwidget::rdial {

    #
    # widget default values
    #
    option -bg         -default "#dfdfdf"  -configuremethod SetOption
    option -background -default "#dfdfdf"  -configuremethod SetOption
    option -fg         -default "black"    -configuremethod SetOption
    option -foreground -default "black"    -configuremethod SetOption
    option -callback   -default ""
    option -orient     -default horizontal
    option -width      -default 80         -configuremethod SetOption
    option -height     -default 8          -configuremethod SetOption
    option -step       -default 10
    option -value      -default 0.0        -configuremethod SetOption
    option -slow       -default 0.1
    option -fast       -default 10
    option -scale      -default 1.0        -configuremethod SetOption
    option -variable   -default {}         -configuremethod VariableName
    option -bindwheel  -default 2.0        -configuremethod SetOption

    variable d2r
    variable sfact
    variable ssize
    variable ovalue
    variable sector    88
    variable callback
    variable buttonwheel 1
    variable wheelfactor 15.0


    constructor args {

        # I did not find a platform independent method :-(
        if {$::tcl_platform(platform) eq "windows"} {
            set buttonwheel 0
        }

        #
        # A few constants to reduce expr
        #
        set d2r   [expr {atan(1.0)/45.0}]
        set ssize [expr {sin($sector*$d2r)}]

        #
        # Now initialise the widget
        #
        $self configurelist $args

        canvas $win.c   \
            -background $options(-background)

        grid $win.c -sticky nsew

        set wid $options(-width)
        set hgt $options(-height)
        set bgc $options(-background)

        # canvas dimensions and bindings
        if {$options(-orient) eq "horizontal"} {
            $win.c configure -width $wid -height $hgt
            # standard bindings
            bind $win.c <ButtonPress-1> [list $self SetVar ovalue %x]
            bind $win.c <B1-Motion>       [list $self drag %W %x 0]
            bind $win.c <ButtonRelease-1> [list $self drag %W %x 0]
            # course movement
            bind $win.c <Shift-ButtonPress-1> [list $self SetVar ovalue %x]
            bind $win.c <Shift-B1-Motion>       [list $self drag %W %x 1]
            bind $win.c <Shift-ButtonRelease-1> [list $self drag %W %x 1]
            # fine movement
            bind $win.c <Control-ButtonPress-1> [list $self SetVar ovalue %x]
            bind $win.c <Control-B1-Motion>       [list $self drag %W %x -1]
            bind $win.c <Control-ButtonRelease-1> [list $self drag %W %x -1]
        } else {
            $win.c configure -width $hgt -height $wid
            # standard binding
            bind $win.c <ButtonPress-1> [list $self SetVar ovalue %y]
            bind $win.c <B1-Motion>       [list $self drag %W %y 0]
            bind $win.c <ButtonRelease-1> [list $self drag %W %y 0]
            # course movement
            bind $win.c <Shift-ButtonPress-1> [list $self SetVar ovalue %y]
            bind $win.c <Shift-B1-Motion>       [list $self drag %W %y 1]
            bind $win.c <Shift-ButtonRelease-1> [list $self drag %W %y 1]
            # fine movement
            bind $win.c <Control-ButtonPress-1> [list $self SetVar ovalue %y]
            bind $win.c <Control-B1-Motion>       [list $self drag %W %y -1]
            bind $win.c <Control-ButtonRelease-1> [list $self drag %W %y -1]
        }
        if {$options(-bindwheel) != 0} {
            if {$buttonwheel} {
                set up $options(-bindwheel)
                set dn [expr {0.0 - $up}]
                # standard binding
                bind $win.c <ButtonPress-4> [list $self roll %W $up 0]
                bind $win.c <ButtonPress-5> [list $self roll %W $dn 0]
                # course movement
                bind $win.c <Shift-ButtonPress-4> [list $self roll %W $up 1]
                bind $win.c <Shift-ButtonPress-5> [list $self roll %W $dn 1]
                # fine movement
                bind $win.c <Control-ButtonPress-4> [list $self roll %W $up -1]
                bind $win.c <Control-ButtonPress-5> [list $self roll %W $dn -1]
            } else {
                # it seem that Shift+Control doesn't work :-(
                bind $win.c <MouseWheel> [list $self roll %W %D 0]
                bind $win.c <Shift-MouseWheel> [list $self roll %W %D 1]
                bind $win.c <Control-MouseWheel> [list $self roll %W %D -1]
            }
        }

        if {$options(-variable) ne ""} {
            if { [info exists ::$options(-variable)] } {
                set options(-value) [set ::$options(-variable)]
            } else {
                set ::options(-variable) [expr {$options(-value)*$options(-scale)}]
            }

            trace add variable ::$options(-variable) write [mymethod variableChanged]
        }

        # draw insides
        $self draw $win.c $options(-value)
    }

    #
    # public methods --
    #

    method set {newValue} {
        if { $options(-variable) != "" } {
            set ::$options(-variable) $newValue   ;#! This updates the dial too
        } else {
            set options(-value) $newValue
            $self draw $win.c $options(-value)
        }
    }
    method get {} {
        return $options(-value)
    }

    #
    # private methods --
    #

    # store some private variable
    method SetVar {var value} {
        set $var $value
    }

    # configure method - write only
    method SetOption {option arg} {
        switch -- $option {
            "-bg" {set option "-background"}
            "-fg" {set option "-foreground"}
            "-scale" {
                 switch -glob -- $arg {
                     "d*" {set arg 1.0}
                     "r*" {set arg $d2r}
                 }
                 # numeric check
                 set arg [expr {$arg*1.0}]
            }
            "-value" {
                  set arg [expr {$arg/$options(-scale)}]
            }
            "-height" {
                if { [winfo exists $win.c] } {
                    $win.c configure $option $arg
                }
            }
            "-width" {
                if { [winfo exists $win.c] } {
                    $win.c configure $option $arg
                }
                # sfact depends on width
                set sfact [expr {$ssize*2/$arg}]
            }
        }
        set options($option) $arg

        if { [winfo exists $win.c] } {
            $self draw $win.c $options(-value)
        }
    }

    method VariableName {option name} {

        # Could be still constructing in which case
        # $win.c does not exist:

        if {![winfo exists $win.c]} {
            set options(-variable) $name
            return;
        }

        # Remove any old traces

        if {$options(-variable) ne ""} {
            trace remove variable ::$options(-variable) write [mymethod variableChanged]
        }

        # Set new trace if appropriate and update value.

        set options(-variable) $name
        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod variableChanged]
            $self draw $win.c [set ::$options(-variable)]
        }
    }

    method variableChanged {name1 name2 op} {

        set options(-value) [expr {[set ::$options(-variable)]/$options(-scale)}]
        $self draw $win.c [set ::$options(-variable)]

        if { $options(-callback) ne "" } {
            {*}$options(-callback) [expr {$options(-value)*$options(-scale)}]
        }
    }


    # cget method
    proc GetOption {option} {
        if { $option eq "-value" } {
            return [expr {$options(-value)*$options(-scale)}]
        } else  {
            return $options(-value)
        }
    }

    # draw the thumb wheel view
    method draw {w val} {

        set stp $options(-step)
        set wid $options(-width)
        set hgt $options(-height)
        set dfg $options(-foreground)
        set dbg $options(-background)

        $win.c delete all
        if {$options(-orient) eq "horizontal"} {
            # every value is mapped to the visible sector
            set mod [expr {$val-$sector*int($val/$sector)}]
            $win.c create rectangle 0 0 $wid $hgt -fill $dbg
            # from normalized value to left end
            for {set ri $mod} {$ri>=-$sector} {set ri [expr {$ri-$stp}]} {
                set offs [expr {($ssize+sin($ri*$d2r))/$sfact}]
                $win.c create line $offs 0 $offs $hgt -fill $dfg
            }
            # from normalized value to right end
            for {set ri [expr {$mod+$stp}]} {$ri<=$sector} {set ri [expr {$ri+$stp}]} {
                set offs [expr {($ssize+sin($ri*$d2r))/$sfact}]
                $win.c create line $offs 0 $offs $hgt -fill $dfg
            }
        } else {
            # every value is mapped to the visible sector
            set mod [expr {$sector*int($val/$sector)-$val}]
            $win.c create rectangle 0 0 $hgt $wid -fill $dbg
            # from normalized value to upper end
            for {set ri $mod} {$ri>=-$sector} {set ri [expr {$ri-$stp}]} {
                set offs [expr {($ssize+sin($ri*$d2r))/$sfact}]
                $win.c create line 0 $offs $hgt $offs -fill $dfg
            }
            # from normalized value to lower end
            for {set ri [expr {$mod+$stp}]} {$ri<=$sector} {set ri [expr {$ri+$stp}]} {
                set offs [expr {($ssize+sin($ri*$d2r))/$sfact}]
                $win.c create line 0 $offs $hgt $offs -fill $dfg
            }
        }
        # let's return the widget/canvas
        set options(-value) $val
    }

    # update rdials after value change
    method rdupdate {w diff} {
        # calculate "new" calue
        set options(-value) [expr {$options(-value)+$diff*$options(-scale)}]

        # call callback if defined...
        if {$options(-callback) ne ""} {
            {*}$options(-callback) $options(-value)
        }

        # draw knob with new angle
        $self draw $w $options(-value)
    }

    # change by mouse dragging
    method drag {w coord mode} {
        variable ovalue

        # calculate new value
        if {$options(-orient) eq "horizontal"} {
            set diff [expr {$coord-$ovalue}]
        } else  {
            set diff [expr {$ovalue-$coord}]
        }
        if {$mode<0} {
            set diff [expr {$diff*$options(-slow)}]
        } elseif {$mode>0} {
            set diff [expr {$diff*$options(-fast)}]
        }
        $self rdupdate $w $diff

        # store "old" value for diff
        set ovalue $coord
    }

    # change by mouse wheel
    method roll {w diff mode} {

        if {! $buttonwheel} {
            set diff [expr {$diff/$wheelfactor/$options(-bindwheel)}]
        }
        if {$mode<0} {
            set diff [expr {$diff*$options(-slow)}]
        } elseif {$mode>0} {
            set diff [expr {$diff*$options(-fast)}]
        }
        $self rdupdate $w $diff
    }
}

# Announce our presence
package provide rdial 0.7

#-------- test & demo ... disable it for package autoloading -> {0}
if {0} {
    if {[info script] eq $argv0} {
        array set disp_value {rs -30.0 rh 120.0 rv 10.0}
        proc rndcol {} {
            set col "#"
            for {set i 0} {$i<3} {incr i} {
                append col [format "%02x" [expr {int(rand()*230)+10}]]
            }
            return $col
        }
        proc set_rand_col {} {
            .rs configure -fg [rndcol] -bg [rndcol]
        }
        proc show_value {which v} {
            set val [.$which cget -value]
            set ::disp_value($which) [format "%.1f" $val]
            switch -- $which {
                "rh" {
                    if {abs($val)<30} return
                    .rs configure -width [expr {abs($val)}]
                }
                "rv" {
                    if {abs($val)<5}  return
                    .rs configure -height [expr {abs($val)}]
                }
                "rs" {
                    if {!(int($val)%10)} set_rand_col
                }
            }
        }
        set help "Use mouse button with Shift &"
        append help "\nControl for dragging the dials"
        append help "\nwith Mouswheel support"
        label .lb -text $help
        label .lv -textvariable disp_value(rv)
        controlwidget::rdial .rv -callback {show_value rv} -value $disp_value(rv)\
                -width 200 -step 5 -bg blue -fg white \
                -variable score -bindwheel -10.0
        label .lh -textvariable disp_value(rh)
        controlwidget::rdial .rh -callback {show_value rh} -value $disp_value(rh)\
                -width $disp_value(rh) -height 20 -fg blue -bg yellow -orient vertical
        label .ls -textvariable disp_value(rs)
        controlwidget::rdial .rs -callback {show_value rs} -value $disp_value(rs)\
                -width $disp_value(rh) -height $disp_value(rv)
        pack {*}[winfo children .]
        wm minsize . 220 300

        after 2000 {
            set ::score 0.0
        }
        after 3000 {
            set ::score 100.0
            .rh set 3
        }
    }
}

Added scriptlibs/tklib0.7/controlwidget/tachometer.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
# tachometer.tcl --
#
# Adapted by Arjen Markus (snitified), july 2010
#
# TODO:
#     motion through the start and end - it can jump through the gap
#     scaling (scale widget)
#     deal with sizes of the widget (aspect ratio != 1)
#
#
# Part of: The TCL'ers Wiki
# Contents: a tachometer-like widget
# Date: Fri Jun 13, 2003
#
# Abstract
#
#
#
# Copyright (c) 2003 Marco Maggi
#
# The author  hereby grant permission to use,  copy, modify, distribute,
# and  license this  software  and its  documentation  for any  purpose,
# provided that  existing copyright notices  are retained in  all copies
# and that  this notice  is included verbatim  in any  distributions. No
# written agreement, license, or royalty  fee is required for any of the
# authorized uses.  Modifications to this software may be copyrighted by
# their authors and need not  follow the licensing terms described here,
# provided that the new terms are clearly indicated on the first page of
# each file where they apply.
#
# IN NO  EVENT SHALL THE AUTHOR  OR DISTRIBUTORS BE LIABLE  TO ANY PARTY
# FOR  DIRECT, INDIRECT, SPECIAL,  INCIDENTAL, OR  CONSEQUENTIAL DAMAGES
# ARISING OUT  OF THE  USE OF THIS  SOFTWARE, ITS DOCUMENTATION,  OR ANY
# DERIVATIVES  THEREOF, EVEN  IF THE  AUTHOR  HAVE BEEN  ADVISED OF  THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE  AUTHOR  AND DISTRIBUTORS  SPECIFICALLY  DISCLAIM ANY  WARRANTIES,
# INCLUDING,   BUT   NOT  LIMITED   TO,   THE   IMPLIED  WARRANTIES   OF
# MERCHANTABILITY,    FITNESS   FOR    A    PARTICULAR   PURPOSE,    AND
# NON-INFRINGEMENT.  THIS  SOFTWARE IS PROVIDED  ON AN "AS  IS" BASIS,
# AND  THE  AUTHOR  AND  DISTRIBUTORS  HAVE  NO  OBLIGATION  TO  PROVIDE
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#
# $Id: tachometer.tcl,v 1.4 2010/09/10 17:16:29 andreas_kupries Exp $
#

package require Tk  8.5
package require snit
package provide tachometer 0.1

namespace eval controlwidget {
    namespace export tachometer
}

# tachometer --
#     Tachometer-like widget
#
snit::widget controlwidget::tachometer {

    #
    # widget default values
    #
    option -borderwidth    -default 1
    option -title          -default speed
    option -labels         -default {}
    option -resolution     -default 1
    option -showvalue      -default 1
    option -variable       -default {}      -configuremethod VariableName

    option -min            -default 0.0
    option -max            -default 100.0
    option -dangerlevel    -default 90.0
    option -dangercolor    -default red
    option -dangerwidth    -default 3m
    option -dialcolor      -default white
    option -pincolor       -default red
    option -indexid        -default {}

    option -background         -default gray
    option -width              -default 50m
    option -height             -default 50m
    option -foreground         -default black
    option -highlightthickness -default 0
    option -relief             -default raised

    variable pi [expr {3.14159265359/180.0}]
    variable xc
    variable yc
    variable motion

    constructor args {

        #
        # Configure the widget
        #
        $self configurelist $args

        canvas $win.c -background $options(-background) -width $options(-width) -height $options(-height) \
                      -relief $options(-relief) -borderwidth $options(-borderwidth)
        grid $win.c -sticky news

        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod tracer $options(-variable)]
        }

        #
        # Draw the tachometer
        #
        set width  [$win.c cget -width]
        set height [$win.c cget -height]
        set num    [llength $options(-labels)]
        set delta  [expr {(360.0-40.0)/($num-1)}]

        # display
        set x1 [expr {$width/50.0*2.0}]
        set y1 [expr {$width/50.0*2.0}]
        set x2 [expr {$width/50.0*48.0}]
        set y2 [expr {$width/50.0*48.0}]
        $win.c create oval $x1 $y1 $x2 $y2 -fill $options(-dialcolor) -width 1 -outline lightgray
        shadowcircle $win.c $x1 $y1 $x2 $y2 40 0.7m 135.0

        # pin
        set x1 [expr {$width/50.0*23.0}]
        set y1 [expr {$width/50.0*23.0}]
        set x2 [expr {$width/50.0*27.0}]
        set y2 [expr {$width/50.0*27.0}]
        $win.c create oval $x1 $y1 $x2 $y2 -width 1 -outline lightgray -fill $options(-pincolor)
        shadowcircle $win.c $x1 $y1 $x2 $y2 40 0.7m -45.0

        # danger marker
        if { $options(-dangerlevel) != {} && $options(-dangerlevel) < $options(-max)} {

            set deltadanger [expr {(360.0-40.0)*($options(-max)-$options(-dangerlevel))/(1.0*$options(-max)-$options(-min))}]

            # Transform the thickness into a plain number (if given in mm for instance)
            set id [$win.c create line 0 0 1 0]
            $win.c move $id $options(-dangerwidth) 0
            set coords    [$win.c coords $id]
            set thickness [expr {[lindex $coords 0]/2.0}]
            $win.c delete $id

            # Create the arc for the danger level
            $win.c create arc \
                [expr {$width/50.0*4.0+$thickness}]  [expr {$width/50.0*4.0+$thickness}] \
                [expr {$width/50.0*46.0-$thickness}] [expr {$width/50.0*46.0-$thickness}] \
                -start -70 -extent $deltadanger -style arc \
                -outline $options(-dangercolor) -fill $options(-dangercolor) -width $options(-dangerwidth)
        }

        # graduate line
        set x1 [expr {$width/50.0*4.0}]
        set y1 [expr {$width/50.0*4.0}]
        set x2 [expr {$width/50.0*46.0}]
        set y2 [expr {$width/50.0*46.0}]
        $win.c create arc $x1 $y1 $x2 $y2 \
            -start -70 -extent 320 -style arc \
            -outline black -width 0.5m
        set xc [expr {($x2+$x1)/2.0}]
        set yc [expr {($y2+$y1)/2.0}]

        set motion 0
        bind $win.c <ButtonRelease>  [list $self needleRelease %W]
        bind $win.c <Motion>         [list $self needleMotion %W %x %y]

        set half [expr {$width/2.0}]
        set l1 [expr {$half*0.85}]
        set l2 [expr {$half*0.74}]
        set l3 [expr {$half*0.62}]

        set angle  110.0
        for {set i 0} {$i < $num} {incr i} \
        {
            set a [expr {($angle+$delta*$i)*$pi}]

            set x1 [expr {$half+$l1*cos($a)}]
            set y1 [expr {$half+$l1*sin($a)}]
            set x2 [expr {$half+$l2*cos($a)}]
            set y2 [expr {$half+$l2*sin($a)}]
            $win.c create line $x1 $y1 $x2 $y2 -fill black -width 0.5m

            set x1 [expr {$half+$l3*cos($a)}]
            set y1 [expr {$half+$l3*sin($a)}]

            set label [lindex $options(-labels) $i]
            if { [string length $label] } \
            {
               $win.c create text $x1 $y1 \
                   -anchor center -justify center -fill black \
                   -text $label -font { Helvetica 10 }
            }
        }

        rivet $win.c 10 10
        rivet $win.c [expr {$width-10}] 10
        rivet $win.c 10 [expr {$height-10}]
        rivet $win.c [expr {$width-10}] [expr {$height-10}]

        set value 0
        $self drawline $win $value
    }

    method destructor { widget } \
    {
        set varname [option get $widget varname {}]
        trace remove variable $varname write \
         [namespace code "tracer $widget $varname"]
    }

    #
    # public methods --
    #
    method set {newValue} {
        if { $options(-variable) != "" } {
            set ::$options(-variable) $newValue   ;#! This updates the dial too
        } else {
            set options(-value) $newValue
            $self draw $win.c $options(-value)
        }
    }
    method get {} {
        return $options(-value)
    }


    #
    # private methods --
    #

    method VariableName {option name} {

        # Could be still constructing in which case
        # $win.c does not exist:

        if {![winfo exists $win.c]} {
            set options(-variable) $name
            return;
        }

        # Remove any old traces

        if {$options(-variable) ne ""} {
            trace remove variable ::$options(-variable) write [mymethod tracer $options(-variable)]
        }

        # Set new trace if appropriate and update value.

        set options(-variable) $name
        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod tracer $options(-variable)]
            $self drawline $win.c [set ::$options(-variable)]
        }
    }
    method tracer { varname args } \
    {
        set options(-value) [set ::$varname]
        $self drawline $win [set ::$varname]
    }

    method drawline { widget value } \
    {
        set c $widget.c

        set min  $options(-min)
        set max  $options(-max)
        set id   $options(-indexid)

        set v [expr { ($value <= ($max*1.02))? $value : ($max*1.02) }]
        set angle [expr {((($v-$min)/($max-$min))*320.0+20.0)*$pi}]

        set width  [$c cget -width]
        set half [expr {$width/2.0}]
        set length [expr {$half*0.8}]

        set xl [expr {$half-$length*sin($angle)}]
        set yl [expr {$half+$length*cos($angle)}]

        set xs [expr {$half+0.2*$length*sin($angle)}]
        set ys [expr {$half-0.2*$length*cos($angle)}]

        catch {$c delete $id}
        set id [$c create line $xs $ys $xl $yl -fill $options(-pincolor) -width 0.6m]
        $c bind $id <ButtonPress> [list $self needlePress %W]
        set options(-indexid) $id
    }

    method needlePress {w} \
    {
        set motion 1
    }

    method needleRelease {w} \
    {
        set motion 0
    }

    method needleMotion {w x y} \
    {
        if {! $motion} { return }
        if {$y == $yc && $x == $xc} { return }

        #
        # Compute the angle with the positive y-axis - easier to examine!
        #
        set angle [expr {atan2($xc - $x,$yc - $y) / $pi}]
        if { $angle >= 160.0 } {
            set angle 160.0
        }
        if { $angle < -160.0 } {
            set angle -160.0
        }
        set ::$options(-variable) [expr {$options(-min) + ($options(-max)-$options(-min))*(160.0-$angle) / 320.0}]
    }

    proc rivet { c xc yc } \
    {
        set width 5
        set bevel 0.5m
        set angle -45.0
        set ticks 7
          shadowcircle $c \
           [expr {$xc-$width}] [expr {$yc-$width}] [expr {$xc+$width}] [expr {$yc+$width}] \
           $ticks $bevel $angle
    }

    proc shadowcircle { canvas x1 y1 x2 y2 ticks width orient } \
    {
        set angle $orient
        set delta [expr {180.0/$ticks}]
        for {set i 0} {$i <= $ticks} {incr i} \
        {
           set a [expr {($angle+$i*$delta)}]
           set b [expr {($angle-$i*$delta)}]

           set color [expr {40+$i*(200/$ticks)}]
           set color [format "#%x%x%x" $color $color $color]

           $canvas create arc $x1 $y1 $x2 $y2 -start $a -extent $delta \
             -style arc -outline $color -width $width
           $canvas create arc $x1 $y1 $x2 $y2 -start $b -extent $delta \
             -style arc -outline $color -width $width
        }
    }
}

if {0} {
# main --
#     Demonstration of the tachometer object
#
proc main { argc argv } \
{
    global forever

    wm withdraw .
    wm title . "A tachometer-like widget"
    wm geometry . +10+10

    controlwidget::tachometer .t1 -variable ::value1 -labels { 0 10 20 30 40 50 60 70 80 90 100 } \
       -pincolor green -dialcolor lightpink
    scale .s1 -command "set ::value1" -variable ::value1

    #
    # Note: the labels are not used in the scaling of the values
    #
    controlwidget::tachometer .t2 -variable ::value2 -labels { 0 {} {} 5 {} {} 10 } -width 100m -height 100m \
        -min 0 -max 10 -dangerlevel 3
    scale .s2 -command "set ::value2" -variable ::value2 -from 0 -to 10

    button .b -text Quit -command "set ::forever 1"

    grid .t1 .s1 .t2 .s2 .b -padx 2 -pady 2
    wm deiconify .

    console show


    vwait forever
    #tachometer::destructor .t1
    #tachometer::destructor .t2
    exit 0
}

main $argc $argv
}

### end of file
# Local Variables:
# mode: tcl
# page-delimiter: "^#PAGE"
# End:

Added scriptlibs/tklib0.7/controlwidget/vertical_meter.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
# vertical_meter.tcl --
#    Implement various meter types
#
#    This software is Copyright by the Board of Trustees of Michigan
#    State University (c) Copyright 2005.
#
#    You may use this software under the terms of the GNU public license
#    (GPL) ir the Tcl BSD derived license  The terms of these licenses
#     are described at:
#
#     GPL:  http://www.gnu.org/licenses/gpl.txt
#     Tcl:  http://www.tcl.tk/softare/tcltk/license.html
#     Start with the second paragraph under the Tcl/Tk License terms
#     as ownership is solely by Board of Trustees at Michigan State University.
#
#     Author:
#             Ron Fox
#             NSCL
#             Michigan State University
#             East Lansing, MI 48824-1321
#
#     Adjusted by Arjen Markus
#
#     TODO:
#     Add options:
#     -readonly, -arrowthickness, -arrowcolor, -background/-bg
#     -majorticklength, -minorticklength
#     -drawaxle
#
#     Add features/TODO:
#     - proper update if to/from changes
#     - unit tests
#     - check behaviour if no variable defined
#
#     Add widgets:
#     - shiftbar (or what is the best name?)
#     - equalizer bars
#
#
#

#  Implements a 'meter' megawidget.  A meter is a
#  box with a needle that goes up and down between
#  two possible limits.
#
# This is drawn in a canvas as follows:
#    +-------+
#    |       |
#    |  <----|
#    | ...
#    +-------+
#
#
# OPTIONS:
#    -from        - Value represented by the lower limit of the meter.  (dynamic)
#    -to          - Value represented by the upper limit of the meter.  (dynamic)
#    -height      - Height of the meter.                                (static)
#    -width       - Width of the meter.                                 (static)
#    -variable    - Variable the meter will track.                      (dynamic)
#    -majorticks  - Interval between major (labelled) ticks.            (dynamic)
#    -minorticks  - Number of minor ticks drawn between major ticks.    (dynamic)
#    -log         - True if should be log scale                         (dynamic).
#
# Methods:
#    set value    - Set the meter to a specific value (if -variable is defined it is modified).
#    get          - Returns the current value of the meter.

package provide meter 1.0
package require Tk
package require snit
package require bindDown

namespace eval controlwidget {
    namespace export meter
    namespace export slider
    namespace export equalizerBar
    namespace export thermometer
}

# verticalAxis --
#     Private type for handling a vertical axis
#     Some options are obligatory
#
snit::type controlwidget::verticalAxis {

    option -canvas       {}
    option -x            {}
    option -xright       {}
    option -ytop         {}
    option -ybottom      {}
    option -axisformat   -default %.2g    -configuremethod SetAxisProperty
    option -axisfont     -default {fixed} -configuremethod SetAxisProperty
    option -axiscolor    black
    option -drawaxle     1
    option -from         -default -1.0    -configuremethod SetAxisRange
    option -to           -default  1.0    -configuremethod SetAxisRange
    option -majorticks   -default  1.0    -configuremethod SetAxisProperty
    option -minorticks   -default  4      -configuremethod SetAxisProperty
    option -log          -default  false  -configuremethod SetAxisType
    option -axisstyle    -default  left

    variable majorlength 7
    variable valueRange

    constructor args {
         $self configurelist $args
    }

    method drawAxis {} {
         if { $options(-drawaxle) } {
             $options(-canvas) create line $options(-x) $options(-ytop) $options(-x) $options(-ybottom) \
                 -fill $options(-axiscolor) -tags axis
         }
         $self drawTicks
    }


    # Draw the tick marks on the axis face.  The major ticks are
    # labelled, while the minor ticks are just some length.
    # Major ticks extend from the meter left edge to 1/5 the width of the meter
    # while minor ticks extend from the meter left edge to 1/10 the width of the meter.
    # Tick labels are drawn at x coordinate 0.
    #
    method drawTicks {} {

        if {!$options(-log)} {
            $self drawLinearTicks
        } else {
            $self drawLogTicks
        }
    }
    #
    #  Draw the ticks for a log scale.
    #
    method drawLogTicks {} {
        set decades     [$self computeDecades];       # Range of axis ...
        set majorRight  [$self getMajorRight];        # Right end coordinate of major tick.
        set minorRight  [$self getMinorRight];        # Right end coord of minor tick.
        set xleft       $options(-x)

        #  Major ticks are easy.. they are at the decades.

        set range    [expr $options(-ytop) - $options(-ybottom)]
        set interval [expr $range/([llength $decades] -1) ];  # Space decades evenly.

        set pos   $options(ybottom)
        foreach decade $decades {
            $options(-canvas) create text $xleft $pos -text $decade -anchor e -font $options(-axisfont) \
                -fill $options(-axiscolor) -tags ticks
            $options(-canvas) create line $xleft $pos $majorRight $pos -fill $options(-axiscolor) -tags ticks]
            #
            #  Now the minor ticks... we draw for 1-9. of them in log spacing.
            #
            foreach mant [list 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0] {
                set ht [expr $pos + $interval*log10($mant)]
                $options(-canvas) create line $xleft $ht $minorRight $ht -fill $options(-axiscolor) -tags ticks]
            }
            set pos [expr $pos + $interval]
        }
    }
    #
    #  Draw the ticks for a linear scale:
    #
    method drawLinearTicks {} {
        set first $options(-from)
        set last  $options(-to)
        set major $options(-majorticks)
        set xleft $options(-x)


        # minor ticks are just given in terms of the # ticks between majors so:

        set minor [expr 1.0*$major/($options(-minorticks)+1)]

        # Figure out the right most coordinates of the tick lines.

        set majorRight [$self getMajorRight]
        set minorRight [$self getMinorRight]

        # the for loop is done the way it is in order to reduce
        # the cumulative roundoff error from repetitive summing.
        #
        set majorIndex 0
        for {set m $first} {$m <= $last} {set m [expr $first + $majorIndex*$major]} {
            # Draw a major tick label and the tick mark itself
            # major ticks are formatted in engineering notation (%.1e).

            set label [format $options(-axisformat) $m]
            set height [$self computeHeight $m]
            $options(-canvas) create text  $xleft $height -text $label -anchor e -font $options(-axisfont) \
                -fill $options(-axiscolor) -tags ticks]
            $options(-canvas) create line  $xleft $height $majorRight $height \
                -fill $options(-axiscolor) -tags ticks]

            for {set i 1} {$i <=  $options(-minorticks)} {incr i} {
                set minorH [expr $m + 1.0*$i*$minor]
                set minorH [$self computeHeight $minorH]
                $options(-canvas) create line $xleft $minorH $minorRight $minorH \
                -fill $options(-axiscolor) -tags ticks]
            }
            incr majorIndex
        }
    }
    #
    #  Erase the Tick ids from the meter:
    #
    method eraseTicks {} {
        $options(-canvas) delete ticks
    }
    #
    #     Compute the right x coordinate of the major ticks:
    #
    method getMajorRight {} {
        set majorRight  [expr {$options(-x) + $majorlength}]

        return $majorRight
    }
    #
    #    Compute the right x coordinate of the minor ticks:
    #
    method getMinorRight {} {
        set minorlength [expr  $majorlength/2]
        set minorRight  [expr $options(-x) + $minorlength]
        return $minorRight
    }

    # compute the decades in the plot.  This is also where we will complain if the
    # range covers 0 or a negative range as for now we only support positive log scales.
    # Returns a list of the decades e.g. {1.0e-9 1.0e-08 1.0e-7}  that cover the range.
    # The low decade truncates.  The high one is a ceil.
    #

    method computeDecades {} {
        set low $options(-from)

        if {$low <= 0.0} {
            return -code error "Log scale with negative or zero -from value is not supported"
        }
        set high $options(-to)
        if {$high <= 0.0} {
            return -code error "Log scale with negative or zero -to value no"
        }
        #
        set lowDecade  [expr log10($low)]
        if {$lowDecade < 0} {
            set lowDecade [expr $lowDecade - 0.5]
        }
        set lowDecade [expr int($lowDecade)]

        set result     [format "1.0e%02d" $lowDecade]
        set highDecade [expr log10($high)];               # Don't truncate...
        while {$lowDecade < $highDecade} {
            incr lowDecade
            lappend result [format "1.0e%02d" $lowDecade]
        }
        set decadeLow  [lindex $result 0]
        set decadeHigh [lindex $result end]
        return $result
    }

    # Compute the correct height of the needle given
    # A new coordinate value for it in needle units:

    method computeHeight needleCoords {
        if {$options(-log)} {
            return [$self computeLogHeight  $needleCoords]
        } else {
            return [$self computeLinearHeight $needleCoords]
        }
    }

    #  Compute the needle height if the scale is log.

    method computeLogHeight needleCoords {
        $self computeDecades
        #
        #  The following protect against range errors as well as
        #  negative/0 values:
        #
        if {$needleCoords < $decadeLow} {
            set needleCoords $decadeLow
        }
        if {$needleCoords > $decadeHigh} {
            set needleCoords $decadeHigh
        }

        #  Now it should be safe to do the logs:
        #  the scaling is just linear in log coords:

        set valueRange [expr {log10($decadeHigh) - log10($decadeLow)}]
        set value      [expr {log10($needleCoords) - log10($decadeLow)}]

        set pixelRange [expr {1.0*($options(-ybottom) - $options(-ytop)}]

        set height [expr {$value*$pixelRange/$valueRange}]
        return [expr {$options(-ybottom) - $height}]

    }

    #  Compute the needle height if the scale is linear
    #
    method  computeLinearHeight needleCoords {

        #
        # Peg the needle to the limits:
        #
        if {$needleCoords > $options(-to)}  {
            return $options(-ytop)
        }
        if {$needleCoords < $options(-from)} {
            return $options(-ybottom)
        }
        set pixelRange [expr {1.0*($options(-ybottom) - $options(-ytop))}]

        # Transform the coordinates:

        set valueRange [expr {1.0*($options(-to) - $options(-from))}]
        set height [expr {($needleCoords - $options(-from))*$pixelRange/$valueRange}]
        return [expr {$options(-ybottom) - $height}]
    }

    # Compute the correct value of the needle given the position

    method computeValue needleCoords {
        if {$options(-log)} {
            return [$self computeLogValue $needleCoords]
        } else {
            return [$self computeLinearValue $needleCoords]
        }
    }

    #  Compute the needle's value if the scale is log.

    method computeLogValue needleCoords {
        $self computeDecades
        #
        #  The following protect against range errors as well as
        #  negative/0 values:
        #
        if {$needleCoords < $options(-ytop)} {
            set needleCoords $options(-ytop)
        }
        if {$needleCoords > $options(-ybottom)} {
            set needleCoords $options(-ybottom)
        }

        set logScale   [expr {log10($decadeHigh/$decadeLow)}]
        set yratio     [expr {($y - $ymin) / double($ymax - $ymin)}]

        set value      [expr {$decadeLow * pow(10.0,$logScale*$yratio)}]

        return $value
    }

    #  Compute the needle's value if the scale is linear
    #
    method computeLinearValue needleCoords {

        #
        # Peg the needle to the limits:
        #
        if {$needleCoords < $options(-ytop)}  {
            return $options(-to)
        }
        if {$needleCoords > $options(-ybottom)} {
            return $options(-from)
        }

        set pixelRange [expr {1.0*($options(-ybottom) - $options(-ytop))}]

        # Transform the coordinates:

        set scaleFactor [expr {($options(-to) - $options(-from)) / $pixelRange}]
        set value       [expr {$options(-from) + ($options(-ybottom) - $needleCoords)*$scaleFactor}]

        return $value
    }

    #------------------------ Configuration handlers for dynamic options  ----
    #    -from        - Value represented by the lower limit of the meter.  (dynamic)
    #    -to          - Value represented by the upper limit of the meter.  (dynamic)
    #    -log         - Type of axis (linear or logarithmic)                (dynamic)
    #    -majorticks  - Interval between major (labelled) ticks.            (dynamic)
    #    -minorticks  - Number of minor ticks drawn between major ticks.    (dynamic)


    # Handle configure -to and -from
    # Need to set the stuff needed to scale the meter positions and reset the meter position.
    # Need to redraw ticks as well.
    #
    method SetAxisRange {option value} {
        set options($option) $value
        if {![winfo exists $win.c]} return;     # Still constructing.
        $self eraseTicks
        if { $option == "-from" } {
            set valueRange [expr $options(-to) - $value]
        } else {
            set valueRange [expr $value - $options(-from)]
        }
        $self drawTicks

        $self needleTo $lastValue
    }

    #  Handle configure -log
    #  Set the log flag accordingly and then redraw the ticks and value:
    #  Note that we must check the -from/-to and figure out the first decade
    #  and the last decade.
    #
    method SetAxisType {option value} {
        #  No change return.

        if {$value == $options(-log)}  return;    # short cut exit.

        # require booleanness.

        if {![string is boolean $value]} {
            return -error "meter.tcl - value of -log flag must be a boolean"
        }
        #  Set the new value and update the meter:

        set options(-log) $value
        if {!$constructing} {
            $self computeDecades
            $self eraseTicks
            $self drawTicks
            $self needleTo $lastValue
        }
    }

    # Handle a change in the axis' properties ... we just need to set the option and redraw the ticks.
    #
    method SetAxisProperty {option value} {
        set options($option) $value
        if {![winfo exists $options(-canvas)]} return;     # Still constructing.
        $self eraseTicks
        $self drawTicks
    }
}


# move indicator --
#     Collection of procedures to move an item
#

# installVerticalMoveBindings --
#     Install the move bindings for a particular set of items
#
# Arguments:
#     widget         Widget containing the items
#     object         Snit object controlling the items
#     indicatorTag   Tag common to the items
#     ymin           Minimum y coordinate
#     ymax           Maximum y coordinate
#
# Note:
#     The object must define a method NewPosition that takes two arguments:
#     The pixel value of the new position and the tag it belongs to
#
proc ::controlwidget::installVerticalMoveBindings {widget object indicatorTag ymin ymax} {
    variable grab

    if { [info exists grab($object,$indicatorTag)] } {
        unset grab($object,$indicatorTag)
    }

    $widget bind $indicatorTag <ButtonPress-1> [list ::controlwidget::GetIndicator     $widget $object $indicatorTag $ymin $ymax %y]
    $widget bind $indicatorTag <ButtonRelease> [list ::controlwidget::ReleaseIndicator $widget $object $indicatorTag $ymin $ymax %y]
    $widget bind $indicatorTag <Motion>        [list ::controlwidget::MoveIndicator    $widget $object $indicatorTag $ymin $ymax %y]
}

proc ::controlwidget::GetIndicator {w object tag ymin ymax y} {
    variable grab
   # console show
   # puts "Got needle"

    set readonly 0
    catch {
        set readonly [$object cget -readonly]
    }
    if { ! $readonly } {
        set grab($object,$tag) $y
    }
}
proc ::controlwidget::ReleaseIndicator {w object tag ymin ymax y} {
    variable grab
   # puts "Released needle"
    unset grab($object,$tag)
}

proc ::controlwidget::MoveIndicator {w object tag ymin ymax y} {
    variable grab

    if { [info exists grab($object,$tag)] } {
        #
        # Determine the middle of the tagged canvas items
        # - we must limit the repositioning
        #
        set bbox    [$w bbox $tag]
        set ycentre [expr {([lindex $bbox 1] + [lindex $bbox 3]) / 2}]

        set dy [expr {$y - $grab($object,$tag)}]

        if { $ycentre + $dy < $ymin } {
            set dy [expr {$ymin - $ycentre}]
            #set y  [expr {$y + $dy}]
        }
        if { $ycentre + $dy > $ymax } {
            set dy [expr {$ymax - $ycentre}]
            #set y  [expr {$y + $dy}]
        }


        # This should be done by the trace procedure ...
        # TODO: what if there is no variable?
        $w move $tag 0 $dy
        set grab($object,$tag) $y

       # puts "move: $dy -- $y -- [$w bbox $tag]"
        $object NewPosition $y $tag
    }
}


# meter --
#     Type for displaying and controlling a vertical meter
#
snit::widget controlwidget::meter {
    option -height         {2i}
    option -width          {1.5i}
    option -background     white
    option -arrowthickness -default 1      -configuremethod SetArrow
    option -arrowcolor     -default black  -configuremethod SetArrow
    option -variable       -default {}     -configuremethod VariableName
    option -readonly       -default 0      -type snit::boolean

    component axis
    foreach option {-from -to -majorticks -minorticks -log -axisfont -axiscolor -axisformat} {
        delegate option $option to axis
    }

    variable constructing   1

    variable needleId       {}
    variable topY           {}
    variable bottomY        {}
    variable valueRange     {}
    variable needleLeft     {}
    variable meterLeft      {}
    variable majorlength

    variable tickIds        {}
    variable lastValue       0

    variable decadeLow       0;       # e.g. 1 -10... this is the low end exponent.
    variable decadeHigh      1;        # e.g. 10-100.

    variable fontList

    # Construct the widget:

    constructor args {
        install axis using verticalAxis %AUTO% -canvas $win.c
        $self configurelist $args

        # In order to get the font info, we need to create an invisible
        # label so we can query the default font.. we'll accept that
        # but ensure that the font size is 10.

        label $win.hidden
        set fontList [$win.hidden cget -font]
        set fontList [font actual $fontList]
        set fontList [lreplace $fontList 1 1 10];    # Force size to 10pt.

        # Create the canvas and draw the meter into the canvas.
        # The needle is drawn at 1/2 of the rectangle height.
        # 3/4 width.
        # We'll store the resulting size back in the options asn
        # pixels since their much easier to work with:

        canvas $win.c   \
            -width $options(-width)   \
            -height $options(-height) \
            -background white

        set to         [$axis cget -to]
        set from       [$axis cget -from]
        set log        [$axis cget -log]
        set valueRange [expr {1.0*($to - $from)}]


        set options(-height) [$win.c cget -height]
        set options(-width)  [$win.c cget -width]

        # In order to support label we need to create a left margin
        # the margin will be 8chars worth of 8's  in the font we've used
        # and a top/bottom margin of 5pt.. the assumption is that the labels
        # will be drawn in 10pt font.

        set leftmargin [font measure $fontList 88888888]

        set leftmargin [$win.c canvasx $leftmargin]
        set vmargin    [$win.c canvasy 5p]

        # Compute the coordinates of the rectangle and the top/bottom limits
        # (for scaling the arrow position).

        set meterLeft  $leftmargin
        set topY       $vmargin
        set meterRight $options(-width)
        set bottomY    [expr $options(-height) - $vmargin]

        $axis configure -x       $meterLeft
        $axis configure -ybottom $bottomY
        $axis configure -ytop    $topY
        $axis drawAxis


        # draw the frame of the meter as a rectangle:

        $win.c create rectangle $meterLeft $topY $meterRight $bottomY

        # figure out how to put the needle in the middle of the
        # height of the meter allowing 1/4 of the meter for ticks.
        #

        set needleWidth   [expr {3*($meterRight - $meterLeft)/4}]
        set needleHeight  [$axis computeHeight   \
                             [expr {($to + $from)/2}]]
        set needleLeft   [expr $options(-width) - $needleWidth]

        set needleId [$win.c create line $needleLeft $needleHeight      \
                                         $options(-width) $needleHeight -tags {needle arrow} \
                                        -arrow first -fill $options(-arrowcolor) -width $options(-arrowthickness)]]

        set needleHalo [$win.c create rectangle $needleLeft [expr {$needleHeight-3}]      \
                                                $options(-width) [expr {$needleHeight+3}] -fill $options(-background) \
                                                -outline $options(-background) -tags needle]
        $win.c lower $needleHalo


        grid $win.c -sticky nsew

        $axis drawTicks

        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod variableChanged]
            if { [info exists ::$options(-variable)] } {
                $self needleTo [set ::$options(-variable)]
            }
        }
        bindDown $win $win

        installVerticalMoveBindings $win.c $self needle $topY $bottomY

        set constructing 0
    }

    #-------------------------------------------------------------------------------
    # public methods
    #

    # Set a new value for the meter... this moves the pointer to a new value.
    # if a variable is tracing the meter, it is changed
    #
    method set newValue {
        if {$options(-variable) ne ""} {
            set ::$options(-variable) $newValue;      # This updates meter too.
        } else {
            $self needleTo $newValue
        }
    }

    # Get the last meter value.
    #
    method get {} {
        return $lastValue
    }

    #-------------------------------------------------------------------------------
    # 'private' methods.

    # trace on -variable being modified.

    method variableChanged {name1 name2 op} {

        $self needleTo [set ::$options(-variable)]
    }

    # Set a new position for the needle:

    method needleTo newCoords {
        set lastValue $newCoords

        set height [$axis computeHeight $newCoords]
        $win.c coords $needleId $needleLeft $height $options(-width) $height
    }


    #  Configure the variable for the meter.
    #  Any prior variable must have its trace removed.
    #  The new variable gets a trace established and the meter position
    #  is updated from it.
    #  Note that if the new variable is "" then the meter will have
    #  no variable associated with it.

    method VariableName {option name} {

        # Could be still constructing in which case
        # $win.c does not exist:

        if {![winfo exists $win.c]} {
            set options(-variable) $name
            return;
        }

        # Remove any old traces


        if {$options(-variable) ne ""} {
            trace remove variable ::$options(-variable) write [mymethod variableChanged]
        }

        # Set new trace if appropriate and update value.

        set options(-variable) $name
        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod variableChanged]
            $self needleTo [set ::$options(-variable)]
        }
    }

    # Configure the arrow
    method SetArrow {option value} {
        switch -- $option {
            "-arrowthickness" {
                 $win.c itemconfigure arrow -width $value
            }
            "-arrowcolor" {
                 $win.c itemconfigure arrow -fill $value
            }
        }
    }

    # React to the dragging of the needle
    method NewPosition {y tag} {
        if { $options(-variable) ne "" } {
            set ::$options(-variable) [$axis computeValue $y]
        }
    }
}


# slider --
#     Type for displaying and controlling a vertical slider
#     (It actually supports one or several sliders at once)
#
snit::widget controlwidget::slider {
    option -height         200
    option -width          150
    option -background      -default grey
    option -sliderthickness -default 10     -readonly true -type snit::double
    option -sliderwidth     -default 20     -readonly true -type snit::double
    option -troughwidth     -default 10     -readonly true -type snit::double
    option -variable        -default {}     -configuremethod VariableName
    option -number          -default 1      -readonly true -type snit::integer

    component axis
    foreach option {-from -to -majorticks -minorticks -log -axisfont -axiscolor -axisformat} {
        delegate option $option to axis
    }

    variable constructing   1

    variable topY           {}
    variable bottomY        {}

    variable lastValue      {}
    variable lastHeight     {}

    variable decadeLow       0;       # e.g. 1 -10... this is the low end exponent.
    variable decadeHigh      1;        # e.g. 10-100.

    variable fontList

    # Construct the widget:

    constructor args {
        install axis using verticalAxis %AUTO% -canvas $win.c
        $self configurelist $args

        # In order to get the font info, we need to create an invisible
        # label so we can query the default font.. we'll accept that
        # but ensure that the font size is 10.

        label $win.hidden
        set fontList [$win.hidden cget -font]
        set fontList [font actual $fontList]
        set fontList [lreplace $fontList 1 1 10];    # Force size to 10pt.

        # Create the canvas and draw the slider(s) into the canvas.
        #
        # The geometry of the sliders determines the size of the canvas
        #
        canvas $win.c

        set leftmargin [font measure $fontList 88888888]

        set leftmargin [$win.c canvasx $leftmargin]
        set vmargin    [$win.c canvasy 5p]

        set height [expr {$options(-height) + $vmargin + $options(-sliderthickness)}]
        set width  [expr {$leftmargin + $options(-number) * $options(-sliderwidth) * 1.5 + 0.25* $options(-sliderwidth)}]

        $win.c configure \
            -width $width \
            -height $height \
            -background $options(-background)

        set to         [$axis cget -to]
        set from       [$axis cget -from]
        set log        [$axis cget -log]
        set valueRange [expr {1.0*($to - $from)}]

        set meterLeft  $leftmargin
        set topY       [expr {$vmargin  + 0.5 * $options(-sliderthickness)}]
        set meterRight $options(-width)
        set bottomY    [expr {$height - $vmargin - 0.5 * $options(-sliderthickness)}]

        $axis configure -x       $meterLeft
        $axis configure -ybottom $bottomY
        $axis configure -ytop    $topY
        $axis drawAxis


        # draw the sliders and the troughs

        set sliderThickness $options(-sliderthickness)
        set sliderWidth     $options(-sliderwidth)
        set troughWidth     $options(-troughwidth)
        set number          $options(-number)

        set sliderCentre       [expr {($bottomY + $topY)/2.0}]
        set sliderTop          [expr {$sliderCentre - $sliderThickness/2.0}]
        set sliderCentreTop    [expr {$sliderCentre - 1}]
        set sliderCentreBottom [expr {$sliderCentre + 1}]
        set sliderBottom       [expr {$sliderCentre + $sliderThickness/2.0}]

        set lastHeight {}
        for { set i 0 } { $i < $number } { incr i } {

            set troughLeft      [expr {$meterLeft + ($i*1.5+0.75) * $sliderWidth}]
            set troughRight     [expr {$troughLeft                + $troughWidth}]
            set sliderLeft      [expr {$meterLeft + ($i*1.5+0.5)  * $sliderWidth - 1}]
            set sliderRight     [expr {$sliderLeft                + $sliderWidth}]

            #
            # Trough holding the slider bar
            #
            $win.c create rectangle [expr {$troughLeft-2}] [expr {$topY-2}] $troughRight $bottomY -fill black   ;# Slightly shifted for shadow effect
            $win.c create rectangle $troughLeft $topY $troughRight $bottomY -fill gray40

            #
            # Slider
            #
            $win.c create rectangle $sliderLeft $sliderTop          $sliderRight $sliderCentreTop    -fill gray90 -tag slider$i -outline {}
            $win.c create rectangle $sliderLeft $sliderCentreBottom $sliderRight $sliderBottom       -fill gray30 -tag slider$i -outline {}
            $win.c create rectangle $sliderLeft $sliderCentreTop    $sliderRight $sliderCentreBottom -fill white  -tag slider$i -outline {}
            $win.c create rectangle $sliderLeft $sliderTop          $sliderRight $sliderBottom       -fill {}     -tag slider$i -outline black

            installVerticalMoveBindings $win.c $self slider$i $topY $bottomY

            lappend lastHeight $sliderCentre
        }

        grid $win.c -sticky nsew

        $axis drawTicks

        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod variableChanged]
            if { [info exists ::$options(-variable)] } {
                $self sliderTo [set ::$options(-variable)]
            }
        }
        bindDown $win $win

        set constructing 0
    }

    #-------------------------------------------------------------------------------
    # public methods
    #

    # Set a new value for the meter... this moves the pointer to a new value.
    # if a variable is tracing the meter, it is changed
    #
    method set newValue {
        if {$options(-variable) ne ""} {
            set ::$options(-variable) $newValue;      # This updates meter too.
        } else {
            $self sliderTo $newValue
        }
    }

    # Get the last meter value.
    #
    method get {} {
        return $lastValue
    }

    #-------------------------------------------------------------------------------
    # 'private' methods.

    # trace on -variable being modified.

    method variableChanged {name1 name2 op} {

        $self sliderTo [set ::$options(-variable)]
    }

    # Set a new position for the slider:
    #
    # NOTE:
    # Current implementation causes the slider to shift twice as
    # fast! That should not happen of course
    #
    method sliderTo newCoords {

        set move 1
        if { [llength [array names ::controlwidget::grab $self,slider*]] > 0 } {
            set move 0
        }

        set idx       0
        set newheight {}
        foreach coord $newCoords currentHeight $lastHeight {
            set height [$axis computeHeight $coord]
            set dy     [expr {$height - $currentHeight}]

            if { $move } {
                $win.c move slider$idx 0 $dy
            }

            lappend newHeight $height
            incr idx
        }

        set lastValue  $newCoords
        set lastHeight $newHeight
       # puts "sliderTo: [$win.c bbox slider2]"
    }


    #  Configure the variable for the meter.
    #  Any prior variable must have its trace removed.
    #  The new variable gets a trace established and the meter position
    #  is updated from it.
    #  Note that if the new variable is "" then the meter will have
    #  no variable associated with it.

    method VariableName {option name} {

        # Could be still constructing in which case
        # $win.c does not exist:

        if {![winfo exists $win.c]} {
            set options(-variable) $name
            return;
        }

        # Remove any old traces


        if {$options(-variable) ne ""} {
            trace remove variable ::$options(-variable) write [mymethod variableChanged]
        }

        # Set new trace if appropriate and update value.

        set options(-variable) $name
        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod variableChanged]
            $self needleTo [set ::$options(-variable)]
        }
    }

    # React to the dragging of the needle
    method NewPosition {y tag} {
        if { $options(-variable) ne "" } {
            set idx [string range $tag 6 end]
            lset ::$options(-variable) $idx [$axis computeValue $y]
            set lastValue [set ::$options(-variable)]
            lset lastHeight $idx $y
          #  puts "$y -- $lastValue -- [$win.c bbox slider2]"
        }
    }
}


# equalizerBar --
#     Type for displaying and controlling a set of coloured bars
#     like the ones found on the display of a hifi equalizer
#
snit::widget controlwidget::equalizerBar {
    option -height         200
    option -width          150
    option -background      -default darkgrey
    option -barwidth        -default 15     -readonly true -type snit::double
    option -segments        -default 10     -readonly true -type snit::integer
    option -variable        -default {}     -configuremethod VariableName
    option -safecolor       -default green
    option -warningcolor    -default red
    option -warninglevel    -default 1.0
    option -number          -default 1      -readonly true -type snit::integer

    component axis
    foreach option {-from -to -majorticks -minorticks -log -axisfont -axiscolor -axisformat} {
        delegate option $option to axis
    }

    variable constructing   1

    variable topY           {}
    variable bottomY        {}

    variable lastValue      {}
    variable lastHeight     {}

    variable decadeLow       0;        # e.g. 1 -10... this is the low end exponent.
    variable decadeHigh      1;        # e.g. 10-100.

    variable segmentIds     {}

    variable fontList

    # Construct the widget:

    constructor args {
        install axis using verticalAxis %AUTO% -canvas $win.c
        $self configurelist $args

        # In order to get the font info, we need to create an invisible
        # label so we can query the default font.. we'll accept that
        # but ensure that the font size is 10.

        label $win.hidden
        set fontList [$win.hidden cget -font]
        set fontList [font actual $fontList]
        set fontList [lreplace $fontList 1 1 10];    # Force size to 10pt.

        # Create the canvas and draw the slider(s) into the canvas.
        #
        # The geometry of the sliders determines the size of the canvas
        #
        canvas $win.c

        set leftmargin [font measure $fontList 88888888]

        set leftmargin [$win.c canvasx $leftmargin]
        set vmargin    [$win.c canvasy 5p]

        set height [expr {$options(-height) + $vmargin}]
        set width  [expr {$leftmargin + $options(-number) * $options(-barwidth) * 1.2 + $options(-barwidth)}]

        set segmentHeight [expr {$options(-height)/double($options(-segments)) - 2}]

        $win.c configure \
            -width $width \
            -height $height \
            -background $options(-background)

        set to         [$axis cget -to]
        set from       [$axis cget -from]
        set log        [$axis cget -log]
        set valueRange [expr {1.0*($to - $from)}]

        set meterLeft  $leftmargin
        set topY       $vmargin
        set meterRight $options(-width)
        set bottomY    [expr {$height - $vmargin}]

        $axis configure -x       $meterLeft
        $axis configure -ybottom $bottomY
        $axis configure -ytop    $topY
        $axis drawAxis

        # draw the bar segments - keep track of the IDs

        set barWidth        $options(-barwidth)
        set numberSegments  $options(-segments)
        set numberBars      $options(-number)

        set lastHeight {}
        set segmentIds {}
        for { set i 0 } { $i < $numberBars } { incr i } {

            set barLeft         [expr {$meterLeft + 10 + $i*1.2 * $barWidth}]
            set barRight        [expr {$barLeft                 + $barWidth}]

            set segmentColumn   {}

            for { set j 0 } { $j < $numberSegments } { incr j } {
                set segmentTop      [expr {$bottomY    - $j * ($segmentHeight+1)}]
                set segmentBottom   [expr {$segmentTop -       $segmentHeight}]

                lappend segmentColumn \
                    [$win.c create rectangle $barLeft $segmentTop $barRight $segmentBottom \
                        -fill $options(-background) -outline $options(-background)]
            }

            lappend segmentIds $segmentColumn
        }

        grid $win.c -sticky nsew

        $axis drawTicks

        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod variableChanged]
            if { [info exists ::$options(-variable)] } {
                $self barsTo [set ::$options(-variable)]
            }
        }
        bindDown $win $win

        set constructing 0
    }

    #-------------------------------------------------------------------------------
    # public methods
    #

    # Set a new value for the meter... this moves the pointer to a new value.
    # if a variable is tracing the meter, it is changed
    #
    method set newValue {
        if {$options(-variable) ne ""} {
            set ::$options(-variable) $newValue;      # This updates meter too.
        } else {
            $self barsTo $newValue
        }
    }

    # Get the last meter value.
    #
    method get {} {
        return $lastValue
    }

    #-------------------------------------------------------------------------------
    # 'private' methods.

    # trace on -variable being modified.

    method variableChanged {name1 name2 op} {

        $self barsTo [set ::$options(-variable)]
    }

    # Set a new position for the slider:

    method barsTo newCoords {

        set lowerLimit [$axis cget -from]
        set valueStep  [expr {([$axis cget -to] - $lowerLimit) / double($options(-segments))}]

        set background $options(-background)

        foreach value $newCoords barIds $segmentIds {

            for { set i 0 } { $i < $options(-segments) } { incr i } {
                set limitValue [expr {$lowerLimit + ($i+1) * $valueStep}]

                if { $limitValue <= $value } {
                    set color $options(-safecolor)
                    if { $limitValue > $options(-warninglevel) } {
                        set color $options(-warningcolor)
                    }

                    $win.c itemconfigure [lindex $barIds $i] -fill $color -outline black
                } else {
                    $win.c itemconfigure [lindex $barIds $i] -fill $background -outline $background
                }
            }
        }
    }


    #  Configure the variable for the meter.
    #  Any prior variable must have its trace removed.
    #  The new variable gets a trace established and the meter position
    #  is updated from it.
    #  Note that if the new variable is "" then the meter will have
    #  no variable associated with it.

    method VariableName {option name} {

        # Could be still constructing in which case
        # $win.c does not exist:

        if {![winfo exists $win.c]} {
            set options(-variable) $name
            return;
        }

        # Remove any old traces


        if {$options(-variable) ne ""} {
            trace remove variable ::$options(-variable) write [mymethod variableChanged]
        }

        # Set new trace if appropriate and update value.

        set options(-variable) $name
        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod variableChanged]
            $self barsTo [set ::$options(-variable)]
        }
    }
}


# thermometer --
#     Type for displaying and controlling a thermometer
#
snit::widget controlwidget::thermometer {
    option -height         200
    option -width          100
    option -background     white
    option -linethickness  -default 5      -type snit::integer
    option -linecolor      -default red
    option -variable       -default {}     -configuremethod VariableName
    option -readonly       -default 1      -type snit::boolean

    component axis
    foreach option {-from -to -majorticks -minorticks -log -axisfont -axiscolor -axisformat} {
        delegate option $option to axis
    }

    variable constructing   1

    variable topY           {}
    variable bottomY        {}
    variable valueRange     {}
    variable lineId         {}
    variable lineCentre     {}
    variable lineBottom     {}
    variable meterLeft      {}
    variable meterRight     {}
    variable majorlength

    variable lastValue       0

    variable decadeLow       0;       # e.g. 1 -10... this is the low end exponent.
    variable decadeHigh      1;        # e.g. 10-100.

    variable fontList

    # Construct the widget:

    constructor args {
        install axis using verticalAxis %AUTO% -canvas $win.c -axisstyle both
        $self configurelist $args

        # In order to get the font info, we need to create an invisible
        # label so we can query the default font.. we'll accept that
        # but ensure that the font size is 10.

        label $win.hidden
        set fontList [$win.hidden cget -font]
        set fontList [font actual $fontList]
        set fontList [lreplace $fontList 1 1 10];    # Force size to 10pt.

        # Create the canvas and draw the thermometer into the canvas.

        canvas $win.c   \
            -width $options(-width)   \
            -height $options(-height) \
            -background $options(-background)

        set to         [$axis cget -to]
        set from       [$axis cget -from]
        set log        [$axis cget -log]
        set valueRange [expr {1.0*($to - $from)}]


        set options(-height) [$win.c cget -height]
        set options(-width)  [$win.c cget -width]

        # In order to support labels we need to create both a left margin
        # and a right margin
        # the margin will be 8chars worth of 8's  in the font we've used
        # and a top/bottom margin of 5pt.. the assumption is that the labels
        # will be drawn in 10pt font.

        set leftmargin [font measure $fontList 88888888]

        set leftmargin    [$win.c canvasx $leftmargin]
        set topmargin     [expr { 5 + [$win.c canvasy 5p]}]
        set bottommargin  [expr {10 + [$win.c canvasy 5p]}]

        # Compute the coordinates of the rectangle and the top/bottom limits
        # (for scaling the arrow position).

        set meterLeft  $leftmargin
        set meterRight [expr {$leftmargin + $options(-linethickness) + 2}]
        set topY       $topmargin
        set bottomY    [expr $options(-height) - $bottommargin]

        $axis configure -x       $meterLeft
        $axis configure -ybottom $bottomY
        $axis configure -ytop    $topY
        $axis configure -xright  $meterRight
        $axis drawAxis


        # draw the "glass" frame of the thermometer as a double line
        # and some curves

        set lineCentre  [expr {($meterLeft + $meterRight)/2.0}]

        $win.c create line $meterLeft  [expr {$topY - 2}] $meterLeft  [expr {$bottomY + 5}]
        $win.c create line $meterRight [expr {$topY - 2}] $meterRight [expr {$bottomY + 5}]
        $win.c create arc  $meterLeft  [expr {$topY - 5}] $meterRight [expr {$topY + 3}] \
            -start 0 -extent 180 -style arc
        $win.c create oval [expr {$lineCentre - 5}] [expr {$bottomY +  0}] \
                           [expr {$lineCentre + 5}] [expr {$bottomY + 10}] \
            -fill $options(-linecolor) -outline black


        # figure out how to put the needle in the middle of the
        # height of the meter allowing 1/4 of the meter for ticks.
        #

        set lineBottom  [expr {$bottomY + 3}]
        set lineTop     [$axis computeHeight [expr {($to + $from)/2}]]

        set lineId [$win.c create rectangle [expr {$meterLeft+1}] $lineTop $meterRight $lineBottom \
                        -fill $options(-linecolor) -outline {} -tags line]

        set lineHalo [$win.c create rectangle $meterLeft  [expr {$lineTop-3}] $meterRight [expr {$lineTop+3}] \
                        -fill $options(-background) -outline $options(-background) -tags linetop]

        $win.c lower $lineHalo

        grid $win.c -sticky nsew

        $axis drawTicks

        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod variableChanged]
            if { [info exists ::$options(-variable)] } {
                $self needleTo [set ::$options(-variable)]
            }
        }
        bindDown $win $win

      # NOT YET
      # installVerticalMoveBindings $win.c $self needle $topY $bottomY

        set constructing 0
    }

    #-------------------------------------------------------------------------------
    # public methods
    #

    # Set a new value for the meter... this moves the pointer to a new value.
    # if a variable is tracing the meter, it is changed
    #
    method set newValue {
        if {$options(-variable) ne ""} {
            set ::$options(-variable) $newValue;      # This updates meter too.
        } else {
            $self lineTo $newValue
        }
    }

    # Get the last meter value.
    #
    method get {} {
        return $lastValue
    }

    #-------------------------------------------------------------------------------
    # 'private' methods.

    # trace on -variable being modified.

    method variableChanged {name1 name2 op} {

        $self lineTo [set ::$options(-variable)]
    }

    # Set a new position for the needle:

    method needleTo newCoords {
        set lastValue $newCoords

        set height [$axis computeHeight $newCoords]
        $win.c coords $lineId [expr {$meterLeft+1}] $lineBottom $meterRight $height
    }


    #  Configure the variable for the meter.
    #  Any prior variable must have its trace removed.
    #  The new variable gets a trace established and the meter position
    #  is updated from it.
    #  Note that if the new variable is "" then the meter will have
    #  no variable associated with it.

    method VariableName {option name} {

        # Could be still constructing in which case
        # $win.c does not exist:

        if {![winfo exists $win.c]} {
            set options(-variable) $name
            return;
        }

        # Remove any old traces


        if {$options(-variable) ne ""} {
            trace remove variable ::$options(-variable) write [mymethod variableChanged]
        }

        # Set new trace if appropriate and update value.

        set options(-variable) $name
        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod variableChanged]
            $self needleTo [set ::$options(-variable)]
        }
    }

    # Configure the arrow
    method SetArrow {option value} {
        switch -- $option {
            "-arrowthickness" {
                 $win.c itemconfigure arrow -width $value
            }
            "-arrowcolor" {
                 $win.c itemconfigure arrow -fill $value
            }
        }
    }

    # React to the dragging of the needle
    method NewPosition {y tag} {
        if { $options(-variable) ne "" } {
            set ::$options(-variable) [$axis computeValue $y]
        }
    }
}

Added scriptlibs/tklib0.7/controlwidget/voltmeter.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
# voltmeter.tcl --
#
# Adapted by Arjen Markus (snitified), july 2010
#
#
#
#
# Part of: The TCL'ers Wiki
# Contents: a voltmeter-like widget
# Date: Fri Jun 13, 2003
#
# Abstract
#
#
#
# Copyright (c) 2003 Marco Maggi
#
# The author  hereby grant permission to use,  copy, modify, distribute,
# and  license this  software  and its  documentation  for any  purpose,
# provided that  existing copyright notices  are retained in  all copies
# and that  this notice  is included verbatim  in any  distributions. No
# written agreement, license, or royalty  fee is required for any of the
# authorized uses.  Modifications to this software may be copyrighted by
# their authors and need not  follow the licensing terms described here,
# provided that the new terms are clearly indicated on the first page of
# each file where they apply.
#
# IN NO  EVENT SHALL THE AUTHOR  OR DISTRIBUTORS BE LIABLE  TO ANY PARTY
# FOR  DIRECT, INDIRECT, SPECIAL,  INCIDENTAL, OR  CONSEQUENTIAL DAMAGES
# ARISING OUT  OF THE  USE OF THIS  SOFTWARE, ITS DOCUMENTATION,  OR ANY
# DERIVATIVES  THEREOF, EVEN  IF THE  AUTHOR  HAVE BEEN  ADVISED OF  THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE  AUTHOR  AND DISTRIBUTORS  SPECIFICALLY  DISCLAIM ANY  WARRANTIES,
# INCLUDING,   BUT   NOT  LIMITED   TO,   THE   IMPLIED  WARRANTIES   OF
# MERCHANTABILITY,    FITNESS   FOR    A    PARTICULAR   PURPOSE,    AND
# NON-INFRINGEMENT.  THIS  SOFTWARE IS PROVIDED  ON AN "AS  IS" BASIS,
# AND  THE  AUTHOR  AND  DISTRIBUTORS  HAVE  NO  OBLIGATION  TO  PROVIDE
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#
# $Id: voltmeter.tcl,v 1.3 2010/09/10 17:16:29 andreas_kupries Exp $
#

package require Tk   8.5
package require snit
package provide voltmeter 0.1

namespace eval controlwidget {
    namespace export voltmeter
}

# voltmeter --
#     Voltmeter-like widget
#
snit::widget controlwidget::voltmeter {

    #
    # widget default values
    #
    option -borderwidth           -default        1
    option -background            -default        gray
    option -dialcolor             -default        white
    option -needlecolor           -default        black
    option -scalecolor            -default        black
    option -indexid               -default         {}

    option -variable              -default         {}         -configuremethod VariableName
    option -min                   -default        0.0
    option -max                   -default      100.0
    option -labelcolor            -default        black
    option -titlecolor            -default        black
    option -labelfont             -default      {Helvetica 8}
    option -titlefont             -default      {Helvetica 9}
    option -labels                -default         {}
    option -title                 -default         {}
    option -width                 -default        50m
    option -height                -default        25m
    option -highlightthickness    -default        0
    option -relief                -default        raised

    variable pi [expr {3.14159265359/180.0}]
    variable motion
    variable xc
    variable yc

    constructor args {

        #
        # Configure the widget
        #
        $self configurelist $args

        canvas $win.c -background $options(-background) -width $options(-width) -height $options(-height) \
                      -relief $options(-relief) -borderwidth $options(-borderwidth)
        grid $win.c -sticky news -padx 2m -pady 2m

        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod tracer $options(-variable)]
        }

        set width   [$win.c cget -width]
        set height  [$win.c cget -height]
        set xcentre [expr {$width*0.5}]
        set ycentre [expr {$width*1.4}]
        set t       1.15
        set t1      1.25

        $win.c create arc \
               [expr {$xcentre-$width*$t}] [expr {$ycentre-$width*$t}] \
               [expr {$xcentre+$width*$t}] [expr {$ycentre+$width*$t}] \
               -start 70.5 -extent 37 -style arc -outline lightgray \
               -width [expr {$ycentre*0.245}]
        $win.c create arc \
               [expr {$xcentre-$width*$t}] [expr {$ycentre-$width*$t}] \
               [expr {$xcentre+$width*$t}] [expr {$ycentre+$width*$t}] \
               -start 71 -extent 36 -style arc -outline $options(-dialcolor) \
               -width [expr {$ycentre*0.23}]
        $win.c create arc \
               [expr {$xcentre-$width*$t1}] [expr {$ycentre-$width*$t1}] \
               [expr {$xcentre+$width*$t1}] [expr {$ycentre+$width*$t1}] \
               -start 75 -extent 30 \
               -fill black -outline $options(-scalecolor) -style arc -width 0.5m

        set num    [llength $options(-labels)]
        set angle  255.0
        set delta  [expr {30.0/($num-1)}]
        set l1     [expr {$width*$t1}]
        set l2     [expr {$width*$t1*0.95}]
        set l3     [expr {$width*$t1*0.92}]
        for {set i 0} {$i < $num} {incr i} {
           set a [expr {($angle+$delta*$i)*$pi}]

           set x1 [expr {$xcentre+$l1*cos($a)}]
           set y1 [expr {$ycentre+$l1*sin($a)}]
           set x2 [expr {$xcentre+$l2*cos($a)}]
           set y2 [expr {$ycentre+$l2*sin($a)}]
           $win.c create line $x1 $y1 $x2 $y2 -fill $options(-scalecolor) -width 0.5m

           set x1 [expr {$xcentre+$l3*cos($a)}]
           set y1 [expr {$ycentre+$l3*sin($a)}]

           set label [lindex $options(-labels) $i]
           if { [string length $label] } {
               $win.c create text $x1 $y1 \
                       -anchor center -justify center -fill $options(-labelcolor) \
                       -text $label -font $options(-labelfont)
           }
        }

        set title $options(-title)
        if { [string length $title] } {
           $win.c create text $xcentre [expr {$ycentre-$width*1.05}] \
                   -anchor center -justify center -fill $options(-titlecolor) \
                   -text $title -font $options(-titlefont)
        }

        rivet $win.c 10 10
        rivet $win.c    [expr {$width-10}] 10
        rivet $win.c 10 [expr {$height-10}]
        rivet $win.c    [expr {$width-10}] [expr {$height-10}]

        set motion 0
        set xc $xcentre
        set yc $ycentre
        bind $win.c <ButtonRelease>  [list $self needleRelease %W]
        bind $win.c <Motion>         [list $self needleMotion %W %x %y]

        set value 0
        $self drawline $win $value
    }

    method destructor {} {
        set varname ::$options(-variable)]
        trace remove variable $varname write \
            [namespace code "mymethod tracer $win $varname"]
    }

    #
    # public methods --
    #
    method set {newValue} {
        if { $options(-variable) != "" } {
            set ::$options(-variable) $newValue   ;#! This updates the dial too
        } else {
            set options(-value) $newValue
            $self draw $win.c $options(-value)
        }
    }
    method get {} {
        return $options(-value)
    }

    #
    # private methods --
    #

    method VariableName {option name} {

        # Could be still constructing in which case
        # $win.c does not exist:

        if {![winfo exists $win.c]} {
            set options(-variable) $name
            return;
        }

        # Remove any old traces

        if {$options(-variable) ne ""} {
            trace remove variable ::$options(-variable) write [mymethod tracer $options(-variable)]
        }

        # Set new trace if appropriate and update value.

        set options(-variable) $name
        if {$options(-variable) ne ""} {
            trace add variable ::$options(-variable) write [mymethod tracer $options(-variable)]
            $self drawline $win.c [set ::$options(-variable)]
        }
    }

    method tracer { varname args } \
    {
        set options(-value) [set ::$varname]
        $self drawline $win [set ::$varname]
    }

    method drawline { widget value } {
        set id     $options(-indexid)
        set min    $options(-min)
        set max    $options(-max)

        set c      $widget.c

        set v [expr { ($value <= ($max*1.05))? $value : ($max*1.05) }]

        set angle [expr {((($v-$min)/(1.0*($max-$min)))*30.0+165.0)*$pi}]

        set width   [$c cget -width]
        set xcentre [expr {$width/2.0}]
        set ycentre [expr {$width*1.4}]
        set l1      [expr {$ycentre*0.85}]
        set l2      [expr {$ycentre*0.7}]

        set xl      [expr {$xcentre-$l1*sin($angle)}]
        set yl      [expr {$ycentre+$l1*cos($angle)}]
        set xs      [expr {$xcentre-$l2*sin($angle)}]
        set ys      [expr {$ycentre+$l2*cos($angle)}]

        catch {$c delete $id}
        set id [$c create line $xs $ys $xl $yl -fill $options(-needlecolor) -width 0.6m]
        $c bind $id <ButtonPress> [list $self needlePress %W]
        set options(-indexid) $id
    }

    method needlePress {w} \
    {
        set motion 1
    }

    method needleRelease {w} \
    {
        set motion 0
    }

    method needleMotion {w x y} \
    {
        if {! $motion} { return }
        if {$y == $yc && $x == $xc} { return }

        #
        # Compute the angle with the positive y-axis - easier to examine!
        #
        set angle [expr {atan2($xc - $x,$yc - $y) / $pi}]
        if { $angle >= 15.0 } {
            set angle 15.0
        }
        if { $angle < -15.0 } {
            set angle -15.0
        }
        set ::$options(-variable) [expr {$options(-min) + ($options(-max)-$options(-min))*(15.0-$angle) / 30.0}]
    }


    proc rivet { c xc yc } {
        shadowcircle $c \
            [expr {$xc-4}] [expr {$yc-4}] [expr {$xc+4}] [expr {$yc+4}] \
            5 0.5m -45.0
    }

    proc shadowcircle { canvas x1 y1 x2 y2 ticks width orient } {
        set radius [expr {($x2-$x1)/2.0}]

        set angle $orient
        set delta [expr {180.0/$ticks}]
        for {set i 0} {$i <= $ticks} {incr i} {
           set a [expr {($angle+$i*$delta)}]
           set b [expr {($angle-$i*$delta)}]

           set color [expr {40+$i*(200/$ticks)}]
           set color [format "#%x%x%x" $color $color $color]

           $canvas create arc $x1 $y1 $x2 $y2 -start $a -extent $delta \
                   -style arc -outline $color -width $width
           $canvas create arc $x1 $y1 $x2 $y2 -start $b -extent $delta \
                   -style arc -outline $color -width $width
        }
    }
}

if {0} {
# main --
#     Demonstration of the voltmeter object
#
proc main { argc argv } {
    global     forever

    wm withdraw .
    wm title    . "A voltmeter-like widget"
    wm geometry . +10+10

    ::controlwidget::voltmeter .t1 -variable value1 -labels { 0 50 100 } -title "Voltmeter (V)"
    scale .s1 -command "set ::value1" -variable value1

    ::controlwidget::voltmeter .t2 -variable value2 -labels { 0 {} 2.5 {} 5 } \
       -width 80m -height 40m -title "Ampere (mA)" -dialcolor lightgreen -scalecolor white \
       -min 0 -max 5
    scale .s2 -command "set ::value2" -variable value2

    button .b -text Quit -command "set ::forever 1"

    grid .t1 .s1 .t2 .s2 .b
    wm deiconify .
    vwait forever
    .t1 destructor
    .t2 destructor
    exit 0
}

main $argc $argv
}

### end of file
# Local Variables:
# mode: tcl
# page-delimiter: "^#PAGE"
# End:

Added scriptlibs/tklib0.7/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
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
# 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 of the Tcl License.
#
# Copyright (c) 2008 Andreas Kupries. Added ability to provide the tracking
#               information to external users.
#
# Copyright (c) 2013 Frank Gover, Andreas Kupries. Added ability to
#               bound the crosshairs to an area of the canvas. Useful
#               for plots.
#	(Actual code inspired by Frank's, but modified and extended (multiple bboxes)).

# ### ### ### ######### ######### #########
## 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
    set opts(hidden) 0
    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 $w
	set bindtags [bindtags $w]
	set pos [lsearch -exact $bindtags Crosshair]
	if { $pos >= 0 } {
	    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]

	# Immediately apply to a visible crosshair
	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::bbox_add --
#
#       Confines the crosshairs to a rectangular area in the canvas widget.
#	Multiple calls add areas, each allowing the crosshairs.
#
#	NOTE: Bounding boxes can overlap to the point of being identical.
#
# Parameters:
#       w - Path name of the widget
#       bbox - Area in the canvas. A list of 4 numbers in the form
#		{bbox_llx bbox_lly bbox_urx bbox_ury}
#            where:
#                 bbox-llx = Lower left  X coordinate of the area
#                 bbox-lly = Lower left  Y coordinate of the area
#                 bbox-urx = Upper right X coordinate of the area
#                 bbox-ury = Upper right Y coordinate of the area
#
# Result:
#	A token identifying the bounding box, for future removal.
#
#----------------------------------------------------------------------

proc ::crosshair::bbox_add { w bbox } {
    variable config
    if { ![info exists config($w)] } {
	return -code error "no crosshairs in $w"
    }
    array set opts $config($w)

    if {[info exists opts(bbox)]} {
	set len [llength $opts(bbox)]
    } else {
	set len 0
    }
    set token bbox$w/$len

    lappend opts(bbox) $token
    set config($w) [array get opts]
 
    foreach {nllx nlly nurx nury} $bbox break
    # Tcl 8.4 foreach-as-lassign hack
    set rect [$w create rect \
		  $nllx $nlly $nurx $nury \
		  -tags $token -state hidden]

    return $token
}

#----------------------------------------------------------------------
#
# ::crosshair::bbox_remove --
#
#       Remove a bounding box for the crosshairs, identified by token.
#	The crosshairs are confined to the remaining boxes, or not at
#	all if no boxes remain.
#
#	NOTE: Bounding boxes can overlap to the point of being identical.
#
# Parameters:
#       token - The bbox token, identifying both canvas and bbox in it.
#
# Result:
#	Nothing.
#
#----------------------------------------------------------------------

proc ::crosshair::bbox_remove { token } {
    variable config
    if {![regexp {^bbox([^/]+)/(\d+)$} -> w index]} {
	return -code error "Expected a bbox token, got \"$token\""
    }
    if { ![info exists config($w)] } {
	return -code error "no crosshairs in $w"
    }
    array set opts $config($w)

    # Replace chosen box with nothing.
    incr index -1
    set newboxes [lreplace $opts(bbox) $index $index {}]

    # Remove empty boxes from the end of the list.
    while {[llength $newboxes] && ![llength [lindex $newboxes end]]} {
	set newboxes [lreplace $newboxes end end]
    }

    if {![llength $newboxes]} {
	# Nothing left, disable entirely
	unset opts(bbox)
    } else {
	# Keep remainder.
	set opts(bbox) $newboxes
    }

    set config($w) [array get opts]
    
    #--- Delete Bbox
    $w delete $token 
    
    return
}

#----------------------------------------------------------------------
#
# ::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)

    # Already hidden, do nothing
    if { $opts(hidden) } return
    set opts(hidden) 1

    # Destroy the parts of a visible cross-hair
    Kill $w opts

    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)

    # Already unhidden, do nothing
    if { !$opts(hidden) } return
    set opts(hidden) 0

    # Recreate cross-hair. This takes the bounding boxes, if any, into
    # account, i.e. if we are out of bounds nothing will appear.
    Move $w $x $y
    return
}

proc ::crosshair::GetBoundaries { w x y llxv llyv urxv uryv } {
    upvar 1 $llxv llx $llyv lly $urxv urx $uryv ury
    variable config
    array set opts $config($w)

    # Defaults
    set llx [$w canvasx 0]
    set lly [$w canvasy 0]
    set urx [$w canvasx [winfo width  $w]]
    set ury [$w canvasy [winfo height $w]]

    # (x) No boxes confining the crosshair.
    if {![info exists opts(bbox)]} {
	#puts ANY($x,$y)
	return 1
    }

    # Determine active boundaries based on the boxes we are in (or not).

    # NOTE: This is linear in the number of active boundaries on the
    # canvas. If this is a really large number this will become
    # slow. If that happens consider creation and maintenance of some
    # fast data structure (R-tree, or similar) which can take
    # advantage of overlap and nesting to quickly rule out large
    # areas. Note that such a structure has its own price in time,
    # memory, and code complexity.

    set first 1
    foreach token $opts(bbox) {
	# Ignore removed boxes, not yet cleaned up. Note that we have
	# at least one active box here to touch by the loop. If we had
	# none the bbox_remove command ensured that (x) above
	# triggered.
	if {$token eq {}} continue

	# Get the box data, then test for usability. Ignore all boxes
	# we are outside of. They are not used for the boundary
	# calculation.
	set box [$w coords $token]
	if {[Outside $box $x $y]} continue

	# Unfold the box data and check if its boundaries are better
	# (less restrictive) than we currently have, or if this is the
	# first restriction.

	foreach {nllx nlly nurx nury} $box break

	if {$first || ($nllx < $llx)} { set llx $nllx }
	if {$first || ($nlly > $lly)} { set lly $nlly }
	if {$first || ($nurx > $urx)} { set urx $nurx }
	if {$first || ($nury < $ury)} { set ury $nury }

	set first 0
    }

    if {$first} {
	# We have boxes limiting us (See both (x)), and we are outside
	# of all of them. Time to hide the crosshairs.
	#puts OUT($x,$y)
	return 0
    }

    # We are inside of some box and have the proper boundaries of
    # visibility.
    #puts LIMIT($x,$y):$llx,$lly,$urx,$ury
    return 1
}

proc ::crosshair::Outside { box x y } {
    # Unfold box
    foreach {llx lly urx ury} $box break
 
    #puts \tTEST($x,$y):$llx,$lly,$urx,$ury:[expr {($x < $llx) || ($x > $urx) || ($y < $lly) || ($y > $ury)}]

    # Test each edge. Note that the border lines are considered as
    # "outside".

    expr {($x <= $llx) ||
	  ($x >= $urx) ||
	  ($y <= $lly) ||
	  ($y >= $ury)}
}

#----------------------------------------------------------------------
#
# ::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 x [$w canvasx $x]
    set y [$w canvasy $y]
    set opts(x) $x
    set opts(y) $y

    if {![GetBoundaries $w $x $y opts(x0) opts(y0) opts(x1) opts(y1)]} {
	# We are out of bounds. Kill the crosshair, store changes, and
	# return. This last disables the use of the tracking
	# callback. The crosshairs track only inside the allowed
	# boxes.
	Kill $w opts

	# Store changes back.
	set config($w) [array get opts]
	return
    }

    # Inside the boundaries, create or move.
    Place $w opts

    # Store changes back.
    set config($w) [array get opts]

    # And run the tracking callback, if active.
    if {![info exists opts(track)]} return
    uplevel \#0 [linsert $opts(track) end \
		     $w $opts(x) $opts(y) \
		     $opts(x0) $opts(y0) $opts(x1) $opts(y1)]
    return
}

# ### ### ### ######### ######### #########
## Create, destroy, or modify the parts of a crosshair.

proc ::crosshair::Place {w ov} {
    upvar 1 $ov opts

    # +/-4 is the minimal possible distance which still prevents the
    # canvas from choosing the crosshairs as 'current' object under
    # the cursor.
    set n 4

    set x  $opts(x)
    set y  $opts(y)
    set x0 $opts(x0)
    set y0 $opts(y0)
    set x1 $opts(x1)
    set y1 $opts(y1)
    set ax [expr {$x-$n}]
    set bx [expr {$x+$n}]
    set ay [expr {$y-$n}]
    set by [expr {$y+$n}]

    if { [info exists opts(hhairl)] } {
	# Modify a visible crosshair.

	$w coords $opts(hhairl) $x0 $y $ax $y
	$w coords $opts(hhairr) $bx $y $x1 $y
	$w coords $opts(vhairu) $x $y0 $x $ay
	$w coords $opts(vhaird) $x $by $x $y1

	$w raise $opts(hhairl)
	$w raise $opts(hhairr)
	$w raise $opts(vhaird)
	$w raise $opts(vhairu)
    } else {
	# Create a newly visible crosshair. After unhide and/or
	# entering into one of the active bboxes, if any.

	set opts(hhairl) [eval [list $w create line $x0 $y $ax $y] $opts(args)]
	set opts(hhairr) [eval [list $w create line $bx $y $x1 $y] $opts(args)]
	set opts(vhaird) [eval [list $w create line $x $y0 $x $ay] $opts(args)]
	set opts(vhairu) [eval [list $w create line $x $by $x $y1] $opts(args)]
    }
    return
}

proc ::crosshair::Kill {w ov} {
    upvar 1 $ov opts

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

Added scriptlibs/tklib0.7/crosshair/pkgIndex.tcl.





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

Added scriptlibs/tklib0.7/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
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
# By George Peter Staplin
# See also the README for a list of contributors
# RCS: @(#) $Id: ctext.tcl,v 1.9 2011/04/18 19:49:48 andreas_kupries Exp $

package require Tk
package provide ctext 3.3

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
    }
    if {[llength $lineList] > 0} {
	linemapUpdateOffset $win $lineList
    }
    set endrow [lindex [split [$win._t index end-1c] .] 0]
    $win.l configure -width [string length $endrow]
}

# Starting with Tk 8.5 the text widget allows smooth scrolling; this
# code calculates the offset for the line numbering text widget and
# scrolls by the specified amount of pixels

if {![catch {
    package require Tk 8.5
}]} {
    proc ctext::linemapUpdateOffset {win lineList} {
	# reset view for line numbering widget
	$win.l yview 0.0

	# find the first line that is visible and calculate the
	# corresponding line in the line numbers widget
	set lline 1
	foreach line $lineList {
	    set tystart [lindex [$win.t bbox $line.0] 1]
	    if {$tystart != ""} {
		break
	    }
	    incr lline
	}

	# return in case the line numbers text widget is not up to
	# date
	if {[catch {
	    set lystart [lindex [$win.l bbox $lline.0] 1]
	}]} {
	    return
	}

	# return in case the bbox for any of the lines returned an
	# empty value
	if {($tystart == "") || ($lystart == "")} {
	    return
	}

	# calculate the offset and then scroll by specified number of
	# pixels
	set offset [expr {$lystart - $tystart}]
	$win.l yview scroll $offset pixels
    }
}  else  {
    # Do not try to perform smooth scrolling if Tk is 8.4 or less.
    proc ctext::linemapUpdateOffset {args} {}
}

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

Added scriptlibs/tklib0.7/ctext/pkgIndex.tcl.



>
1
package ifneeded ctext 3.3 [list source [file join $dir ctext.tcl]]

Added scriptlibs/tklib0.7/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
126
127
128
129
130
131
132
133
134
135
136
137
# cursor.tcl --
#
#       Tk cursor handling routines
#
# Copyright (c) 2001-2009 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.4 2011/01/18 18:17:17 andreas_kupries Exp $

package require Tk 8.0
package provide cursor 0.3.1

namespace eval ::cursor {
    namespace export propagate restore display

    # Default to depthfirst (bottom up) restore to account for
    # megawidgets that will self-propagate cursor changes down.
    variable depthfirst 1

    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 configure -cursor $cursor
    } else {
	catch {unset CURSOR($w)}
    }
    foreach child [winfo children $w] { propagate $child $cursor }
}

# ::cursor::restore --
#
#	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 depthfirst
    variable CURSOR

    if {$depthfirst} {
	foreach child [winfo children $w] { restore $child $cursor }
    }
    if {[info exists CURSOR($w)]} {
	$w configure -cursor $CURSOR($w)
    } else {
	# Not all widgets have -cursor
	catch {$w configure -cursor $cursor}
    }
    if {!$depthfirst} {
	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 configure -cursor [%W get [%W nearest %y]] }
    wm deiconify $t
}

Added scriptlibs/tklib0.7/cursor/pkgIndex.tcl.



>
1
package ifneeded cursor 0.3.1 [list source [file join $dir cursor.tcl]]

Added scriptlibs/tklib0.7/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
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
##+##########################################################################
#
# 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 \
#   -format "%Y-%m-%d"
#  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
# TW	Mar 26, 2017	- support more keys and the mouse wheel
#			- add option -format to support 3 date-styles:
#				"%d.%m.%Y" (for German)
#				"%m/%d/%Y" (for English, standard)
#				"%Y-%m-%d" (for ISO)
#
##+##########################################################################
#############################################################################

package require Tk 8.0
package provide datefield 0.3

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
	variable Format
	variable Separator

	set i [lsearch $args "-form*"]
	if {$i == -1} {		# Default English
	    set Format($w) "%m/%d/%Y"
	} else {
	    set Format($w) [lindex [lreplace $args $i $i] $i]
	    switch -- $Format($w) {
		"%d.%m.%Y" {	# German
		}
		"%m/%d/%Y" {	# English
		}
		"%Y-%m-%d" {	# ISO
		}
		default {	# Error
		    error "ERROR: Unknown value for option -format on datefield $w $args"
		}
	    }
	    set args [lreplace $args $i $i]
	    set args [lreplace $args $i $i]
	}
	set Separator($w) [string range $Format($w) 2 2]
	eval $entry $w -width 10 -justify center $args
	if {([$w get] eq "") \
	 || [catch {clock scan [$w get] -format $Format($w)} base]} {
	    $w delete 0 end
	    $w insert end [clock format [clock seconds] -format $Format($w)]
	}
	$w icursor 0
	bind $w <KeyPress>	 [list ::datefield::KeyPress $w %A %K %s]
	bind $w <MouseWheel>	 [list ::datefield::MouseWheel $w %D]
	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
    }

    proc Spin {w dir unit code} {
	variable Format

	set base [clock scan [$w get] -format $Format($w)]
	set new [clock add $base $dir $unit]
	set date [clock format $new -format $Format($w)]
	set icursor [$w index insert]
	$w delete 0 end
	$w insert end $date
	$w icursor $icursor
	return $code
    }

    proc MouseWheel {w dir} {
	$w selection clear
	set Dir [expr {$dir / 120}]
	return -code [Spin $w $Dir "day" continue]
    }

    # internal routine for all key presses in the datefield entry widget
    proc KeyPress {w char sym state} {
	variable Format
	variable Separator

	proc Move {w dir} {
	    variable Format

	    set icursor [$w index insert]
	    set icursor [expr {($icursor + 10 + $dir) % 10}]
	    if {$Format($w) ne "%Y-%m-%d"} {			# English or German
		if {($icursor == 2) || ($icursor == 5)} {		# Don't land on a / or .
		    set icursor [expr {($icursor + 10 + $dir) % 10}]
		}
	    } \
	    elseif {($icursor == 4) || ($icursor == 7)} {	# ISO	# Don't land on a -
		set icursor [expr {($icursor + 10 + $dir) % 10}]
	    }
	    $w icursor $icursor
	}

	set icursor [$w index insert]
	$w selection clear
	# Handle some non-number characters first
	switch -exact -- $sym {
	    "Down"	{return -code [Spin $w -1 "day"		continue]}
	    "End"	{$w icursor 9;		return -code	break}
	    "minus"	{return -code [Spin $w -1 "day"		break]}
	    "Next"	{return -code [Spin $w -1 "month"	continue]}
	    "plus"	{return -code [Spin $w 1 "day"		break]}
	    "Prior"	{return -code [Spin $w 1 "month"	continue]}
	    "Up"	{return -code [Spin $w 1 "day"		continue]}
	    "BackSpace"	-
	    "Delete"	-
	    "Left"	{Move $w -1;		return -code	break}
	    "Right"	{Move $w 1;		return -code	break}
	    "Tab"		{
		if {$Format($w) ne "%Y-%m-%d"} {	# English or German
		    if {($state & 5) == 0} {		# ->|
			if {$icursor < 3} {	# from 1st to 2nd
			    $w icursor 3
			} \
			elseif {$icursor < 6} {	# from 2nd to 10th-year
			    $w icursor 8
			} else {		# next widget
			    return -code continue
			}
		    } \
		    elseif {$icursor > 4} {		# |<-
			$w icursor 3		;# from year to 2nd
		    } \
		    elseif {$icursor > 1} {	# from 2nd to 1st
			$w icursor 0
		    } else {			# previous widget
			return -code continue
		    }
		} \
		elseif {($state & 5) == 0} {		# ->|	ISO
		    if {$icursor < 5} {		# from year to month
			$w icursor 5
		    } \
		    elseif {$icursor < 8} {	# from month to day
			$w icursor 8
		    } else {			# next widget
			return -code continue
		    }
		} \
		elseif {$icursor > 6} {			# |<-
		    $w icursor 5		;# from day to month
		} \
		elseif {$icursor > 2} {		# from month to 10th-year
		    $w icursor 2
		} else {			# previous widget
		    return -code continue
		}
		return -code break
	    }
	}
	if {$char eq ""} {			# remaining special keys
	    return -code continue
	}
	if {! [regexp -- {[0-9]} $char]} {	# Unknown character
	    bell
	    return -code break
	}
	if {$icursor >= 10} {			# Can't add beyond end
	    bell
	    return -code break
	}
	switch -- $Separator($w) {
	    "." {	# German
		foreach {day month year} [split [$w get] $Separator($w)] break
		if {$icursor < 2} {			# DAY SECTION
		    set endday [lastDay $month $year]
		    foreach {d1 d2} [split $day ""] break
		    set cursor 3		;# Where to leave the cursor
		    if {$icursor == 0} {	# 1st digit of day
			if {($char < 3) \
			 || (($char == 3) && ($month ne "02"))} {
			    set day "$char$d2"
			    if {$day eq "00"} {set day "01"}
			    if {$day > $endday} {set day $endday}
			    set cursor 1
			} else {
			    set day "0$char"
			}
		    } else {			# 2nd digit of day
			set day "$d1$char"
			if {($day > $endday) || ($day eq "00")} {
			    bell
			    return -code break
			}
		    }
		    $w delete 0 2
		    $w insert 0 $day
		    $w icursor $cursor
		    return -code break
		}
		if {$icursor < 5} {			# MONTH SECTION
		    foreach {m1 m2} [split $month ""] break
		    set cursor 6		;# Where to leave the cursor
		    if {$icursor == 3} {	# 1st digit of month
			if {$char < 2} {
			    set month "$char$m2"
			    set cursor 4
			} else {
			    set month "0$char"
			}
			if {$month > 12} {set month "10"}
			if {$month eq "00"} {set month "01"}
		    } else {			# 2nd digit of month
			set month "$m1$char"
			if {$month > 12} {set month "0$char"}
			if {$month eq "00"} {
			    bell
			    return -code break
			}
		    }
		    $w delete 3 5
		    $w insert 3 $month
		    # Validate the day of the month
		    if {$day > [set endday [lastDay $month $year]]} {
			$w delete 0 2
			$w insert 0 $endday
		    }
		    $w icursor $cursor
		    return -code break
		}
		set y1 [string range $year 0 0];	# YEAR SECTION
		if {$icursor < 7} {		# 1st digit of year
		    if {($char ne "1") && ($char ne "2")} {
			bell
			return -code break
		    }
		    if {$char != $y1} {		# Different century
			set y 1999
			if {$char eq "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] -format $Format($w)}] != 0} {	# Validate the year
		    $w delete 6 end
		    $w insert end $year		;# Put back in the old year
		    $w icursor $icursor
		    bell
		}
	    }
	    "/" {	# English
		foreach {month day year} [split [$w get] $Separator($w)] break
		if {$icursor < 2} {			# MONTH SECTION
		    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 eq "00"} {set month "01"}
		    } else {			# 2nd digit of month
			set month "$m1$char"
			if {$month > 12} {set month "0$char"}
			if {$month eq "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
		}
		if {$icursor < 5} {			# DAY SECTION
		    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 ne "02"))} {
			    set day "$char$d2"
			    if {$day eq "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 eq "00")} {
			    bell
			    return -code break
			}
		    }
		    $w delete 3 5
		    $w insert 3 $day
		    $w icursor $cursor
		    return -code break
		}
		set y1 [string range $year 0 0];	# YEAR SECTION
		if {$icursor < 7} {		# 1st digit of year
		    if {($char ne "1") && ($char ne "2")} {
			bell
			return -code break
		    }
		    if {$char != $y1} {		# Different century
			set y 1999
			if {$char eq "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] -format $Format($w)}] != 0} {	# Validate the year
		    $w delete 6 end
		    $w insert end $year		;# Put back in the old year
		    $w icursor $icursor
		    bell
		}
	    }
	    default {	# ISO
		foreach {year month day} [split [$w get] $Separator($w)] break
		if {$icursor < 4} {			# YEAR SECTION
		    set y1 [string range $year 0 0];
		    if {$icursor == 0} {	# 1st digit of year
			if {($char ne "1") && ($char ne "2")} {
			    bell
			    return -code break
			}
			if {$char != $y1} {	# Different century
			    set y 1999
			    if {$char eq "2"} {set y 2000}
			    $w delete 0 4
			    $w insert 0 $y
			}
			$w icursor 1
			return -code break
		    }
		    $w delete $icursor
		    $w insert $icursor $char
		    if {[catch {clock scan [$w get] -format $Format($w)}] != 0} {	# Validate the year
			$w delete 0 4
			$w insert 0 $year	;# Put back in the old year
			$w icursor $icursor
			bell
		    }
		    if {$icursor == 3} {	# last digit of year
			$w icursor 5	;# Don't land on a -
		    }
		    return -code break
		}
		if {$icursor < 7} {			# MONTH SECTION
		    foreach {m1 m2} [split $month ""] break
		    set cursor 8		;# Where to leave the cursor
		    if {$icursor == 5} {	# 1st digit of month
			if {$char < 2} {
			    set month "$char$m2"
			    set cursor 6
			} else {
			    set month "0$char"
			}
			if {$month > 12} {set month "10"}
			if {$month eq "00"} {set month "01"}
		    } else {			# 2nd digit of month
			set month "$m1$char"
			if {$month > 12} {set month "0$char"}
			if {$month eq "00"} {
			    bell
			    return -code break
			}
		    }
		    $w delete 5 7
		    $w insert 5 $month
		    # Validate the day of the month
		    if {$day > [set endday [lastDay $month $year]]} {
			$w delete 8 end
			$w insert end $endday
		    }
		    $w icursor $cursor
		    return -code break
		}
		set endday [lastDay $month $year]	;# DAY SECTION
		foreach {d1 d2} [split $day ""] break
		set cursor 10			;# Where to leave the cursor
		if {$icursor == 8} {		# 1st digit of day
		    if {($char < 3) \
		     || (($char == 3) && ($month ne "02"))} {
			set day "$char$d2"
			if {$day eq "00"} {set day "01"}
			if {$day > $endday} {set day $endday}
			set cursor 9
		    } else {
			set day "0$char"
		    }
		} else {			# 2nd digit of day
		    set day "$d1$char"
		    if {($day > $endday) || ($day eq "00")} {
			bell
			return -code break
		    }
		}
		$w delete 8 end
		$w insert end $day
		$w icursor $cursor
	    }
	}
	return -code break
    }

    # internal routine that returns the last valid day of a given month and year
    proc lastDay {month year} {
	return [clock format [clock scan "+1 month -1 day" \
	 -base [clock scan "$month/01/$year"]] -format %d]
    }
}

Added scriptlibs/tklib0.7/datefield/pkgIndex.tcl.



>
1
package ifneeded datefield 0.3 [list source [file join $dir datefield.tcl]]

Added scriptlibs/tklib0.7/diagrams/application.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
## -*- tcl -*-
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>
## BSD Licensed
# # ## ### ##### ######## ############# ######################

#
# application on top of the diagram drawing package.
#

## Use Cases
## (1) Reading a single diagram file and showing it on a canvas.

## (1a) Like (1), for multiple input files. This requires an additional
##     selection step before the diagram is shown.

## (2) Convert one or more diagram files into raster images in various
##     formats.

# # ## ### ##### ######## ############# #####################
## Command syntax

## (Ad 1)  show picfile
## (Ad 1a) show picfile picfile...

## (Ad 2)  convert -o output-file-or-dir format picfile
##         convert -o output-dir         format picfile picfile...

# # ## ### ##### ######## ############# #####################
## Requirements

package require Tcl 8.5
package require Tk  8.5
package require fileutil

wm withdraw . ; # Hide the main toplevel until we actually need it, if
		# ever.
namespace eval ::diagram::application {}

# # ## ### ##### ######## ############# #####################
## Implementation

proc ::diagram::application {arguments} {
    variable application::mode
    application::ProcessCmdline $arguments
    application::Run::$mode
    return
}

proc ::diagram::application::showerror {text} {
    global argv0
    puts stderr "$argv0: $text"
    exit 1
}

# # ## ### ##### ######## ############# #####################
## Internal data and status

namespace eval ::diagram::application {
    # Path to where the output goes to. Depending on the chosen mode
    # this information may be irrelevant, a file, or a directory.
    # Specified through the option '-o' where suitable.

    variable  output ""

    # Paths of the documents to convert. Always a list, even in the
    # case of a single input file. Specified through the trailing
    # arguments on the command line. The relative path of a file under
    # 'input' also becomes its relative path under 'output'.

    variable  input  ""

    # The name of the format to convert the diagram documents
    # into. Used as extension for the generated files as well when
    # converting multiple files. Internally this is the name of the
    # canvas::* or img::* package for the image format. The two cases
    # are distinguished by the value of the boolean flag "snap". True
    # indicates a raster format via img::*, false a canvas::* dump
    # package ... FUTURE :: Should have a 'canvas::write::*' or
    # somesuch family of packages which hide this type of difference
    # from us.

    variable  format ""
    variable  snap   0

    # Name of the found processing mode. Derived during processing all
    # arguments on the command line. This value is used during the
    # dispatch to the command implementing the mode, after processing
    # the command line.
    #
    # Possible/Legal values:	Meaning
    # ---------------------	-------
    # ---------------------	-------

    variable  mode   ""
}

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

proc ::diagram::application::ProcessCmdline {arguments} {
    variable input  {} ; # Set defaults.
    variable output "" ; #
    variable format "" ; #
    variable mode   "" ; #

    # syntax: show file...
    #         convert -o output format file...

    if {[llength $arguments] < 2} Usage
    set arguments [lassign $arguments command]

    switch -exact -- $command {
	show    {ProcessShow    $arguments}
	convert {ProcessConvert $arguments}
	default Usage
    }

    set mode $command
    return
}

proc ::diagram::application::ProcessShow {arguments} {
    if {[llength $arguments] < 1} Usage
    variable input   {}
    variable trusted 0

    # Basic option processing and validation.
    while {[llength $arguments]} {
        set opt [lindex $arguments 0]
        if {![string match "-*" $opt]} break

        switch -exact -- $opt {
            -t {
                if {[llength $arguments] < 1} Usage
                set arguments [lassign $arguments _opt_]
                set trusted 1
            }
            default Usage
        }
    }

    set input $arguments
    CheckInput
    return
}

proc ::diagram::application::ProcessConvert {arguments} {
    variable output ""
    variable input  {}
    variable format ""
    variable trusted 0

    if {[llength $arguments] < 4} Usage

    # Basic option processing and validation.
    while {[llength $arguments]} {
	set opt [lindex $arguments 0]
	if {![string match "-*" $opt]} break

	switch -exact -- $opt {
	    -o {
		if {[llength $arguments] < 2} Usage
		set arguments [lassign $arguments _opt_ output]
	    }
            -t {
                if {[llength $arguments] < 1} Usage
                set arguments [lassign $arguments _opt_]
                set trusted 1
            }
	    default Usage
	}
    }
    # Format and at least one file are expected.
    if {[llength $arguments] < 2} Usage
    set input [lassign $arguments format]

    ValidateFormat
    CheckInput
    CheckOutput
    return
}

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

proc ::diagram::application::Usage {} {
    showerror "wrong#args, expected: show file...|convert -o outputpath format file..."
    # not reached ...
}

# # ## ### ##### ######## ############# #####################
## Various complex checks on the arguments

proc ::diagram::application::ValidateFormat {} {
    variable format
    variable snap
    if {![catch {
	package require canvas::snap
	package require img::$format
	set snap 1
    } msgA]} return

    if {![catch {
	package require canvas::$format
    } msgB]} return

    showerror "Unable to handle format \"$format\", because of: $msgA and $msgB"
    return
}

proc ::diagram::application::CheckInput {} {
    variable input
    foreach f $input {
	if {![file exists $f]} {
	    showerror "Unable to find picture \"$f\""
	} elseif {![file readable $f]} {
	    showerror "picture \"$f\" not readable (permission denied)"
	}
    }
    if {[llength $input] < 1} {
	showerror "No picture(s) specified"
    }
    return
}

proc ::diagram::application::CheckOutput {} {
    variable input
    variable output

    if {$output eq ""} {
	showerror "No output path specified"
    }

    set base [file dirname $output]
    if {$base eq ""} {set base [pwd]}

    # Multiple inputs: Output must either exist as directory, or
    # output base writable so that we can create the directory.
    # Single input: As above except existence as file.

    if {![file exists $output]} {
	if {![file exists $base]} {
	    showerror "Output base path \"$base\" not found"
	}
	if {![file writable $base]} {
	    showerror "Output base path \"$base\" not writable (permission denied)"
	}
    } else {
	if {![file writable $output]} {
	    showerror "Output path \"$output\" not writable (permission denied)"
	}

	if {[llength $input] > 1} {
	    if {![file isdirectory $output]} {
		showerror "Output path \"$output\" not a directory"
	    }
	} else {
	    if {![file isfile $output]} {
		showerror "Output path \"$output\" not a file"
	    }
	}
    }
    return
}

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

namespace eval ::diagram::application::Run::GUI {}

proc ::diagram::application::Run::show {} {
    variable ::diagram::application::input

    GUI::Show

    if {[llength $input] == 1} {
	after 100 {
	    .l selection clear 0 end
	    .l selection set   0
	    event generate .l <<ListboxSelect>>
	}
    }

    vwait __forever__
    return
}

proc ::diagram::application::Run::convert {} {
    variable ::diagram::application::input
    variable ::diagram::application::output

    set dip [MakeInterpreter]
    GUI::Convert
    PrepareOutput

    if {[llength $input] > 1} {
	foreach f $input {
	    Convert $dip $f [GetDestination $f]
	}
    } else {
	set f [lindex $input 0]
	if {[file exists $output] && [file isdirectory $output]} {
	    Convert $dip $f [GetExtension $output/[file tail $input]]
	} else {
	    Convert $dip $f $output
	}
    }

    interp delete $dip
    GUI::Close
    return
}

proc ::diagram::application::Run::Convert {dip src dst} {
    variable ::diagram::application::format
    variable ::diagram::application::snap

    puts ${src}...
    set pic [fileutil::cat $src]

    if {[catch {
	$dip eval [list D draw $pic]
    } msg]} {
	puts "FAIL $msg : $src"
    } elseif {$snap} {
	set DIA [canvas::snap .c]
	$DIA write $dst -format $format
	image delete $DIA
    } else {
	# Direct canvas dump ...
	fileutil::writeFile $dst [canvas::$format .c]
    }

    # Wipe controller state, no information transfer between pictures.
    $dip eval {D reset}
    return
}

proc ::diagram::application::Run::GUI::Show {} {
    package require widget::scrolledwindow
    #package require crosshair

    set dip [::diagram::application::Run::MakeInterpreter]

    ttk::notebook          .n
    button                 .e -text Exit -command ::exit
    widget::scrolledwindow .sl -borderwidth 1 -relief sunken
    widget::scrolledwindow .sc -borderwidth 1 -relief sunken
    widget::scrolledwindow .st -borderwidth 1 -relief sunken
    listbox                .l -width 40 -selectmode single -listvariable ::diagram::application::input
    canvas                 .c -width 800 -height 600 -scrollregion {-4000 -4000 4000 4000}
    text                   .t -font {Arial 20}

    .sl setwidget .l
    .sc setwidget .c
    .st setwidget .t

    pack .e  -fill none -expand 0 -side bottom -anchor e

    #panedwindow .p -orient vertical
    #.p add .sl .sc
    #.p paneconfigure .sl -width 100

    pack .sl -fill both -expand 1 -padx 4 -pady 4 -side left
    pack .n -fill both -expand 1 -padx 4 -pady 4 -side right

    .n add .sc -state normal -sticky swen -text Diagram
    .n add .st -state normal -sticky swen -text Code

    bind .l <<ListboxSelect>> [list ::diagram::application::Run::GUI::ShowPicture $dip]

    # Panning via mouse
    bind .c <ButtonPress-2> {%W scan mark   %x %y}
    bind .c <B2-Motion>     {%W scan dragto %x %y}

    # Cross hairs ...
    #.c configure -cursor tcross
    #crosshair::crosshair .c -width 0 -fill \#999999 -dash {.}
    #crosshair::track on  .c TRACK

    wm deiconify .
    return
}

proc ::diagram::application::Run::GUI::ShowPicture {dip} {

    set selection [.l curselection]
    if {![llength $selection]} return

    $dip eval {catch {D destroy}}
    $dip eval {diagram D .c}

    set pic [fileutil::cat [.l get $selection]]

    .t delete 0.1 end
    .t insert 0.1 $pic

    after 0 [list $dip eval [list D draw $pic]]
    return
}

proc ::diagram::application::Run::GUI::Convert {} {
    canvas .c -width 800 -height 600 -scrollregion {0 0 1200 1000}
    grid   .c -row 0 -column 0 -sticky swen

    grid rowconfigure    . 0 -weight 1
    grid columnconfigure . 0 -weight 1

    wm attributes     . -fullscreen 1
    wm deiconify      .
    tkwait visibility .
    return
}

proc ::diagram::application::Run::GUI::Close {} {
    wm withdraw .
    destroy     .
    return
}

proc ::diagram::application::Run::PrepareOutput {} {
    variable ::diagram::application::input
    variable ::diagram::application::output

    if {[llength $input] > 1} {
	file mkdir [file dirname $output]
    }
    return
}

proc ::diagram::application::Run::GetDestination {f} {
    variable ::diagram::application::output

    if {[file pathtype $f] ne "relative"} {
	return set f [file join $output {*}[lrange [file split $f] 1 end]]
    } else {
       set f $output/$f
    }
    file mkdir [file dirname $f]
    return [GetExtension $f]
}

proc ::diagram::application::Run::GetExtension {f} {
    variable ::diagram::application::format
    return [file rootname $f].$format
}

proc ::diagram::application::Run::MakeInterpreter {} {
    variable ::diagram::application::trusted
    set sec [expr {[lindex [time {
        if {$trusted} {
            puts {Creating trusted environment, please wait...}
            set dip [interp create]
            $dip eval [list set auto_path $::auto_path]
        } else {
            puts {Creating safe environment, please wait...}
	    set dip [::safe::interpCreate]
        }
	interp alias $dip .c {} .c ; # Import of canvas
	interp alias $dip tk {} tk ; # enable tk scaling
	$dip eval {package require diagram}
	$dip eval {diagram D .c}
    }] 0]/double(1e6)}]
    puts "... completed in $sec seconds."
    after 100
    return $dip
}

# # ## ### ##### ######## ############# #####################
package provide diagram::application 1.2
return

Added scriptlibs/tklib0.7/diagrams/attributes.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
## -*- tcl -*-
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>
## BSD Licensed
# # ## ### ##### ######## ############# ######################

#
# diagram attribute database, basic data plus extensibility features.

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

package require Tcl 8.5             ; # Want the nice things it brings (dicts, {*}, etc.)
package require snit                ; # Object framework.
package require struct::queue       ; # Word storage when processing attribute arguments.

# # ## ### ##### ######## ############# ######################
## Implementation

snit::type ::diagram::attribute {

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Attribute extensibility

    method new {name args} {
	array set spec $args

	if {![info exists spec(key)]} { set spec(key) $name }
	set key $spec(key)

	set getvalue   [GetFunction       spec]
	set ovalidate  [ValidateFunction  spec] ; # snit validation type, or API compatible.
	set otransform [TransformFunction spec] ; # o* <=> optional function.
	set merger     [MergeFunction     spec $key]
	set odefault   [DefaultFunction   spec $key]

	set myattrp($name) [ProcessingFunction $getvalue $ovalidate $otransform $merger]

	if {![llength $odefault]} return

	set myattrd($key) $odefault
	{*}$odefault init
	return
    }

    method {unknown =} {unknowncmd} {
	set myunknown [list $unknowncmd]
	return
    }

    method {unknown +} {unknowncmd} {
	lappend myunknown $unknowncmd
	return
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API :: attribute processing, integrated loading of requested defaults.

    method attributes {shape words required} {
	return [$self defaults [$self process $shape $words] $required]
    }

    method process {shape words} {
	if {![llength $words]} {
	    return {}
	}

	set attributes [ReadySame $shape]

	{*}$wq clear
	{*}$wq put {*}$words

	while {[{*}$wq size]} {
	    set aname [{*}$wq get]
	    set shape [dict get $attributes /shape]

	    if {[{*}$wq size]} {
		#puts A|do|$aname|/$shape|\t\t(([{*}$wq peek [{*}$wq size]]))
	    } else {
		#puts A|do|$aname|/$shape|\t\t(())
	    }

	    # Check for a shape-specific attribute first, then try the
	    # name as is.

	    if {[info exists myattrp(${shape}::$aname)]} {
		{*}$myattrp(${shape}::$aname) $wq attributes
		continue
	    } elseif {[info exists myattrp($aname)]} {
		{*}$myattrp($aname) $wq attributes
		continue
	    }

	    #puts A|unknown|$aname|

	    # Hooks for unknown names, for dynamic extension.
	    {*}$wq unget $aname
	    set ok 0
	    foreach hook $myunknown {
		#puts A|unknown/$shape|\t\t(([{*}$wq peek [{*}$wq size]]))
		if {[{*}$hook $shape $wq]} {
		    #puts A|unknown|taken|$hook
		    set ok 1
		    break
		}
	    }
	    if {$ok} continue
	    BadAttribute $shape $wq
	}

	#puts A|done|$attributes|

	SaveSame $attributes
	return $attributes
    }

    method defaults {attributes required} {
	# Note: All default hooks are run, even if the key is already
	# specified. This gives the hook the opportunity to not only
	# fill in defaults, but to compute and store derived
	# information (from multiple other attributes) as well. An
	# example using this ability are the Waypoint and ArcLocation
	# handlers which essentially precompute large parts of their
	# elements' geometry.

	foreach key $required {
	    #if {[dict exists $attributes $key]} continue
	    if {![info exists myattrd($key)]} {
		#return -code error "Unable to determine a default for \"$key\""
		continue
	    }
	    {*}$myattrd($key) fill attributes
	}
	return $attributes
    }

    method set {attributes} {
	dict for {key value} $attributes {
	    if {![info exists myattrd($key)]} continue
	    {*}$myattrd($key) set $key $value
	}
	return
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Instance construction

    constructor {core} {
	# Core attributes (shape redefinition, history access (same))
	set mycore    $core
	#set myunknown [myproc BadAttribute]

	$self new /shape                        merge [mymethod Merge/shape]
	$self new same   get [mymethod GetSame] merge [mymethod MergeSame]

	install wq using struct::queue ${selfns}::WQ

	# Queue Tracer
	if {0} {set wq [list ::apply [list {args} {
	    puts $args
	    uplevel 1 $args
	}] $wq]}

	return
    }

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

    proc ReadySame {shape} {
	upvar 1 mycurrentsame mycurrentsame mysame mysame
	set mycurrentsame {}
	catch {
	    set mycurrentsame $mysame($shape)
	}
	return [list /shape $shape]
    }

    proc SaveSame {attributes} {
	upvar 1 mysame mysame
	set shape [dict get $attributes /shape]
	set mysame($shape) $attributes
	return
    }

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

    proc BadAttribute {shape words} {
	return -code error "Expected attribute, got \"[{*}$words peek]\""
    }

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

    method GetSame {words_dummy} {
	return $mycurrentsame
    }

    method MergeSame {key samedict attributes} {
	# key == "same"
	return [dict merge $attributes $samedict]
    }

    method Merge/shape {key newshape attributes} {
	# key == "/shape"
	ReadySame $newshape
	dict set attributes /shape $newshape
	return $attributes
    }

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

    method Get {words} {
	return [{*}$words get]
    }

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

    method Set {key value attributes} {
	#puts AM.=|$key||$value|\t|$attributes|

	dict set attributes $key $value

	#puts AM:=|$attributes|
	return $attributes
    }

    method Lappend {key value attributes} {
	#puts AM++|$key||$value|\t|$attributes|

	dict lappend attributes $key $value

	#puts AM:=|$attributes|
	return $attributes
    }

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

    method Linked {key varname defaultvalue cmd args} {
	#puts "Linked ($key $varname $defaultvalue) $cmd $args"

	$self Linked_ $cmd $key $varname $defaultvalue {*}$args
    }

    method {Linked_ init} {key varname defaultvalue} {
	$mycore state set $varname $defaultvalue
	return
    }

    method {Linked_ set} {key varname defaultvalue _key newvalue} {
	$mycore state set $varname $newvalue
	return
    }

    method {Linked_ fill} {key varname defaultvalue av} {
	upvar 2 $av attributes ; # Bypass the 'Linked' dispatcher.
	#puts LINK|$key|$varname|-|$attributes|-|[$mycore state get $varname]|
	if {[dict exists $attributes $key]} return
	dict set attributes $key [$mycore state get $varname]
	return
    }

    # # ## ### ##### ######## ############# ######################
    ## Helper commands processing an attribute specification into a set of anonymous functions

    proc GetFunction {sv} {
	upvar 1 $sv spec selfns selfns
	if {[info exists spec(get)]} { return $spec(get) }
	return [mymethod Get]
    }

    proc ValidateFunction {sv} {
	upvar 1 $sv spec
	if {[info exists spec(type)]} {
	    set f $spec(type)
	    if {[llength $f] > 1} {
		# The specification is type + arguments. Create a
		# proper object by inserting a name into the command and then running it.
		set f [eval [linsert $f 1 AttrType%AUTO%]]
	    }
	    return [list {*}$f validate]
	}
	return {}
    }

    proc TransformFunction {sv} {
	upvar 1 $sv spec
	if {[info exists spec(transform)]} { return $spec(transform) }
	return {}
    }

    proc MergeFunction {sv key} {
	upvar 1 $sv spec selfns selfns
	if {[info exists spec(merge)]} { return [list {*}$spec(merge) $key] }
	if {![info exists spec(aggregate)]} {
	    set spec(aggregate) 0
	}
	if {$spec(aggregate)} {
	    return [mymethod Lappend $key]
	} else {
	    return [mymethod Set $key]
	}
    }

    proc DefaultFunction {sv key} {
	upvar 1 $sv spec selfns selfns
	if {[info exists spec(default)]} { return $spec(default) }
	if {[info exists spec(linked)]} {
	    #lassign $spec(linked) varname defaultvalue
	    return [mymethod Linked $key {*}$spec(linked)]
	}
	return {}
    }

    proc ProcessingFunction {get validate transform merge} {
	# partial functions.
	# validate, transform - optional
	# get, merge          - required

	# Types
	# get       : wordvar -> value
	# transform : value   -> value
	# validate  : value   -> value
	# merge     : value -> dict -> dict

	if {[llength $validate] && [llength $transform]} {
	    return [list ::apply [list {get validate transform merge words av} {
		upvar 1 $av attributes
		set value      [{*}$get       $words]
		set value      [{*}$transform $value]
		set value      [{*}$validate  $value]
		set attributes [{*}$merge     $value $attributes]
	    }] $get $validate $transform $merge]

	} elseif {[llength $validate]} {
	    return [list ::apply [list {get validate merge words av} {
		upvar 1 $av attributes
		set value      [{*}$get      $words]
		set value      [{*}$validate $value]
		set attributes [{*}$merge    $value $attributes]
	    }] $get $validate $merge]

	} elseif {[llength $transform]} {
	    return [list ::apply [list {get transform merge words av} {
		upvar 1 $av attributes
		set value      [{*}$get       $words]
		set value      [{*}$transform $value]
		set attributes [{*}$merge     $value $attributes]
	    }] $get $transform $merge]

	} else {
	    return [list ::apply [list {get merge words av} {
		upvar 1 $av attributes
		set value      [{*}$get   $words]
		set attributes [{*}$merge $value $attributes]
	    }] $get $merge]
	}
    }

    # # ## ### ##### ######## ############# ######################
    ## Instance data. Maps from attribute names and dictionary keys to
    ## relevant functions for processing input and defaults.

    variable mycore    {}
    variable myunknown {}

    variable myattrp -array {} ; # attribute command -> processing function
    variable myattrd -array {} ; # attribute key -> default management function

    # History stack, one level deep, keyed by shape name.

    variable mysame -array {}
    variable mycurrentsame {}

    component wq ; # Storage for the words we are processing as attributes.

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

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

package provide diagram::attribute 1

Added scriptlibs/tklib0.7/diagrams/basic.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
## -*- tcl -*-
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>
## BSD Licensed
# # ## ### ##### ######## ############# ######################

#
# diagram, basic elements (line, arc, box, circle, ellipse, diamond, drum, text)
#

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

package require Tcl 8.5              ; # Want the nice things it
				       # brings (dicts, {*}, etc.)
package require snit                 ; # Object framework.
package require math::geometry 1.1.2 ; # Vector math (points, line
				       # (segments), poly-lines).
package require diagram::point       ; # Tagged geometry data and ops

# # ## ### ##### ######## ############# ######################
## Implementation

snit::type ::diagram::basic {

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Construction, attach to the specified core.

    constructor {thecore} {
	set core $thecore

	# Basic elements ... First the closed elements (closed curves) ...

	DefE $core box     {textcolor textfont anchor justify stroke style color fillcolor at with width height slant}
	DefE $core circle  {textcolor textfont anchor justify stroke style color fillcolor at with circle::radius} 
	DefE $core diamond {textcolor textfont anchor justify stroke style color fillcolor at with diamond::width diamond::height diamond::aspect}
	DefE $core drum    {textcolor textfont anchor justify stroke style color fillcolor at with width height drum::aspect}
	DefE $core ellipse {textcolor textfont anchor justify stroke style color fillcolor at with width height}
	DefE $core text    {textcolor textfont anchor justify text at with}

	# ... and then the open elements (open curves).

	DefE $core line    {textcolor textfont anchor justify stroke style color fillcolor from to then smooth arrowhead noturn}
	DefE $core arc     {textcolor textfont anchor justify stroke style color fillcolor arc::radius clockwise arc::from arc::to}

	$core new shape arrow
	$core new shape spline

	# Note 1: The attribute order is important for arc elements.
	#         We wish to resolve both clockwise and radius before
	#         the from/to points, as we need this data available
	#         for when we have to determine defaults.

	# Note 2: text elements do not require defaults for width and
	#         height, see the marker (%%) for more information.

	# ... and their attributes ...

	# common validation types
	set dzero [snit::double  ${selfns}::D0 -min 0]
	set dmin  [snit::double  ${selfns}::D1 -min 0];# 0 exclusive.
	set izero [snit::integer ${selfns}::I0 -min 0]
	#set imin  [snit::integer ${selfns}::I1 -min 1]

	# general element style

	$core new attribute stroke    linked {linewidth  1}  type $izero
	$core new attribute style     linked {linestyle  {}} transform [myproc LineStyle]
	$core new attribute color     linked {linecolor  black}
	$core new attribute fillcolor linked {fillcolor  {}}

	$core new attribute text      aggregate 1
	$core new attribute textcolor linked {textcolor black}
	$core new attribute textfont  linked {textfont  {Helvetica 12}}
	$core new attribute anchor    linked {anchor    center}
	$core new attribute justify   linked {justify   left}

	# box geometry, width/height shared with ellipse, drum

	$core new attribute width  linked [Link boxwidth  2 cm] type $dmin
	$core new attribute height linked [Link boxheight 2 cm] type $dmin
	$core new attribute slant  linked {slant     90} type snit::double;# degrees - range normalization - transform ?

	# circle geometry

	$core new attribute arc::radius      linked [Link arcradius    1 cm] type $dmin
	$core new attribute circle::radius   linked [Link circleradius 1 cm] type $dmin
	$core new attribute diameter key circle::radius type $dmin \
	    transform [myproc CircleRadiusByDiameter]

	# diamond geometry

	set dd [mymethod Diamond]
	$core new attribute diamond::width  type $dmin  default $dd
	$core new attribute diamond::height type $dmin  default $dd
	$core new attribute diamond::aspect type $dzero default $dd

	# drum geometry, width, height, see box.

	$core new attribute drum::aspect type $dzero linked {drumaspect 0.35}

	# line style. geometry see core, shared with move command.
	# Note that chop processing happens in the 'Waypoints' ensemble, in core!

	$core new attribute chop aggregate 1 type $dzero get [mymethod Chop]
	$core new attribute arrowhead transform [myproc LineArrows] linked {arrowhead none}
	$core new attribute smooth    type snit::boolean            linked {smooth 0} \
	    get [myproc Smooth]
	$core new attribute noturn    type snit::boolean \
	    get     [myproc NoTurn]
	#default [myproc NoTurnDefault]

	# arc location, and direction (counter(clockwise))

	set al [mymethod ArcLocation]
	$core new attribute arc::from type diagram::point default $al
	$core new attribute arc::to   type diagram::point default $al
	$core new attribute clockwise type snit::boolean linked {clockwise 0} \
	    get [myproc ClockWise 1]
	$core new attribute counterclockwise key clockwise type snit::boolean \
	    get [myproc ClockWise 0]

	# Further a number of shorthands for some commands and
	# attributes, and commands using the unicode glyphs looking
	# like the elements.

	$core new alias spline {line /shape spline smooth}
	$core new alias arrow  {line /shape arrow  arrowhead ->}
	$core new alias \u21d2 {line /shape arrow  arrowhead <-}
	$core new alias \u27f6 {line /shape arrow  arrowhead ->}
	$core new alias -->    {line /shape arrow  arrowhead ->}
	$core new alias <--    {line /shape arrow  arrowhead <-}
	$core new alias <-->   {line /shape arrow  arrowhead <->}
	$core new alias O      circle
	$core new alias --     line
	$core new alias <>     diamond
	$core new alias \u25cb circle
	$core new alias \u25fb box
	$core new alias \u25c7 diamond
	$core new alias \u2312 arc
	$core new alias \u21b6 arc
	$core new alias \u21b7 {arc clockwise}
	$core new alias \u2780 1th
	$core new alias \u2781 2th
	$core new alias \u2782 3th
	$core new alias \u2783 4th
	$core new alias \u2784 5th
	$core new alias \u2785 6th
	$core new alias \u2786 7th
	$core new alias \u2787 8th
	$core new alias \u2788 9th
	$core new alias \u2789 10th
	$core new alias \u2776 {1th last}	
	$core new alias \u2777 {2th last}	
	$core new alias \u2778 {3th last}	
	$core new alias \u2779 {4th last}	
	$core new alias \u277a {5th last}	
	$core new alias \u277b {6th last}	
	$core new alias \u277c {7th last}	
	$core new alias \u277d {8th last}	
	$core new alias \u277e {9th last}	
	$core new alias \u277f {10th last}	

	# The hooks are run in the specified order, first to last,
	# until one takes the element, or the system runs out of of
	# hooks.
	$core unknown attribute [myproc Styles]
	$core unknown attribute [myproc Arrowheads]
	$core unknown attribute [myproc Shorthands]
	$core unknown attribute [myproc Label]
	return
    }

    # # ## ### ##### ######## ############# ######################
    ## Internal :: Register a shape.

    proc DefE {core name required} {
	upvar 1 selfns selfns
	$core new element $name $required [mymethod $name]
	return
    }

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

    proc CircleRadiusByDiameter {diameter} {
	return [expr {double($diameter)/2}]
    }

    proc LineStyle {s} {
	switch -exact -- $s {
	    solid        { return {}  }
	    dot          { return .   }
	    dotted       { return .   }
	    dash         { return -   }
	    dashed       { return -   }
	    dash-dot     { return -.  }
	    dash-dot-dot { return -.. }
	    default      { return $s }
	}
    }

    proc Styles {shape words} {
	set w [{*}$words peek]
	if {![info exists ourstyles($w)]} {return 0}
	{*}$words unget style
	return 1
    }

    proc LineArrows {s} {
	switch -exact -- $s {
	    start   { return first }
	    end     { return last  }
	    ->      { return last  }
	    <-      { return first }
	    <->     { return both  }
	    -       { return none  }
	    \u21a6  { return last  }
	    \u21a4  { return first }
	    \u21ae  { return both  }
	    default { return $s }
	}
    }

    proc Arrowheads {shape words} {
	set w [{*}$words peek]
	if {![info exists ourarrows($w)]} {return 0}
	{*}$words unget arrowhead
	return 1
    }

    proc Shorthands {shape words} {
	set w [{*}$words peek]
	if {![info exists ourshorts($w)]} {return 0}
	# Drop the alias name and then stuff the replacement in.
	{*}$words get
	foreach str [lreverse $ourshorts($w)] {
	    {*}$words unget $str
	}
	return 1
    }

    proc Label {shape words} {
	# Catch all attribute hook. Register last, as no hook coming
	# after it will be run. Any unknown attribute is taken to be a
	# text label associated with the element.
	{*}$words unget text
	return 1
    }

    # # ## ### ##### ######## ############# ######################
    ## Internal :: Shape implementations.

    method box {canvas attributes} {
	array set a $attributes

	set styling [list \
			 -fill    $a(fillcolor) \
			 -outline $a(color)     \
			 -width   $a(stroke)    \
			 -dash    $a(style)]

	if {$a(slant) != 90} {
	    lassign [BoxSlantedCorners a] corners polygon

	    lappend items [$canvas create polygon \
			       {*}$polygon {*}$styling]
	} else {
	    lassign [BoxCorners a] corners rect

	    lappend items [$canvas create rectangle \
			       {*}$rect {*}$styling]
	}

	HandleText $canvas $attributes items [dict get $corners center]
	return [list $items $corners]
    }

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

    proc BoxSlantedCorners {av} {
	upvar 1 $av a

	lassign [BoxCorners a] corners rect

	set s $a(slant)
	set w $a(width)
	set h $a(height)

	set dx    [expr {cos($s * (4*atan(1))/180.) * $h}]
	set shift [geo::h $dx]
	set up    [geo::s* -0.5 [geo::v $h]]
	set right [geo::s*  0.5 [geo::h $w]]

	set nw [list \
		    [expr {-$w/2.0}] \
		    [expr {-$h/2.0}]]
	set se [list \
		    [expr { $w/2.0}] \
		    [expr { $h/2.0}]]

	# We compute all the corner points as well, given that they
	# have custom locations.

	set center {0 0};#[geo::between $nw $se 0.5]

	if {$dx > 0} {
	    #             xc
	    #          xnw xn  xne
	    # ynw     (*)--*---*
	    #         /   /   /
	    #        *--<*>--* yc
	    #       /   /   /
	    #      *---*--(*) yse
	    #      xsw xs  xse

	    set vne [geo::+ [geo::+ $right $shift] $up]

	    set northwest $nw
	    set northeast [geo::+ $center $vne]
	    set southeast $se
	    set southwest [geo::- $center $vne]

	} else {
	    #             xc
	    #      xnw xn  xne
	    # ynw (*)--*---*
	    #       \   \   \.
	    #        *--<*>--* yc
	    #         \   \   \.
	    #          *---*--(*) yse
	    #          xsw xs  xse

	    lassign $nw xnw ynw
	    lassign $se xse yse

	    set northwest [geo::+ $nw $shift]
	    set northeast [geo::p $xse $ynw]
	    set southeast [geo::- $se $shift]
	    set southwest [geo::p $xnw $yse]
	}

	set north [geo::between $northwest $northeast 0.5]
	set east  [geo::between $northeast $southeast 0.5]
	set south [geo::between $southwest $southeast 0.5]
	set west  [geo::between $northwest $southwest 0.5]

	set polygon [list \
			 {*}$northwest {*}$northeast \
			 {*}$southeast {*}$southwest]

	set corners [list \
			 north     [diagram::point at {*}$north] \
			 northeast [diagram::point at {*}$northeast] \
			 east      [diagram::point at {*}$east] \
			 southeast [diagram::point at {*}$southeast] \
			 south     [diagram::point at {*}$south] \
			 southwest [diagram::point at {*}$southwest] \
			 west      [diagram::point at {*}$west] \
			 northwest [diagram::point at {*}$northwest] \
			 center    [diagram::point at {*}$center]]

	return [list $corners $polygon]
    }

    proc BoxCorners {av} {
	upvar 1 $av a

	#      xnw xns
	# ynw (*)--*---*
	#      |   |   |
	#      *--<*>--* yew
	#      |   |   |
	#      *---*--(*) yse
	#              xse

	set w $a(width)
	set h $a(height)

	set rect [list \
		      [expr {-$w/2.0}] \
		      [expr {-$h/2.0}] \
		      [expr { $w/2.0}] \
		      [expr { $h/2.0}]]

	return [list [BoxCornersRect $rect] $rect]
    }

    proc BoxCornersRect {rect} {
	lassign $rect xnw ynw xse yse

	set xns [expr {($xnw + $xse) / 2.0}]
	set yew [expr {($ynw + $yse) / 2.0}]

	set w [expr {$xse - $xnw}]
	set h [expr {$yse - $ynw}]

	return [list \
		    north     [diagram::point at $xns $ynw] \
		    northeast [diagram::point at $xse $ynw] \
		    east      [diagram::point at $xse $yew] \
		    southeast [diagram::point at $xse $yse] \
		    south     [diagram::point at $xns $yse] \
		    southwest [diagram::point at $xnw $yse] \
		    west      [diagram::point at $xnw $yew] \
		    northwest [diagram::point at $xnw $ynw] \
		    center    [diagram::point at $xns $yew] \
		    width     $w \
		    height    $h]
    }

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

    method circle {canvas attributes} {
	array set a $attributes

	lassign [CircleCorners a] corners rect

	lappend items [$canvas create oval {*}$rect \
			   -fill    $a(fillcolor) \
			   -outline $a(color)     \
			   -width   $a(stroke)    \
			   -dash    $a(style)]

	HandleText $canvas $attributes items [dict get $corners center]
	return [list $items $corners]
    }

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

    proc CircleCorners {av} {
	upvar 1 $av a

	#      xnw xns
	# ynw (*)--*---*
	#      |   |   |
	#      *--<*>--* yew
	#      |   |   |
	#      *---*--(*) yse
	#              xse

	set r  $a(circle::radius)
	set rm [expr {-1 * $r}]
	set di [expr { 2 * $r}]

	set rect [list $rm $rm $r $r]

	# The 90-angles are trivial, no need for big floating of math.
	set corners [list \
			 north  [diagram::point at 0   $rm] \
			 east   [diagram::point at $r  0]   \
			 south  [diagram::point at 0   $r]  \
			 west   [diagram::point at $rm 0]   \
			 center [diagram::point at 0   0]   \
			 radius $r  \
			 width  $di \
			 height $di]

	foreach {dir angle} {
	    northeast   45
	    southeast  -45
	    southwest -135
	    northwest  135
	} {
	    lappend corners $dir [diagram::point at {*}[geo::s* $r [geo::direction $angle]]]
	}

	return [list $corners $rect]
    }

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

    method ellipse {canvas attributes} {
	array set a $attributes

	lassign [EllipseCorners a] corners rect

	lappend items [$canvas create oval {*}$rect \
			   -fill    $a(fillcolor) \
			   -outline $a(color)     \
			   -width   $a(stroke)    \
			   -dash    $a(style)]

	HandleText $canvas $attributes items [dict get $corners center]
	return [list $items $corners]
    }

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

    proc EllipseCorners {av} {
	upvar 1 $av a

	# Like CircleCorners, except taking the different radii into account.
	# ra = w/2
	# rb = h/2

	set ra [expr {$a(width)  / 2.0}]
	set rb [expr {$a(height) / 2.0}]

	set rect [list -$ra -$rb $ra $rb]

	# The 90-degree angles are trivial, no need for floating-point math.
	set corners [list \
			 north  [diagram::point at  0   -$rb] \
			 east   [diagram::point at  $ra  0]   \
			 south  [diagram::point at  0    $rb] \
			 west   [diagram::point at -$ra  0]   \
			 center [diagram::point at  0    0]   \
			 width  $a(width) \
			 height $a(height)]

	# For the 45-degree angles we use precomputed values we just
	# have to stretch per the actual ellipse radii
	foreach {dir cos} $ourecos {_ sin} $ouresin {
	    set x [expr {$ra * $cos}]
	    set y [expr {$rb * $sin}]
	    lappend corners $dir [diagram::point at $x $y]
	}

	return [list $corners $rect]
    }

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

    method diamond {canvas attributes} {
	array set a $attributes

	lassign [DiamondCorners a] corners poly

	lappend items [$canvas create polygon {*}$poly \
			   -fill    $a(fillcolor) \
			   -outline $a(color)     \
			   -width   $a(stroke)    \
			   -dash    $a(style)]

	HandleText $canvas $attributes items [dict get $corners center]
	list $items $corners
    }

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

    proc DiamondCorners {av} {

	#      *
	#     /|\.
	#    * | *
	#   / \|/ \.
	#  *--<*>--*
	#   \ /|\ /
	#    * | *
	#     \|/
	#      *

	upvar 1 $av a

	set w $a(diamond::width)
	set h $a(diamond::height)

	# No calculation of aspect here. This was handled in
	# DiamondDefaults. Well, in DefaultDiamondGeometry it
	# delegated this to.

	set hh [expr {0.5 * $h}]
	set hw [expr {0.5 * $w}]

	# Cardinal points.
	set north [geo::p 0 -$hh]
	set south [geo::p 0  $hh]
	set east  [geo::p  $hw 0]
	set west  [geo::p -$hw 0]

	# 45-angled points, interpolated between the cardinals.
	set northeast [geo::between $north $east 0.5]
	set northwest [geo::between $north $west 0.5]
	set southeast [geo::between $south $east 0.5]
	set southwest [geo::between $south $west 0.5]

	set poly    [list {*}$north {*}$east {*}$south {*}$west]
	set corners [list \
			 north     [diagram::point at {*}$north] \
			 northeast [diagram::point at {*}$northeast] \
			 east      [diagram::point at {*}$east] \
			 southeast [diagram::point at {*}$southeast] \
			 south     [diagram::point at {*}$south] \
			 southwest [diagram::point at {*}$southwest] \
			 west      [diagram::point at {*}$west] \
			 northwest [diagram::point at {*}$northwest] \
			 center    [diagram::point at 0 0] \
			 width     $w \
			 height    $h]

	return [list $corners $poly]
    }

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

    method {Diamond init} {} {
	# boxwidth, boxheight - Handled by the box attributes.
	$core state set diamondaspect 2
	return
    }

    method {Diamond set} {key newvalue} {
	if {$key ne "diamond::aspect"} return
	$core state set diamondaspect $newvalue
	return
    }

    method {Diamond fill} {av} {
	upvar 1 $av attributes

	# Note: In contrast to box we have to see what we have in toto
	# before pulling the missing pieces out of the defaults,
	# because for some combinations the missing data is derived
	# from what we have. Box otoh can handle each attribute (key)
	# independently.

	set hw [dict exists $attributes diamond::width]
	set hh [dict exists $attributes diamond::height]

	if {$hw && $hh} {
	    # Both width and height were specified, we can ignore the
	    # aspect, if any. The aspect is implicit in the specified
	    # geometry.
	    return
	}

	set ha [dict exists $attributes diamond::aspect]

	# Pull the known values into locals for quicker access below,
	# also, and more importantly making the code more readable.
	if {$hw} { set w [dict get $attributes diamond::width] }
	if {$hh} { set h [dict get $attributes diamond::height] }
	if {$ha} { set a [dict get $attributes diamond::aspect] }

	if {$hw && $ha} {
	    # Derive height from aspect and width.
	    dict set attributes diamond::height [expr {$w / double($a)}]
	} elseif {$hh && $ha} {
	    # Derive width from aspect and height.
	    dict set attributes diamond::width [expr {$h * $a}]
	} elseif {$ha} {
	    # Get default width, and derive height.
	    dict set attributes diamond::width  [set w [$core state get boxwidth]]
	    dict set attributes diamond::height [expr {$w / double($a)}]
	} elseif {$hw} {
	    # Get default aspect, and derive height.
	    dict set attributes diamond::aspect [set a [$core state get diamondaspect]]
	    dict set attributes diamond::height [expr {$w / double($a)}]
	} elseif {$hh} {
	    # Get default aspect, and derive width.
	    dict set attributes diamond::aspect [set a [$core state get diamondaspect]]
	    dict set attributes diamond::width  [expr {$h * $a}]
	} else {
	    # Get defaults for aspect and width, and derive height.
	    dict set attributes diamond::width  [set w [$core state get boxwidth]]
	    dict set attributes diamond::aspect [set a [$core state get diamondaspect]]
	    dict set attributes diamond::height [expr {$w / double($a)}]
	}
	return
    }

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

    method drum {canvas attributes} {
	array set a $attributes

	lassign [DrumCorners a] corners mbody vlinel vliner top bottom

	# Main body, background (no outline!)
	lappend items [$canvas create rectangle {*}$mbody \
			   -fill    $a(fillcolor) \
			   -outline {}]

	# Left vertical line of the main drum body
	lappend items [$canvas create line {*}$vlinel \
			   -fill $a(color)]

	# Right vertical line of the main drum body
	lappend items [$canvas create line {*}$vliner \
			   -fill $a(color)]

	# Drum top, full ellipsis
	lappend items [$canvas create oval {*}$top \
			   -fill    $a(fillcolor) \
			   -outline $a(color)  \
			   -width   $a(stroke) \
			   -dash    $a(style) ]

	# Drum bottom, background (no outline!)
	lappend items [$canvas create arc  {*}$bottom \
			   -fill    $a(fillcolor)  \
			   -outline {}   \
			   -dash    $a(style)  \
			   -start   175  \
			   -extent  190  \
			   -style   chord]

	# Drum bottom arc (partial ellipsis, outline only)
	lappend items [$canvas create arc  {*}$bottom \
			   -fill    $a(fillcolor) \
			   -outline $a(color)  \
			   -width   $a(stroke) \
			   -dash    $a(style) \
			   -start   175 \
			   -extent  190 \
			   -style   arc ]

	HandleText $canvas $attributes items [dict get $corners center]
	return [list $items $corners]
    }

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

    proc DrumCorners {av} {
	upvar 1 $av a

	set w $a(width)
	set h $a(height)

	set rect [list \
		      [expr {-$w/2.0}] \
		      [expr {-$h/2.0}] \
		      [expr { $w/2.0}] \
		      [expr { $h/2.0}]]

	lassign [geo::nwse $rect] nw se
	lassign $nw xnw ynw
	lassign $se xse yse

	set width   $w
	set height  [expr {$h + $a(drum::aspect) * $w}]
	set hellips [expr {$height * $a(drum::aspect)}]
	# hellips = as*(h+as*w) = h*as+w*as^2

	set center {0 0};#[geo::between $nw $se 0.5]

	set uphe   [geo::s* -0.5 [geo::v $hellips]]
	set up     [geo::s* -0.5 [geo::v $height]]
	set right  [geo::s*  0.5 [geo::h $width]]

	# topne = center + (up + (uphe + right))
	# topsw = center + (up - (uphe + right))
	# botne = center - (up - (uphe + right))
	# botsw = center - (up + (uphe + right))

	set hr  [geo::+ $uphe $right]
	set uhr [geo::+ $up $hr]
	set dhr [geo::- $up $hr]

	set topne [geo::+ $center $uhr]
	set topsw [geo::+ $center $dhr]
	set botne [geo::- $center $dhr]
	set botsw [geo::- $center $uhr]

	# mnw = center + (up - right)
	# mne = center + (up + right)
	# mse = center - (up - right)
	# msw = center - (up + right)

	set ur  [geo::+ $up $right]
	set dr  [geo::- $up $right]

	set mnw [geo::+ $center $dr]
	set mne [geo::+ $center $ur]
	set mse [geo::- $center $dr]
	set msw [geo::- $center $ur]

	# Complete corner and rect/poly calculations.

	set northeast $topne
	set north     [geo::- $topne $right]
	set northwest [geo::- $topne [geo::s* 2 $right]]
	set southwest $botsw
	set south     [geo::+ $botsw $right]
	set southeast [geo::+ $botsw [geo::s* 2 $right]]
	set east      [geo::between $northeast $southeast 0.5]
	set west      [geo::between $northwest $southwest 0.5]

	set corners [list \
			 north     [diagram::point at {*}$north] \
			 northeast [diagram::point at {*}$northeast] \
			 east      [diagram::point at {*}$east] \
			 southeast [diagram::point at {*}$southeast] \
			 south     [diagram::point at {*}$south] \
			 southwest [diagram::point at {*}$southwest] \
			 west      [diagram::point at {*}$west] \
			 northwest [diagram::point at {*}$northwest] \
			 center    [diagram::point at {*}$center] \
			 width     $width \
			 height    $height]

	set mbody  [list {*}$mnw   {*}$mse]
	set vlinel [list {*}$mnw   {*}$msw]
	set vliner [list {*}$mne   {*}$mse]
	set top    [list {*}$topne {*}$topsw]
	set bottom [list {*}$botne {*}$botsw]

	return [list $corners $mbody $vlinel $vliner $top $bottom]
    }

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

    method text {canvas attributes} {
	array set a $attributes

	set label [join $a(text) \n]
	lappend items [$canvas create text 0 0    \
			   -text    $label        \
			   -font    $a(textfont)  \
			   -fill    $a(textcolor) \
			   -justify $a(justify)]

	# (%%)
	# The text's box defaults to the canvas item's box. This is
	# different from the other closed elements, which use standard
	# values for their defaults, handled by the attribute processor.

	if {![info exists a(width)]||![info exists a(height)]} {
	    lassign [$canvas bbox [lindex $items end]] xnw ynw xse yse
	    if {![info exists a(width)]}  { set a(width)  [expr {$xse - $xnw}] }
	    if {![info exists a(height)]} { set a(height) [expr {$yse - $ynw}] }
	}

	lassign [BoxCorners a] corners __dummy_rect__

	return [list $items $corners]
    }

    proc HandleText {canvas attributes iv at} {
	upvar 1 $iv items self self core core
	array set a $attributes

	# Ignore this if there is no text.
	if {![info exists a(text)]} return

	# Note: Caller may not have width/height data (open
	# elements). Force defaults.

	# At the language level the code here is equivalent to
	#     text <text> justify <justify> textcolor <textcolor> with <anchor> at <at>.
	#     (Where <at> is [last center]).

	lassign [$self text $canvas $attributes] textitems corners

	# Now perform a simplified 'relocate' (See diagram::element)
	# (no sub-elements, ignore the corners, just the one item).

	# Find current location of the specified corner.
	set at     [diagram::point unbox $at]
	set with   [$core map $corners $a(anchor)]
	set origin [diagram::point unbox [dict get $corners $with]]

	# Determine movement vector
	set delta [geo::- $at $origin]

	# And do it.
	foreach i $textitems {
	    $canvas move $i {*}$delta
	}

	# At last make the item part of the calling element.
	lappend items {*}$textitems
	return
    }

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

    method line {canvas attributes} {
	array set a $attributes

	lassign [LineCorners a] corners poly newdirection

	lappend items [$canvas create line {*}$poly \
			   -arrow   $a(arrowhead) \
			   -fill    $a(color) \
			   -smooth  $a(smooth) \
			   -width   $a(stroke) \
			   -dash    $a(style) ]

	# Check for optional shift of line.
	if {[info exists a(at)]} {
	    set at   $a(at)
	    set with [expr {[info exists a(with)] ? $a(with) : "start"}]
	    Relocate $with $at $canvas $items corners
	}

	HandleText $canvas $attributes items [dict get $corners center]

	if {[info exists a(noturn)] && $a(noturn)} {
	    return [list $items $corners absolute]
	} else {
	    return [list $items $corners absolute $newdirection]
	}
    }

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

    proc LineCorners {av} {
	upvar 1 $av a

	# Convert waypoints into canvas polyline, generating the basic
	# corners at the same time.

	# XXX share parts with basic::move command

	set poly    {}
	set corners {}
	set n 1

	#puts LC<$a(from)>|<$a(waypoints)>|<$a(to)>

	lappend corners start  [diagram::point at {*}$a(from)]
	lappend corners end    [diagram::point at {*}$a(to)]
	lappend corners center [diagram::point at {*}[geo::between $a(from) $a(to) 0.5]]

	foreach p $a(waypoints) {
	    lassign $p x y
	    lappend poly $x $y
	    lappend corners $n [diagram::point at $x $y]
	    incr n
	}

	# Lines have trivial corners. The 'end' key is recognized by
	# the layout engine as a magic overide, it keeps getting used
	# regardless of the direction turned to.

	lassign [geo::nwse [lrange $poly end-3 end]] pa pb
	set direction [geo::octant [geo::- $pb $pa]]

	return [list $corners $poly $direction]
    }

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

    proc Smooth {words_dummy} { return 1 }

    proc NoTurn        {words_dummy} { return 1 }
    #proc NoTurnDefault {args}        { return 0 }

    method Chop {words} {
	if {![{*}$words size] ||
	    ![string is double -strict [set v [{*}$words peek]]]} {
	    return [$core state get circleradius]
	}
	{*}$words get
	return $v
    }

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

    method arc {canvas attributes} {
	array set a $attributes
	#parray a

	set corners [ArcCorners a]

	# For debugging purposes, draw a number of helper elements
	# showing the construction of the arc (from, to, center,
	# f-c/t-c radii, bounding box, whole circle, and corners).
	if {0} {
	    lassign $a(rect) w n e s
	    $core draw [subst -nocommands {
		circle at [$a(center)] radius $a(arc::radius) color black dotted
		circle at [$a(arc::from)] radius 5 color orange 
		circle at [$a(center)]    radius 5 color green
		circle at [$a(arc::to)]   radius 5 color blue
		line from [$a(arc::from)] then [$a(center)] to [$a(arc::to)] dashed color red
		line from [$w $n] then [$e $n] then [$e $s] then [$w $s] to [$w $n] color yellow
	    }]
	    foreach {k v} $corners {
		if {![llength $v] == 2} continue
		lassign $v cmd detail
		if {$cmd ne "point"} continue
		$core draw [subst -nocommands {
		    circle color red radius 3 at [$detail]
		}]
	    }
	}

	# arc start  = 0-360, 0 == east, 90 == north.
	# arc extent = offset from start.

	lappend items [$canvas create arc {*}$a(rect) \
			   -start   $a(start)     \
			   -extent  $a(extent)    \
			   -fill    $a(fillcolor) \
			   -outline $a(color)     \
			   -width   $a(stroke)    \
			   -dash    $a(style)     \
			   -style   arc]

	HandleText $canvas $attributes items [dict get $corners center]
	return [list $items $corners absolute $a(direction)]
    }

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

    proc ArcCorners {av} {
	upvar 1 $av a core core

	# Arcs have trivial corners. The 'end' key is recognized by
	# 'navigation move' as magic overide, it keeps getting used
	# regardless of the chosen direction. The center is the center
	# of the arc's circle, and this also provides the compass
	# points. We only have to provide the proper radius element,
	# and then translate them per the actual center.

	set a(circle::radius) $a(arc::radius)
	set center  $a(center)
	lassign [CircleCorners a] corners __dummy_rect__
	set corners [$core move $center $corners]

	lappend corners \
	    start  [diagram::point at {*}$a(arc::from)] \
	    end    [diagram::point at {*}$a(arc::to)] \
	    center [diagram::point at {*}$center]

	return $corners
    }

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

    method {ArcLocation init} {}             {}  ; # Nothing to
						   # initialize
    method {ArcLocation set}  {key newvalue} {}  ; # in the language
						   # namespace, nor to
						   # set.
    method {ArcLocation fill} {av} {
	upvar 1 $av attributes

	# Bail out quickly when done already.
	if {[dict exists $attributes center]} return

	#puts AL|_________________________________________________________________________

	array set a $attributes
	#parray a

	# Note: We assume that both radius and clockwise have been
	# resolved already. This means that they have to come before
	# arc::{from,to} in the list of required attributes (see DefE
	# calls in the constructor).

	lassign [$core where] at angle

	set from $at
	if {[info exists a(arc::from)]} {
	    set from [diagram::point resolve $from $a(arc::from)]
	}

	#puts AL|from|$from|

	if {![info exists a(arc::to)]} {
	    # Do a (counter)clockwise 90-degree arc beginning at from,
	    # with radius, using the layout engine's current direction
	    # for the baseline.

	    # Note how we are able to directly compute the arc's
	    # center as well.

	    set cangle $angle
	    set tangle $angle
	    set radius $a(arc::radius)

	    if {$a(clockwise)} {
		incr cangle -90
	    } else {
		incr cangle 90
	    }

	    #puts C/angle\t$cangle
	    #puts T/angle\t$tangle

	    set center [diagram::point resolve $from   [diagram::point by $radius $cangle]]
	    set to     [diagram::point resolve $center [diagram::point by $radius $tangle]]
	} else {
	    set to [diagram::point resolve $at $a(arc::to)]

	    #puts AL|to|$to|

	    # Here we know from, to, and radius, and now have to find
	    # the circle's center. That is in essence an intersection
	    # of two circles, around the two points. If the distance
	    # between them is greater than 2*radius we have no center,
	    # strictly speaking. In that case we put the center in the
	    # geometric middle and make it an 180-degree arc, with
	    # adjusted larger radius.

	    set d [geo::distance $from $to]

	    #puts AL|dist|$d|\tr|$a(arc::radius)|

	    if {$d >= (2*$a(arc::radius))} {
		set center [geo::between $from $to 0.5]
		set radius [expr {$d/2.}]
	    } else {
		# Reference
		# http://local.wasp.uwa.edu.au/~pbourke/geometry/2circle/

		set ad [expr {$d/2.}]
		# a = (r0^2 - r1^2 + d^2 ) / (2 d) |r0==r1 ==> a = d/2

		set p [geo::between $from $to 0.5]
		# P2 = P0 + a/d ( P1 - P0 )
		# a/d = (d/2)/d = 1/2

		set radius $a(arc::radius)
		set hd [expr {sqrt($radius*$radius - $ad*$ad)/$d}]
		# h^2 = r0^2 - a^2, hd = h/d

		#P3 = center
		#x3 = x2 +/- h/d ( y1 - y0 )
		#y3 = y2 -/+ h/d ( x1 - x0 )

		lassign $p    mx my ; # P2
		lassign $from fx fy ; # P0
		lassign $to   tx ty ; # P1

		if {$a(clockwise)} {
		    set cx [expr {$mx - $hd * ($ty - $fy)}]
		    set cy [expr {$my + $hd * ($tx - $fx)}]
		} else {
		    set cx [expr {$mx + $hd * ($ty - $fy)}]
		    set cy [expr {$my - $hd * ($tx - $fx)}]
		}

		set center [geo::p $cx $cy]
	    }
	}

	# We now have to, from, center, and radius for our arc. The
	# last two pieces are now used to define the bounding box,
	# i.e. the rectangle we need for the canvas item, and the
	# from/center, to/center angles define the start and extent
	# information.

	set d    [geo::p $radius $radius]
	set nw   [geo::- $center $d]
	set se   [geo::+ $center $d]
	set rect [list {*}$nw {*}$se]

	# NOTE: The angle proc assumes that positive y is north. The
	# canvas coordinate system has positive y as south. By
	# conjugating the point along the y-axis we get the proper
	# angles for the canvas.

	set cf [geo::conjy $center]
	set ff [geo::conjy $from]
	set tf [geo::conjy $to]
	set s  [math::geometry::angle [list {*}$cf {*}$ff]]
	set e  [math::geometry::angle [list {*}$cf {*}$tf]]

	# Reorder the angles for direction and use by the canvas.
	if {$s < 0} { set s [expr {$s + 360}] }
	if {$e < 0} { set e [expr {$e + 360}] }
	if {($e < $s) && !$a(clockwise)} { set e [expr {$e + 360}] }
	if {($s < $e) && $a(clockwise)}  { set s [expr {$s + 360}] }

	#puts start=$s
	#puts end===$e

	set direction [geo::octant [geo::- $center $from]]
	set start     $s
	set extent    [expr {$e - $s}]

	# Save the new state back to the attributes, both original and
	# derived keys.

	dict set attributes arc::radius $radius
	dict set attributes arc::from   $from
	dict set attributes arc::to     $to

	dict set attributes direction   $direction
	dict set attributes rect        $rect
	dict set attributes center      $center
	dict set attributes start       $start
	dict set attributes extent      $extent
	return
    }

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

    proc ClockWise {v words_dummy} { return $v }

    proc Link {v n unit} {
	upvar 1 core core
	return [list $v [$core unit $n $unit]]
    }

    # Factor this with proc 'element::Move'
    proc Relocate {with at canvas items cv} {
	upvar 1 $cv corners core core
	set at     [diagram::point unbox $at]
	set origin [diagram::point unbox [dict get $corners $with]]

	# Determine movement vector
	set delta [geo::- $at $origin]

	# And do it.
	foreach i $items {
	    $canvas move $i {*}$delta
	}

	set corners [$core move $delta $corners]
	return
    }

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

    component core ; # diagram core

    # # ## ### ##### ######## ############# ######################
    ## Type construction (pre-computed tables for ellipsis corners)

    typevariable ouresin 
    typevariable ourecos
    typeconstructor {
	::variable ::math::geometry::torad
	foreach {dir angle} {
	    northeast   45
	    southeast  -45
	    southwest -135
	    northwest  135
	} {
	    lappend ourecos $dir [expr {  cos($angle * $torad)}]
	    lappend ouresin $dir [expr {- sin($angle * $torad)}]
	}
    }

    typevariable ourstyles -array {
	solid        .
	dot          .
	dotted       .
	dash         .
	dashed       .
	dash-dot     .
	dash-dot-dot .
    }

    typevariable ourarrows -array {
	start   .
	end     .
	->      .
	<-      .
	<->     .
	-       .
	\u21a6  .
	\u21a4  .
	\u21ae  .
    }

    typevariable ourshorts -array {
	cw           clockwise
	\u21bb       clockwise
	ccw          counterclockwise
	\u21ba       counterclockwise
	wid          width
	ht           height
	rad          radius
	diam         diameter
	\u2300	     diameter
	ljust        {anchor west}
	rjust        {anchor east}
	above        {anchor south}
	below        {anchor north}
    }

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

namespace eval ::diagram::basic::geo {
    namespace import ::math::geometry::*
}

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

package provide diagram::basic 1.0.1

Added scriptlibs/tklib0.7/diagrams/core.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
## -*- tcl -*-
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>
## BSD Licensed
# # ## ### ##### ######## ############# ######################

#
# diagram core, using direction and element databases, plus layout
# engine. Implements the base language (concrete attributes and
# elements are specified outside, the core only has the pertinent
# extensibility features).
#
# Uses an instance specific namespace to encapsulate the commands of
# the drawing language, and the drawing state (variables for points,
# elements, etc.).
#

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

package require Tcl 8.5              ; # Want the nice things it
                                       # brings (dicts, {*}, etc.)
package require snit                 ; # Object framework.
package require diagram::direction   ; # Database of named directions
package require diagram::element     ; # Database of drawn elements
package require diagram::navigation  ; # State of automatic layouting
package require diagram::point       ; # Point validation and processing.
package require diagram::attribute   ; # Database of element attributes
package require namespacex           ; # Namespace utility functions
package require struct::set          ; # Set arithemetics (blocks)
package require math::geometry 1.1.2 ; # Vector math (points, line
				       # (segments), poly-lines).

# # ## ### ##### ######## ############# ######################
## Implementation

snit::type ::diagram::core {

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Core extensibility (drawing elements, attributes,
    ##               special attribute forms)

    method {new direction} {name args} {
	$dir new direction $name {*}$args
	return
    }

    method {new shape} {name} {
	$elm shape $name
	return
    }

    method {new element} {name attrcmd drawcmd} {
	$elm shape $name
	$self new alias $name [mymethod Element $name $attrcmd $drawcmd]
	return
    }

    method {new alias} {name cmdprefix} {
	#$self new command $name args "$cmdprefix {*}\$args"
	$self new command $name args "uplevel 1 \[list $cmdprefix {*}\$args\]"
	return
    }

    method {new command} {name arguments body} {
	proc ${mylangns}::$name $arguments $body
	return
    }

    method {new attribute} {name args} {
	$att new $name {*}$args
	return
    }

    method {unknown attribute} {hook} {
	$att unknown + $hook
	return
    }

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

    method snap {} {
	return [namespacex state get $mylangns]
    }

    method restore {state} {
	return [namespacex state set $mylangns $state]
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Draw

    method draw {script} {
	#set script [list block $script with nw at [diagram::point at 0 0]]
	return [uplevel 1 [list namespace eval $mylangns $script]]
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Instance construction

    constructor {canvas args} {
	set mycanvas $canvas
	set mylangns ${selfns}::$ourlang

	install dir using ::diagram::direction  ${selfns}::DIR
	install elm using ::diagram::element    ${selfns}::ELM $dir
	install nav using ::diagram::navigation ${selfns}::NAV $dir
	install att using ::diagram::attribute  ${selfns}::ATT $self

	$self SetupLanguage

	if {![llength $args]} return
	$self draw $args
	return
    }

    destructor {
	if {$mycanvas eq {}} return

	# This object has not been detached from the drawing engine
	# (canvas), therefor its destruction implies the destruction
	# of the drawn diagram as well.
	catch {
	    $self drop
	}
	return
    }

    method detach {} {
	set mycanvas {}
	return
    }

    method drop {} {
	# Destroy all elements and their items.
	$mycanvas delete {*}[$elm items {*}[$elm elements]]
	$elm drop
	$nav reset
	return
    }

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

    method {state set} {varname value} {
	#puts \tState($varname):=|$value|

	namespace upvar $mylangns $varname x
	set x $value
	return
    }

    method {state get} {varname} {
	namespace upvar $mylangns $varname x

	#puts \tState($varname)->|$x|
	return $x
    }

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

    method where {} {
	return [list [$nav at] [$dir get [$nav direction] angle]]
    }

    method move {delta corners} {
	return [$elm move $delta $corners]
    }

    method map {corners c} {
	return [$dir map $corners $c]
    }

    # # ## ### ##### ######## #############
    ## Internal :: Setup of core language

    method SetupLanguage {} {
	# Language encapsulation
	namespace eval $mylangns {}

	# Standard elements and operations

	$self new alias set       [mymethod Set]
	$self new alias unset     [mymethod Unset]
	$self new alias move      [mymethod Move]
	$self new alias block     [mymethod Block]
	$self new alias group     [mymethod Group]
	$self new alias here      [mymethod At]
	$self new alias direction [list $nav direction]
	$self new alias by        [mymethod By]
	$self new alias intersect [mymethod Intersect]

	$elm shape move
	$elm shape block

	# Standard attributes (element appearance, location).

	# keep here ... / type == snit validation type!

	$att new movelength type {snit::double -min 1} linked [list movelength [Unit 2 cm]]

	# XXX refactor the mymethod calls out, use variables
	$att new with                                                       default [mymethod Placement]
	$att new at   type diagram::point transform [mymethod DerefElement] default [mymethod Placement]
	$att new from type diagram::point transform [mymethod DerefElement] default [mymethod Waypoints]
	$att new to   type diagram::point transform [mymethod DerefElement] default [mymethod Waypoints]	    
	$att new then type diagram::point transform [mymethod DerefElement] default [mymethod Waypoints] \
	    get [mymethod GetPoints] aggregate 1

	$att unknown + [mymethod Directions]

	# Now special forms of commands, handled via 'namespace
	# unknown'. Making, for example, elements and points into
	# pseudo-objects.

	namespacex hook add $mylangns [mymethod CatchAll]

	# syntax: [<direction>] --> ()
	namespacex hook on $mylangns [mymethod DCGuard] [mymethod DCRun]

	# Global commands for named directions. The commands are
	# created on first use. That allows extension packages
	# declaring their own directions to do this after the core has
	# booted. Just creating the direction commands at boot time
	# will miss the directions of extensions.

	# (%%) Commands to access the history (n'th ...)

	# Visible syntax:
	#
	# <n>th      <shape> ?<corner>? | 2/3 | (1)
	# <n>th last <shape> ?<corner>? | 3/4 | (2)
	#       last <shape> ?<corner>? | 2/3 | (3)
	# <n>th last         ?<corner>? | 2/3 | (4)
	#       last         ?<corner>? | 1/2 | (5)
	#
	# Note: The form <shape> ?<corner>? is NOT possible.
	#       <shape> is the drawing command.
	#
	# Note 2: Because of (xx) the internal syntax is simpler, as
	#         the argument <n>th is always present, and not
	#         optional.
	#
	# <n>th      <shape> ?<corner>? | 2-3
	# <n>th last <shape> ?<corner>? | 3-4
	# <n>th last         ?<corner>? | 2-3
	#

	$self new alias 1st 1th
	$self new alias 2nd 2th
	$self new alias 3rd 3th
	$self new alias last [mymethod Recall 1th last] ; # (xx)
	namespacex hook on $mylangns [mymethod RecallGuard] [mymethod Recall]

	# Pseudo object commands for points
	#
	# syntax: [<number> cm|mm|point|inch]         --> <number>
	# syntax: [<number> <number>]                 --> <point>
	# syntax: [<number> between <point> <point>]  --> <point>
	# syntax: [<point> by <distance> <direction>] --> <point>
	# syntax: [<point> +|- <point>]               --> <point>

	namespacex hook on $mylangns [myproc   IsUnit]          [myproc Unit]
	namespacex hook on $mylangns [myproc   IsPointCons]     {diagram::point at}
	namespacex hook on $mylangns [myproc   IsInterpolation] [mymethod Interpolation]
	namespacex hook on $mylangns [mymethod IsPointArithBy]  [mymethod PointArithBy]
	namespacex hook on $mylangns [myproc   IsPointArithOp]  [mymethod PointArithOp]

	# Pseudo object commands for elements.
	#
	# syntax: [<element> ?<corner>...? ?names ?<pattern>??] --> <point>|<element>|...

	namespacex hook on $mylangns [myproc IsElementOp] [mymethod ElementOp]
	return
    }

    # # ## ### ##### ######## ############# ######################
    ## Internal :: Implementation of the core language commands.

    method CatchAll {args} {
	#puts |||$args|||
	# Unknown commands are compiled as text elements
	# --> Calls out into basic, assumes its presence.
	return [$self draw [list text text {*}$args]]
    }

    method Move {args} {
	set attributes [$att attributes move $args {from to then}]
	set w [dict get $attributes waypoints]

	# XXX share corner generation with line - sub packages.
	lappend corners start [diagram::point at {*}[lindex $w 0]]
	lappend corners end   [diagram::point at {*}[lindex $w end]]
	set n 1
	foreach p $w {
	    lappend corners $n [diagram::point at {*}$p]
	    incr n
	}

	# note: move is a bit special. It has neither child elements,
	# nor canvas items. We define it actually only to make it
	# visible in the history, and to block corner creation.
	set eid	[$elm new move $corners {} {}]
	$nav move $corners
	return $eid
    }

    method Set {args} {
	#puts SET|$args|
	# Run builtin for the regular behaviour of the intercepted command.

	set result [uplevel 1 [list ::set {*}$args]]

	# During block processing we save variable re-definitions as
	# the block's corners
	if {$myinblock && ([llength $args] == 2)} {
	    lappend mycorners {*}$args
	}
	return $result
    }

    method Unset {args} {
	#puts UNSET|$args|
	# Run builtin for the regular behaviour of the intercepted command.

	set result [uplevel 1 [list ::unset {*}$args]]

	# During block processing we are saving variable
	# re-definitions as the block's corners, so have to remove
	# that definition too.
	if {$myinblock} {
	    foreach c $args {
		dict unset mycorners $c
	    }
	}
	return $result
    }

    method Block {script args} {
	# args = attributes.

	# Save current state
	set old [$elm elements]
	set ehi [$elm history get]
	set lst [namespacex state get $mylangns]
	$nav save

	# Process the attributes, and store the changed settings into
	# their linked variables (if any), to make them proper
	# defaults inside of the block.

	set attributes [$att attributes block $args {at with}]
	$att set $attributes
	set at   [dict get $attributes at]
	set with [dict get $attributes with]

	# Run the block definition, prepare for the capture of corners.
	set inblock $myinblock
	set myinblock 1
	set mycorners {}

	#$self draw $script
	uplevel 1 $script

	# Remember the captured corners and reset capture system.
	set myinblock $inblock
	set corners [dict merge $mycorners]
	set mycorners {}

	# Extract the set of newly drawn elements.
	set new [struct::set difference [$elm elements] $old]

	#puts |$new|bb|[$elm bbox {*}$new]|

	# Get the block's bbox from the union of its elements' bboxes.
	lassign [$elm bbox {*}$new] xnw ynw xse yse

	# XXX see BoxCornersRect of basic, share code
	set xns [expr {($xnw + $xse) / 2.0}]
	set yew [expr {($ynw + $yse) / 2.0}]
	set w   [expr {$xse - $xnw}]
	set h   [expr {$yse - $ynw}]

	set compass [list \
			 north     [diagram::point at $xns $ynw] \
			 northeast [diagram::point at $xse $ynw] \
			 east      [diagram::point at $xse $yew] \
			 southeast [diagram::point at $xse $yse] \
			 south     [diagram::point at $xns $yse] \
			 southwest [diagram::point at $xnw $yse] \
			 west      [diagram::point at $xnw $yew] \
			 northwest [diagram::point at $xnw $ynw] \
			 center    [diagram::point at $xns $yew] \
			 width     $w \
			 height    $h]

	#puts COMPASS|$compass|
	#puts CORNERS|$corners|

	set corners [dict merge $compass $corners]

	#puts BLOCK__\t($corners)
	#puts __BLOCK

	# Restore the system state to what it was before we entered
	# the block.
	$nav restore
	namespacex state set $mylangns $lst
	$elm history set $ehi

	# Now save the block as element, aggregating the children, and
	# move it into position, based on the placement attributes.
	set eid [$elm new block $corners {} $new]
	$elm relocate $eid $at $with $mycanvas
	$nav move [$elm corners $eid]

	return $eid
    }

    method Group {script} {
	# A group is similar to a block, except that only the state of
	# the layout engine is saved across it, not the whole element
	# history, etc. The elements created here are not aggregated
	# either. Further, changes to any attributes made inside the
	# group are visible after it as well.

	$nav save
        #$self draw $script
	uplevel 1 $script
	$nav restore
	return
    }

    method Element {shape required drawcmd args} {
	# args = attributes.

	# attrcmd :: attr-dict -> attr-dict
	# drawcmd :: canvas -> attr-dict -> 
	#            (attr-dict canvas-item-list corner-dict ?placement-mode ?layout-direction??)

	set newdirection {}
	set mode         {}
	set attributes   [$att attributes $shape $args $required]
	lassign [{*}$drawcmd $mycanvas $attributes] \
	    items corners mode newdirection
	if {$mode eq {}} { set mode relative }

	# Allow the user's commands to override the element type. For
	# example, an 'arrow' element not only exapnd to 'line
	# arrowhead ->', but also set the attribute '/shape arrow' to
	# distinguish them from plain lines in the history.

	if {[dict exists $attributes /shape]} {
	    set shape [dict get $attributes /shape]
	}

	set eid [$elm new $shape $corners $items {}]

	#puts $shape=$eid\t/mode=$mode/

	if {$mode eq "relative"} {
	    # Determine the final location of the new element and move
	    # it there, as it was not created at its absolute/final
	    # location already by its drawing command.

	    set at   [dict get $attributes at]
	    set with [dict get $attributes with]

	    #puts "shift such $with at ($at)"
	    $elm relocate $eid $at $with $mycanvas
	}

	# Update the layout engine with new position, and possibly a
	# new direction to follow.

	$nav move [$elm corners $eid] ; # This also discards the
	# intermediate location set
	# for any turns done during
	# attribute processing.

	if {$newdirection ne {}} {
	    # The new element changed direction, notify the layout
	    # engine. Commit immediately to the location for the
	    # direction.

	    $nav turn $newdirection 1
	}

	return $eid
    }

    method At {} {
	return [diagram::point at {*}[$nav at]]
    }

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

    method Corners {elements} {
	set results {}
	foreach e $elements {
	    foreach {k v} [$elm corners $e] {
		lappend result $e.$k $v
	    }
	}
	return $result
    }

    # # ## ### ##### ######## ############# ######################
    ## Handling of directions as attributes and global commands.

    method Directions {shape words} {
	#puts AU||$shape|u(([{*}$words peek [{*}$words size]]))

	# Try to process like for a 'then' attribute, and if that
	# succeeds stuff the result back to run it through the actual
	# handling of the implicit 'then'.

	if {![catch {
	    $self ProcessPoints $words newdirection
	} p]} {
	    #puts <<ok|$p>>

	    {*}$words unget $p
	    {*}$words unget then

	    #puts AU|||x(([{*}$words peek [{*}$words size]]))

	    if {$newdirection ne {}} {
		$nav turn $newdirection
	    }
	    #puts AU|done
	    return 1
	}

	#puts AU<<$p>>
	#puts $::errorInfo
	return 0
    }

    # syntax: [<direction>] --> ()
    method DCGuard {args} {
	#puts DCG|$args|[llength $args]|
	return [expr {([llength $args] == 1) &&
		      [$dir isStrict [lindex $args 0]]}]
    }

    method DCRun {direction} {
	#puts DCR|$direction|
	$nav turn $direction 1
	$self new command $direction {} \
	    [list $nav turn $direction 1]
	return
    }

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

    method RecallGuard {args} {
	#puts RecallGuard|$args|[llength $args]|[regexp {(\d+)th} [lindex $args 0]]
	return [regexp {(\d+)th} [lindex $args 0]]
    }
    method Recall {offset args} {
	#puts RECALL|$offset|$args|______________________________________________________________

	# Syntax (internal!). See comments at (%%) in this file for
	# the differences between internal and user visible syntax,
	# and how the translation is made.
	#
	# <n>th      <shape> ?<corner>? | 2-3 | 1-2 | (a)
	# <n>th last <shape> ?<corner>? | 3-4 | 2-3 | (b)
	# <n>th last         ?<corner>? | 2-3 | 1-2 | (c)
	#

	set n [llength $args]
	if {$n < 1 || $n > 3} {
	    return -code error "wrong\#args: should be \"?n'th? ?last? ?shape? ?corner?\""
	}

	regexp {(\d+)th} $offset -> offset

	# forward/backward search ?
	if {[lindex $args 0] eq "last"} {
	    set args [lassign $args _]
	    set offset -$offset
	}

	# specific shape/all shapes ?
	if {[$elm isShape [lindex $args 0]]} {
	    set args [lassign $args shape]
	} else {
	    set shape {} ;# Search all shapes.
	}

	# corner yes/no ?
	set corner {}
	set n [llength $args]
	if {$n == 1} {
	    lassign $args corner
	} elseif {$n > 1} {
	    return -code error "wrong\#args: should be \"?n'th? ?last? ?shape? ?corner?\""
	}

	#puts H|recall|o|$offset|
	#puts H|recall|s|$shape|
	#puts H|recall|c|$corner|

	# ... And access the history files ...

	set eid [$elm history find $shape $offset]

	#puts H|recall|e|$eid|

	# ... at last return result, resolving the corner, if any such
	# was specified.

	if {$corner ne {}} {
	    #puts H|recall|p|[$elm corner $eid $corner]
	    return [$elm corner $eid $corner]
	} else {
	    #puts H|recall|x|$eid|
	    return $eid
	}
    }

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

    # syntax: [<number> <unit>] --> <number>
    proc IsUnit {args} {
	#puts IsUnit|$args|[llength $args]|[string is double -strict [lindex $args 0]]|[info exists ourunit([lindex $args 1])]
	return [expr {([llength $args] == 2) &&
		      [string is double -strict [lindex $args 0]] &&
		      [info exists ourunit([lindex $args 1])]}]
    }

    proc Unit {n unit} {
	#puts "Unit $unit ($n)"
	return [expr {$n * $ourunit($unit)}]
    }

    method unit {n unit} { return [Unit $n $unit] }

    # syntax: [<number> <number>] --> <point>
    proc IsPointCons {args} {
	#puts IsPointCons|$args|[llength $args]|[string is double -strict [lindex $args 0]]|[string is double -strict [lindex $args 1]]
	return [expr {([llength $args] == 2) &&
		      [string is double -strict [lindex $args 0]] &&
		      [string is double -strict [lindex $args 1]]}]
    }

    # syntax: [<number> between <point> <point>] --> <point>
    proc IsInterpolation {args} {
	#puts IsInterpolation|$args|[llength $args]|[string is double -strict [lindex $args 0]]|[string is double -strict [lindex $args 1]]
	return [expr {([llength $args] == 4) &&
		      [string is double -strict [lindex $args 0]] &&
		      ([lindex $args 1] eq "between") &&
		      [diagram::point is [lindex $args 2]] &&
		      [diagram::point is [lindex $args 3]]}]
    }

    method Interpolation {s __between__ a b} {
	set a [diagram::point resolve [$nav at] $a]
	set b [diagram::point resolve $a $b]
	return [diagram::point at {*}[geo::between $a $b $s]]
    }

    method By {distance direction} {
	if {[$dir isStrict $direction]} {
	    set angle [$dir get $direction angle]
	} else {
	    set angle $direction
	}
	return [diagram::point by $distance $angle]
    }

    # syntax: [<point> by <distance> <direction>] --> <point>
    method IsPointArithBy {args} {
	#puts IsPointArith|$args|[llength $args]|
	return [expr {([llength $args] == 4) &&
		      [diagram::point is [lindex $args 0]] &&
		      ([lindex $args 1] eq "by") &&
		      [string is double -strict [lindex $args 2]] &&
		      [$dir is [lindex $args 3]]}]
    }

    method PointArithBy {p __by__ distance direction} {
	if {[$dir isStrict $direction]} {
	    set angle [$dir get $direction angle]
	} else {
	    set angle $direction
	}
	set delta [diagram::point by $distance $angle]

	#puts PointArith|$p|++|D/$direction|A/$angle|d/$delta|==|[diagram::point + $p $delta]|
	return [diagram::point + $p $delta]
    }

    # syntax: [<point> by <distance> <direction>] --> <point>
    proc IsPointArithOp {args} {
	#puts IsPointArithOp|$args|[llength $args]|
	# See ElementOp for similar code.
	return [expr {([llength $args] == 3) &&
		      [diagram::point is [lindex $args 0]] &&
		      ([lindex $args 1] in {+ - |}) &&
		      [diagram::point is [lindex $args 2]]}]
    }

    method PointArithOp {pa op pb} {
	#puts PointArithOp|$pa|$op|$pb|=|[diagram::point $op $pa $pb]|
	return [diagram::point $op $pa $pb]
    }

    method Intersect {ea eb} {
	set pas [diagram::point unbox [$elm corner $ea start]]
	set pae [diagram::point unbox [$elm corner $ea end]]
	set pbs [diagram::point unbox [$elm corner $eb start]]
	set pbe [diagram::point unbox [$elm corner $eb end]]

	#puts |$pas|---|$pae|
	#puts |$pbs|---|$pbe|

	set linea [list {*}$pas {*}$pae]
	set lineb [list {*}$pbs {*}$pbe]

	set p [geo::findLineIntersection $linea $lineb]
	#puts |$p|

	if {$p eq "none"} {
	    return -code error "Intersection failure, parallel lines have none"
	} elseif {$p eq "coincident"} {
	    return -code error "Intersection failure, unable to choose among infinite set of points of coincident lines"
	}

	return [diagram::point at {*}$p]
    }

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

    # syntax: [<element> ?<corner>...? ?names ?<pattern>??] --> <point>|<element>|...
    proc IsElementOp {args} {
	#puts IsElementOp|$args|[llength $args]|[diagram::element is [lindex $args 0]]
	return [expr {([llength $args] > 1) &&
		      [diagram::element is [lindex $args 0]]}]
    }

    method ElementOp {eid args} {
	#puts Element|$eid|$corner|=|[$elm corner $eid $corner]|
	#array set c [$elm corners $eid];parray c

	# See IsPointArithOp guard for similar code.
	if {([llength $args] == 2) &&
	    ([lindex $args 0] in {+ - |}) &&
	    [diagram::point is [lindex $args 1]]} {

	    # Point arithmetic on an element is based in the
	    # element's center. Resolve and divert.
	    lassign $args op p
	    return [$self PointArithOp [$elm corner $eid center] $op $p]
	}

	set stop 0
	foreach operation $args next [lrange $args 1 end] {
	    if {$stop} {
		if {$stop == 2} { incr stop -1 ; continue }
		return -code error "wrong#args: should be \"?corner...? ?names ?pattern??\""
	    }
	    if {$operation eq "names"} {
		if {$next eq {}} { set next * }
		set eid [$elm names $eid $next]
		set stop 2
		# stop => error out if there is an argument after next
	    } else {
		set eid [$elm corner $eid $operation]
	    }
	}
	return $eid
    }

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

    method DerefElement {p} {
	# Convert element references to the elements' center point.
	# Used when processing the attributes 'from', 'to', 'then',
	# and 'at'.

	if {[diagram::element is $p]} {
	    return [dict get [$elm corners $p] center]
	} else {
	    return $p
	}
    }

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

    method {Placement init} {}             {} ; # Nothing to
    # initialize
    method {Placement set}  {key newvalue} {} ; # in the language
    # namespace, nor to
    # set.
    method {Placement fill} {av} {
	upvar 1 $av attributes

	if {[dict exists $attributes .withat]} return
	dict set attributes .withat .

	# at/with - rules
	#

	# (1) If the user did not specify 'at', nor 'with', then both
	#     are filled with the information from the layout engine.
	#
	# (2) If 'with' was specified, but not 'at', then 'at' is
	#     filled from the layout engine.
	#
	# (3) If 'at' was specified, but not 'with' then 'with'
	#     defaults to the 'center', and the layout engine is
	#     ignored.
	#
	# (4) If both have been specified, then nothing is done.
	#
	# (5) The data for 'at' is an untagged absolute location.
	#     A user specified value is a diagram::point/delta.
	#     This is resolved as well.

	if {![dict exists $attributes at]} {
	    dict set attributes at [$nav at] ; # (1,2)
	    if {[dict exists $attributes with]} return
	    dict set attributes with [$nav corner] ; # (1)
	} else {
	    # (5) User specified location. Resolve to untagged
	    #     absolute location.
	    dict set attributes at \
		[diagram::point resolve \
		     [$nav at] [dict get $attributes at]]

	    if {![dict exists $attributes with]} {
		dict set attributes with center ; # (3)
	    } ; # else (4)
	}
	return
    }

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

    method {Waypoints init} {}             {}  ; # Nothing to
    # initialize
    method {Waypoints set}  {key newvalue} {}  ; # in the language
    # namespace, nor to
    # set.
    method {Waypoints fill} {av} {
	upvar 1 $av attributes

	# from/then/to - rules
	# Bail out quickly when done already.
	if {[dict exists $attributes waypoints]} return

	# Determine a starting point if not specified, and/or make a
	# relative specification absolute.

	set awaypoints {}
	set last [$nav at] ; # absolute location, untagged.

	if {[dict exists $attributes from]} {
	    set last [diagram::point resolve $last [dict get $attributes from]]
	}

	dict set attributes from $last
	lappend waypoints $last

	if {[dict exists $attributes then]} {
	    #puts |then|[dict get $attributes then]|
	    foreach p [dict get $attributes then] {
		#puts \t|$p|
		set last [diagram::point resolve $last $p]
		lappend waypoints $last
	    }
	}

	if {![dict exists $attributes to]} {
	    # Use a default if and only if no intermediate waypoints
	    # have been specified. For if they have, then the last of
	    # the intermediates will serve as the 'to'.

	    if {![dict exists $attributes then]} {
		# Compute a location based on direction and defaults

		set distance [$self state get movelength]
		set angle    [$dir get [$nav direction] angle]
		set delta    [diagram::point by $distance $angle]
		set last     [diagram::point resolve $last $delta]
		lappend waypoints $last
	    }
	} else {
	    set last [diagram::point resolve $last [dict get $attributes to]]
	    lappend waypoints $last
	}

	dict set attributes waypoints $waypoints
	dict set attributes to        $last

	# If chop values have been specified then now is the time to
	# process their effect on the waypoints.

	if {[dict exists $attributes chop]} {
	    set choplist [dict get $attributes chop]
	    if {[llength $choplist] > 2} {
		set choplist [lrange $choplist end-1 end]
	    } elseif {[llength $choplist] < 2} {
		lappend choplist [lindex $choplist end]
	    }

	    #puts w|||$waypoints|||
	    #puts c|||$choplist|||

	    lassign $choplist chopstart chopend

	    # We have to handle multi-segment lines. First we chop
	    # whole segments until the length to chop is less than the
	    # length of the current first/last segment. Note that we
	    # may be left with an empty path.

	    while {[llength $waypoints] >= 2} {
		lassign $waypoints pa pb
		set seglen [geo::distance $pa $pb]
		if {$seglen > $chopstart} break
		set waypoints [lrange $waypoints 1 end]
		set chopstart [expr {$chopstart - $seglen}]
	    }
	    while {[llength $waypoints] >= 2} {
		lassign [lrange $waypoints end-1 end] pa pb
		set seglen [geo::distance $pa $pb]
		if {$seglen > $chopend} break
		set waypoints [lrange $waypoints 0 end-1]
		set chopend [expr {$chopend - $seglen}]
	    }

	    #puts w'|||$waypoints|||
	    #puts c'|||$choplist|||

	    if {[llength $waypoints] > 2} {
		# Ok, we have enough segments left, now actually chop
		# the first and last segments.

		# Relative chop positions, translated to actual
		# position through interpolation.
		lassign $waypoints pa pb
		set s [expr {double($chopstart)/$seglen}]
		set anew [geo::between $pa $pb $s]

		lassign [lrange $waypoints end-1 end] a b
		set s [expr {1-double($chopend)/$seglen}]
		set bnew [geo::between $pa $pb $s]

		set waypoints [lreplace [lreplace $waypoints 0 0 $anew] end end $bnew]

	    } elseif {[llength $waypoints] == 2} {
		# There is only one segment left in the
		# poly-line. Check that chopping the ends doesn't
		# leave it empty.

		lassign $waypoints pa pb
		set seglen [geo::distance $pa $pb]
		if {($chopstart + $chopend) > $seglen} {
		    set waypoints {}
		} else {
		    # Relative chop positions.
		    set ss [expr {double($chopstart)/$seglen}]
		    set se [expr {1-double($chopend)/$seglen}]

		    #puts s|$ss
		    #puts e|$se

		    # Translate to actual position through interpolation.
		    set anew [geo::between $pa $pb $ss]
		    set bnew [geo::between $pa $pb $se]

		    set waypoints [list $anew $bnew]
		}
	    } else {
		set waypoints {}
	    }

	    dict set attributes waypoints $waypoints
	    dict set attributes from      [lindex $waypoints 0]
	    dict set attributes to        [lindex $waypoints end]
	}

	# Note: Keeping from, and to. direct access to these points
	# could be beneficial.

	#puts WP
	#puts ______________________________________________________
	#array set a $attributes ; parray a
	#puts ______________________________________________________

	return
    }

    method GetPoints {words} {
	set p [$self ProcessPoints $words newdirection]
	if {$newdirection ne {}} {
	    $nav turn $newdirection
	}
	return $p
    }

    method ProcessPoints {words nv} {
	upvar 1 $nv newdirection
	set newdirection {}

	# words = P ... !P
	# P = <point>
	#   | <directionname> <double>
	#   | <directionname>

	if {![{*}$words size]} {
	    return -code error "wrong\#args, expected a point"
	}

	set p [{*}$words peek]
	if {[diagram::point is $p]} {
	    # Got an immediate location (absolute or relative). As we
	    # expect only one of such we stop processing input and
	    # return.

	    {*}$words get
	    return $p
	}

	# Not a proper location. Check if we have a series
	# of <direction> ?<distance>? words.

	set point [diagram::point delta 0 0]
	set resok 0

	while {[{*}$words size]} {

	    set p [{*}$words peek]
	    if {![$dir isStrict $p]} {
		# Not a direction. If we had delta specs before then
		# we just have found the end and can stop processing.
		# Otherwise there was no spec at at all, which is an
		# error.
		break
	    }

	    set direction [$dir validate $p]

	    # We have a direction, check if there is a distance coming
	    # after, then add to the sum of previous deltas,
	    # i.e. integrate the path.

	    {*}$words get
	    if {[{*}$words size] && [string is double -strict [{*}$words peek]]} {
		set distance [{*}$words get]
	    } else {
		set distance [$self state get movelength]
	    }

	    set angle [$dir get $direction angle]
	    set v     [diagram::point by $distance $angle]
	    set point [diagram::point + $point $v]
	    set resok 1

	    # Keep track of the last direction used. When we are done
	    # the caller will push this to the layout engine, so that
	    # it tracks turns specified in the attributes of an
	    # element.

	    set newdirection $direction
	}

	if {$resok} {
	    return $point
	} else {
	    return -code error "Expected point/delta specification, got \"$p\""
	}
    }

    # # ## ### ##### ######## ############# ######################
    ## Instance data, database tables as arrays, keyed by direction
    ## and alias names.

    variable mycanvas  {} ; # Drawing backend
    variable mylangns  {} ; # Name of the namespace holding the drawing state.

    variable myinblock 0  ; # Boolean flag. True when processing a block.
    variable mycorners {} ; # Corner dictionary during block processing.

    component dir        ; # Knowledge base of named directions.
    component elm        ; # Database of drawn elements.
    component nav        ; # State of automatic layout engine
    component att        ; # Database of attributes

    typevariable ourlang LANG

    typevariable ourunit -array {} ; # database for unit conversion

    typeconstructor {
	# [tk scaling] is in pixels/point, with point defined as 1/72 inch
	foreach {unit s} {
	    mm    2.83464566929
	    cm    28.3464566929
	    inch  72
	    point 1
	} {
	    set ourunit($unit) [expr {$s * [tk scaling]}]
	}
    }

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

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

namespace eval ::diagram::core::geo {
    namespace import ::math::geometry::*
}

package provide diagram::core 1

Added scriptlibs/tklib0.7/diagrams/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
## -*- tcl -*-
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>
## BSD Licensed
# # ## ### ##### ######## ############# ######################

#
# diagram drawing package.
#

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

package require Tcl 8.5        ; # Want the nice things it brings
				 # (dicts, {*}, etc.)
package require diagram::core  ; # Core drawing management
package require diagram::basic ; # Basic shapes.
package require snit           ; # Object framework.

# # ## ### ##### ######## ############# ######################
## Implementation

snit::type ::diagram {

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Instance construction, and method routing

    constructor {canvas args} {
	install core  using diagram::core  ${selfns}::CORE  $canvas
	install basic using diagram::basic ${selfns}::BASIC $core

	set mybaseline [$core snap]

	if {![llength $args]} return
	$core draw {*}$args
	return
    }

    method reset {} {
	$core drop
	$core restore $mybaseline
	return
    }

    delegate method * to core

    # # ## ### ##### ######## ############# ######################
    ## Instance data, just two components,

    component core  ; # Fundamental drawing engine and management
    component basic ; # Fundamental shapes we can draw

    variable mybaseline

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

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

package provide diagram 1

Added scriptlibs/tklib0.7/diagrams/direction.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
## -*- tcl -*-
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>
## BSD Licensed
# # ## ### ##### ######## ############# ######################

#
# Database of named directions, for use in the diagram controller.
#
# Directions are identified by name and each has a set of attributes,
# each identified by name, with associated value. The attributes are
# not typed.
#
# Standard attributes are 'angle' and 'oppposite', the first providing
# the angle of the direction, in degrees (0-360, 0 == right/east, 90
# == up/north), and the second naming the complentary direction going
# into the opposite direction (+/- 180 degrees).
#
# The eight directions (octants) of the compass rose are predefined,
# standard.
#
# Beyond the directions the system also manages 'aliases',
# i.e. alternate/secondary names for the primary directions.
#
# All names are handled case-insensitive!
#

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

package require Tcl 8.5 ; # Want the nice things it brings (dicts, {*}, etc.)
package require snit    ; # Object framework.

# # ## ### ##### ######## ############# ######################
## Implementation

snit::type ::diagram::direction {

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Extending the database

    method {new direction} {name args} {
	set thename [string tolower $name]
	# Argument validation.
	if {[info exists myinfo($thename)] ||
	    [info exists myalias($thename)]} {
	    return -code error "direction already known"
	} elseif {[llength $args] % 2 == 1} {
	    return -code error "Expected a dictionary, got \"$args\""
	} elseif {![dict exists $args angle]} {
	    return -code error "Standard attribute 'angle' is missing"
	} elseif {![dict exists $args opposite]} {
	    return -code error "Standard attribute 'opposite' is missing"
	}
	# Note: Can't check the value of opposite, a direction, for
	# existence, because then we are unable to define the pairs.

	# Should either check the angle, or auto-reduce to the proper
	# interval.

	set myinfo($thename) $args
	return
    }

    method {new alias} {name primary} {
	set thename    [string tolower $name]
	set theprimary [string tolower $primary]
	# Argument validation.
	if {[info exists myalias($thename)]} {
	    return -code error "alias already known"
	} elseif {![info exists myalias($theprimary)] &&
		  ![info exists myinfo($theprimary)]} {
	    return -code error "existing direction expected, not known"
	}
	# (*a) Resolve alias to alias in favor of the underlying
	# primary => Short lookup, no iteration required.
	if {[info exists myalias($theprimary)]} {
	    set theprimary $myalias($theprimary)
	}
	# And remember the mapping.
	set mydb($thename) $theprimary
	return
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Validate directions, either as explict angle, or named.
    ##               and return it normalized (angle reduced to
    ##               interval, primary name of any alias).

    method validate {direction} {
	if {[Norm $direction angle]} { return $angle }
	set d $direction
	# Only one alias lookup necessary, see (*a) in 'new alias'.
	if {[info exists myalias($d)]} { set d $myalias($d) }
	if {[info exists myinfo($d)]}  { return $d }
	return -code error "Expected direction, got \"$direction\""
    }

    method is {d} {
	if {[Norm $d angle]} { return 1 }
	# Only one alias lookup necessary, see (*a) in 'new alias'.
	if {[info exists myalias($d)]} { set d $myalias($d) }
	return [info exists myinfo($d)]
    }

    method isStrict {d} {
	# Only one alias lookup necessary, see (*a) in 'new alias'.
	if {[info exists myalias($d)]} { set d $myalias($d) }
	return [info exists myinfo($d)]
    }

    method map {corners c} {
	if {[dict exists $corners $c]} {
	    return $c
	} elseif {[$self is $c]} {
	    set new [$self validate $c]
	    if {$new ne $c} {
		return $new
	    }
	}

	# Find nearest corner by angle.
	set angle [$self get $c angle]
	set delta Inf
	set min {}
	foreach d [dict keys $corners] {
	    if {![$self isStrict $d]} continue
	    if {[catch {
		set da [$self get $d angle]
	    }]} continue
	    set dda [expr {abs($da - $angle)}]
	    if {$dda >= $delta} continue
	    set delta $dda
	    set min   $d
	}
	if {$min ne $c} {
	    return $min
	}
	return $c
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Retrieve directional attributes (all, or
    ##               specific). Accepts angles as well, and uses
    ##               nearest named direction.

    method get {direction {detail {}}} {
	if {[Norm $direction angle]} {
	    set d [$self FindByAngle $angle]
	} elseif {[info exists myalias($direction)]} {
	    set d $myalias($direction)
	} else {
	    set d $direction
	}
	if {[info exists myinfo($d)]}  {
	    if {[llength [info level 0]] == 7} {
		return [dict get $myinfo($d) $detail]
	    } else {
		return $myinfo($d)
	    }
	}
	return -code error "Expected direction, got \"$direction\""
    }

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

    proc Norm {angle varname} {
	if {![string is double -strict $angle]} { return 0 }
	while {$angle < 0}   { set angle [expr {$angle + 360}] }
	while {$angle > 360} { set angle [expr {$angle - 360}] }
	upvar 1 $varname normalized
	set normalized $angle
	return 1
    }

    method FindByAngle {angle} {
	# Find nearest named angle.
	set name {}
	set delta 720
	foreach k [array names myinfo] {
	    if {![dict exists $myinfo($k) angle]} continue
	    set a [dict get $myinfo($k) angle]
	    if {$a eq {}} continue
	    set d [expr {abs($a-$angle)}]
	    if {$d < $delta} {
		set delta $d
		set name $k
	    }
	}
	return $name
    }

    # # ## ### ##### ######## ############# ######################
    ## Instance data, database tables as arrays, keyed by direction
    ## and alias names.

    # Standard directions, the eight sections of the compass rose,
    # with angles and opposite, complementary direction.
    #
    #  135   90  45
    #     nw n ne
    #       \|/
    # 180 w -*- e 0
    #       /|\.
    #     sw s se
    #  225  270  315

    variable myinfo -array {
	east       {angle   0  opposite west     }
	northeast  {angle  45  opposite southwest}
	north      {angle  90  opposite south    }
	northwest  {angle 135  opposite southeast}
	west       {angle 180  opposite east     }
	southwest  {angle 225  opposite northeast}
	south      {angle 270  opposite north    }
	southeast  {angle 315  opposite northwest}

	center     {}
    }

    # Predefined aliases for the standard directions
    # Cardinal and intermediate directions.
    # Names and appropriate unicode symbols.
    variable myalias -array {
	c         center

	w         west         left       west         \u2190 west
	s         south        down       south        \u2191 north
	e         east         right      east         \u2192 east
	n         north        up         north        \u2193 south

	t         north        top        north	       r      east
	b         south        bottom     south	       l      west
	bot       south

	nw        northwest    up-left    northwest    \u2196 northwest
	ne        northeast    up-right   northeast    \u2197 northeast
	se        southeast    down-right southeast    \u2198 southeast
	sw        southwest    down-left  southwest    \u2199 southwest

	upleft    northwest    leftup     northwest	
	upright   northeast    rightup    northeast
	downright southeast    rightdown  southeast
	downleft  southwest    leftdown   southwest	
    }

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

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

package provide diagram::direction 1

Added scriptlibs/tklib0.7/diagrams/element.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
## -*- tcl -*-
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>
## BSD Licensed
# # ## ### ##### ######## ############# ######################

#
# Database of the created/drawn elements, with their canvas items,
# corners (named points), and sub-elements.
#

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

package require Tcl 8.5              ; # Want the nice things it
				       # brings (dicts, {*}, etc.)
package require snit                 ; # Object framework.
package require math::geometry 1.1.2 ; # Vector math (points, line
				       # (segments), poly-lines).
package require diagram::point

# # ## ### ##### ######## ############# ######################
## Implementation

snit::type ::diagram::element {
    # # ## ### ##### ######## ############# ######################

    typemethod validate {id} {
	if {[$type is $id]} {return $id}
	return -code error "Expected element id, got \"$id\""
    }

    typemethod is {id} {
	return [expr {[llength $id] == 2 &&
		      [lindex $id 0] eq "element" &&
		      [string is integer -strict [lindex $id 1]] &&
		      ([lindex $id 1] >= 1)}]
    }

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

    method shape {shape} {
	set myshape($shape) .
	return
    }

    method isShape {shape} {
	return [info exists myshape($shape)]
    }


    # # ## ### ##### ######## ############# ######################
    ## Public API :: Extending the database

    method new {shape corners items subelements} {
	# Generate key
	set id [NewIdentifier]

	# Save the element information.
	set myelement($id) [dict create \
				shape    $shape \
				corners  $corners \
				items    $items \
				elements $subelements]

	lappend myhistory()       $id
	lappend myhistory($shape) $id

	return $id
    }

    method drop {} {
	set mycounter 0
	array unset myelement *
	array unset myhistory *
	set myhistory() {}
	return
    }

    method {history get} {} {
	return [array get myhistory]
    }

    method {history set} {history} {
	array unset myhistory *
	array set   myhistory $history
	return
    }

    method {history find} {shape offset} {
	#  1, 2,...: Offset from the beginning of history, forward.
	# -1,-2,...: Offset from the end history, backward.

	if {$offset < 0} {
	    set offset [expr {[llength $myhistory($shape)] + $offset}]
	} else {
	    incr offset -1
	}

	#parray myhistory
	#puts E|hf|$shape|$offset|

	return [lindex $myhistory($shape) $offset]
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Query database.

    method elements {} {
	return $myhistory()
    }

    method corner {id corner} {
	#puts MAP($corner)=|[MapCorner $id $corner]|
	set corners [dict get $myelement($id) corners]
	return [dict get $corners [$dir map $corners $corner]]
    }

    method corners {id} {
	return [dict get $myelement($id) corners]
    }

    method names {id {pattern *}} {
	return [dict keys [dict get $myelement($id) corners] $pattern]
    }

    method items {args} {
	set items {}
	foreach id $args {
	    lappend items {*}[dict get $myelement($id) items]
	    lappend items {*}[$self items {*}[dict get $myelement($id) elements]]
	}

	# Elements with sub-elements elements can cause canvas items
	# to appear multiple times. Reduce this to only one
	# appearance. Otherwise items may be processed multiple times
	# later.

	return [lsort -uniq $items]
    }

    method bbox {args} {
	# We compute the bounding box from the corners we have for the
	# specified elements. This makes the assumption that the
	# convex hull of the element's corners is a good approximation
	# of the areas they cover.
	#
	# (1) We cannot fall back to canvas items, as the items may
	# cover a much smaller area than the system believes. This
	# notably happens for text elements. In essence a user-
	# declared WxH would be ignored by looking at the canvas.
	#
	# (2) We have to look at all corners because the simple NW/SE
	# diagonal may underestimate the box. This happens for circles
	# where these anchors are near the circle boundary and thus
	# describe the in-scribed box, instead of the outer bounds.

	# Note that corners may contain other information than
	# points. This is why the corner values are type tagged,
	# allowing us to ignore the non-point corners.

	set polyline {}
	foreach id $args {
	    foreach v [dict values [dict get $myelement($id) corners]] {
		lassign $v cmd detail
		if {$cmd ne "point"} continue
		lappend polyline [geo::x $detail] [geo::y $detail]
	    }
	}

	return [geo::bbox $polyline]
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Move elements to a point.

    method relocate {id destination corner canvas} {

	#puts \trelocate($id).$corner\ @$destination

	# Move the id'entified element such that the corner's point is
	# at the destination.

	# Retrieve element data.
	array set el $myelement($id)

	# Find current location of the specified corner.
	set origin [diagram::point unbox [$self corner $id $corner]]

	#puts \t$corner=$origin

	# Determine the movement vector which brings the corner into
	# coincidence with the destination.
	set delta [geo::- $destination $origin]

	#puts \tdelta=$delta

	# And perform the movement.
	$self Move $id $delta $canvas
	return
    }

    method move {delta corners} {
	set newcorners {}
	foreach {key location} $corners {
	    #puts PLACE|$key|$location|$delta|
	    if {[llength $location] == 2} {
		lassign $location cmd detail
		if {$cmd eq "point"} {
		    #puts \tSHIFT
		    lappend newcorners $key \
			[list $cmd [geo::+ $detail $delta]]
		} else {
		    lappend newcorners $key $location
		}
	    } else {
		lappend newcorners $key $location
	    }
	}

	return $newcorners
    }

    method Move {id delta canvas} {
	# Retrieve element data.
	array set el $myelement($id)

	# Move the primary items on the canvas.
	foreach item $el(items) {
	    $canvas move $item {*}$delta
	}

	# Recursively move child elements
	foreach sid  $el(elements) {
	    $self Move $sid $delta $canvas
	}

	# And modify the corners appropriately

	set newcorners [$self move $delta $el(corners)]

	dict set myelement($id) corners $newcorners
	return
    }

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

    constructor {thedir} {
	set dir $thedir
	return
    }

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

    proc NewIdentifier {} {
	upvar 1 mycounter mycounter
	return [list element [incr mycounter]]
    }

    # # ## ### ##### ######## ############# ######################
    ## Instance data, database tables as arrays, keyed by direction
    ## and alias names.

    component dir                ; # Database of named directions.
                                   # Used to check for and resolve
                                   # corner aliases.
    variable mycounter 0         ; # Counter for the generation of
				   # element identifiers. See
				   # 'NewIdentifier' for the user.
    variable myelement -array {} ; # Database of drawn elements. Maps
				   # from element identifiers to a
				   # dictionary holding the pertinent
				   # information (type, canvas items,
				   # sub elements, and corners (aka
				   # attributes).
    variable myhistory -array {
	{} {}
    }                            ; # History database. Keyed by
				   # element type, they are mapped to
				   # lists of element identifiers
				   # naming the elements in order of
				   # creation. The empty key has the
				   # history without regard to type.

    variable myshape -array {}  ; # Database of element shapes.

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

namespace eval ::diagram::element::geo {
    namespace import ::math::geometry::*
}

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

package provide diagram::element 1

Added scriptlibs/tklib0.7/diagrams/navigation.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
## -*- tcl -*-
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>
## BSD Licensed
# # ## ### ##### ######## ############# ######################

#
# Auto-layout management
#

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

package require Tcl 8.5              ; # Want the nice things it
				       # brings (dicts, {*}, etc.)
package require snit                 ; # Object framework.
package require struct::stack
package require diagram::point

# # ## ### ##### ######## ############# ######################
## Implementation

snit::type ::diagram::navigation {

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Modify the state

    method reset {} {
	set mylocation {0 0}
	set mydirection east
	set mycorner    west
	set mycorners   {}
	$mystack clear
	return
    }

    method turn {direction {commit 0}} {
	#puts T|$direction|$commit
	set mydirection [$mydirections validate $direction]
	set mycorner    [$mydirections get $mydirection opposite]
	#puts O|$mycorner

	if {$commit && [dict exists $mycorners $mydirection]} {
	    set mylocation \
		[diagram::point unbox \
		     [diagram::point absolute \
			  [dict get $mycorners $mydirection]]]
	}
	return
    }

    method move {newcorners} {
	#puts M|$newcorners
	if {[dict exists $newcorners end]} {
	    set mycorners {}
	    set at [dict get $newcorners end]
	} else {
	    # Note: We map mydirection to the corners to handle the
	    # possibility of directions which are not on the compass
	    # rose. Such are mapped to the nearest compass or other
	    # direction which is supported by the element we have
	    # moved to.
	    set mycorners $newcorners
	    set at [dict get $newcorners \
			[$mydirections map $newcorners $mydirection]]
	}

	set mylocation \
	    [diagram::point unbox [diagram::point absolute $at]]
	return
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API :: State nesting

    method save {} {
	$mystack push [list \
			   $mylocation \
			   $mydirection \
			   $mycorner \
			   $mycorners]
	return
    }

    method restore {} {
	lassign [$mystack pop] \
	    mylocation \
	    mydirection \
	    mycorner \
	    mycorners
	return
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API :: Querying

    method at {} {
	# TODO :: gap processing goes here -- maybe not required, given 'chop'.
	return $mylocation
    }

    method corner {} {
	return $mycorner
    }

    method direction {} {
	return $mydirection
    }

    # # ## ### ##### ######## ############# ######################
    ## Public API ::

    constructor {directions} {
	install mystack using struct::stack ${selfns}::STACK
	set mydirections $directions
	return
    }

    # # ## ### ##### ######## ############# ######################
    ## Instance data,

    component mystack
    component mydirections

    variable mylocation     {0 0} ; # attribute 'at' default
    variable mydirection    east  ; # current layout direction.
    variable mycorner       west  ; # attribute 'with' default
				    # (opposite of direction').
    variable mycorners      {}    ; # The corners we can turn to.

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

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

package provide diagram::navigation 1

Added scriptlibs/tklib0.7/diagrams/pkgIndex.tcl.































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
if {![package vsatisfies [package provide Tcl] 8.5]} {
    # PRAGMA: returnok
    return
}
package ifneeded diagram::navigation  1 [list source [file join $dir navigation.tcl]]
package ifneeded diagram::direction   1 [list source [file join $dir direction.tcl]]
package ifneeded diagram::element     1 [list source [file join $dir element.tcl]]
package ifneeded diagram::attribute   1 [list source [file join $dir attributes.tcl]]
package ifneeded diagram::point       1 [list source [file join $dir point.tcl]]
package ifneeded diagram::core        1 [list source [file join $dir core.tcl]]
package ifneeded diagram::basic   1.0.1 [list source [file join $dir basic.tcl]]
package ifneeded diagram              1 [list source [file join $dir diagram.tcl]]

package ifneeded diagram::application 1.2 [list source [file join $dir application.tcl]]

Added scriptlibs/tklib0.7/diagrams/point.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
## -*- tcl -*-
## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>
## BSD Licensed
# # ## ### ##### ######## ############# ######################

#
# diagram points.
#
# Type validation and implementation of the various operations on
# points and lines. The low-level commands for this come from
# math::geometry. The operations here additionally (un)box from/to
# tagged values. They also handle operations mixing polar and
# cartesian specifications.
#

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

package require Tcl 8.5              ; # Want the nice things it
                                       # brings (dicts, {*}, etc.)
package require math::geometry 1.1.2 ; # Vector math (points, line
				       # (segments), poly-lines).

namespace eval ::diagram::point {
    namespace export is isa validate absolute at delta by unbox + - | resolve
    namespace ensemble create
}

# # ## ### ##### ######## ############# ######################
## Implementation
# # ## ### ##### ######## ############# ######################
## Public API :: validation

proc ::diagram::point::validate {value} {
    if {[is $value]} {return $value}
    return -code error "Expected diagram::point, got \"$value\""
}

proc ::diagram::point::absolute {value} {
    if {[isa $value]} {return $value}
    return -code error "Expected absolute diagram::point, got \"$value\""
}

proc ::diagram::point::is {value} {
    return [expr {([llength $value] == 2) &&
		  ([lindex $value 0] in {point + by})}]
}

proc ::diagram::point::isa {value} {
    # note overlap with constructor 'at'.
    return [expr {([llength $value] == 2) ||
		  ([lindex $value 0] eq "point")}]
}

# # ## ### ##### ######## ############# ######################
## Public API :: Constructors

# Absolute location
proc ::diagram::point::at {x y} {
    return [list point [list $x $y]]
}

# Relative location, cartesian
proc ::diagram::point::delta {dx dy} {
    return [list + [list $dx $dy]]
}

# Relative location, polar
proc ::diagram::point::by {distance angle} {
    return [list by [list $distance $angle]]
}

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

proc ::diagram::point::unbox {p} {
    return [lindex $p 1]
}

# # ## ### ##### ######## ############# ######################
## Public API :: Point arithmetic

proc ::diagram::point::+ {a b} {
    set a [2cartesian [validate $a]]
    set b [2cartesian [validate $b]]

    # Unboxing

    lassign $a atag adetail
    lassign $b btag bdetail

    # Calculation and result type determination

    set result [geo::+ $adetail $bdetail]
    set rtype  [expr {(($atag eq "point") || ($btag eq "point"))
		      ? "at"
		      : "delta"}]

    return [$rtype {*}$result]
}

proc ::diagram::point::- {a b} {
    set a [2cartesian [validate $a]]
    set b [2cartesian [validate $b]]

    # Unboxing

    lassign $a atag adetail
    lassign $b btag bdetail

    # Calculation and result type determination

    set result [geo::- $adetail $bdetail]
    set rtype  [expr {(($atag eq "point") || ($btag eq "point"))
		      ? "at"
		      : "delta"}]

    return [$rtype {*}$result]
}

proc ::diagram::point::| {a b} {
    set a [2cartesian [absolute $a]]
    set b [2cartesian [absolute $b]]

    # Unboxing

    lassign $a atag adetail ; lassign $adetail ax ay
    lassign $b btag bdetail ; lassign $bdetail bx by

    # Calculation of the projection.
    return [at $ax $by]
}

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

proc ::diagram::point::resolve {base p} {
    #puts P|resolve|$base|$p|

    # The base is an untagged point, p is a tagged point or delta.
    lassign $p tag detail

    # A point is returned unchanged.
    if {$tag eq "point"} { return [unbox $p] }

    # A delta is normalized, then added to the base.

    #puts R|$base|$p|
    #puts R|[2cartesian $p]|
    #puts R|[unbox [2cartesian $p]]|

    return [geo::+ $base [unbox [2cartesian $p]]]
}

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

# Normalize point/delta information to cartesian
# coordinates. Input and output are both tagged, and points not
# using a polar representation are not modified.

proc ::diagram::point::2cartesian {p} {
    lassign $p tag details
    if {$tag ne "by"} { return $p }
    return [delta {*}[polar2cartesian $details]]
}

# Conversion of a delta from polar to cartesian coordinates,
# operating on untagged data.

proc ::diagram::point::polar2cartesian {polar} {
    lassign $polar distance angle
    return [geo::s* $distance [geo::direction $angle]]
}

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

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

namespace eval ::diagram::point::geo {
    namespace import ::math::geometry::*
}

package provide diagram::point 1

Added scriptlibs/tklib0.7/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]]

Added scriptlibs/tklib0.7/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
    }
}

Added scriptlibs/tklib0.7/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}

Added scriptlibs/tklib0.7/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]]

Added scriptlibs/tklib0.7/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
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
# ico.tcl --
#
# Win32 ico manipulation code
#
# Copyright (c) 2003-2007 Aaron Faupell
# Copyright (c) 2003-2011 ActiveState
#
# RCS: @(#) $Id: ico.tcl,v 1.32 2011/10/05 00:10:46 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 {![file exists $file]} {
        return -code error "couldn't open \"$file\": no such file or directory"
    }
    gettype type $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 {![file exists $file]} {
        return -code error "couldn't open \"$file\": no such file or directory"
    } 
    gettype type $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 {![file exists $file]} {
        return -code error "couldn't open \"$file\": no such file or directory"
    }
    gettype type $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 [lindex [lsearch -inline -glob $mem "* $res $bpp"] 0]
        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 {![file exists $file]} {
        return -code error "couldn't open \"$file\": no such file or directory"
    }
    gettype type $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
    # Bug 3007168 (code is able to create a file if none is present)
    #if {![file exists $file]} {
    #    return -code error "couldn't open \"$file\": no such file or directory"
    #}
    gettype type $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 {![file exists $file1]} {
        return -code error "couldn't open \"$file1\": no such file or directory"
    } 
    if {![file exists $file2]} {
        return -code error "couldn't open \"$file2\": no such file or directory"
    }
    gettype fromtype $file1
    gettype totype $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

    if {![file exists $exeFile]} {
        return -code error "couldn't open \"$exeFile\": no such file or directory"
    } 

    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::gettype {var file} {
    upvar $var type
    if {[info exists type]} { return }
    set type [string trimleft [string toupper [file extension $file]] .]
    if {$type == ""} { return -code error "could not determine file type from extension, use -$var option" }
}

# 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 ""}]}
	set w [string length $l]
	append l [string repeat 0 [expr {($w == 24) ? 8 : ($w % 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==24) ? 8 : ($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 == 24) ? 8 : ($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 == 24) ? 8 : ($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]
    FindResources $file

    if {![info exists RES($file,icon,$name,data)]} {
	return -code error "no icon \"$name\""
    }
    if {"$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 "file is not a valid executable"
    }
    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 "file is not a valid executable"
    }
}

# 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