Check-in [a5a2627681]

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

Overview
Comment:Initial checkin.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:a5a262768194455eb40bb5a571ca90ab0f57ebd3
User & Date: gwlester 2014-12-08 01:03:21
Context
2014-12-08
03:06
Checkin check-in: e8be0b5c97 user: gwlester tags: trunk
01:03
Initial checkin. check-in: a5a2627681 user: gwlester tags: trunk
01:00
initial empty check-in check-in: 9f9e2b5ff2 user: gwlester tags: trunk
Changes

Added CreateShortCuts.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
package require Tcl 8.6
package require Tk 8.6

cd /sdcard/home/WishScripts

proc CreateShortCuts {} {
    foreach file [glob *.tcl] {
        set name [file tail [file rootname $file]]
        set fullFile [file join [pwd] $file]
        set ans [tk_messageBox \
                    -default no \
                    -icon question \
                    -detail "Create shortcut '$name'?" \
                    -type yesno \
                    -parent . \
                    -title {Create Shortcut} \
            ]
        if {[string is boolean -strict $ans] && $ans} {
            catch {borg shortcut add $name $fullFile}
        }
    }
}

proc ListenForServer {socket} {
    global filesDownloaded

    lassign [fconfigure $socket -peer] host fromPort
    set dataDict [read $socket]
    if {[dict exists $dataDict port]} {
        set toPort [dict get $dataDict port]
        set ::status "Sever '$host' found!  Requesting file list..."
        set url [format {http://%s:%d/ScriptSever} $host $toPort]
        set token [::http::geturl $url -query [::http::formatQuery COMMAND LIST]]
        ::http::wait $token
        if {[::http::status $token]} {
            set infoList [::http::data $token]
            ::http::cleanup $token
            foreach {fileName date} $infoList {
                if {![file exists $fileName] || ([file mtime $fileName] < $date)} {
                    set ::status "Downloading '$fileName'..."
                    set ofd [open $fileName w]
                    set query [::http::formatQuery COMMAND GET FILE $fileName]
                    set token [::http::geturl $url -query $query -channel $ofd]
                    ::http::wait $token
                    close $ofd
                    ::http::cleanup $token
                }
            }
        }
        set filesDownloaded 1
    }
}

proc Timeout {} {
    global filesDownloaded

    set filesDownloaded -1
}

set ans [tk_messageBox \
            -default no \
            -detail {Download Scripts from server?} \
            -icon question \
            -parent . \
            -title {Download Scripts?} \
            -type yesno]

if  {[string is boolean -strict $ans] && $ans} {
    package require udp
    package require http

    set filesDownloaded 0
    set group 224.5.1.21
    set port  7771
    set socket [udp_open $port]
    fconfigure $socket -buffering none -blocking 0
    fconfigure $socket -mcastadd $group -remote [list $group $port]
    set afterId [after [expr {1000 * 60}] Timeout]
    fileevent $socket readable [list ListenForServer $socket]
    label .status \
        -textvariable status
    grid configure .status -sticky nsew
    grid columnconfigure . .status -weight 1
    grid rowconfigure . .status -weight 1
    set status {Searching for server!}
    vwait filesDownloaded
}

CreateShortCuts

destroy .
exit 1

Added LaunchApplications.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
package require Tcl 8.6
package require Tk 8.6
package require inifile
package require msgcat

proc LaunchApplication {appName} {
    puts "Launching {$appName}"
    variable applicationsDict
    variable montiorArray

    set applicationDict [dict get $applicationsDict $appName]
    set interpId [interp create]
    set montiorArray($interpId) $appName
    set script {package require Tk}
    set path [dict get $applicationDict Path]
    set argv [dict get $applicationDict StartupArgs]
    set argc [llength $argv]
    append script "\n" [list set argv0 $path]
    append script "\n"  [list set argv $argv]
    append script "\n"  [list set argc $argc]
    append script "\n"  [list after 1 [list source $path]]
    set now [clock seconds]
    dict set applicationsDict $appName _running $interpId startedAt $now
    dict set applicationsDict $appName _running $interpId endedAt 0
    set threadData [.main.data item $appName -values]
    lset threadData end [expr {[lindex $threadData end] + 1}]
    .main.data item $appName -values $threadData
    if {[lindex $threadData end] == [lindex $threadData end-1]} {
        .menubar.applications entryconfigure [dict get $applicationsDict $appName _menuLabel] -state disabled
    }
    $interpId eval $script
}

proc MonitorApplication {} {
    variable applicationsDict
    variable montiorArray

    after 1000 MonitorApplication
    set now [clock seconds]
    foreach interpId [array names montiorArray] {
        if {[catch {$interpId eval {winfo exists .}}]} {
            set appName $montiorArray($interpId)
            dict set applicationsDict $appName _running $interpId endedAt $now
            unset montiorArray($interpId)
            set threadData [.main.data item $appName -values]
            lset threadData end [expr {[lindex $threadData end] - 1}]
            .main.data item $appName -values $threadData
            .menubar.applications entryconfigure [dict get $applicationsDict $appName _menuLabel] -state normal
        }
    }
}

proc ::tkerror {args} {
    tk_messageBox -icon error -title {Application Error} -message $args -detail $::errorInfo
}


##
## Load our message file
##
set baseDir [file dirname [info script]]
::msgcat::mcload [file join $baseDir .LaunchApplications msgs]

##
## Set the title bar
##
wm title . [::msgcat::mc ApplicationTitle]
#wm overrideredirect . yes

##
## Create the main menu
##
. configure -menu .menubar
set mb [menu .menubar -tearoff no]
$mb add cascade \
    -menu $mb.file \
    -label [::msgcat::mc File]
$mb add cascade \
    -menu $mb.applications \
    -label [::msgcat::mc Applications]
$mb add cascade \
    -menu $mb.windows \
    -label [::msgcat::mc Windows]

##
## Configure the base windows menu
##
menu $mb.file -tearoff no
$mb.file add command \
    -command [list destroy .] \
    -label [::msgcat::mc Exit]

##
## Configure the base windows menu
##
menu $mb.windows -tearoff no
$mb.windows add command \
    -command [list console show] \
    -label [::msgcat::mc ShowConsole]
$mb.windows add command \
    -command [list console hide] \
    -label [::msgcat::mc HideConsole]
$mb.windows add separator

##
## Configure the application menu
##
menu $mb.applications -tearoff no

##
## Read the ini file there should be one section per application. The section
## name will be the symbolic name of the application, this should be a Tcl
## "word" and must not begin with an underscore ("_").
##
## Each section should have the following keys:
##      Title           -- the title of the application
##      Path            -- the path to the wish file
##
## Each section may have the following keys:
##      StartupDir  -- the directory to start the application in, defaults to ~/
##      StartupArgs -- a list with the contents of argv defaults to the empty list
##      MaxAllowed  -- Maximum number of copies of the application that can be
##                      run connurently. Defaults to 1. A value of 0 means, the
##                      application is disabled in the menu.  A negative value
##                      means there is no limit.
##
set applicationsDict {}
set iniFd [::ini::open [file join $baseDir .LaunchApplications LaunchApplications.ini] r]
foreach section [lsort -dictionary [::ini::sections $iniFd]] {
    dict set applicationsDict $section StartupDir [file normalize ~/]
    dict set applicationsDict $section StartupArgs {}
    dict set applicationsDict $section MaxAllowed 1
    foreach {key value} [::ini::get $iniFd $section] {
        dict set applicationsDict $section $key $value
    }
    dict set applicationsDict $section _menuLabel [::msgcat::mc [dict get $applicationsDict $section Title]]
    dict set applicationsDict $section _threads {}
    $mb.applications add command \
        -command [list LaunchApplication $section] \
        -label [dict get $applicationsDict $section _menuLabel] \
        -state disabled
    if {[dict get $applicationsDict $section MaxAllowed] &&
        [file exists [dict get $applicationsDict $section Path]]} {
        $mb.applications entryconfigure [dict get $applicationsDict $section _menuLabel] \
            -state normal
    } else {
        puts stdout "$section diabled"
        puts stdout "\t Max Threads: [dict get $applicationsDict $section MaxAllowed]"
        puts stdout "\t File {[dict get $applicationsDict $section Path]} == [file exists [dict get $applicationsDict $section Path]]"
        puts stdout {}
    }
}
::ini::close $iniFd

##
## Define the display part
##
::ttk::frame .main
grid configure .main -sticky nsew
grid columnconfigure . .main -weight 1
grid rowconfigure . .main -weight 1

::ttk::treeview .main.data \
    -yscrollcommand [list .main.vsb set] \
    -xscrollcommand [list .main.hsb set] \
    -columns {appName appTitle maxCount activeCount} \
    -displaycolumns {appTitle maxCount activeCount} \
    -show headings \
    -selectmode browse
::ttk::scrollbar .main.vsb \
    -orient vertical \
    -command [list .main.data yview]
::ttk::scrollbar .main.hsb \
    -orient horizontal \
    -command [list .main.data xview]
grid configure .main.data .main.vsb -sticky nsew
grid configure .main.hsb -sticky ew
grid columnconfigure .main .main.data -weight 1
grid rowconfigure .main .main.data -weight 1
foreach column {appName appTitle maxCount activeCount}  {
    .main.data heading $column -text [::msgcat::mc $column,Heading]
}
foreach app [lsort -dictionary [dict keys $applicationsDict]] {
    .main.data insert {} end \
        -id $app \
        -values [list $app [dict get $applicationsDict $app _menuLabel] [dict get $applicationsDict $app MaxAllowed]  0]
}
bind .main.data <Double-Button-1> {
    LaunchApplication [.main.data selection]
}

after 1000 MonitorApplication
catch {console hide}

Added NaughtSquirrel.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
package require Tk 8.6

proc SayIt {name} {
    borg speak "$name is a naughty squirrel!"
    return;
}

button .hailey \
    -text {Hailey} \
    -command [list SayIt Hailey]

button .logan \
    -text {Logan} \
    -command [list SayIt Logan]

button .blake \
    -text {Blake} \
    -command [list SayIt Blake]

grid configure .logan -row 2 -column 2
grid configure .hailey -row 4 -column 2
grid configure .blake -row 6 -column 2

grid rowconfigure . {1 3 5 7} -weight 1
grid columnconfigure . {1 3} -weight 1

set h [winfo screenheight .]
set w [winfo screenwidth .]
incr w -10
incr h -10
wm geometry . [format {%dx%d} $w $h]
wm title . {Naughty Squirrel}

Added Sensors.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
# Android demo for <<Sensor>> events

proc createTab {baseType} {
    global tabList
    global tab

    set tab .top.tab_$baseType
    lappend tabList $baseType
    ::ttk::frame $tab
    grid configure $tab -row 1 -column 1 -sticky nsew
    grid forget $tab
    puts stdout "Created frame '$tab'"
}

proc mksensor {sensor} {
    set i [dict get $sensor index]
    set baseType [lindex [split [dict get $sensor type] {_}] 0]
    set tab .top.tab_$baseType
    if {![winfo exists $tab]} {
        createTab $baseType
    }
    set f $tab.s$i
    ::ttk::labelframe $f \
        -text [dict get $sensor name]
    ::ttk::checkbutton $f.en \
        -text "Enable" \
        -command [list togglesensor $i] \
	-variable ::SENSOR($i,enabled) \
        -onvalue enable \
        -offvalue disable
    grid configure $f.en -row 0 -column 0 -sticky w -padx 10 -pady 5
    entry $f.val \
        -textvariable ::SENSOR($i,values) \
        -width 40 \
	-disabledforeground black \
        -disabledbackground white \
	-state disabled
    grid configure $f.val -row 1 -column 0 -sticky ew -padx 10 -pady 5
    grid configure $f
    set ::SENSOR($i,enabled) enable
    updatesensor $i
}

proc updatesensor {i} {
    set data [borg sensor get $i]
    set ::SENSOR($i,values) [dict get $data values]
    if {($::SENSOR($i,enabled) eq "enable") && ![dict get $data enabled]} {
	set ::SENSOR($i,enabled) disable
    }
}

proc togglesensor {i} {
    borg sensor $::SENSOR($i,enabled) $i
}

proc watchdog {} {
    after cancel watchdog
    after 10000 watchdog
    foreach sensor [borg sensor list] {
	set i [dict get $sensor index]
	set data [borg sensor get $i]
	if {[dict get $data enabled]} {
	    set ::SENSOR($i,enabled) enable
	} else {
	    set ::SENSOR($i,enabled) disable
        }
    }
}

proc displaySelectedTab {args} {
    global chosenSensor
    global lastTab

    set tab .top.tab_$chosenSensor
    if {$lastTab ne {}} {
        grid forget $lastTab
    }
    grid configure $tab
    set lastTab $tab
}

##
## Main body
##
#wm attributes . -fullscreen 1
bind . <Break> exit
bind . <<SensorUpdate>> {updatesensor %x}

::ttk::combobox .sensorNB \
    -state readonly \
    -textvariable chosenSensor
::ttk::labelframe .top \
    -labelwidget .sensorNB \
    -labelanchor n
grid configure .top -sticky nsew
grid columnconfigure . .top -weight 1
grid rowconfigure . .top -weight 1

set tabList {}
set lastTab {}
foreach s [borg sensor list] {
    mksensor $s
}

.sensorNB configure -values $tabList
raise .sensorNB
trace add variable chosenSensor write displaySelectedTab
set chosenSensor [lindex $tabList 0]

watchdog

Added ServeScripts.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
#!/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" ${1+"$@"}

###############################################################################
##                                                                           ##
##  Copyright (c) 2015, Gerald W. Lester                                     ##
##  All rights reserved.                                                     ##
##                                                                           ##
##  Redistribution and use in source and binary forms, with or without       ##
##  modification, are permitted provided that the following conditions       ##
##  are met:                                                                 ##
##                                                                           ##
##    * Redistributions of source code must retain the above copyright       ##
##      notice, this list of conditions and the following disclaimer.        ##
##    * Redistributions in binary form must reproduce the above              ##
##      copyright notice, this list of conditions and the following          ##
##      disclaimer in the documentation and/or other materials provided      ##
##      with the distribution.                                               ##
##    * Neither the name of the Visiprise Software, Inc nor the names        ##
##      of its contributors may be used to endorse or promote products       ##
##      derived from this software without specific prior written            ##
##      permission.                                                          ##
##                                                                           ##
##  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS      ##
##  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT        ##
##  LIMITED  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS       ##
##  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE           ##
##  COPYRIGHT OWNER OR  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,     ##
##  INCIDENTAL, SPECIAL,  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,    ##
##  BUT NOT LIMITED TO,  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;        ##
##  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER         ##
##  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT       ##
##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
##  POSSIBILITY OF SUCH DAMAGE.                                              ##
##                                                                           ##
###############################################################################

package require Tcl 8.6
package require uri
package require base64
package require html
package require udp

namespace eval httpd {
    array set portInfo {}

    set portList [list]

    variable returnCodeText [dict create \
                                200 OK \
                                404 "Not Found" \
                                500 "Internal Server Error" \
                                501 "Not Implemented" \
                            ]

    ###########################################################################
    #
    # Public Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PUBLIC<<
    #
    # Procedure Name : addHandler
    #
    # Description : Register a handler for a url on a port.
    #
    # Arguments :
    #       port     -- The port to register the callback on
    #       url      -- The URL to register the callback for
    #       callback -- The callback prefix, two additionally arguments are lappended
    #                   the callback: (1) the socket (2) the null string
    #
    # Returns :     Nothing
    #
    # Side-Effects :
    #       None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : Listen must have been called for the port
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PUBLIC<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #
    #
    ###########################################################################
    proc addHandler {port url callback} {
        variable portInfo

        dict set portInfo($port,handlers) $url $callback
        return;
    }

    ###########################################################################
    #
    # Public Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PUBLIC<<
    #
    # Procedure Name : listen
    #
    # Description : Instruct the module to listen on a Port, security information.
    #
    # Arguments :
    #       port     -- Port number to listen on
    #       certfile -- Name of the certificate file
    #       keyfile  -- Name of the key file
    #       userpwds -- A list of username:password
    #       realm    -- The security realm
    #
    # Returns :     socket handle
    #
    # Side-Effects :
    #       None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : Listen must have been called for the port
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PUBLIC<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #
    #
    ###########################################################################
    proc listen {port {certfile {}} {keyfile {}} {userpwds {}} {realm {}}} {
        variable portInfo
        variable portList

        lappend portList $port
        foreach key {port certfile keyfile userpwds realm} {
            set portInfo($port,$key) [set $key]
        }
        if {![info exists portInfo($port,handlers)]} {
            set portInfo($port,handlers) {}
        }
        foreach up $userpwds {
            lappend portInfo($port,auths) [base64::encode $up]
        }

        set handle [socket -server [list [namespace current]::Accept $port] $port]

        return $handle
    }

    ###########################################################################
    #
    # Private Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PRIVATE<<
    #
    # Procedure Name : Respond
    #
    # Description : Send response back to user.
    #
    # Arguments :
    #       sock -- Socket to send reply on
    #       code -- Code to send
    #       body -- HTML body to send
    #       head -- Additional HTML headers to send
    #
    # Returns :
    #       Nothing
    #
    # Side-Effects : None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : None
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PRIVATE<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #   2.3.0  11/06/2012  H.Oehlmann   Separate head and body,
    #                                   correct Content-length
    #
    #
    ###########################################################################
    proc Respond {sock code body {head ""}} {
        set body [encoding convertto iso8859-1 $body\r\n]
        chan configure $sock -translation crlf
        puts $sock "[HttpReturnCode $code]\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]"
        if {"" ne $head} {
            puts -nonewline $sock $head
        }
        # Separator head and body
        puts $sock ""
        chan configure $sock -translation binary
        puts -nonewline $sock $body
    }

    ###########################################################################
    #
    # Private Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PRIVATE<<
    #
    # Procedure Name : HttpReturnCode
    #
    # Description : Format the first line of a http return including the status code
    #
    # Arguments :
    #       code -- numerical http return code
    #
    # Returns :
    #       Nothing
    #
    # Side-Effects : None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : None
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PRIVATE<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  10/05/2012  H.Oehlmann   Initial version
    #
    #
    ###########################################################################
    proc HttpReturnCode {code} {
        variable returnCodeText
        if {[dict exist $returnCodeText $code]} {
            set textCode [dict get $returnCodeText $code]
        } else {
            set textCode "???"
        }
        return "HTTP/1.0 $code $textCode"
    }

    ###########################################################################
    #
    # Private Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PRIVATE<<
    #
    # Procedure Name : CheckAuth
    #
    # Description : Check to see if the user is allowed.
    #
    # Arguments :
    #       port -- Port number
    #       sock -- Incoming socket
    #       ip   -- Requester's IP address
    #       auth -- Authentication information
    #
    # Returns :
    #       Nothing
    #
    # Side-Effects : None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : None
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PRIVATE<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #
    #
    ###########################################################################
    proc CheckAuth {port sock ip auth} {
        variable portInfo

        if {[info exists portInfo($port,auths)] && [llength $portInfo($port,auths)] && [lsearch -exact $portInfo($port,auths) $auth]==-1} {
            set realm $portInfo($port,realm)
            Respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n"
            return -code error
        }
    }

    ###########################################################################
    #
    # Private Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PRIVATE<<
    #
    # Procedure Name : Handler
    #
    # Description : Handle a request.
    #
    # Arguments :
    #       port        -- Port number
    #       sock        -- Incoming socket
    #       ip          -- Requester's IP address
    #       reqstring   -- Requester's message
    #       auth        -- Authentication information
    #
    # Returns :
    #       Nothing
    #
    # Side-Effects : None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : None
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PRIVATE<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #   2.3.0  10/31/2012  G.Lester     bug fix for [68310fe3bd] -- correct encoding and data length
    #
    #
    ###########################################################################
    proc Handler {port sock ip reqstring auth} {
        variable portInfo
        upvar #0 Httpd$sock req

        if {[catch {CheckAuth $port $sock $ip $auth}]} {
            return
        }

        array set req $reqstring
        #foreach var {type data code} {
        #    dict set req(reply) $var [set $var]
        #}
        set path "/[string trim $req(path) /]"
        if {[dict exists $portInfo($port,handlers) $path]} {
            set cmd [dict get $portInfo($port,handlers) $path]
            lappend cmd $sock req
            if {[catch {eval $cmd} msg]} {
                Respond $sock 404 "Error: $msg"
            } else {
                set type [dict get $req(reply) type]
                set encoding [string tolower [lindex [split [lindex [split $type {;}] 1] {=}] 1]]
                if {$encoding ni [encoding names]} {
                    set encoding utf-8
                    set type "[lindex [split $type ";"] 0]; charset=UTF-8"
                }
                set data [encoding convertto $encoding [dict get $req(reply) data]]
                set reply "[HttpReturnCode [dict get $req(reply) code]]\n"
                append reply "Content-Type: $type\n"
                append reply "Connection: close\n"
                append reply "Content-length: [string length $data]\n"
                chan configure $sock -translation crlf
                puts $sock $reply
                chan configure $sock -translation binary
                puts -nonewline $sock $data
            }
        } else {
            Respond $sock 404 "URL not found"
        }

        return;
    }

     
    ###########################################################################
    #
    # Private Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PRIVATE<<
    #
    # Procedure Name : Accept
    #
    # Description : Accept an incoming connection.
    #
    # Arguments :
    #       port        -- Port number
    #       sock        -- Incoming socket
    #       ip          -- Requester's IP address
    #       clientport  -- Requester's port number
    #
    # Returns :
    #       Nothing
    #
    # Side-Effects : None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : None
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PRIVATE<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #   2.3.0  10/31/2012  G.Lester     Bug fix [66fb3aeef5] -- correct header parsing
    #
    #
    ###########################################################################
    proc Accept {port sock ip clientport} {
        variable portInfo

        upvar #0 Httpd$sock query

        array unset query reply
        chan configure $sock -translation crlf
        if {1 == [catch {
            gets $sock line
            set auth {}
            set request {}
            while {[gets $sock temp] > 0 && ![eof $sock]} {
                if {[regexp {^([^:]*):(.*)$} $temp -> key data]} {
                    dict set request header [string tolower $key] [string trim $data]
                }
            }
            if {[eof $sock]} {
                return
            }
            if {[dict exists $request header authorization]} {
                regexp -nocase {^basic +([^ ]+)$}\
                    [dict get $request header authorization] -> auth
            }
            if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} {
                return
            }
 
            switch -exact -- $method {
                POST {
                    ##
                    ## This is all broken and needs to be fixed
                    ##
                    set data ""
                    if {[dict exists $request header transfer-encoding]
                        && [dict get $request header transfer-encoding] eq "chunked"} {
                        # Receive chunked request body.
                        while {[scan [gets $sock line] %x length] == 1 && $length > 0} {
                            chan configure $sock -translation binary
                            append data [read $sock $length]
                            chan configure $sock -translation crlf
                        }
                    } else {
                        # Receive non-chunked request body.
                        chan configure $sock -translation binary
                        set data [read $sock [dict get $request header content-length]]
                        chan configure $sock -translation crlf
                    }
                    array set query [uri::split $url]
                    #set query(query) $data
                    set query(headers) $request
                    set query(ipaddr) $ip
		    set result {}
		    foreach pair [split $data "&"] {
			foreach {name value} [split $pair "="] {
			    lappend result [Url_Decode $name] [Url_Decode $value]
			}
		    }
		    set query(query) $result
                    Handler $port $sock $ip [array get query] $auth
                }
                default {
                    Respond $sock 501 "Method not implemented"
                }
            }
        } msg]} {
            # catch this against an eventual closed socket
            catch {Respond $sock 500 "Server Error"}
        }

        catch {flush $sock}
        catch {close $sock}
        return
    }

    proc Url_Decode {data} {
	regsub -all {\+} $data " " data
	regsub -all {([][$\\])} $data {\\\1} data
	regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data  {[format %c 0x\1]} data
	return [subst $data]
    }


    namespace export addHandler listen
    namespace ensemble create
}

proc HandleRequest {socket requestArrName} {
    upvar 1 $requestArrName requestArr
    set replyDict [dict create type text/plain data {}]
    dict set replyDict code 200
    if {[dict exists $requestArr(query) COMMAND]} {
        set cmd [dict get $requestArr(query) COMMAND]
        switch -exact -- $cmd {
            LIST {
                dict set replyDict data [GetFileList]
            }
            GET {
                if {![dict exists $requestArr(query) FILE]} {
                   return -code error {Missing file name in GET request.}
                } else {
                    set fileName [dict get $requestArr(query) FILE]
                }
                dict set replyDict data [GetFile $fileName]
            }
            default {
                return -code error [format {Unkown command: %s} $cmd]
            }
        }
    }

    set requestArr(reply) $replyDict
    return;
}

proc GetFileList {} {
    set results [list]
    foreach file [glob -nocomplain *.tcl] {
        lappend results $file [file mtime $file]
    }
    return $results
}

proc GetFile {fileName} {
    set ifd [open $fileName r]
    set data [read $ifd]
    close $ifd
    return $data
}

proc Broadcast {} {
    global afterId
    global port
    global udpSocket

    after cancel $afterId
    set afterId [after 5000 Broadcast]
    puts -nonewline $udpSocket [dict create port $port]
}

lassign $argv baseDir port

if {$baseDir ne {}} {
   cd $baseDir
}

if {$port eq {}} {
    set port 8080
}

httpd addHandler $port /ScriptSever HandleRequest
httpd listen $port

set group 224.5.1.21
set port  7771
set udpSocket [udp_open $port]
fconfigure $udpSocket -buffering none -blocking 0
fconfigure $udpSocket -mcastadd $group -remote [list $group $port]
set afterId [after 5000 Broadcast]


set forever 0
vwait forever

Added ServeScripts_Copy.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
#!/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" ${1+"$@"}

###############################################################################
##                                                                           ##
##  Copyright (c) 2015, Gerald W. Lester                                     ##
##  All rights reserved.                                                     ##
##                                                                           ##
##  Redistribution and use in source and binary forms, with or without       ##
##  modification, are permitted provided that the following conditions       ##
##  are met:                                                                 ##
##                                                                           ##
##    * Redistributions of source code must retain the above copyright       ##
##      notice, this list of conditions and the following disclaimer.        ##
##    * Redistributions in binary form must reproduce the above              ##
##      copyright notice, this list of conditions and the following          ##
##      disclaimer in the documentation and/or other materials provided      ##
##      with the distribution.                                               ##
##    * Neither the name of the Visiprise Software, Inc nor the names        ##
##      of its contributors may be used to endorse or promote products       ##
##      derived from this software without specific prior written            ##
##      permission.                                                          ##
##                                                                           ##
##  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS      ##
##  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT        ##
##  LIMITED  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS       ##
##  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE           ##
##  COPYRIGHT OWNER OR  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,     ##
##  INCIDENTAL, SPECIAL,  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,    ##
##  BUT NOT LIMITED TO,  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;        ##
##  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER         ##
##  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT       ##
##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
##  POSSIBILITY OF SUCH DAMAGE.                                              ##
##                                                                           ##
###############################################################################

package require Tcl 8.6
package require uri
package require base64
package require html
package require udp

namespace eval httpd {
    array set portInfo {}

    set portList [list]

    variable returnCodeText [dict create \
                                200 OK \
                                404 "Not Found" \
                                500 "Internal Server Error" \
                                501 "Not Implemented" \
                            ]

    ###########################################################################
    #
    # Public Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PUBLIC<<
    #
    # Procedure Name : addHandler
    #
    # Description : Register a handler for a url on a port.
    #
    # Arguments :
    #       port     -- The port to register the callback on
    #       url      -- The URL to register the callback for
    #       callback -- The callback prefix, two additionally arguments are lappended
    #                   the callback: (1) the socket (2) the null string
    #
    # Returns :     Nothing
    #
    # Side-Effects :
    #       None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : Listen must have been called for the port
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PUBLIC<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #
    #
    ###########################################################################
    proc addHandler {port url callback} {
        variable portInfo

        dict set portInfo($port,handlers) $url $callback
        return;
    }

    ###########################################################################
    #
    # Public Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PUBLIC<<
    #
    # Procedure Name : listen
    #
    # Description : Instruct the module to listen on a Port, security information.
    #
    # Arguments :
    #       port     -- Port number to listen on
    #       certfile -- Name of the certificate file
    #       keyfile  -- Name of the key file
    #       userpwds -- A list of username:password
    #       realm    -- The security realm
    #
    # Returns :     socket handle
    #
    # Side-Effects :
    #       None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : Listen must have been called for the port
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PUBLIC<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #
    #
    ###########################################################################
    proc listen {port {certfile {}} {keyfile {}} {userpwds {}} {realm {}}} {
        variable portInfo
        variable portList

        lappend portList $port
        foreach key {port certfile keyfile userpwds realm} {
            set portInfo($port,$key) [set $key]
        }
        if {![info exists portInfo($port,handlers)]} {
            set portInfo($port,handlers) {}
        }
        foreach up $userpwds {
            lappend portInfo($port,auths) [base64::encode $up]
        }

        set handle [socket -server [list [namespace current]::Accept $port] $port]

        return $handle
    }

    ###########################################################################
    #
    # Private Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PRIVATE<<
    #
    # Procedure Name : Respond
    #
    # Description : Send response back to user.
    #
    # Arguments :
    #       sock -- Socket to send reply on
    #       code -- Code to send
    #       body -- HTML body to send
    #       head -- Additional HTML headers to send
    #
    # Returns :
    #       Nothing
    #
    # Side-Effects : None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : None
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PRIVATE<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #   2.3.0  11/06/2012  H.Oehlmann   Separate head and body,
    #                                   correct Content-length
    #
    #
    ###########################################################################
    proc Respond {sock code body {head ""}} {
        set body [encoding convertto iso8859-1 $body\r\n]
        chan configure $sock -translation crlf
        puts $sock "[HttpReturnCode $code]\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]"
        if {"" ne $head} {
            puts -nonewline $sock $head
        }
        # Separator head and body
        puts $sock ""
        chan configure $sock -translation binary
        puts -nonewline $sock $body
    }

    ###########################################################################
    #
    # Private Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PRIVATE<<
    #
    # Procedure Name : HttpReturnCode
    #
    # Description : Format the first line of a http return including the status code
    #
    # Arguments :
    #       code -- numerical http return code
    #
    # Returns :
    #       Nothing
    #
    # Side-Effects : None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : None
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PRIVATE<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  10/05/2012  H.Oehlmann   Initial version
    #
    #
    ###########################################################################
    proc HttpReturnCode {code} {
        variable returnCodeText
        if {[dict exist $returnCodeText $code]} {
            set textCode [dict get $returnCodeText $code]
        } else {
            set textCode "???"
        }
        return "HTTP/1.0 $code $textCode"
    }

    ###########################################################################
    #
    # Private Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PRIVATE<<
    #
    # Procedure Name : CheckAuth
    #
    # Description : Check to see if the user is allowed.
    #
    # Arguments :
    #       port -- Port number
    #       sock -- Incoming socket
    #       ip   -- Requester's IP address
    #       auth -- Authentication information
    #
    # Returns :
    #       Nothing
    #
    # Side-Effects : None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : None
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PRIVATE<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #
    #
    ###########################################################################
    proc CheckAuth {port sock ip auth} {
        variable portInfo

        if {[info exists portInfo($port,auths)] && [llength $portInfo($port,auths)] && [lsearch -exact $portInfo($port,auths) $auth]==-1} {
            set realm $portInfo($port,realm)
            Respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n"
            return -code error
        }
    }

    ###########################################################################
    #
    # Private Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PRIVATE<<
    #
    # Procedure Name : Handler
    #
    # Description : Handle a request.
    #
    # Arguments :
    #       port        -- Port number
    #       sock        -- Incoming socket
    #       ip          -- Requester's IP address
    #       reqstring   -- Requester's message
    #       auth        -- Authentication information
    #
    # Returns :
    #       Nothing
    #
    # Side-Effects : None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : None
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PRIVATE<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #   2.3.0  10/31/2012  G.Lester     bug fix for [68310fe3bd] -- correct encoding and data length
    #
    #
    ###########################################################################
    proc Handler {port sock ip reqstring auth} {
        variable portInfo
        upvar #0 Httpd$sock req

        if {[catch {CheckAuth $port $sock $ip $auth}]} {
            return
        }

        array set req $reqstring
        #foreach var {type data code} {
        #    dict set req(reply) $var [set $var]
        #}
        set path "/[string trim $req(path) /]"
        if {[dict exists $portInfo($port,handlers) $path]} {
            set cmd [dict get $portInfo($port,handlers) $path]
            lappend cmd $sock req
            if {[catch {eval $cmd} msg]} {
                Respond $sock 404 "Error: $msg"
            } else {
                set type [dict get $req(reply) type]
                set encoding [string tolower [lindex [split [lindex [split $type {;}] 1] {=}] 1]]
                if {$encoding ni [encoding names]} {
                    set encoding utf-8
                    set type "[lindex [split $type ";"] 0]; charset=UTF-8"
                }
                set data [encoding convertto $encoding [dict get $req(reply) data]]
                set reply "[HttpReturnCode [dict get $req(reply) code]]\n"
                append reply "Content-Type: $type\n"
                append reply "Connection: close\n"
                append reply "Content-length: [string length $data]\n"
                chan configure $sock -translation crlf
                puts $sock $reply
                chan configure $sock -translation binary
                puts -nonewline $sock $data
            }
        } else {
            Respond $sock 404 "URL not found"
        }

        return;
    }

     
    ###########################################################################
    #
    # Private Procedure Header - as this procedure is modified, please be sure
    #                            that you update this header block. Thanks.
    #
    #>>BEGIN PRIVATE<<
    #
    # Procedure Name : Accept
    #
    # Description : Accept an incoming connection.
    #
    # Arguments :
    #       port        -- Port number
    #       sock        -- Incoming socket
    #       ip          -- Requester's IP address
    #       clientport  -- Requester's port number
    #
    # Returns :
    #       Nothing
    #
    # Side-Effects : None
    #
    # Exception Conditions : None
    #
    # Pre-requisite Conditions : None
    #
    # Original Author : Gerald W. Lester
    #
    #>>END PRIVATE<<
    #
    # Maintenance History - as this file is modified, please be sure that you
    #                       update this segment of the file header block by
    #                       adding a complete entry at the bottom of the list.
    #
    # Version     Date     Programmer   Comments / Changes / Reasons
    # -------  ----------  ----------   -------------------------------------------
    #       1  03/28/2008  G.Lester     Initial version
    #   2.3.0  10/31/2012  G.Lester     Bug fix [66fb3aeef5] -- correct header parsing
    #
    #
    ###########################################################################
    proc Accept {port sock ip clientport} {
        variable portInfo

        upvar #0 Httpd$sock query

        array unset query reply
        chan configure $sock -translation crlf
        if {1 == [catch {
            gets $sock line
            set auth {}
            set request {}
            while {[gets $sock temp] > 0 && ![eof $sock]} {
                if {[regexp {^([^:]*):(.*)$} $temp -> key data]} {
                    dict set request header [string tolower $key] [string trim $data]
                }
            }
            if {[eof $sock]} {
                return
            }
            if {[dict exists $request header authorization]} {
                regexp -nocase {^basic +([^ ]+)$}\
                    [dict get $request header authorization] -> auth
            }
            if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} {
                return
            }

            switch -exact -- $method {
                POST {
                    ##
                    ## This is all broken and needs to be fixed
                    ##
                    set data ""
                    if {[dict exists $request header transfer-encoding]
                        && [dict get $request header transfer-encoding] eq "chunked"} {
                        # Receive chunked request body.
                        while {[scan [gets $sock line] %x length] == 1 && $length > 0} {
                            chan configure $sock -translation binary
                            append data [read $sock $length]
                            chan configure $sock -translation crlf
                        }
                    } else {
                        # Receive non-chunked request body.
                        chan configure $sock -translation binary
                        set data [read $sock [dict get $request header content-length]]
                        chan configure $sock -translation crlf
                    }
                    array set query [uri::split $url]
                    #set query(query) $data
                    set query(headers) $request
                    set query(ipaddr) $ip
		    set result {}
		    foreach pair [split $data "&"] {
			foreach {name value} [split $pair "="] {
			    lappend result [Url_Decode $name] [Url_Decode $value]
			}
		    }
		    set query(query) $result
                    Handler $port $sock $ip [array get query] $auth
                }
                default {
                    Respond $sock 501 "Method not implemented"
                }
            }
        } msg]} {
            # catch this against an eventual closed socket
            catch {Respond $sock 500 "Server Error"}
        }

        catch {flush $sock}
        catch {close $sock}
        return
    }

    proc Url_Decode {data} {
	regsub -all {\+} $data " " data
	regsub -all {([][$\\])} $data {\\\1} data
	regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data  {[format %c 0x\1]} data
	return [subst $data]
    }


    namespace export addHandler listen
    namespace ensemble create
}

