package require Tk
proc main {{tilesize 20}} {
set bg green4
set width [expr {$tilesize*17}]
pack [canvas .c -bg $bg -height $width -width $width]
foreach {row col color} [specials] {
set x0 [expr {$col*$tilesize}]
set y0 [expr {$row*$tilesize}]
.c create rect $x0 $y0 [incr x0 $tilesize] [incr y0 $tilesize] \
-fill $color -outline $bg
} ;#-- Draw grid
set x0 $tilesize
set x1 [expr {$width-$tilesize}]
set y0 $tilesize
set y1 [expr {$width-$tilesize}]
for {set x $x0} {$x<$width} {incr x $tilesize} {
.c create line $x $y0 $x $y1 -fill yellow -width 2
}
for {set y $y0} {$y<$width} {incr y $tilesize} {
.c create line $x0 $y $x1 $y -fill yellow -width 2
}
button .c.b -text Reset -command [list reset .c $tilesize] -bg $bg
.c create window $width 2 -window .c.b -anchor ne
reset .c $tilesize
}
proc reset {w tilesize} {
$w delete mv
#-- Make a list of all tiles
set ts {}
foreach {letter value number} [tilelist] {
for {set i 0} {$i<$number} {incr i} {
lappend ts [list $letter $value]
}
}
#-- Create tiles in random order
while {[llength $ts]} {
foreach {letter value} [ldraw ts] break
tile $w $letter $value $tilesize
}
#---------------------- bindings for moving tiles
$w bind mv <1> {
set X %X; set Y %Y
set id [lindex [%W gettags current] 0]
%W raise $id
}
$w bind mv <B1-Motion> {
%W move $id [expr %X-$X] [expr %Y-$Y]
set X %X; set Y %Y
}
$w bind mv <ButtonRelease-1> {
foreach {x0 y0 x1 y1} [%W bbox $id] break
set sz [expr {$x1-$x0}]
set s2 [expr {$sz/2}]
if {$x0>=$sz && $y0>=$sz} {
%W move $id [expr $s2-(($x0+$s2)%%$sz)] \
[expr $s2-(($y0-$s2)%%$sz)]
}
}
}
#-- Positions and colors of special fields
proc specials {} {
string map {lbl lightblue} {
1 1 red 1 4 lbl 1 8 red 1 12 lbl 1 15 red
2 2 pink 2 6 blue 2 10 blue 2 14 pink
3 3 pink 3 7 lbl 3 9 lbl 3 13 pink
4 1 lbl 4 4 pink 4 8 lbl 4 12 pink 4 15 lbl
5 5 pink 5 11 pink
6 2 blue 6 6 blue 6 10 blue 6 14 blue
7 3 lbl 7 7 lbl 7 9 lbl 7 13 lbl
8 1 red 8 4 lbl 8 8 pink 8 12 lbl 8 15 red
9 3 lbl 9 7 lbl 9 9 lbl 9 13 lbl
10 2 blue 10 6 blue 10 10 blue 10 14 blue
11 5 pink 11 11 pink
12 1 lbl 12 4 pink 12 8 lbl 12 12 pink 12 15 lbl
13 3 pink 13 7 lbl 13 9 lbl 13 13 pink
14 2 pink 14 6 blue 14 10 blue 14 14 pink
15 1 red 15 4 lbl 15 8 red 15 12 lbl 15 15 red
}
}
#-- "Constructor" for a tile
proc tile {w letter value tilesize} {
set id [$w create rect 2 2 $tilesize $tilesize -fill beige]
set tags [list t$id mv]
$w itemconfigure $id -tag $tags
set font1 [list Helvetica [expr $tilesize/2]]
set pos [expr $tilesize/2]
$w create text $pos $pos -text $letter -font $font1 -tag $tags
set font2 [list Helvetica [expr $tilesize/4]]
set pos [expr $tilesize*5/6]
$w create text $pos $pos -text $value -font $font2 -tag $tags
}
#-- Tiles distribution (Germany): letter - value - occurrence
proc tilelist {} {
return {
A 1 5 Ą 6 1 B 3 2 D 1 4 E 1 15 F 4 2 G 2 3 H 2 4
I 1 6 J 6 1 K 4 2 L 2 3 M 3 4 N 1 9 O 2 3 \ud6 8 1
P 4 1 Q 10 1 R 1 6 S 1 7 T 1 6 U 1 6 \udc 1 6 V 6 1
W 3 1 X 8 1 Y 10 1 Z 3 1 * "" 2
}
}
proc ldraw listName {
upvar 1 $listName list
set pos [expr {int(rand()*[llength $list])}]
K [lindex $list $pos] [set list [lreplace $list $pos $pos]]
}
proc K {a b} {set a}
main
bind . <Escape> {exec wish $argv0 &; exit} ;# dev helperAlastair Davies (21 October 2005) - I've taken the liberty of developing this code to deal seven tiles to each of up to four players, check turns are legal, score words etc etc. (Beyond this, my unfinished interest is in exploring the possibility of playing against the computer. At the moment, although the computer plays the first few turns satisfactorily, as the board becomes crowded it cannot find enough places to move.)Alastair Davies (22 November 2005) - A month later, I've finished this to a standard where it usually beats me. It uses the 2of12inf.txt word list from the 12-dicts project [1]. I've wrapped this in a Tcl procedure, so it is included in the source code, which I've submitted to the Starkit Distribution Archive. It's also available as an Windows executable from my website [2]. I've called it CrossWaysWords to avoid confusion with trademarks.
