# TITLE: A crossword game
if 0 {[Richard Suchenwirth] 2003-10-05 - This game is famous under the
trademark Scrabble - here's a simple Tcl approximation which gives you
the board and the randomly drawn letter tiles. The rest you have to do
yourself, like judge whether a word is valid, and even compute the
scores. Tiles are "stacked" at top left corner, and can be drawn from there
to any place on the margin, and to board positions.

[http://mini.net/files/scrabble.jpg]
}
 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  Ö 8 1
        P 4 1  Q 10 1 R 1 6  S 1 7  T 1 6   U 1 6  Ü 6 1  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 helper
----
[Category Games] - [Arts and crafts of Tcl-Tk programming]