proc HandleRequest {socket requestArrName} {
    upvar 1 $requestArrName requestArr
    set replyDict [dict create type text/plain data {}]
    dict set replyDict code 200
    if {[dict exists $requestArr(query) COMMAND]} {
        set cmd [dict get $requestArr(query) COMMAND]
        switch -exact -- $cmd {
            LIST {
                dict set replyDict data [GetFileList]
            }
            GET {
                if {![dict exists $requestArr(query) FILE]} {
                   return -code error {Missing file name in GET request.}
                } else {
                    set fileName [dict get $requestArr(query) FILE]
                }
                dict set replyDict data [GetFile $fileName]
            }
            default {
                return -code error [format {Unkown command: %s} $cmd]
            }
        }
    }

    set requestArr(reply) $replyDict
    return;
}

proc GetFileList {} {
    set results [list]
    foreach file [glob -nocomplain *.tcl] {
        lappend results $file [file mtime $file]
    }
    return $results
}

proc GetFile {fileName} {
    set ifd [open $fileName r]
    set data [read $ifd]
    close $ifd
    return $data
}

proc Broadcast {} {
    global afterId
    global port
    global udpSocket

    after cancel $afterId
    set afterId [after 5000 Broadcast]
    puts -nonewline $udpSocket [dict create port $port]
}

lassign $argv baseDir port

if {$baseDir ne {}} {
   cd $baseDir
}

if {$port eq {}} {
    set port 8080
}

httpd addHandler $port /ScriptSever HandleRequest
httpd listen $port

#set group 224.5.1.21
#set port  7761
#set udpSocket [udp_open $port]
#fconfigure $udpSocket -buffering none -blocking 0
#fconfigure $udpSocket -mcastadd $group -remote [list $group $port]
#set afterId [after 5000 Broadcast]


set forever 0
vwait forever

Added TkGems.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"
#################################################################
 #
 # GemGame -- based on a game by Derek Ramey and others
 # by Keith Vetter -- May 2003
 #
 # Also known as Elf balls, Santa Balls and Santa Balls 2
 # http://www.afunzone.com/Kewel/santaballs.htm
 # Flip the Mix w/ M&M's: http://www.afunzone.com/mm.htm
 # Carnival Jackpot (hex): http://www.afunzone.com/Kewel/CarnJackpot.htm
 #
 # See http://javaboutique.internet.com/GemGame/
 #
 # 2003/06/12: zoom, robot on key, 8th jewel, resizable via console
 # 2003/06/13: timer levels
 # 2003/06/24: mute and pause
 # 2005-05-25: pause-button; Keys: "S": ShowStats, "H": Hint; Console-Message
 # 2005-05-26: Select number of jewels, re-arranged jewel-colors and buttons
 # 2005-05-28: System-Menu to set cols, rows, jewels
 # 2005-05-31: Options-Menu: set cols, rows, jewels, level, mute, stats
 # 2005-06-01: Center pause + gameover-messages on all playfield-sizes
 #
 # Bugs:
 # * Timer increments while paused
 # * Resize+Robot: while paused & after game-over
 # Todo:
 # * Support for Keyboard (Cursor-Keys)
 # * Highscore
 # * Profile: Save/Load Options
 # * Robot/Sortkey: calc. number of exploding gems for move --> optimize play
 # * Random seed --> Robot-Benchmark
 # * detect "triple play" in either direction
 # * "Last chance" - prompt for "triple play" before gameover

 package require Tk 8.3

 array set S {title "Gem Game" version 1.5.7 cols 10 rows 10 cell 30 jewels 7}
 set S(w) [expr {$S(cell) * $S(cols) + 10}]
 set S(h) [expr {$S(cell) * $S(rows) + 10}]
 set S(delay) 10
 set S(mute) 0
 set S(lvl) 2
 #set S(strlvl) "Level 2"
 #set S(strjew) "7 Jewels"
 # old - 2: Blue,Green 3:Yellow 4:Red 5:White 6:Cyan 7:Magenta 8:Grey
 # new -       ...     3:Red 4:White 5:Yellow ...
 array set S {lvl,1 0 lvl,2 180 lvl,3 90 lvl,4 60 lvl,5 30}

 proc DoDisplay {} {
    wm title . $::S(title)
    CompressImages

    option add *Label.background black
    frame .ctrl -relief ridge -bd 2 -bg black
    canvas .c   -relief ridge       -bg black -height $::S(h) -width $::S(w) \
        -highlightthickness 0 -bd 2 -relief raised

    label .score -text Score: -fg white
    .score configure  -font "[font actual [.score cget -font]] -weight bold"
    option add *font [.score cget -font]

    label .vscore  -textvariable S(score)  -fg yellow
    label .vscore2 -textvariable S(score2) -fg yellow
    label .ltimer  -text Time: -fg white
    label .timer   -textvariable S(timer)  -fg yellow

    button .new -text "New Game" -underline 0 -command NewGame
 #  tk_optionMenu .optlvl S(strlvl) "Level 1" "Level 2" "Level 3" "Level 4" "Level 5"
 #  .optlvl config -highlightthickness 0
 #  trace variable ::S(strlvl) w Tracer
    button .opt -text "Options"  -command {OptMenu .}

 #  tk_optionMenu .optjew S(strjew) "3 Jewels" "4 Jewels" "5 Jewels" "6 Jewels" "7 Jewels" "8 Jewels"
 #  .optjew config -highlightthickness 0
 #  trace variable ::S(strjew) w Tracer

    button      .hint  -text "Hint"       -underline 0 -command Hint
    bind .c <Button-3> {Hint 2}
    bind .c <h>         Hint
    bind .c <H>         Hint
 #  button      .bstat -text "Statistics" -underline 0 -command ShowStats
    button      .pause -text "Pause"      -underline 0 -command Pause
    button      .about -text "About"      -command About
 #  checkbutton .mute  -text "Mute"       -variable S(mute)
    bind .c <M>         Mute
    bind .c <m>         Mute

    pack .ctrl -side left -fill y    -ipady 5 -ipadx 5
    pack .c    -side top  -fill both -expand 1

    grid .score   -in .ctrl -sticky ew -row 1
    grid .vscore  -in .ctrl -sticky ew
    grid .vscore2 -in .ctrl -sticky ew
    grid .ltimer  -in .ctrl -sticky ew
    grid .timer   -in .ctrl -sticky ew

    grid rowconfigure .ctrl 20 -minsize 10
    grid .opt     -in .ctrl -sticky ew -row 25 -pady 1
    grid .new     -in .ctrl -sticky ew         -pady 1
 ## grid .optlvl  -in .ctrl -sticky ew -pady 1
 #  grid .optjew  -in .ctrl -sticky ew -pady 1

 ## grid .mute    -in .ctrl -sticky ew -pady 1
 ## grid .bstat   -in .ctrl -sticky ew -pady 1

    grid rowconfigure .ctrl 40 -weight 1
    grid .pause   -in .ctrl -sticky ew -row 45 -pady 1
    grid .hint    -in .ctrl -sticky ew         -pady 1

    grid rowconfigure .ctrl 60 -weight 4
    grid .about   -in .ctrl -row 100 -sticky ew -pady 5

    bind all <F2> {console show; puts "GemGame-Console:"; \
         puts -nonewline "set S(jewels) "; puts $S(jewels); \
         puts -nonewline "set S(rows) ";   puts $S(rows); \
         puts -nonewline "set S(cols) ";   puts $S(cols) }
    bind .c <R> Robot
    bind .c <r> {Robot 10}
    bind .c <x> {Robot  1} ;#debug
    bind .c <z> Resize
    bind .c <n> NewGame
    bind .c <N> NewGame
    bind .c <p> Pause
    bind .c <P> Pause
    bind .c <s> ShowStats
    bind .c <S> ShowStats
    focus .c
 }

 proc OptMenu w {
    destroy .m
    menu .m        -tearoff 0
    menu .m.cols   -tearoff 0
    menu .m.rows   -tearoff 0
    menu .m.jewels -tearoff 0
    menu .m.level  -tearoff 0
    for {set i 6} {$i <= 16} {incr i} {
      .m.cols   add radiobutton -label $i -value $i -variable S(cols)   -command {NewGame}
      .m.rows   add radiobutton -label $i -value $i -variable S(rows)   -command {NewGame}
    }
    for {set i 3} {$i <= 8} {incr i} {
      .m.jewels add radiobutton -label $i -value $i -variable S(jewels) -command {NewGame}
    }
    for {set i 1} {$i <= 5} {incr i} {
      .m.level  add radiobutton -label $i -value $i -variable S(lvl)    -command {NewGame}
    }
   .m add cascade     -label "Cols"       -menu .m.cols
   .m add cascade     -label "Rows"       -menu .m.rows
   .m add cascade     -label "Jewels"     -menu .m.jewels
   .m add cascade     -label "Level"      -menu .m.level
   .m add separator
   .m add checkbutton -label "Mute"       -underline 0 -variable S(mute)
   .m add command     -label "Statistics" -underline 0 -command ShowStats
    tk_popup .m [winfo pointerx $w] [winfo pointery $w]  ;# pos. of cursor
  # tk_popup .m [winfo rootx $w] [winfo rooty $w]        ;# upper left corner
 }

 proc CompressImages {} {
    image create photo ::img::img(0)            ;# Blank image
    foreach id {1 2 3 4 5 6 7 8} {
        foreach a {2 3 4} {                     ;# We need narrower images
            image create photo ::img::img($id,$a)
            if {$a == 4} continue
            ::img::img($id,$a) copy ::img::img($id) -subsample $a $a
        }
    }
 }
 #proc Tracer {var1 var2 op} {
 #   if {$var2 == "strlvl"} {
 #       scan $::S(strlvl) "Level %d" lvl
 #       if {$lvl != $::S(lvl)} NewGame
 #       return
 #   }
 #   if {$var2 == "strjew"} {
 #       scan $::S(strjew) "%d Jewels" jew
 #       if {$jew != $::S(jewels)} NewGame
 #       return
 #   }
 #}
 proc NewGame {} {
    Timer off
  # scan $::S(strlvl) "Level %d"  ::S(lvl)
  # scan $::S(strjew) "%d Jewels" ::S(jewels)
    array set ::S {
        score 0 score2 "" busy 0 click {} click1 {} click2 {} pause 0
        cnt 0 time 00:00 sturn 0 tmin 0 best 0 robot 0 tbonus 0 tpause 0
    }
    set ::S(timer) $::S(lvl,$::S(lvl))

    if {$::S(lvl) > 1} {
        .hint   config -state disabled
        .ltimer config -fg white
        .timer  config -fg yellow
    } else {
        .hint   config -state normal
        .ltimer config -fg black
        .timer  config -fg black
    }
    .c delete all
    for {set row -2} {$row < $::S(rows)+2} {incr row} { ;# Initialize the board
        for {set col -2} {$col < $::S(cols)+2} {incr col} {
            set ::B($row,$col) -1
            if {$row < 0 || $row >= $::S(rows)} continue
            if {$col < 0 || $col >= $::S(cols)} continue
            set ::B($row,$col) [expr {1 + int(rand() * $::S(jewels))}]
            .c create image [GetXY $row $col] -tag "c$row,$col"
            .c bind "c$row,$col" <Button-1> [list DoClick $row $col]
        }
    }
    # Change all cells on initial board that would explode
    while {1} {
        set cells [FindExploders]
        if {$cells == {}} break
        foreach cell $cells {
            set ::B($cell) [expr {1 + int(rand() * $::S(jewels))}]
        }
    }
    DrawBoard 1
 }
 proc DrawBoard {{resize 0}} {
    global S

    if {$resize} {
        set S(w) [expr {$S(cell) * $S(cols) + 10}]
        set S(h) [expr {$S(cell) * $S(rows) + 10}]
        .c config -height $S(h) -width $S(w)
    }

    .c delete box
    for {set row 0} {$row < $::S(rows)} {incr row} {
        for {set col 0} {$col < $::S(cols)} {incr col} {
            if {$resize} {
                .c coords "c$row,$col" [GetXY $row $col]
            }
            .c itemconfig "c$row,$col" -image ::img::img($::B($row,$col))
        }
    }
    set ::S(legal) [llength [FindLegalMoves 0]]
 }
 proc GetXY {r c} {
    global S
    set x [expr {5 + $c * $S(cell) + $S(cell)/2}]
    set y [expr {5 + $r * $S(cell) + $S(cell)/2}]
    return [list $x $y]
 }
 proc DoClick {row col} {                       ;# Handles mouse clicks
    global S

    if {$S(busy)} return
    set S(busy) 1
    .c delete box

    if {$S(click) == {}} {                      ;# 1st click, draw the box
        set xy [.c bbox "c$row,$col"]
        .c create rect $xy -tag box -outline white -width 2
        set S(click) [list $row $col]
        set S(busy) 0
        if {$::S(timer) <= 0 && $::S(lvl) > 1} {
            GameOver "Out of time"
        }
        return
    }

    foreach {row1 col1} $S(click) break         ;# 2nd click, swap and explode
    set click [list [concat $S(click) $row $col]]
    set S(click) {}

    set dx [expr {abs($col - $col1)}]
    set dy [expr {abs($row - $row1)}]
    if {$dx <= 1 && $dy <= 1 && $dx != $dy} {   ;# Valid neighbors
        SwapCells $row $col $row1 $col1
        set n [Explode]
        if {$n} {                               ;# Something exploded
            set click {}                        ;# Clear for triple play
            incr S(cnt)
            incr S(tbonus) [expr {6 - $S(lvl)}] ;# Add to time bonus
        } else {                                ;# Nothing exploded
            # Check for triple click
            if {$click == $S(click1) && $click == $S(click2)} {
                # decrease score by 10%...
                set ten [expr {round($S(score) / -10.0)}]
                if {$ten > -100} { set ten -100}
                incr S(score) $ten
                set S(score2) "($ten)"
                set click {}
                if {! $S(mute)} {catch { snd_bad play; snd_ok play }}
                incr S(cnt)
            } else {
                if {! $S(mute)} {catch { snd_bad play }} ;# Nope, undo the move
                SwapCells $row1 $col1 $row $col
            }
        }
        set S(click2) $S(click1)
        set S(click1) $click
        if {! [Hint 1]} {                       ;# Is the game over???
            GameOver
        }
    }
    set S(legal) [llength [FindLegalMoves 0]]
    set S(busy) 0
    catch {
        set ::S(sturn) [format "%.1f" [expr {$::S(score) / double($::S(cnt))}]]
    }
    if {$::S(cnt) == 1} {Timer start}
    if {$::S(timer) <= 0 && $::S(lvl) > 1} {
        GameOver "Out of time"
    }

 }
 proc SlideCells {cells} {                       ;# Slides some cells down
    foreach {r c} $cells {
        .c itemconfig c$r,$c -image {}
        if {[info exists ::B($r,$c)] && $::B($r,$c) != -1} {
            set M($r,$c) $::B($r,$c)
        } else {
            set M($r,$c) [expr {1 + int(rand() * $::S(jewels))}]
        }
        .c create image [GetXY $r $c] -image ::img::img($M($r,$c)) -tag slider
    }
    set numSteps 8
    set dy [expr {double($::S(cell)) / $numSteps}]
    for {set step 0} {$step < $numSteps} {incr step} {
        .c move slider 0 $dy
        update
        after $::S(delay)
    }
    foreach {r c} $cells {                      ;# Update board data
        set ::B([expr {$r+1}],$c) $M($r,$c)
    }
    DrawBoard
    .c delete slider
 }
 proc SwapCells {r1 c1 r2 c2} {
    global B

    .c itemconfig c$r1,$c1 -image {}
    .c itemconfig c$r2,$c2 -image {}
    foreach {x1 y1} [GetXY $r1 $c1] break
    foreach {x2 y2} [GetXY $r2 $c2] break
    .c create image $x1 $y1 -image ::img::img($B($r1,$c1)) -tag {slide1 slide}
    .c create image $x2 $y2 -image ::img::img($B($r2,$c2)) -tag {slide2 slide}

    set numSteps 8
    set dx  [expr {$x2 - $x1}]
    set dy  [expr {$y2 - $y1}]
    set dx1 [expr {double($dx) / $numSteps}]
    set dy1 [expr {double($dy) / $numSteps}]
    set dx2 [expr {-1 * $dx1}]
    set dy2 [expr {-1 * $dy1}]
    for {set step 0} {$step < $numSteps} {incr step} {
        .c move slide1 $dx1 $dy1
        .c move slide2 $dx2 $dy2
        update
        after $::S(delay)
    }
    .c delete slide
    foreach [list B($r1,$c1) B($r2,$c2)] [list $B($r2,$c2) $B($r1,$c1)] break
    DrawBoard
 }
 proc Explode {} {
    set cnt 0
    while {1} {
        set cells [FindExploders]               ;# Find who should explode
        if {$cells == {}} break                 ;# Nobody, we're done
        incr cnt [llength $cells]
        if {! $::S(mute)} {catch { snd_ok play }}
        ExplodeCells $cells                     ;# Do the explosion affect
        CollapseCells                           ;# Move cells down
    }

    set n [expr {$cnt * $cnt}]
    incr ::S(score) $n
    set ::S(score2) ""                          ;# Show special scores
    if {$cnt > 3} {set ::S(score2) "([expr {$cnt*$cnt}])"}
    if {$n > $::S(best)}  {set ::S(best) $n }
    return [expr {$cnt > 0 ? 1 : 0}]
 }
 proc CollapseCells {} {
    while {1} {                                 ;# Stop nothing slides down
        set sliders {}
        for {set col 0} {$col < $::S(cols)} {incr col} {
            set collapse 0
            for {set row [expr {$::S(rows)-1}]} {$row >= 0} {incr row -1} {
                if {$collapse || $::B($row,$col) == 0} {
                    lappend sliders [expr {$row-1}] $col
                    set collapse 1
                }
            }
        }
        if {$sliders == {}} break
        SlideCells $sliders
    }
 }
 proc ExplodeCells {cells} {
    foreach stage {2 3 4} {
        foreach who $cells {
            .c itemconfig c$who -image ::img::img($::B($who),$stage)
            if {$stage == 4} {set ::B($who) 0}
        }
        update
        after [expr {10 * $::S(delay)}]
    }
 }
 proc FindExploders {} {                         ;# Find all triplets and up
    global S B

    array set explode {}
    for {set row 0} {$row < $S(rows)} {incr row} {
        for {set col 0} {$col < $S(cols)} {incr col} {
            set me $B($row,$col)
            if {$me == 0} continue
            foreach {dr dc} {-1 0 1 0 0 -1 0 1} {
                set who [list $row $col]
                for {set len 1} {1} {incr len} {
                    set r [expr {$row + $len * $dr}]
                    set c [expr {$col + $len * $dc}]
                    if {$B($r,$c) != $me} break
                    lappend who $r $c
                }
                if {$len < 3} continue
                foreach {r c} $who {
                    set explode($r,$c) [list $r $c]
                }
            }
        }
    }
    return [array names explode]
 }
 # 0 => 1 hint, 1 => is game over, 2 => all hints
 proc Hint {{how 0}} {
    if {$how == 0} {
        if {$::S(pause) != 0} return
        incr ::S(score)   -50
        set  ::S(score2) (-50)
        if {$::S(cnt) > 0} {
            set ::S(sturn) [format "%.1f" [expr {$::S(score)/double($::S(cnt))}]]
        }
    }
    .c delete box
    set S(click) {}

    set hints [FindLegalMoves $how]
    set len [llength $hints]
    if {$how == 1} {return [expr {$len > 0 ? 1 : 0}]}
    if {$how == 0} {                            ;# Highlight only 1 hint
        set hints [list [lindex $hints [expr {int(rand() * $len)}]]]
    }

    foreach hint $hints {                       ;# Highlight every hint
        foreach {r c} $hint { .c addtag hint withtag c$r,$c }
        .c create rect [.c bbox hint] -outline white -width 3 -tag box
        .c dtag hint
    }
    return $hints
 }
 proc FindLegalMoves {how} {
    global S B

    set h {0 1 -1  2 0  2    0 1  1  2 0  2    0 2 -1  1  0 1   0 2  1  1  0 1
           0 1 -1 -1 0 -1    0 1  1 -1 0 -1    1 0  2  1  2 0   1 0  2 -1  2 0
           2 0  1 -1 1  0    2 0  1  1 1  0    1 0 -1 -1 -1 0   1 0 -1  1 -1 0
           0 1  0  3 0  2    0 1  0 -2 0 -1    1 0  3  0  2 0   1 0 -2  0 -1 0}

    set hints {}
    for {set row 0} {$row < $::S(rows)} {incr row} { ;# Test each cell
        for {set col 0} {$col < $::S(cols)} {incr col} {
            set me $B($row,$col)
            foreach {dr1 dc1 dr2 dc2 dr3 dc3} $h { ;# Check certain neighbors
                set r [expr {$row+$dr1}]; set c [expr {$col+$dc1}]
                if {$B($r,$c) != $me} continue
                set r [expr {$row+$dr2}]; set c [expr {$col+$dc2}]
                if {$B($r,$c) != $me} continue
                lappend hints [list $r $c [expr {$row+$dr3}] [expr {$col+$dc3}]]
                if {$how == 1} { return $hints }
            }
        }
    }
    return $hints
 }
 proc About {} {
    set msg "$::S(title) v$::S(version)\nby Keith Vetter, June 2003\n"
    append msg "Based on a program by Derek Ramey\n\n"
    append msg "Click on adjacent gems to swap them. If you get three or\n"
    append msg "more gems in a row or column, they will explode and those\n"
    append msg "above will drop down and new gems will fill in the top.\n"
    append msg "The game ends when you have no more moves.\n\n"

    append msg "The score for a move is the square of the number of cells\n"
    append msg "exploded. Asking for a hint costs 50 points.\n"
    append msg "If you are insistent and repeat an illegal move three times,\n"
    append msg "it will do it, but cost you 10% of your score.\n\n"

    append msg "Keyboard-shortcuts:\n"
    append msg "N: New Game\n"
    append msg "P: Pause\n"
    append msg "H: Hint\n"
    append msg "M: Mute: Sound on/off\n"
    append msg "S: Statistics on/off\n"
    append msg "z: Resize \n"

    tk_messageBox -message $msg -title "About"
 }
 proc GameOver {{txt "Game Over"}} {
    .c create rect 0 0 [winfo width .c] [winfo height .c] \
        -fill white -stipple gray25
    set x [expr {[winfo width  .c] / 2}]
    set y [expr {[winfo height .c] / 2}]
  # .c create text [GetXY 4 5] -text $txt -font {Helvetica 28 bold}
    .c create text $x $y -text $txt -font {Helvetica 28 bold} \
        -fill white -tag over
    .c delete box
    .hint  config -state disabled
    .pause config -state disabled
    Timer off
    ShowStats 1
 }
 proc DoSounds {} {
    proc snd_ok  {play} {}                      ;# Stub
    proc snd_bad {play} {}                      ;# Stub
    if {[catch {package require base64}]} return
    if {[catch {package require snack}]}  return

    set s(ok) {UklGRkACAABXQVZFZm10IBAAAAABAAEAESsAABErAAABAAgAZGF0YRwCAACAgId0Z
        HZbU5aMj7/MsIZ6UX6nWIiITWiIRUGUlZesvrGCiKiKTl96Fit3YF5emrGHqcqhlJuAdWxgW
        01EbWSHubW1uJ2MkqGPYFVSamtvgHmEh5ybraWLkHp5Xm5oWGRvb3WSlYqMi4+JhY6Ac25xd
        Xp5jYR/hoODdIN8e356goCHgoqGgIV/g35/d3N2eHZ6gIOIgouHioaNioGAfHpycHp2dH2Hi
        ouNiYiKhIF9enZzd3l+dX2BgYKIjoaJhIJ/fX6AfHl8fICAgICEgISFhYF/gH+AfIJ/gH6Af
        X6AfICAfYB+gn2DfoGAgIOAgYB8e3x9gIKChYCDgIN/g32Afn+BgIF+gH+BgIOAgX2CfYGAg
        IB/gH9/fIB/gICBgH+Df4KAgIB9gHuBfYKAgoCAhICDgIN+gH+Af4CAgIGAg4CFgIOAgICAg
        H9/f32AfoF/gn+BgICAf4B/gICAgICAgIKAgYCAgH+AfYB8f4CAgoGBgIKBgHt0cnqEi4yIh
        oKHioOBeoF+gHRvbW10eYSHhoyMmI+PhIF5dm9tbW92fICJjpKRkY6JhHx5b2xlbnWAhYeOj
        pSQkIiAe3R1cnNzdnx/gomLj4yJhICAfHp3d3d6fYKDhoKGgIeAhX1/eXt9foCAg4GCg4CDf
        YF6gHmAfYCBgIR/h4CEf4B9fn98gHuEfYV/g4CAgn6Fe4R6gn1/gHuDe4V+g4CAgn8=}
    set s(bad) {UklGRrEHAABXQVZFZm10IBAAAAABAAEAESsAABErAAABAAgAZGF0YY0HAAB/f39/
        gICAgICAgICAf39/fn9/f4CAgICAf3+AgICBgYGBf359fX5/gIGChISEgX14dXZ6f4OFiIuM
        iYB2bm52foSHio+Sk4x+bWBXY3mHjY2NlZqSg3NtcXp6eHd5goqLiY6Nf2tqeIKLnLGrhmJC
        OWF8h4+xvJJ3WTJTeX6Eja+/mH1qUE5lfoKIlsK6h3tbL2l/go28xIR9Qz15gIq9w31+Qjp2
        f4a0y4yBbkM9b3mDls6zgnY3Q3d5goWSp8yxjoF4VRlVc3iHvdGGhVYlWnt6o9irf4NAKmh2
        fpnYuYOLRytleX2w2KKGg0cpYnZ9sdaiiXc7Qmx0jsbAknUvT32Dw7uhhXo+NGF1g7LPpoqE
        Wj9GYXV+jK3gq4+FVihab3uJv9OWjXdEMmJxjqGsr4xqXm96iH1zflphcoqyv4xvaVNpiZSA
        f4qCgIiloJh+TFRja259nbiphnxnbGJfdpKXmaKPbl1fX26JnKOYe3BiaXqMinyHgn18fYeA
        e29xiot2fYiIi4h7dn+Fl6eMamNmcYGFg5Gbjn56cHVzdYWXnpB+bmhgdIibqqWHbFpUYnGH
        m6igjXlrX1hohJWkjnd2e397en1/b2NufYKSoqqUe2hbVVtte5KjpKKhgmFaZ3B3f5GclYp/
        gnxyamdwgIyapaGOgXFdaHeBhYN9h5eMjImBfm1pfIJ/g46WiXx1cm92gYeKkZeNf3h7fGhb
        aHmAkamqnIt1X09Vb3+PoqSQhXFcYXGAhI+moYp2alZRbIKLm62tmHtkTk9hc4KVpKmehHBl
        Xmh4hI6TlpOMdmpnaHOBi5OUjoRwcG5tfIWLj5GPgXl8fXyChICDeWptd3qCiYyLjI2BfYJ9
        d3d3fIB/h4h+enh+g4OHhoKAeXV5gIOCgoOAfHd7gYeNj4+LgXNsam12foOMjYqLhoB+eXqD
        hYeMhHVtam55h4yNjYd/fH18fH6AgYGCgoWJhnxxbnR8g4uQjIN7eXt5e36AgYGEh4N8eXp+
        goSEg358e3l7gIGEh4WDgHl3eHqAhYeIhoJ7dnV3fYKEhoWDgHt8gYSGhX95dXV3fYSJiYWD
        fXl6e31+gYSEg4SCfXp4d3Z5gYmNjIh+c3F0e4OHiYuKhX56eHh5fYGDg4F/fn1/hYaDgX16
        eHl9gIOFh4mGgHx6d3Z6gYaJiIWCfXl4eXyBhIOBfn+Cg4SFg396dHJ0eoOLjouFgH57e36A
        gH58enp7fYCFioiFgX17ent9fH+Cg4F/fn+Af3+AgYODg4OBfnt4d3l8foGFiYmGg4F/e3h2
        d3uAhIaHhYJ+e3t+gIGChIOAfXp5eXt+gIOFhoOCg4F+fX19fXx8fX6AgYKDgX9/goOCgH58
        e3l5fICDhYaFg4B9fn9+fXx8fH6AgoSFhYKAfnp6e35/gYKDgoB/f3+AgIGCgICAgIGBfnp4
        eHyAhouNi4V8c29xeYGIjY2Gfnh1eHyBg4ODg4F+fX5+fXt7fYCEiImGgXx2dHd9g4eIh4WB
        fXp5e36ChoaDf3p4eXx+gYWGhYKAfXp7fH6Ag4SDf318fH1+gYSEgoB9fH1/goODgYB9e3t8
        gISIiIaAenZ2eX2Ch4qIhYB6d3h6foGFh4aDgH17ent9f4GCg4OCgX9+fX19fXx9gIKEhYSB
        fnt6enx/g4SDgYB/fn59fX1+gIGBgoOCf3x7fH1/gYODgH9/f39/gYGAf318e31/goOEhIJ/
        fHp6fYCDhYWDf3x6e32Ag4WFhIF+fHt8fX+AgYOEhIF/fHp6fYGEhYWDf3t6e32Ag4aGg397
        enp7foCCg4OCgH9+fn5+f4CBgYGAf359fX5+foGDhIWFgn57eHh6foKFhoSAfHp6fICEh4eD
        fnp4eHt/goSFhIF+fHx9gIKDgoF/fXx8fn+BgoKCgYCAf359foCAgYB/fn9/f4CBgYB+fn+A
        gYKCgX99fX1+gIGCgoGAfn18fX5/gYOEg4F+fHt7fX+Cg4OCgH58fHx+gIOEhIOBfnx7e31/
        gYOEhIKAfXx8fn+AgYGAf35+f3+BgoKBgH99fX5/gIGBgYB/fn1+f4GDg4OAfnx8fH6AgoOD
        gX59fX5/gYGBgIB/f3+AgYGBgH9+fn5/f4CAgICAgH9+fX5+gIGCgoF/fn19fX+AgoKCgYB/
        fn19foCBgoKAf359fn5/gIGBgIB/f39+fn5+f4CBgoKBgH9+fX1+gIGBgYGAgH9/fn9/f39/
        f3+AgICAgICAgIB/f39/f4CAgICAgICAgYCAf35+f39/gIGAgH9+fn5/gIGCgoB/fn1+fn+A
        gYGAf39/f3+AgICAgIB/f39/f3+AgICAgICAgH9/fn5/f4CAgIB/f39/gICAgIB/f35+fn9/
        gIGBgIB/f39/f39/f39/f39/f4CBgYGBgH9+fX1+gIGCgoGAfn5+fn+AgYGAf35+fn5/gIGB
        gYB/f35+f3+AgICAf39/f3+AgICAgH9/f39/gICAf39/f3+AgICAgICAf39/f3+AgICAgICA
        f39/f39/gICAgIB/f4CAgH9/f39/f3+AgICAgICAf39/f4CAgICA}
    foreach snd {ok bad} {
        regsub -all {\s} $s($snd) {} sdata            ;# Bug in base64 package
        sound snd_$snd
        snd_$snd data [::base64::decode $sdata]
    }
 }
 image create photo ::img::img(1) -data {
    R0lGODdhHgAeALMAAAAAAAAAyAAAKAAA6EhI2FBQ/xAQSBgQSDAw////////////////////////
    /////ywAAAAAHgAeAAAE/xDISau9OOvN+4RBhBDCCCEIQggshRAiAgRyyhCCCWGMEWAQhJRSCBEh
    BAjkBMLAI+cxUkAjpxBCQCBnCOHAImchIEAkpxSEQCBlGOHAIqc0EMk5DSEQSBlGOAQWOYuBSM5p
    SIFAyjDCgUXOQg5Eck5TCgRShhEOLHIWciCScxpSIJAyjHBgkVMeiOSchhQIpAwjHFjklAYiOach
    BAIpwwgHFjkLORDJOQ0hEEgZQjiwyEkIgEhOGQQhEEhpjDnHnHOMgUIaKaUUEMhJCDEBIjmDgEHO
    KSQEUpJCDERyShHgkHMEEQIEUpJCDERyShHgkHMEEwIEUpJCBERyShHgkIJzBBECBFKSQgxEckoR
    4JBzBBECBFKSQgxEckoT4JBzBBECBFKSQgxEckoR4JBzBBMCBFISQkSASM4gYJBzCgmBnMYIIYwR
    xggohDFCGCOEEBDICUIIYowxQoBBEEJKIUSMQSCQE5wAQhhjhAADKISUQgg55EAgpzwQyEmrvTjr
    zW8EADs=}
 image create photo ::img::img(2) -data {
    R0lGODdhHgAeAJEAAAAAABDgAGj/WP///ywAAAAAHgAeAAACzISPqcvtDyMi8YHkA8Un+EjxgeQD
    xSf4R/EDSD5Q/CD4QPEDSL4BxQ+CT/EDSL4BxQ+Cj6nLQPGB5BtQ/CD4QPGB5BtQ/CD4RvGB5APF
    D4J/FB9IPlD8IPhIsYHkA8Un+GgREQTKB4pN8PEoNpBsoNgEHzEigiCJAMUm+JgQEQRJBCKCQviY
    FhEESQQigkL4mBcRBEkgIgg+JkYEQRKICIKPmRFAMiIIPqZCAEmIIPiYahEEIYLgY+oFkBCCj6kq
    u7sAEeFj6nL7wxhJAQA7}
    image create photo ::img::img(5) -data {
    R0lGODdhHgAeAJEAAAAAAP//QOjwAODgACwAAAAAHgAeAAACxISPqctLgQg+pmYEQSL4mHoRFEiE
    4GMqRFACERGCj5kUG0g2wcc8ig8kn+BjAsUPIPlC8BEpvgHJN4KPRvEPSP4RfKT4CCQfCb5RfAwg
    +SgEn+KjAclHAwCg+HhA8vEIPqZuknw8oPl4AAAkHw1oPhrBJ/koQPNxCL6RfASajwQfSf4BzT+C
    j0byDWi+EXxEki9A84fgYwLJB5pP8DGPZAPNJviYKSIkbGYIPqaCCAmbIfiYeiKEjeBjagrQCB9T
    l9ufkQIAOw==}
 image create photo ::img::img(3) -data {
    R0lGODdhHgAeAJEAAAAAANAAAP8AAP84OCwAAAAAHgAeAAAC/4SPqcvtD0h8zAAh+CgCFB8TRAi+
    iQhQfEQQEYIPJBsoPh6ICInwSTZQfDQg2QQ7TESEwPgYICIEyCwijCRQfAQRAJIBABQbQODuCKZs
    AACKHwQfjeQLAADFN6D5BiTfAAAovgHNNyD5BgBA8Q1ovgHJNwAAim9A8w1IvgEAUHwDmm9A8g0A
    gOIb0HwDkm8AABTfgOYbkHwDAKD4BjTfgOQbAADFD4KPRvIFAIBiAwiQfAMBQCEYEWEiBMpHmAEg
    SAAAAQRJBEg+As0m+ECy4e4OaD7BJtlwdwc0n2CLiADJR4SZoRE+iAiQfESYGYJ/AiQfU2CG4J8A
    yccUGIKPqQK7BQA7}
 image create photo ::img::img(4) -data {
    R0lGODlhHgAeALMAAAAAAFyI/5zO/xtX/3qn/zx1/16T/zF5/2+V/wAwzT9w/6b5/wAduAA75SBg
    /424/yH5BAEAAAAALAAAAAAeAB4AAwT/EMhJq704601ZcyBYOAzDWYNYHGx7NKfUDEqxujjJJU5d
    BECD0HAgtkwZnmIJDAwJUILwiGHQFIFfAGFAEB4PgeAhZTkwg6sW4SWIF/CFoPyyfJbYLfsriMfn
    RkgTDXhMbF5vfnAPgR2FQAh6YYpxZEaOhVh7bn2UgAdnEwyPkGxglHCfB5h4pV5hnX+MRAWsTKVQ
    sLJQl6KZeYe5YmJgUrS2t3qvX8zGZhVXpMptUVwGAXUUhL+uwdZABwWCEqPcwIfo4AMX5ZkBCpGQ
    W00jVdGPeU1ANgowGff4gGCp0Y8DwF94HCSIkQBhIQcDxnHwALBHA38xKpTYWCKjx48gAytEAAA7}
 image create photo ::img::img(6) -data {
    R0lGODdhHgAeAJEAAAAAAIDw/xjo/1jo/ywAAAAAHgAeAAACv4SPqcvtD6OcjMTHI/iYIEDxMWAI
    PqKIAMU/mBmCj0ayCf7RbIKPJBto/gEOwTeSDTQfB5Lgk2yg+XiQAARQNtB8TEgAAiQCNB/T4IAA
    BAjQfEyEARoAEUDzMRUMCEgAzcdUMCAgIEDzMRECaACAiADNxzSIoAAAJBtoPiZQbAAAkg00Hw8o
    NsEn2UDzcYBiE3wj2UDzDyg2wUeSTfCPYhN8NBEBkn8QEQQfUYDko0AQfEwg+XgEH1OX2x9GORsp
    ADs=}
 image create photo ::img::img(7) -data {
    R0lGODlhHgAeALMAAAAAANtNyeId0/8A/wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAACH5BAAAAAAALAAAAAAeAB4AAwSWEMhJq703AMG7/8KGAUG5gegZWmWroty7Tm0tf/dc72Me
    SzvTYEgs5iYhXnFJlJEkMRdzOlCRNFYNlSpyvQDb7dX0DXNtZTNzjPWA1Us2tPOGN9FuuxFP19+9
    eX5VfDGCg4B9gnJZdXBdZFFCjnSQbFpmTliWklwpQEFkGDA6QZs2njQ2oDw4LCarpXQYGrCgIj24
    uQARADs=}
 image create photo ::img::img(8) -data {
    R0lGODlhHgAeALMAAAQCBATO/GSazDRmnJzO/KyqrDRmzHcAAMjAyNGz71/tEwB3AHg6AQEAABMA
    AAAAACH5BAEAAAAALAAAAAAeAB4AAwR5EMhJq704640L/1NBeOAmnmV2jmNqrbAbsl7s2gD+2YGk
    a7xAL0fjBIXDX+WITBYvzKYTtXxKr74npSDgkq5I36Aw7nS7ErCYTDJ708112XT+CuVt+huQHM9B
    Xmh4MoE1fnkphYcyW10GbIxLXX+RIZSVIZiam5wbEQA7}

 proc Robot {{cnt -1}} {
    global S

    if {$S(robot)} {                            ;# Already going
        set S(robot) 0
        return
    }
    set S(robot) 1
    .pause config -state disabled

    if {$cnt == -1} {
        foreach {delay S(delay)} [list $S(delay) 0] break
        foreach snd {ok bad} {                  ;# Disable sound
            rename snd_$snd org.snd_$snd
            proc snd_$snd {play} {}
        }
    }

    for {} {$cnt != 0} {incr cnt -1} {
        if {! $S(robot)} break
        set moves [FindLegalMoves 2]
        if {$moves == {}} break

        # Massage data by adding a sorting key
        set all {}
        foreach m $moves {
            foreach {r1 c1 r2 c2} $m break

            # Top most
            set mm [concat [expr {$r1 < $r2 ? $r1 : $r2}] $m]
            # Random
            #set mm [concat [expr {rand() * 10000}] $m]
            # Bottom most
            #set mm [concat [expr {$r1 > $r2 ? -$r1 : -$r2}] $m]
            lappend all $mm
        }
        set all [lsort -index 0 -integer $all]
        set move [lindex $all 0]

        foreach {. r1 c1 r2 c2} $move break
        DoClick $r1 $c1
        DoClick $r2 $c2
    }
    set S(robot) 0
    if {$cnt < 0} {
        set S(delay) $delay
        foreach snd {ok bad} {   ;# Re-Enable sound
            rename snd_$snd {}
            rename org.snd_$snd snd_$snd
        }
    }
    .pause config -state normal
 }

 proc Timer {{how go}} {
    global S
    foreach a [after info] { after cancel $a }

    if {$how == "off"} return
    if {$how == "start"} { set S(tstart) [clock seconds] }

    set sec [expr {[clock seconds] - $S(tstart)}]
    set pause 0
    if {$S(pause) != 0} {
        set pause [expr {[clock seconds] - $S(pause)}]
    }
    set sec [expr {$sec - $pause - $S(tpause)}]

    if {$sec < 3600} {
        set S(time) [clock format $sec -gmt 1 -format %M:%S]
    } else {
        set S(time) [clock format $sec -gmt 1 -format %H:%M:%S]
    }
    if {$sec > 0} {
        set S(tmin) [format "%.1f" [expr {60.0 * $S(cnt) / $sec}]]
    }
    set S(timer) [expr {$S(lvl,$S(lvl))-$sec+$S(tbonus)+$S(tpause)}]
    if {$S(timer) < 0} {set S(timer) 0}

    if {! $S(busy) && $S(timer) <= 0 && $S(lvl) > 1} {
        GameOver "Out of time"
        return
    }
    after 1000 Timer
 }

 proc Mute {} {
    global S
    if {$S(mute) == 0} {
      set S(mute) 1
    } else {
      set S(mute) 0
    }
 }
 proc Pause {} {
    global S

    if {$S(pause) == 0} {                       ;# Pause on
        if {$S(cnt) == 0} return                ;# Not started yet
        set S(pause) [clock seconds]
        .c create rect 0 0 [winfo width .c] [winfo height .c] \
            -fill black -tag pause
        set x [expr {[winfo width  .c] / 2}]
        set y [expr {[winfo height .c] / 2}]
      # .c create text [GetXY 4 5]         -font {Helvetica 28 bold}
        .c create text $x [expr {$y - 15}] -font {Helvetica 28 bold} \
            -fill white -tag pause -text "PAUSED" -justify center
      # .c create text [GetXY 6 5]         -font {Helvetica 12 bold}
        .c create text $x [expr {$y + 15}] -font {Helvetica 12 bold} \
            -fill white -tag pause -text "Press p to continue" -justify center
        .c delete box
    } else {                                    ;# Pause off
        incr S(tpause) [expr {[clock seconds] - $S(pause)}]
        set S(pause) 0
        .c delete pause
    }
 }
 proc ShowStats {{on 0}} {
    set w .stats

    if {[winfo exists $w]} {
        if {! $on} {destroy $w}
        return
    }
    toplevel $w -bg black
    wm title $w "$::S(title)"
    wm geom $w "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"

    label $w.title  -text "$::S(title) Statistics" -fg white -relief ridge
    label $w.lscore -text Score:                   -fg white
    label $w.vscore -textvariable S(score)         -fg yellow
    label $w.lturn  -text "Turns:"                 -fg white
    label $w.vturn  -textvariable S(cnt)           -fg yellow
    label $w.lsturn -text "Score/turn:"            -fg white
    label $w.vsturn -textvariable S(sturn)         -fg yellow
    label $w.lbest  -text "Best:"                  -fg white
    label $w.vbest  -textvariable S(best)          -fg yellow
    label $w.ltime  -text "Time:"                  -fg white
    label $w.vtime  -textvariable S(time)          -fg yellow
    label $w.ltmin  -text "Turns/minute:"          -fg white
    label $w.vtmin  -textvariable S(tmin)          -fg yellow
    label $w.lgood  -text "Legal Moves:"           -fg white
    label $w.vgood  -textvariable S(legal)         -fg yellow

    grid $w.title -
    grid $w.lscore $w.vscore
    grid $w.lturn  $w.vturn
    grid $w.lsturn $w.vsturn
    grid $w.lbest  $w.vbest
    grid $w.ltime  $w.vtime
    grid $w.ltmin  $w.vtmin
    grid $w.lgood  $w.vgood
 }
 proc Resize {} {
    if {[lsearch [image names] ::img::img(1).org] == -1} {
        foreach id {1 2 3 4 5 6 7 8} {
            image create photo ::img::img($id).org
            ::img::img($id).org copy ::img::img($id)
        }
    }
    set zoom [expr {$::S(cell) == 30 ? 2 : 1}]
    foreach id {1 2 3 4 5 6 7 8} {
        image delete ::img::img($id)            ;# For easier resizing
        image create photo ::img::img($id)
        ::img::img($id) copy ::img::img($id).org -zoom $zoom
    }
    CompressImages
    set ::S(cell) [image width ::img::img(1)]
    DrawBoard 1
 }

 DoDisplay
 DoSounds
 NewGame

Added WebViewServer.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
###############################################################################
##                                                                           ##
##  Copyright (c) 2008, Gerald W. Lester                                     ##
##  All rights reserved.                                                     ##
##                                                                           ##
##  Redistribution and use in source and binary forms, with or without       ##
##  modification, are permitted provided that the following conditions       ##
##  are met:                                                                 ##
##                                                                           ##
##    * Redistributions of source code must retain the above copyright       ##
##      notice, this list of conditions and the following disclaimer.        ##
##    * Redistributions in binary form must reproduce the above              ##
##      copyright notice, this list of conditions and the following          ##
##      disclaimer in the documentation and/or other materials provided      ##
##      with the distribution.                                               ##
##    * Neither the name of the Visiprise Software, Inc nor the names        ##
##      of its contributors may be used to endorse or promote products       ##
##      derived from this software without specific prior written            ##
##      permission.                                                          ##
##                                                                           ##
##  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS      ##
##  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT        ##
##  LIMITED  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS       ##
##  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE           ##
##  COPYRIGHT OWNER OR  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,     ##
##  INCIDENTAL, SPECIAL,  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,    ##
##  BUT NOT LIMITED TO,  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;        ##
##  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER         ##
##  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT       ##
##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
##  POSSIBILITY OF SUCH DAMAGE.                                              ##
##                                                                           ##
###############################################################################

package require Tcl 8.4
# WS::Utils usable here for dict?
if {![llength [info command dict]]} {
    package require dict
}

package require uri
package require base64
package require html
package require log

package provide WS::Embeded 2.3.0

namespace eval ::WS::Embeded {

    array set portInfo {}

    set portList [list]
    set forever {}

    variable returnCodeText [dict create 200 OK 404 "Not Found"\
	    500 "Internal Server Error" 501 "Not Implemented"]
}

 
###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name : ::WS::Embeded::AddHandler
#
# Description : Register a handler for a url on a port.
#
# Arguments :
#       port     -- The port to register the callback on
#       url      -- The URL to register the callback for
#       callback -- The callback prefix, two additionally arguments are lappended
#                   the callback: (1) the socket (2) the null string
#
# Returns :     Nothing
#
# Side-Effects :
#       None
#
# Exception Conditions : None
#
# Pre-requisite Conditions : ::WS::Embeded::Listen must have been called for the port
#
# Original Author : Gerald W. Lester
#
#>>END PUBLIC<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  03/28/2008  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Embeded::AddHandler {port url callback} {
    variable portInfo

    dict set portInfo($port,handlers) $url $callback
    return;
}

 
###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name : ::WS::Embeded::AddHandlerAllPorts
#
# Description : Register a handler for a url on all "defined" ports.
#
# Arguments :
#       url      -- List of three elements:
#       callback -- The callback prefix, two additionally argumens are lappended
#                   the callback: (1) the socket (2) the null string
#
# Returns :     Nothing
#
# Side-Effects :
#       None
#
# Exception Conditions : None
#
# Pre-requisite Conditions : ::WS::Embeded::Listen must have been called for the port
#
# Original Author : Gerald W. Lester
#
#>>END PUBLIC<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  03/28/2008  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Embeded::AddHandlerAllPorts {url callback} {
    variable portList

    foreach port $portList {
        AddHandler $port $url $callback
    }

    return;
}

 
###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name : ::WS::Embeded::Listen
#
# Description : Instruct the module to listen on a Port, security information.
#
# Arguments :
#       port     -- Port number to listen on
#       certfile -- Name of the certificate file
#       keyfile  -- Name of the key file
#       userpwds -- A list of username:password
#       realm    -- The security realm
#
# Returns :     socket handle
#
# Side-Effects :
#       None
#
# Exception Conditions : None
#
# Pre-requisite Conditions : ::WS::Embeded::Listen must have been called for the port
#
# Original Author : Gerald W. Lester
#
#>>END PUBLIC<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  03/28/2008  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Embeded::Listen {port {certfile {}} {keyfile {}} {userpwds {}} {realm {}}} {
    variable portInfo
    variable portList

    lappend portList $port
    foreach key {port certfile keyfile userpwds realm} {
        set portInfo($port,$key) [set $key]
    }
    if {![info exists portInfo($port,handlers)]} {
        set portInfo($port,handlers) {}
    }
    foreach up $userpwds {
        lappend portInfo($port,auths) [base64::encode $up]
    }

    if {$certfile ne ""} {
        package require tls

        ::tls::init \
            -certfile $certfile \
            -keyfile  $keyfile \
            -ssl2 1 \
            -ssl3 1 \
            -tls1 0 \
            -require 0 \
            -request 0
        set handle [::tls::socket -server [list ::WS::Embeded::accept $port] $port]
    } else {
        ::log::log debug [list socket -server [list ::WS::Embeded::accept $port] $port]
        set handle [socket -server [list ::WS::Embeded::accept $port] $port]
    }

    return $handle
}

 
###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name : ::WS::Embeded::ReturnData
#
# Description : Store the information to be returned.
#
# Arguments :
#       socket  -- Socket data is for
#       type    -- Mime type of data
#       data    -- Data
#       code    -- Status code
#
# Returns :     Nothing
#
# Side-Effects :
#       None
#
# Exception Conditions : None
#
# Pre-requisite Conditions : A callback on the socket should be pending
#
# Original Author : Gerald W. Lester
#
#>>END PUBLIC<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  03/28/2008  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Embeded::ReturnData {sock type data code} {
    upvar #0 ::WS::Embeded::Httpd$sock dataArray

    foreach var {type data code} {
        dict set dataArray(reply) $var [set $var]
    }
    return;
}

 
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name : ::WS::Embeded::respond
#
# Description : Send response back to user.
#
# Arguments :
#       sock -- Socket to send reply on
#       code -- Code to send
#       body -- HTML body to send
#       head -- Additional HTML headers to send
#
# Returns :
#       Nothing
#
# Side-Effects : None
#
# Exception Conditions : None
#
# Pre-requisite Conditions : None
#
# Original Author : Gerald W. Lester
#
#>>END PRIVATE<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  03/28/2008  G.Lester     Initial version
#   2.3.0  11/06/2012  H.Oehlmann   Separate head and body,
#                                   correct Content-length
#
#
###########################################################################
proc ::WS::Embeded::respond {sock code body {head ""}} {
    set body [encoding convertto iso8859-1 $body\r\n]
    chan configure $sock -translation crlf
    puts $sock "[httpreturncode $code]\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]"
    if {"" ne $head} {
	puts -nonewline $sock $head
    }
    # Separator head and body
    puts $sock ""
    chan configure $sock -translation binary
    puts -nonewline $sock $body
}

 
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name : ::WS::Embeded::httpreturncode
#
# Description : Format the first line of a http return including the status code
#
# Arguments :
#       code -- numerical http return code
#
# Returns :
#       Nothing
#
# Side-Effects : None
#
# Exception Conditions : None
#
# Pre-requisite Conditions : None
#
# Original Author : Gerald W. Lester
#
#>>END PRIVATE<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  10/05/2012  H.Oehlmann   Initial version
#
#
###########################################################################
proc ::WS::Embeded::httpreturncode {code} {
    variable returnCodeText
    if {[dict exist $returnCodeText $code]} {
	set textCode [dict get $returnCodeText $code]
    } else {
	set textCode "???"
    }
    return "HTTP/1.0 $code $textCode"
}

 
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name : ::WS::Embeded::checkauth
#
# Description : Check to see if the user is allowed.
#
# Arguments :
#       port -- Port number
#       sock -- Incoming socket
#       ip   -- Requester's IP address
#       auth -- Authentication information
#
# Returns :
#       Nothing
#
# Side-Effects : None
#
# Exception Conditions : None
#
# Pre-requisite Conditions : None
#
# Original Author : Gerald W. Lester
#
#>>END PRIVATE<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  03/28/2008  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Embeded::checkauth {port sock ip auth} {
    variable portInfo

    if {[info exists portInfo($port,auths)] && [llength $portInfo($port,auths)] && [lsearch -exact $portInfo($port,auths) $auth]==-1} {
        set realm $portInfo($port,realm)
        respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n"
        ::log::log warning "Unauthorized from $ip"
        return -code error
    }
}

 
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name : ::WS::Embeded::handler
#
# Description : Handle a request.
#
# Arguments :
#       port        -- Port number
#       sock        -- Incoming socket
#       ip          -- Requester's IP address
#       reqstring   -- Requester's message
#       auth        -- Authentication information
#
# Returns :
#       Nothing
#
# Side-Effects : None
#
# Exception Conditions : None
#
# Pre-requisite Conditions : None
#
# Original Author : Gerald W. Lester
#
#>>END PRIVATE<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  03/28/2008  G.Lester     Initial version
#   2.3.0  10/31/2012  G.Lester     bug fix for [68310fe3bd] -- correct encoding and data length
#
#
###########################################################################
proc ::WS::Embeded::handler {port sock ip reqstring auth} {
    variable portInfo
    upvar #0 ::WS::Embeded::Httpd$sock req

    if {[catch {checkauth $port $sock $ip $auth}]} {
        ::log::log warning {Auth Failed}
        return
    }

    array set req $reqstring
    #foreach var {type data code} {
    #    dict set req(reply) $var [set $var]
    #}
    set path "/[string trim $req(path) /]"
    if {[dict exists $portInfo($port,handlers) $path]} {
        set cmd [dict get $portInfo($port,handlers) $path]
        lappend cmd $sock {}
        #puts "Calling {$cmd}"
        if {[catch {eval $cmd} msg]} {
            ::log::log error "Return 404 due to eval error: $msg"
            respond $sock 404 "Error: $msg"
        } else {
            set type [dict get $req(reply) type]
            set encoding [string tolower [lindex [split [lindex [split $type {;}] 1] {=}] 1]]
            if {$encoding ni [encoding names]} {
                set encoding utf-8
                set type "[lindex [split $type ";"] 0]; charset=UTF-8"
            }
            set data [encoding convertto $encoding [dict get $req(reply) data]]
            set reply "[httpreturncode [dict get $req(reply) code]]\n"
            append reply "Content-Type: $type\n"
            append reply "Connection: close\n"
            append reply "Content-length: [string length $data]\n"
            chan configure $sock -translation crlf
            puts $sock $reply
            chan configure $sock -translation binary
            puts -nonewline $sock $data
            ::log::log debug ok
        }
    } else {
        ::log::log warning "404 Error: URL not found"
        respond $sock 404 "URL not found"
    }

    return;
}

 
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name : ::WS::Embeded::accept
#
# Description : Accept an incoming connection.
#
# Arguments :
#       port        -- Port number
#       sock        -- Incoming socket
#       ip          -- Requester's IP address
#       clientport  -- Requester's port number
#
# Returns :
#       Nothing
#
# Side-Effects : None
#
# Exception Conditions : None
#
# Pre-requisite Conditions : None
#
# Original Author : Gerald W. Lester
#
#>>END PRIVATE<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  03/28/2008  G.Lester     Initial version
#   2.3.0  10/31/2012  G.Lester     Bug fix [66fb3aeef5] -- correct header parsing
#
#
###########################################################################
proc ::WS::Embeded::accept {port sock ip clientport} {
    variable portInfo

    upvar #0 ::WS::Embeded::Httpd$sock query
    ::log::log info "Receviced request on $port for $ip:$clientport"

    array unset query reply
    chan configure $sock -translation crlf
    if {1 == [catch {
        gets $sock line
        ::log::log debug "Request is: $line"
        set auth {}
        set request {}
        while {[gets $sock temp] > 0 && ![eof $sock]} {
            if {[regexp {^([^:]*):(.*)$} $temp -> key data]} {
                dict set request header [string tolower $key] [string trim $data]
            }
        }
        if {[eof $sock]} {
            ::log::log warning  "Connection closed from $ip"
            return
        }
        if {[dict exists $request header authorization]} {
            regexp -nocase {^basic +([^ ]+)$}\
                [dict get $request header authorization] -> auth
        }
        if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} {
            ::log::log warning  "Wrong request: $line"
            return
        }
        switch -exact -- $method {
            POST {
                ##
                ## This is all broken and needs to be fixed
                ##
                set data ""
                if {[dict exists $request header transfer-encoding]
                    && [dict get $request header transfer-encoding] eq "chunked"} {
                    # Receive chunked request body.
                    while {[scan [gets $sock line] %x length] == 1 && $length > 0} {
                        chan configure $sock -translation binary
                        append data [read $sock $length]
                        chan configure $sock -translation crlf
                    }
                } else {
                    # Receive non-chunked request body.
                    chan configure $sock -translation binary
                    set data [read $sock [dict get $request header content-length]]
                    chan configure $sock -translation crlf
                }
                array set query [uri::split $url]
                set query(query) $data
                set query(headers) $request
                set query(ipaddr) $ip
                #parray query
                handler $port $sock $ip [array get query] $auth
            }
            GET {
                handler $port $sock $ip [uri::split $url] $auth
            }
            default {
                ::log::log warning "Unsupported method '$method' from $ip"
                respond $sock 501 "Method not implemented"
            }
        }
    } msg]} {
        ::log::log error "Error: $msg"
        # catch this against an eventual closed socket
        catch {respond $sock 500 "Server Error"}
    }

    catch {flush $sock}
    catch {close $sock}
    return
}

Added ZenLoops.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
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"

package require Tcl 8.5
package require Tk 8.5
package require Ttk 8.5

namespace eval zenloops {
    namespace path {::tcl::mathop}

    variable density 0.75
    variable fgcolour #000000
    variable board
    variable values
    variable wrong

}

namespace path {::tcl::mathop}

#-----------------------------------------------------------------------------
#
# zenloops::choose --
#
#        Chooses one from a variable-length set of choices
#
# Parameters:
#        choices -- List of choices
#
# Results:
#        Returns a random selection from the list.
#
#-----------------------------------------------------------------------------

proc zenloops::choose {choices} {
    return [lindex $choices [expr {int([llength $choices] * rand())}]]
}

#-----------------------------------------------------------------------------
#
# zenloops::chooseMulti --
#
#        Chooses r items from a variable-length set of choices
#
# Parameters:
#        choices - List of choices
#
# Results:
#        Returns a randome selection of r items from the list.
#
#-----------------------------------------------------------------------------

proc zenloops::chooseMulti {choices r} {
    set n [llength $choices]
    set retval {}
    foreach item $choices {
        if {$n * rand() <= $r} {
            lappend retval $item
            incr r -1
        }
        incr n -1
    }
    return $retval
}

#-----------------------------------------------------------------------------
#
# zenloops::drawsquare --
#
#        Draws one square of the diagram on the canvas.
#
# Parameters:
#
#        c -- Path name of the canvas
#        x, y -- Co-ordinates of the center of the square
#        s -- Edge length of the square
#        r, d, l, u -- 1 if the square connects to the square to its right,
#                      the square to its right, the square below it, and
#                      the square to its left.
#        tag -- Tag to apply. Two tags will be applied: just the tag, and
#               [linsert $tag 0 $itemType]
#
#-----------------------------------------------------------------------------

proc zenloops::drawsquare {c x y s r d l u tag} {

    variable fgcolour

    $c delete -withtag $tag

    # Three cases: (1) The square has a single connection.
    # (2) The square has two connections that are opposite.
    # (3) The square has two connections that are adjacent, or
    #     more than two connections, in which case each adjacent
    #          pair is linked.

    switch -exact -- [expr {$r + $d + $l + $u}] {
        1 {
            $c create oval [- $x [/ $s 4]] [- $y [/ $s 4]] \
                [+ $x [/ $s 4]] [+ $y [/ $s 4]] \
                -width [/ $s 4] -outline $fgcolour -fill {} \
                -tags [list $tag oval [linsert $tag 0 oval]]
            if {$r} {
                $c create line [+ $x [/ $s 4]] $y \
                    [+ $x [/ $s 2]] $y \
                    -width [/ $s 4] -fill $fgcolour -capstyle round \
                    -tags [list $tag line [linsert $tag 0 line]]
            }
            if {$d} {
                $c create line $x [+ $y [/ $s 4]] \
                    $x [+ $y [/ $s 2]] \
                    -width [/ $s 4] -fill $fgcolour -capstyle round \
                    -tags [list $tag line [linsert $tag 0 line]]
            }
            if {$l} {
                $c create line [- $x [/ $s 4]] $y \
                    [- $x [/ $s 2]] $y \
                    -width [/ $s 4] -fill $fgcolour -capstyle round \
                    -tags [list $tag line [linsert $tag 0 line]]
            }
            if {$u} {
                $c create line $x [- $y [/ $s 4]] \
                    $x [- $y [/ $s 2]] \
                    -width [/ $s 4] -fill $fgcolour -capstyle round \
                    -tags [list $tag line [linsert $tag 0 line]]
            }
            return
        }
        2 {
            if {$u && $d} {
                $c create line $x [- $y [/ $s 2]] $x [+ $y [/ $s 2]] \
                    -width [/ $s 4] -fill $fgcolour -capstyle round \
                    -tags [list $tag line [linsert $tag 0 line]]
                return
            }
            if {$l && $r} {
                $c create line [- $x [/ $s 2]] $y [+ $x [/ $s 2]] $y \
                    -width [/ $s 4] -fill $fgcolour -capstyle round \
                    -tags [list $tag line [linsert $tag 0 line]]
                return
            }
        }
    }
    if {$r} {
        if {$d} {
            $c create line [+ $x [/ $s 2]] $y \
                [+ $x [* $s 0.3]] $y \
                $x [+ $y [* $s 0.3]] \
                $x [+ $y [/ $s 2]] \
                -width [/ $s 4] \
                -fill $fgcolour -capstyle round -smooth 1 \
                -tags [list $tag line [linsert $tag 0 line]]
        }
        if {$u} {
            $c create line [+ $x [/ $s 2]] $y \
                [+ $x [* $s 0.3]] $y \
                $x [- $y [* $s 0.3]] \
                $x [- $y [/ $s 2]] \
                -width [/ $s 4] \
                -fill $fgcolour -capstyle round -smooth 1 \
                -tags [list $tag line [linsert $tag 0 line]]
        }
    }
    if {$l} {
        if {$d} {
            $c create line [- $x [/ $s 2]] $y \
                [- $x [* $s 0.3]] $y \
                $x [+ $y [* $s 0.3]] \
                $x [+ $y [/ $s 2]] \
                -width [/ $s 4] \
                -fill $fgcolour -capstyle round -smooth 1 \
                -tags [list $tag line [linsert $tag 0 line]]
        }
        if {$u} {
            $c create line [- $x [/ $s 2]] $y \
                [- $x [* $s 0.3]] $y \
                $x [- $y [* $s 0.3]] \
                $x [- $y [/ $s 2]] \
                -width [/ $s 4] \
                -fill $fgcolour -capstyle round -smooth 1 \
                -tags [list $tag line [linsert $tag 0 line]]
        }
    }
    return
}

#-----------------------------------------------------------------------------
#
# makeconnections --
#
#        Determines the set of connections on the board to be solved.
#
# Parameters:
#
#        size - Size of the board to make
#
# Return values:
#        Returns a two-element list; the first element is the table of vertical
#        connections ((size-1) x size), and the second is the table of
#        horizontal connections (size x (size-1)).
#
#-----------------------------------------------------------------------------

proc zenloops::makeconnections {size} {

    variable density

    set vconn [lrepeat [- $size 1] [lrepeat $size 0]]
    set hconn [lrepeat $size [lrepeat [- $size 1] 0]]
    set did [lrepeat $size [lrepeat $size 0]]

    # Connections will be made with probability $density

    set n [expr {int(2 * $density * $size * $size-1)}]

    # First, make sure that every cell is connected

    for {set v 0} {$v < $size} {incr v} {
        for {set h 0} {$h < $size} {incr h} {
            if {[lindex $did $v $h]} continue
            set choices {}
            if {$v > 0} {
                lappend choices [list [- $v 1] $h vconn [- $v 1] $h]
            }
            if {$v+1 < $size} {
                lappend choices [list [+ $v 1] $h vconn $v $h]
            }
            if {$h > 0} {
                lappend choices [list $v [- $h 1] hconn $v [- $h 1]]
            }
            if {$h+1 < $size} {
                lappend choices [list $v [+ $h 1] hconn $v $h]
            }
            lassign [choose $choices] v0 h0 table v1 h1
            lset did $v $h 1
            incr n -1
            if {![lindex $did $v0 $h0]} {
                lset did $v0 $h0 1
                incr n -1
            }
            lset $table $v1 $h1 1
        }
    }

    # Fill in enough remaining cells to get the desired density

    set choices {}
    set v 0
    foreach row $vconn {
        set h 0
        foreach cell $row {
            if {!$cell} {
                lappend choices [list vconn $v $h]
            }
            incr h
        }
        incr v
    }
    set v 0
    foreach row $hconn {
        set h 0
        foreach cell $row {
            if {!$cell} {
                lappend choices [list hconn $v $h]
            }
            incr h
        }
        incr v
    }
    foreach item [chooseMulti $choices $n] {
        lassign $item table v h
        lset $table $v $h 1
    }

    return [list $vconn $hconn]
}

#-----------------------------------------------------------------------------
#
# makeboard --
#
#        Makes a new board.
#
# Parameters:
#
#        size - Size of the board.
#
# Results:
#        Returns the new board as a (size x size) table of 4-element lists.
#        Each list element represents whether the board element has a
#        connection to the element to its right, below it, to its left, and
#        above it.
#
#-----------------------------------------------------------------------------

proc zenloops::makeboard {size} {
    variable board
    lassign [makeconnections $size] vconn hconn
    set initboard [lrepeat $size [lrepeat $size [lrepeat 4 0]]]
    set v 0
    foreach row $hconn {
        set h 0
        foreach cell $row {
            if {$cell} {
                lset initboard $v $h 0 1
                lset initboard $v [+ $h 1] 2 1
            }
            incr h
        }
        incr v
    }
    set v 0
    foreach row $vconn {
        set h 0
        foreach cell $row {
            if {$cell} {
                lset initboard $v $h 1 1
                lset initboard [+ $v 1] $h 3 1
            }
            incr h
        }
        incr v
    }
    set board {}
    foreach row $initboard {
        set outrow {}
        foreach cell $row {
            set cut [expr {int(4*rand())}]
            lappend outrow \
                [list {*}[lrange $cell $cut end] \
                     {*}[lrange $cell 0 [- $cut 1]]]
        }
        lappend board $outrow
    }
}

#-----------------------------------------------------------------------------
#
# evalcell --
#
#        Evaluate whether a cell connects to its neighbours
#
# Parameters:
#        v, h - Co-ordinates of the cell
#
# Reuslts:
#        Returns 0 if the cell connects correctly, 1 if it has a problem.
#
#-----------------------------------------------------------------------------

proc zenloops::evalcell {v h} {
    variable board
    set n [llength $board]
    set cell [lindex $board $v $h]
    if {$h + 1 < $n} {
        set shouldbe [lindex $board $v [+ $h 1] 2]
    } else {
        set shouldbe 0
    }
    if {[lindex $cell 0] != $shouldbe} {
        return 1
    }
    if {$v + 1 < $n} {
        set shouldbe [lindex $board [+ $v 1] $h 3]
    } else {
        set shouldbe 0
    }
    if {[lindex $cell 1] != $shouldbe} {
        return 1
    }
    if {$h > 0} {
        set shouldbe [lindex $board $v [- $h 1] 0]
    } else {
        set shouldbe 0
    }
    if {[lindex $cell 2] != $shouldbe} {
        return 1
    }
    if {$v > 0} {
        set shouldbe [lindex $board [- $v 1] $h 1]
    } else {
        set shouldbe 0
    }
    if {[lindex $cell 3] != $shouldbe} {
        return 1
    }
    return 0
}

#-----------------------------------------------------------------------------
#
# adjustcell --
#
#        Adjusts the valuation for a cell when the player spins a cell or
#        one of its neighbours
#
# Parameters:
#        v, h -- Co-ordinates of the cell being adjusted
#
# Results:
#        None.
#
# Side effects:
#        Updates values and wrong for the cell and its neighbours.
#
#-----------------------------------------------------------------------------

proc zenloops::adjustcell {v h} {
    variable board
    variable values
    variable wrong

    incr wrong [- [lindex $values $v $h]]
    set val [evalcell $v $h]
    lset values $v $h $val
    incr wrong $val
}

#-----------------------------------------------------------------------------
#
# adjustvalues --
#
#        Adjusts the valuation for a cell and its neighbours when the player
#        spins a cell.
#
# Parameters:
#        v, h -- Co-ordinates of the cell being spun#
#        board -- State of the board
#        weight -- -1 before the rotation, 1 afterward
#                    count of cells that are wrong.
#
# Results:
#        None.
#
# Side effects:
#        Updates values and wrong for the cell and its neighbours.
#
#-----------------------------------------------------------------------------

proc zenloops::adjustvalues {v h} {
    variable values
    variable wrong
    variable board
    set n [llength $board]
    adjustcell $v $h
    if {$v > 0} {
        adjustcell [- $v 1] $h
    }
    if {$h > 0} {
        adjustcell $v [- $h 1]
    }
    if {$v + 1 < $n} {
        adjustcell [+ $v 1] $h
    }
    if {$h + 1 < $n} {
        adjustcell $v [+ $h 1]
    }
}

#-----------------------------------------------------------------------------
#
# evalboard --
#
#        Make an initial evaluation of the board.
#
# Results:
#        Returns a count of incorrect cells.
#
#-----------------------------------------------------------------------------

proc zenloops::evalboard {} {
    variable board
    variable values
    variable wrong
    set values {}
    set wrong 0
    set v 0
    foreach row $board {
        set outrow {}
        set h 0
        foreach cell $row {
            set val [evalcell $v $h]
            lappend outrow $val
            incr wrong $val
            incr h
 }
        lappend values $outrow
        incr v
    }
    return $wrong
}

#-----------------------------------------------------------------------------
#
# geometry --
#
#        Compute the geometry of the board from its size and the window
#        dimensions.
#
# Parameters:
#        w, h -- Width and height of the window
#
# Results:
#        Returns a three-element list {step xorg yorg} where
#        step is the spacing between squares
#        (xorg, yorg) is the center of square (0,0)
#
#-----------------------------------------------------------------------------

proc zenloops::geometry {w h} {
    variable board
    if {$w > $h} {
        set size $h
        set xorg [expr {double($w - $h) / 2}]
        set yorg 0
    } else {
        set size $w
        set xorg 0
        set yorg [expr {double($h - $w) / 2}]
    }
    set n [llength $board]
    set step [expr {double($size) / ($n + 1)}]
    set xorg [expr {$xorg + $step}]
    set yorg [expr {$yorg + $step}]
    return [list $step $xorg $yorg]
}

#-----------------------------------------------------------------------------
#
# drawboard --
#
#        Draw the whole board from scratch
#
# Parameters:
#        c -- Path name of the canvas
#        w -- Width of the canvas
#        h -- Height of the canvas
#
# Results:
#        Draws the board.
#
#-----------------------------------------------------------------------------

proc zenloops::drawboard {c w h} {
    variable board
    lassign [geometry $w $h] step xorg yorg
    $c delete all
    set v 0
    foreach row $board {
        set h 0
        foreach cell $row {
            drawsquare $c [+ $xorg [* $step $h]] [+ $yorg [* $step $v]] $step \
                {*}$cell [list $v $h]
            incr h
        }
        incr v
    }
    return
}

#-----------------------------------------------------------------------------
#
# configlevel1 --
#
#        Adjust the message for the level1 screen
#
# Parameters:
#        c - Path name of the canvas
#
# Results:
#        None.
#
#-----------------------------------------------------------------------------

proc configlevel1 {c} {
    $c coords line [/ [winfo width $c] 2] [/ [winfo height $c] 2]
}

#-----------------------------------------------------------------------------
#
# startlevel1 --
#
#        Start the first level by displaying instructions
#
# Parameters:
#        c - Path name of the canvas
#
# Results:
#        None.
#
#-----------------------------------------------------------------------------

proc zenloops::startlevel1 {c} {
    variable board
    set board [list [list [list 0 0 0 0]]]
    $c create text [/ [winfo width $c] 2] [/ [winfo height $c] 2] \
        -text [regsub -all -lineanchor {^[ \t]+} [string trim {
            Zen Loops

            Inspired by the game
            "Loops of Zen"
            originally written by
            Dr. Arend Hintze

            Restore harmony to the universe
            by clicking the tiles until all
            the loose ends are attached.

            Click to begin.
        }] {}] \
        -font {Courier -24} -anchor center -justify center -tags line
    bind $c <1> [list [namespace which finishlevel] %W]
    bind $c <Configure> [list [namespace which configlevel1] %W]
}

#-----------------------------------------------------------------------------
#
# startlevel --
#
#        Start playing a new level.  Level 1 is special - it displays
#        instructions and invites the user to click to continue.
#
# Parameters:
#        c - Path name of the canvas.
#
#-----------------------------------------------------------------------------

proc zenloops::startlevel {c} {
    variable board
    set n [+ 1 [llength $board]]
    if {$n == 1} {
        startlevel1 $c
    } else {
        while 1 {
            zenloops::makeboard $n
            set wrong [evalboard]
            if {$wrong} break
        }
        bind $c <Configure> [list [namespace which drawboard] %W %w %h]
        bind $c <Button-1> [list [namespace which spin] %W %x %y]
        drawboard $c [winfo width $c] [winfo height $c]
        fadein $c 100
    }
}

#-----------------------------------------------------------------------------
#
# fadeout --
#
#        Fade out a level when the player succeeds.
#
# Parameters:
#        c -- Path name of the canvas.
#        step -- Number of time steps that have been completed.
#
# Results:
#        None.
#
# Side effects:
#        Fades the board and schedules the next fadeout, or starts the next
#        level.
#
#-----------------------------------------------------------------------------

proc zenloops::fadeout {c step} {
    variable fgcolour
    if {$step < 100} {
        set intens [expr {255 * $step / 100}]
        set fgcolour [format "#%02x%02x%02x" $intens $intens $intens]
        $c itemconfigure oval -outline $fgcolour
        $c itemconfigure line -fill $fgcolour
        after 20 [list [namespace which fadeout] $c [+ 1 $step]]
    } else {
        $c delete all
        startlevel $c
    }
}


#-----------------------------------------------------------------------------
#
# fadein --
#
#        Fade in a level when starting it.
#
# Parameters:
#        c -- Path name of the canvas.
#        step -- Number of time steps that have been completed.
#
# Results:
#        None.
#
# Side effects:
#        Fades the board and schedules the next fadein, or starts the next
#        level.
#
#-----------------------------------------------------------------------------

proc zenloops::fadein {c step} {
    variable fgcolour
    if {$step > 0} {
        set intens [expr {255 * $step / 100}]
        set fgcolour [format "#%02x%02x%02x" $intens $intens $intens]
        $c itemconfigure oval -outline $fgcolour
        $c itemconfigure line -fill $fgcolour
        after 20 [list [namespace which fadein] $c [- $step 1]]
    }
    return
}


#-----------------------------------------------------------------------------
#
# finishlevel --
#
#        Finish playing a level
#
# Parameters:
#        c - Path name of the canvas
#
# Results:
#        None.
#
# Side effects:
#        Starts a fade effect and advances to the next level when it finishes.
#
#-----------------------------------------------------------------------------

proc zenloops::finishlevel {c} {
    bind $c <Button-1> {}
    bind $c <Configure> {}
    fadeout $c 0
}

#-----------------------------------------------------------------------------
#
# spin --
#
#        Rotate the figure in a cell when the player mouses on the cell.
#
# Results:
#        None.
#
# Side effects:
#        Updates board valuation
#
#-----------------------------------------------------------------------------

proc zenloops::spin {c x y} {
    variable board
    variable values
    variable wrong
    set n [llength $board]
    lassign [geometry [winfo width $c] [winfo height $c]] \
        step xorg yorg
    set v [expr {int(($y - $yorg + $step/2) / $step)}]
    set h [expr {int(($x - $xorg + $step/2) / $step)}]
    if {$v < 0 || $v >= $n || $h < 0 || $h >= $n} return
    set cell [lassign [lindex $board $v $h] first]
    lappend cell $first
    lset board $v $h $cell
    drawsquare $c [+ $xorg [* $step $h]] [+ $yorg [* $step $v]] $step \
        {*}$cell [list $v $h]
    adjustvalues $v $h
    if {$wrong == 0} {
        finishlevel $c
    }
    return
}

grid [canvas .c -width 512 -height 512 \
          -background white -relief flat -borderwidth 0] \
    -sticky nsew -columnspan 2 -row 0 -column 0
grid [ttk::frame .f] -row 1 -column 0
grid [ttk::sizegrip .grip] -row 1 -column 1 -sticky se
grid rowconfigure . 0 -weight 1
grid columnconfigure . 0 -weight 1
# temp
set zenloops::board {}
zenloops::startlevel .c

Added android_sensors.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
# Android demo for <<Sensor>> events

proc mksensor {data} {
    array set sensor $data
    set i $sensor(index)
    set f .s$i
    labelframe $f -text $sensor(name)
    ttk::checkbutton $f.en -text "Enable" -command [list togglesensor $i] \
	-variable ::SENSOR($i,enabled)
    grid $f.en -row 0 -column 0 -sticky w -padx 10 -pady 5
    entry $f.val -textvariable ::SENSOR($i,values) -width 40 \
	-disabledforeground black -disabledbackground white \
	-state disabled
    grid $f.val -row 1 -column 0 -sticky ew -padx 10 -pady 5
    pack $f -side top -padx 10 -pady 10
    set ::SENSOR($i,enabled) 1
    updatesensor $i
}

proc updatesensor {i} {
    array set sensor [borg sensor get $i]
    set ::SENSOR($i,values) $sensor(values)
    if {$::SENSOR($i,enabled)} {
	set ::SENSOR($i,enabled) $sensor(enabled)
    }
}

proc togglesensor {i} {
    if {$::SENSOR($i,enabled)} {
	borg sensor enable $i
    } else {
	borg sensor disable $i
    }
}

proc watchdog {} {
    after cancel watchdog
    after 10000 watchdog
    foreach s [borg sensor list] {
	array set data $s
	set i $data(index)
	array set sensor [borg sensor get $i]
	if {!$sensor(enabled)} {
	    set ::SENSOR($i,enabled) 0
	}
    }
}

wm attributes . -fullscreen 1
bind . <Break> exit
bind . <<SensorUpdate>> {updatesensor %x}
label .top -text "Device Sensors"
pack .top -side top -pady 10
foreach s [borg sensor list] {
    mksensor $s
}
watchdog