Word Search

Keith Vetter 2004-09-16 : Here's another little game that I wrote for my daughter who's just learning to read. It's the classic game of finding words hidden in a grid of letters.

You can adjust most of the parameters of the game such as board size, number of words, etc. The only aspect you can't control is the word list--it uses a built in list of 500 words. If you want to create themed word searches you'll have to hack this game.

The trickiest part was getting nicely shaped ovals for highlighting words, especially diagonal words. Luckily I found a solution here on this wiki. The other tricky part was figuring out what size font for a given board size to make everything fit nicely.

MG September 20th 2004 - Added a small fix to the BUp. Now, if $CLICK(last) isn't set (which only happens if you click outside the grid of letters when the program starts), BUp returns, instead of raising an error.

uniquename 2013aug01

This expenditure of coding energy deserves an image to show what this script hath wrought.

vetter_WordSearch_screenshot_474x483.jpg


 ##+##########################################################################
 #
 # Word Search -- creates and solves word search puzzles
 # by Keith Vetter, September 14, 2004
 #
 
 package require Tk
 
 set S(title) "Word Search"
 set S(rows) 11
 set S(cols) 11
 set S(count) 15
 set S(backwards) 1
 set S(diagonals) 1
 set S(shortest) 1
 set S(longest) 99
 set S(debug) 0
 
 set WORDS {THE OF AND TO IN THAT IS WAS HE FOR IT WITH AS HIS ON BE AT BY THIS
    HAD NOT ARE BUT FROM OR HAVE AN THEY WHICH ONE YOU WERE HER ALL SHE
    THERE WOULD THEIR WE HIM BEEN HAS WHEN WHO WILL MORE NO IF OUT SO SAID
    WHAT UP ITS ABOUT INTO THAN THEM CAN ONLY OTHER NEW SOME TIME COULD
    THESE TWO MAY THEN DO FIRST ANY MY NOW SUCH LIKE OUR OVER MAN ME EVEN
    MOST MADE AFTER ALSO DID MANY BEFORE MUST THROUGH BACK YEARS WHERE
    MUCH YOUR WAY WELL DOWN SHOULD BECAUSE EACH JUST THOSE PEOPLE HOW TOO
    LITTLE US STATE GOOD VERY MAKE WORLD STILL SEE OWN MEN WORK LONG HERE
    GET BOTH BETWEEN LIFE BEING UNDER NEVER DAY SAME ANOTHER KNOW YEAR
    WHILE LAST MIGHT GREAT OLD OFF COME SINCE GO AGAINST CAME RIGHT STATES
    TAKE THREE HIMSELF FEW HOUSE USE DURING WITHOUT AGAIN PLACE AROUND
    HOWEVER HOME SMALL FOUND THOUGHT WENT SAY PART ONCE HIGH GENERAL UPON
    SCHOOL EVERY GOT LEFT NUMBER COURSE WAR UNTIL ALWAYS AWAY FACT WATER
    THOUGH LESS PUBLIC PUT THINK KEITH ALMOST HAND ENOUGH FAR TOOK HEAD YET
    SYSTEM SET BETTER TOLD NOTHING NIGHT END WHY FIND GOING LOOK LATER
    POINT KNEW CITY NEXT PROGRAM GIVE GROUP TOWARD YOUNG LET ROOM SIDE
    SOCIAL PRESENT GIVEN SEVERAL ORDER SECOND RATHER PER FACE AMONG FORM
    OFTEN EARLY WHITE JOHN CASE BECOME LARGE NEED BIG FOUR WITHIN FELT
    ALONG SAW BEST CHURCH EVER LEAST POWER THING LIGHT FAMILY WANT MIND
    COUNTRY AREA DONE OPEN GOD SERVICE PROBLEM CERTAIN KIND THUS BEGAN
    DOOR HELP MEANS SENSE WHOLE MATTER PERHAPS ITSELF LAW HUMAN LINE ABOVE
    NAME EXAMPLE ACTION COMPANY LOCAL SHOW WHETHER FIVE HISTORY GAVE TODAY
    EITHER ACT FEET ACROSS TAKEN PAST QUITE SEEN HAVING DEATH WEEK BODY
    WORD HALF REALLY FIELD AM CAR ALREADY TELL COLLEGE SHALL MONEY PERIOD
    HELD KEEP SURE REAL FREE CANNOT BEHIND MISS AIR OFFICE MAKING BROUGHT
    WHOSE SPECIAL MAJOR HEARD FEDERAL BECAME STUDY AGO MOMENT KNOWN RESULT
    STREET BOY REASON CHANGE SOUTH BOARD JOB SOCIETY WEST CLOSE TURN LOVE
    TRUE COURT FORCE FULL COST SEEM WIFE FUTURE AGE VOICE CENTER WOMAN
    CONTROL COMMON POLICY FRONT SIX GIRL CLEAR FURTHER LAND RUN PROVIDE
    FEEL PARTY ABLE MOTHER MUSIC CHILD EFFECT LEVEL STOOD TOWN SHORT
    MORNING TOTAL OUTSIDE RATE FIGURE CLASS ART CENTURY NORTH USUALLY PLAN
    LEAVE TOP MILLION SOUND BLACK STRONG HARD VARIOUS BELIEVE TYPE VALUE
    PLAY SURFACE SOON MEAN NEAR TABLE PEACE MODERN TAX ROAD RED BOOK
    PROCESS IDEA ENGLISH ALONE WOMEN GONE NOR LIVING AMERICA LONGER CUT
    FINALLY THIRD NATURE PRIVATE SECTION GREATER CALL FIRE KEPT GROUND
    VIEW DARK BASIS SPACE EAST FATHER UNION SPIRIT EXCEPT WROTE SUPPORT
    RETURN RECENT LATE HOPE LIVE ELSE BROWN TAKING PERSON BEYOND REPORT
    COMING INSIDE DEAD LOW STAGE READ INSTEAD LOST HEART LOOKING DATA PAY
    AMOUNT FEELING SINGLE BASIC HUNDRED MOVE COLD SIMPLY HOLD ISLAND
    DEFENSE SON SHOWN TEN RIVER GETTING CENTRAL SORT DOING TRYING REST
    MEDICAL CARE PICTURE INDEED FINE SUBJECT HIGHER SIMPLE RANGE WALL
    MEETING}
 
 proc Init {} {
    global S B CLICK
    
    if {[lsearch [font names] myFont] == -1} {
        font create myFont -family Helvetica
    }
    set size [expr {$S(rows) > $S(cols) ? $S(rows) : $S(cols)}]
    if {$size < 10} {
        set S(fontsize) 24
    } elseif {$size < 16} {
        set S(fontsize) 18
    } elseif {$size < 26} {
        set S(fontsize) 12
    } else {
        set S(fontsize) 8
    }
    
    font config myFont -size $S(fontsize)
    set S(cell) [font measure myFont "Wi"]
    set S(cell2) [expr {$S(cell) / 2.0}]
    set S(cell3) [expr {$S(cell) * 2 / 3.0}]
    set S(margin) [expr {$S(cell2) + 5}]
    
    set S(width) [expr {$S(cell) * $S(cols) + 2*$S(margin)}]
    set S(height) [expr {$S(cell) * $S(rows) + 2*$S(margin)}]
    set S(rows2) [expr {($S(rows)-1) / 2.0}]
    set S(cols2) [expr {($S(cols)-1) / 2.0}]
 
    if {[winfo exists .c]} {
        if {[winfo width .c] < $S(width) || [winfo height .c] < $S(height)} {
            .c config -height $S(height) -width $S(width)
            wm geom . {}
        }
        NewBoard 100
    } else {
        NewBoard 0
    }
 }
 
 proc DoDisplay {} {
    global S B
 
    wm title . $S(title)
    frame .ctrl -relief ridge -bd 2 -padx 5 -pady 5
    canvas .c -relief raised -bd 2 -highlightthickness 0 \
        -width $S(width) -height $S(height)
 
    grid .c .ctrl -sticky news
    grid rowconfigure . 0 -weight 1
    grid columnconfigure . 0 -weight 1
 
    bind all <Key-F2> {console show}
    bind .c <Configure> {ReCenter %W %h %w}
 
    DoCtrlFrame
    update
 }
 proc DoCtrlFrame {} {
    button .reset -text "Reset" -command ShowBoard -bd 4
    .reset configure -font "[font actual [.reset cget -font]] -weight bold"
    option add *Button.font [.reset cget -font]
    option add *Checkbutton.font [.reset cget -font]
    option add *Label.font [.reset cget -font]
    button .new -text "New Game" -command NewBoard -bd 4
    button .hint -text "Hint" -command Hint -bd 4
    bind .hint <Button-3> {Hint 1}
    checkbutton .bconfig -text "Configure" -command ::Config::Go -bd 4 \
        -relief raised
    button .about -text About -command \
        [list tk_messageBox -message "$::S(title)\nby Keith Vetter, Sept 2004"]
 
    #listbox .lb -yscrollcommand {.sb set} -listvariable B(all)
    text .tb -width 10 -height 10 -bg white -yscrollcommand {.sb set} -padx 2 \
        -font {Times 12}
    scrollbar .sb -orient vertical -command {.tb yview}
    .tb tag configure found -background red \
        -font "[font actual [.tb cget -font]] -overstrike 1"
    
    grid .tb .sb -in .ctrl -sticky ns -row 0
    grid rowconfigure .ctrl 0 -weight 1
    grid rowconfigure .ctrl 50 -minsize 20
    grid .new - -in .ctrl -sticky ew -pady 5 -row 51 
    grid .reset - -in .ctrl -sticky ew -pady 5
    grid .hint - -in .ctrl -sticky ew
    grid rowconfigure .ctrl 99 -minsize 30
    grid .bconfig - -in .ctrl -sticky ew -pady 5 -row 100
    grid .about - -in .ctrl -sticky ew
    grid columnconfigure .ctrl 0 -weight 1
    grid rowconfigure .ctrl 0 -weight 1
 }
 proc DrawBoard {} {
    global S B
    
    .c delete all
 
    # Outer border
    foreach {x0 y0} [GetCellXY 0 0] break
    foreach {x1 y1} [GetCellXY [expr {$S(rows)-1}] [expr {$S(cols)-1}]] break
    set x0 [expr {$x0 - $S(margin)}]
    set y0 [expr {$y0 - $S(margin)}]
    set x1 [expr {$x1 + $S(margin)}]
    set y1 [expr {$y1 + $S(margin)}]
    .c create rect $x0 $y0 $x1 $y1 -width 3
 
    # The letter grid
    for {set row 0} {$row < $S(rows)} {incr row} {
        for {set col 0} {$col < $S(cols)} {incr col} {
            set xy [GetCellXY $row $col]
            set tag letter,$row,$col
            .c create text $xy -text $B($row,$col) -anchor c -font myFont \
                -tag [list letter letter,$row,$col]
        }
    }
    bind .c <Button-1> [list BDown %x %y]
    bind .c <B1-Motion> [list BMove %x %y]
    bind .c <ButtonRelease-1> [list BUp %x %y]
 }
 proc NewBoard {{show 1}} {
    global B WL
    
    ::Create::Board B
    if {$show} ShowBoard
 }
 proc ShowBoard {} {
    global B
 
    set B(state) 1                              ;# Playing
    set B(found) {}
    DrawBoard
    .tb config -state normal                    ;# Add words to list box
    .tb delete 0.0 end
    .tb insert end [join $B(words) "\n"]
    .tb config -state disabled
 }
 
 proc GetCellXY {row col} {
    set x [expr {[expr {$col - $::S(cols2)}] * $::S(cell)}]
    set y [expr {[expr {$row - $::S(rows2)}] * $::S(cell)}]
    return [list $x $y]
 }
 proc GetCellBox {row col} {
    foreach {x y} [GetCellXY $row $col] break
    return [list [expr {$x - $::S(cell2)}] [expr {$y - $::S(cell2)}] \
                [expr {$x + $::S(cell2)}] [expr {$y + $::S(cell2)}]]
 }
 proc GetCellRowCol {x y} {
    set row [expr {int(($y+$::S(cell2)) / $::S(cell) + $::S(rows2))}]
    set col [expr {int(($x+$::S(cell2)) / $::S(cell) + $::S(cols2))}]
    return [list $row $col]
 }
 proc ReCenter {W h w} {                   ;# Called by configure event
    set h2 [expr {$h / 2}] ; set w2 [expr {$w / 2}]
    $W config -scrollregion [list -$w2 -$h2 $w2 $h2]
 }
 
 proc BDown {x y} {
    global CLICK B S
    if {! $B(state)} return
    set xx [.c canvasx $x]
    set yy [.c canvasy $y]
    foreach {row col} [GetCellRowCol $xx $yy] break
    if {$row < 0 || $col < 0 || $row >= $S(rows) || $col >= $S(cols)} return
    
    set CLICK(arow) $row
    set CLICK(acol) $col
    set CLICK(last) {}
    BMove $x $y
 }
 proc BMove {x y} {
    global CLICK B S
    if {! $B(state)} return
    set x [.c canvasx $x]
    set y [.c canvasy $y]
    foreach {row col} [GetCellRowCol $x $y] break
    if {$row < 0 || $col < 0 || $row >= $S(rows) || $col >= $S(cols)} return
 
    set CLICK(last) [AlignSelection $CLICK(arow) $CLICK(acol) $row $col]
    foreach {row col} $CLICK(last) break
    ShowSelection $CLICK(arow) $CLICK(acol) $row $col
 }
 # Figure out if mouse selection is horizontal, vertical or diagonal
 proc AlignSelection {r0 c0 r1 c1} {
    set dr [expr {abs($r1 - $r0)}]
    set dc [expr {abs($c1 - $c0)}]
    if {$dr == 0 || $dc == 0} {return [list $r1 $c1]}
    if {$::S(diagonals) && $dr == $dc} {return [list $r1 $c1]}
 
    if {! $::S(diagonals)} {
        if {$dr < $dc} { return [list $r0 $c1] }
        return [list $r1 $c0]
    }
    # Could be improved here--snap to diagonal if close to it
    if {$dr < $dc} { return [list $r0 $c1] }
    return [list $r1 $c0]
 }
 proc BUp {x y} {
    global B CLICK
 
    if {!$B(state) || ![info exists CLICK(last)]} return
    foreach {r1 c1} $CLICK(last) break
    CheckWord $CLICK(arow) $CLICK(acol) $r1 $c1 0
 }
 proc CheckWord {r0 c0 r1 c1 hint} {
    global B
    
    set dr [expr {$r1 > $r0 ? 1 : $r1 < $r0 ? -1 : 0}]
    set dc [expr {$c1 > $c0 ? 1 : $c1 < $c0 ? -1 : 0}]
    
    set word ""
    set r $r0
    set c $c0
    while {1} {
        append word $B($r,$c)                   ;# Build up selected word
        if {$r == $r1 && $c == $c1} break
        incr r $dr
        incr c $dc
    }
    .c delete select
    if {[FoundWord $word]} {                    ;# Found a word
        ShowWord $r0 $c0 $r1 $c1 $hint          ;# Highlight found word
        Winner                                  ;# Did we win
    }
 }
 
 proc ShowSelection {r0 c0 r1 c1} {
    .c delete select
    Highlight $r0 $c0 $r1 $c1 -tag select -fill yellow
 }
 proc ShowWord {r0 c0 r1 c1 {hint 0}} {
    set color [expr {$hint ? "red" : "orange"}]
    Highlight $r0 $c0 $r1 $c1 -tag word -fill $color
    Highlight $r0 $c0 $r1 $c1 -tag outword -fill {}
 }
 proc Highlight {r0 c0 r1 c1 args} {
    global S
    
    if {$r0 != $r1 && $c0 != $c1} {             ;# Diagonal highlight
        if {$c1 < $c0} {
            foreach {r0 c0 r1 c1} [list $r1 $c1 $r0 $c0] break
        }           
        foreach {x0 y0 x1 y1} [GetCellBox $r0 $c0] break
        foreach {x2 y2 x3 y3} [GetCellBox $r1 $c1] break
        if {$r0 < $r1} {                        ;# Going down
            set xy [list $x0 $y0 \
                        [expr {$x0 + $S(cell3)}] $y0 \
                        $x3 [expr {$y3 - $S(cell3)}] \
                        $x3 $y3 \
                        [expr {$x3 - $S(cell3)}] $y3 \
                        $x0 [expr {$y0 + $S(cell3)}]]
        } else {
            set xy [list $x0 $y1 \
                        $x0 [expr {$y1 - $S(cell3)}] \
                        [expr {$x3 - $S(cell3)}] $y2 \
                        $x3 $y2 \
                        $x3 [expr {$y2 + $S(cell3)}] \
                        [expr {$x0 + $S(cell3)}] $y1]
        }
        set radii [list 100 100 100 100 100 100]
    } else {                                    ;# Horizontal or vertical
        if {$r1 < $r0 || $c1 < $c0} {
            foreach {r0 c0 r1 c1} [list $r1 $c1 $r0 $c0] break
        }
        foreach {x0 y0 x1 y1} [GetCellBox $r0 $c0] break
        foreach {x2 y2 x3 y3} [GetCellBox $r1 $c1] break
        set xy [list $x0 $y0 $x3 $y0 $x3 $y3 $x0 $y3]
        set radii [list 100 100 100 100]
    }
 
    set n [eval RoundPoly .c [list $xy] [list $radii] -outline black $args]
    .c lower $n
    .c lower word
 }
 
 proc FoundWord {word} {
    global S B
 
    set n [lsearch -exact $B(words) $word]      ;# Is it a word we want???
    if {$n == -1} {                             ;# No, try backwords
        set word [Reverse $word]
        set n [lsearch -exact $B(words) $word]
        if {$n == -1} {return 0}
    }
    if {[lsearch $B(found) $word] != -1} {return 0} ;# Already found
    
    .tb tag add found [expr {$n+1.0}] [expr {$n+2.0}]
    lappend B(found) $word
    return 1
 }
 proc Reverse {word} {
    for {set i [expr {[string length $word] - 1}]} {$i >= 0} {incr i -1} {
        append rword [string index $word $i]
    }
    return $rword
 }
 
 namespace eval ::Create {
    variable BOARD
    variable backwards 0
    variable diagonals 0
    variable FREQ
 
    array set FREQ {A 8.2 B 1.5 C 2.8 D 4.3 E 12.7 F 2.1 G 2.0 H 6.1 I 7.0
        J 0.1 K 0.8 L 4.0 M 2.4 N 6.7 O 7.5 P 1.9 Q 0.1 R 6.0 S 6.3 T 9.1
        U 2.7 V 1.0 W 2.4 X 0.2 Y 2.0 Z 0.1}
 
 }
 proc ::Create::Board {n_board} {
    variable BOARD
    variable backwards $::S(backwards)
    variable diagonals $::S(diagonals)
    
    upvar $n_board master
 
    ::Create::ClearBoard 
 
    set words [::Create::GetWords $::S(count)]
    ::Create::InsertWords $words
    ::Create::FinishBoard
    array unset master
    array set master [array get BOARD]
 }
 proc ::Create::InsertWords {wordlist} {
    variable BOARD
    variable backwards
    variable diagonals
    global S
 
    # Sort biggest word first for easier layout
    set i -1
    foreach word $wordlist {
        incr i
        lset wordlist $i [list $word [string length $word]]
    }
    set wordlist [lsort -decreasing -index 1 $wordlist]
    
    set dirs {r d}
    if {$backwards} {lappend dirs l u}
    if {$diagonals} {lappend dirs ne se}
    if {$backwards && $diagonals} {lappend dirs nw sw}
    
    set BOARD(words) {}
    set BOARD(found) {}
    foreach word $wordlist {
        set word [lindex $word 0]
        for {set try 0} {$try < 100} {incr try} {
            set row [expr {int(rand() * $S(rows))}]
            set col [expr {int(rand() * $S(cols))}]
            set dir [lindex $dirs [expr {int(rand() * [llength $dirs])}]]
            set n [::Create::TryToPlace $word $row $col $dir]
            if {$n != {}} {
                lappend BOARD(words) $word
                set BOARD(soln,$word) $n
                break
            }
        }
    }
    set BOARD(words) [lsort $BOARD(words)]
    if {$S(debug) && [llength $BOARD(words)] != [llength $wordlist]} {
        set msg "ERROR: could only fit [llength $BOARD(words)] words"
        tk_messageBox -icon error -title "$S(title) Error" -message $msg
    }
 }
 proc ::Create::GetWords {cnt} {
    global WORDS
 
    # Shuffle the whole list--it's short enough
    set len [llength $WORDS]
    set len2 $len
    for {set i 0} {$i < $len-1} {incr i} {
        set n [expr {int($i + $len2 * rand())}]
        incr len2 -1
        
        # Swap elements at i & n
        set temp [lindex $WORDS $i]
        lset WORDS $i [lindex $WORDS $n]
        lset WORDS $n $temp
    }
 
    set myWords {}
    foreach word $WORDS {
        if {[string length $word] > $::S(longest)} continue
        if {[string length $word] < $::S(shortest)} continue
        lappend myWords $word
        if {[incr cnt -1] <= 0} break
    }
    return $myWords
    
 
    
    set len [llength $WORDS]
    if {$cnt > $len} {set cnt $len}
    for {set i 0} {$i < $cnt} {incr i} {
        set n [expr {int($i + $len * rand())}]
        incr len -1
        
        # Swap elements at i & n
        set temp [lindex $WORDS $i]
        lset WORDS $i [lindex $WORDS $n]
        lset WORDS $n $temp
    }
    return [lrange $WORDS 0 [expr {$cnt - 1}]]
 }
                         
 proc ::Create::ClearBoard {} {
    variable BOARD
    global S
 
    array unset BOARD
    foreach row [list -1 $S(rows)] {
        for {set col -1} {$col <= $S(cols)} {incr col} {
            set BOARD($row,$col) -1
        }
    }
    foreach col [list -1 $S(cols)] {
        for {set row -1} {$row <= $S(rows)} {incr row} {
            set BOARD($row,$col) -1
        }
    }
 
 }
 
 proc ::Create::TryToPlace {word row col dir} {
    variable BOARD
 
    array set delta {u {-1 0} d {1 0} l {0 -1} r {0 1}}
    array set delta {nw {-1 -1} ne {-1 1} sw {1 -1} se {1 1}}
    foreach {dr dc} $delta($dir) break
 
    set len [string length $word]
    for {set i 0} {$i < $len} {incr i} {
        set r [expr {$row + $i*$dr}]
        set c [expr {$col + $i*$dc}]
        if {[info exists BOARD($r,$c)]} { return {}}
    }
    for {set i 0} {$i < $len} {incr i} {
        set r [expr {$row + $i*$dr}]
        set c [expr {$col + $i*$dc}]
        set BOARD($r,$c) [string index $word $i]
    }
    return [list $row $col $r $c]
 }
 proc ::Create::FinishBoard {} {
    variable BOARD
    global S
 
    for {set row 0} {$row < $S(rows)} {incr row} {
        for {set col 0} {$col < $S(cols)} {incr col} {
            if {[info exists BOARD($row,$col)]} continue
            set BOARD($row,$col) [::Create::RandomLetter]
            if {[info exists S(debug)] && $S(debug)} {
                set BOARD($row,$col) "."
            }
        }
    }
 }
 proc ::Create::RandomLetter {} {
    variable FREQ
    
    set n [expr {rand() * 100}]
    set nn $n
    foreach {letter perc} [array get FREQ] {
        if {$n < $perc} {return $letter}
        set n [expr {$n - $perc}]
    }
    error "ERROR: RandomLetter failed: $nn"
 }
 
 # From https://wiki.tcl-lang.org/DrawingRoundedPolygons
 proc RoundPoly {w xy radii args} {
    set lenXY [llength $xy]
    set lenR [llength $radii]
    if {$lenXY != 2 * $lenR} {
        error "wrong number of vertices and radii: $lenXY $lenR"
    }
 
    # Walk down vertices keeping previous, current and next
    foreach {x0 y0} [lrange $xy end-1 end] break
    foreach {x1 y1} $xy break
    eval lappend xy [lrange $xy 0 1]
    set knots {}                                ;# These are the control points
 
    for {set i 0} {$i < $lenXY} {incr i 2} {
        set radius [lindex $radii [expr {$i/2}]]
        set r [winfo pixels $w $radius]
 
        foreach {x2 y2} [lrange $xy [expr {$i + 2}] [expr {$i + 3}]] break
        set z [_RoundPoly2 $x0 $y0 $x1 $y1 $x2 $y2 $r]
        eval lappend knots $z
 
        foreach {x0 y0} [list $x1 $y1] break    ;# Current becomes previous
        foreach {x1 y1} [list $x2 $y2] break    ;# Next becomes current
    }
    set n [eval $w create polygon $knots -smooth 1 $args]
    return $n
 }
 proc _RoundPoly2 {x0 y0 x1 y1 x2 y2 radius} {
    set d [expr { 2 * $radius }]
    set maxr 0.75
 
    set v1x [expr {$x0 - $x1}]
    set v1y [expr {$y0 - $y1}]
    set v2x [expr {$x2 - $x1}]
    set v2y [expr {$y2 - $y1}]
 
    set vlen1 [expr {sqrt($v1x*$v1x + $v1y*$v1y)}]
    set vlen2 [expr {sqrt($v2x*$v2x + $v2y*$v2y)}]
    if {$d > $maxr * $vlen1} {
        set d [expr {$maxr * $vlen1}]
    }
    if {$d > $maxr * $vlen2} {
        set d [expr {$maxr * $vlen2}]
    }
 
    lappend xy [expr {$x1 + $d * $v1x/$vlen1}] [expr {$y1 + $d * $v1y/$vlen1}]
    lappend xy $x1 $y1
    lappend xy [expr {$x1 + $d * $v2x/$vlen2}] [expr {$y1 + $d * $v2y/$vlen2}]
 
    return $xy
 }
 
 proc Winner {} {
    global B
 
    if {[llength $B(words)] != [llength $B(found)]} {return 0}
    Banner " You Won! "
    
    set bg [.c cget -bg]                        ;# Blink the screen
    for {set i 0} {$i < 4} {incr i} {
        foreach color [list white $bg] {
            .c config -bg $color
            update
            after 100
        }
    }
    .c bind banner <Button-1> NewBoard
    .c bind banner2 <Button-1> NewBoard
 
    set B(state) 0                              ;# Not playing
    return 1
 }
 proc Banner {msg} {
    .c create text 0 0 -tag banner -text $msg -font {Times 36 bold} -fill white
    set xy [.c bbox banner]
    .c create rect $xy -tag banner2 -fill black -outline gold -width 4
    .c raise banner
 }
 proc Hint {{all 0}} {
    if {! $::B(state)} return
 
    foreach word $::B(words) {
        if {[lsearch $::B(found) $word] != -1} continue
        eval CheckWord $::B(soln,$word) 1
        if {! $all} break
        update
    }
 }
 
 namespace eval ::Config {
    variable C
    variable vars {count rows cols shortest longest backwards diagonals debug}
 }
 proc ::Config::Go {} {
    global S
 
    # Check for toggling off
    if {[winfo exists .config] && [winfo ismapped .config]} {
        grid forget .config
        return
    }
 
    # Here to display it
    if {! [winfo exists .config]} {
        foreach var $::Config::vars {set ::Config::C($var) $S($var)}
        
        frame .config -relief ridge -bd 2 -padx 5 -pady 5
        
        label .config.title -text "Configuration" -bd 2 -relief raised
        label .config.rows -text "Rows:" -anchor e
        entry .config.erows -textvariable ::Config::C(rows) -width 5 -justify c
        label .config.cols -text "Columns:" -anchor e
        entry .config.ecols -textvariable ::Config::C(cols) -width 5 -justify c
        label .config.cnt -text "Words:" -anchor e
        entry .config.ecnt -textvariable ::Config::C(count) -width 5 -justify c
        label .config.short -text "Shortest:" -anchor e
        entry .config.eshort -textvariable ::Config::C(shortest) -width 5 -justify c
        label .config.long -text "Longest:" -anchor e
        entry .config.elong -textvariable ::Config::C(longest) -width 5 -justify c
 
        checkbutton .config.back -text "Backwards" -anchor w -relief ridge \
            -variable ::Config::C(backwards)
        checkbutton .config.diag -text "Diagonals" -anchor w -relief ridge \
            -variable ::Config::C(diagonals)
        checkbutton .config.debug -text "Debug" -anchor w -relief ridge \
            -variable ::Config::C(debug)
 
        button .config.easy -text "Easy" -command {::Config::Preset easy}
        button .config.medium -text "Medium" -command {::Config::Preset medium}
        button .config.hard -text "Hard" -command {::Config::Preset hard}
        button .config.apply -text "Apply" -command ::Config::Apply \
            -state disabled
 
        grid .config.title - -sticky ew -row 0
        grid rowconfigure .config 1 -minsize 10
        grid .config.rows .config.erows -sticky ew -row 2
        grid .config.cols .config.ecols -sticky ew
        grid .config.cnt .config.ecnt -sticky ew
        grid .config.short .config.eshort -sticky ew
        grid .config.long .config.elong -sticky ew
 
        grid rowconfigure .config 10 -minsize 20
        grid .config.back - -sticky ew -row 11
        grid .config.diag - -sticky ew
        grid .config.debug - -sticky ew
        
        grid rowconfigure .config 20 -minsize 20
        grid .config.easy - -sticky ew -row 21
        grid .config.medium - -sticky ew -pady 5
        grid .config.hard - -sticky ew 
        grid rowconfigure .config 30 -minsize 20
        grid .config.apply - -sticky ew -row 31
 
        grid rowconfigure .config 100 -weight 1
        trace variable ::Config::C w ::Config::Tracer
    }
    grid .config -row 0 -column 2 -sticky n
 }
 proc ::Config::Tracer {var1 var2 op} {
    if {! [winfo exists .config.apply]} return
    .config.apply config -state disabled
    foreach var $::Config::vars {
        if {$::S($var) != $::Config::C($var)} {
            .config.apply config -state normal
            return
        }
    }
 }
 proc ::Config::Apply {} {
    variable vars
    variable C
    global S
 
    set resize [expr {$S(rows) != $C(rows) || $S(cols) != $C(cols)}]
    foreach var $vars {
        if {[info exists C($var)]} {
            set S($var) $C($var)
        }
    }
    set C(count) $C(count)                      ;# Cause trace to fire
    if {$resize} {
        Init
    } else {
        NewBoard 1
    }
 }
 proc ::Config::Preset {how} {
    variable C
    array set H {"easy" {8 8 10 0 1 2 4} "medium" {10 10 10 1 1 3 99}
        "hard" {15 15 20 1 1 3 99}
    }
    foreach {C(rows) C(cols) C(count) C(backwards) C(diagonals) \
                 C(shortest) C(longest)} $H($how) break
    ::Config::Apply
 }
 Init
 DoDisplay
 if {$argc == 1 && [lsearch [list "easy" "medium" "hard"] $argv] > -1} {
    ::Config::Preset $argv
 }
 ShowBoard

billposer - 2020-09-18 18:37:02

This is a nice game. It would, however, have been nice to have a few comments explaining what the major components. It takes some doing to figure out how to modify it.


billposer - 2020-09-18 18:38:02

In GetWords there is some extra code, never executed since it follows an unconditional return:

    set len [llength $WORDS]
    if {$cnt > $len} {set cnt $len}
    for {set i 0} {$i < $cnt} {incr i} {
        set n [expr {int($i + $len * rand())}]
        incr len -1

        # Swap elements at i & n
        set temp [lindex $WORDS $i]
        lset WORDS $i [lindex $WORDS $n]
        lset WORDS $n $temp
    }
    return [lrange $WORDS 0 [expr {$cnt - 1}]]

wjp - 2020-09-21 23:31:11

Here is a modified version with some extensions.

##+##########################################################################
#
# Word Search -- creates and solves word search puzzles
# by Keith Vetter, September 14, 2004
#
# This version modified starting 2008-04-10 by Bill Poser.
# Added ability to read wordlist.
# List of letters from which random letters are chosen as fill
#   is now generated from the wordlist so as to reflect the
#   appropriate writing system.
# If wordlist contains a second column (separated from the first by a tab),
#    it will be used in the word list instead of the words in the first column.
#    This allows the wordlist to consist of, say, the English glosses for words
#    in another language.
# "You won" banner now disappears after two seconds so as to allow contemplation
#    of the completed board.
# Added "Quit" button.
# Added display of elapsed time.
# Both the wordlist and the board now use three different colors. The most recently
# located word is in one color, whether found by the user or hinted. Words previously
# found by the user are in a second color; words previously hinted are in a third color.
#Added ability to define polygraphs, that is, sequences of characters that
#are treated as single units.

# There is a small built-in word list, but words can also be read from files
# either via the GUI or from a file named on the command line.

package require Tk

set Opts(Rows) 14
set Opts(Cols) 14
set Opts(Count) 15
set Opts(BackwardsP) 0
set Opts(DiagonalsP) 0
set Opts(DebugP) 0
set Opts(Shortest) 1
set Opts(Longest) 99

set Opts(BackgroundColor) moccasin

set Pars(Title) "Word Search"
set Pars(WordListWidth) 26
set Pars(WordListHeight) 15

set Pars(PreviouslyFoundColor) coral
set Pars(PreviouslyHintedColor) LightBlue
set Pars(NewlyFoundOrHintedColor) orange
set Pars(SelectionColor) LightGreen
set Pars(SimpleWordListP) 1
set Pars(PreviousFoundWord) [list]

option add *Button.background grey
option add *Checkbutton.background grey

# Word list
set WORDS {
    dog cat horse cow moose deer caribou elk porcupine fisher marten weasel mink rabbit bear muskrat mouse packrat squirrel shrew pika grizzly fox wolverine coyote wolf}
    
# A wrapper for tk_getOpenFile. This ensures that we get the version that
# understands the virtual filesystem in starpacks.
proc myOpenFile {args} {
    return [eval ::tk::dialog::file:: open $args]
}

# Find out what operating system we are running under
proc OSName {} {
    set OS $::tcl_platform(os);
    if {$OS == "Linux"} {set OS "GNU/Linux"};
    return [format "%s %s" $OS  $::tcl_platform(osVersion)]
}

#Convert seconds to minutes and integral seconds
proc SecondsToMSI {t} {
    set Minutes [expr (int($t / 60.0))]
    set SecondsInMinutes [expr {$Minutes * 60.0}]
    set Seconds [expr {int($t  - $SecondsInMinutes)}]
    return [format "%02d:%02d" $Minutes $Seconds]
}

proc UpdateElapsedTime {} {
    set ElapsedSeconds [expr [clock seconds] - $::Pars(StartTime)]
    set ::Pars(ElapsedTime) [SecondsToMSI $ElapsedSeconds]
    after 1000 UpdateElapsedTime
}

# If a file is in the current working directory, remove the path from the
# full file name, stripping it its final component.
proc MinimizeFileName {s} {
    set cwd [pwd];
    set sdir [file dirname $s]
    if {[string equal $cwd $sdir]} {
        return [file tail $s]
    } else {
        return $s;
    }
}
# Convert an integer to a Unicode character.
proc IntToUnicode {n} {
    return [format "%c" $n]
}

# Compare two strings on the basis of their length.
proc LengthCompare {a b} {
    set LenA [string length $a]
    set LenB [string length $b]
    if {$LenA < $LenB} {
        return 1
    } elseif {$LenB < $LenA} {
        return -1
    } else {
        return [string compare $a $b]
    }
}

#Create a mapping of polygraphs to codepoints in the Private Use Area
proc CreateCompressionMap {MGList} {
    if {[llength $MGList] == 0} {set ::CompressionMap [list]}
    set new [list]
    set tmp [lsort -command LengthCompare $MGList]
    set Code 0xF000
    foreach e $tmp {
        lappend new $e
        lappend new [IntToUnicode $Code]
        incr Code
    }
    set ::CompressionMap $new
}

#Create a map from codepoints in the Private Use Area to polygraphs
# by inverting the compression map.
proc CreateExpansionMap {} {
    set revlist [list]
    foreach {m n} $::CompressionMap {
        lappend revlist $n
        lappend revlist $m
    }
    set ::ExpansionMap $revlist
}
# Read a word list from a file. If the first line begins with a crosshatch
# it is taken to define a set of polygraphs. The remainder may contain
# either one or two colums, separated by a pipe symbol. The first
# column contains the words. The second column, if present, contains
# their glosses. Here is a sample polygraph definition:
# k' t' p' ts dz ts' tl tl' dl lh gh kh hy sh zh ch ch' ų ą į ǫ ų à è ì ò ù ə̀ ų̀ ą̀ į̀ ǫ̀ ų̀
# It defines as single "letters" both some strings that are normally realized
# as sequences, such as kh, and sequences of characters that are normally
# realized as single characters, such as ą̀, which consists of
# LATIN SMALL LETTER A followed  by COMBINING OGONEK followed by
# COMBINING GRAVE ACCENT. This is a sequence of three Unicode characters
# intended to be displayed as a single letter with diacritics.
proc ReadWordList {args} {
    if {[llength $args]} {
        set fn [lindex $args 0]
    } else {
        set initdir [pwd]
        if {[info exists ::starkit::topdir] } {
            set initdir [file join $::starkit::topdir Wordlists]
        }
        set fn [myOpenFile -title "Word List" -initialdir $initdir]
        if {[string equal $fn ""]} {
            return ;
        }
    }
    set fn [MinimizeFileName $fn]
    if {[catch {open $fn "r"} fh] != 0} {
        return
    }
    array unset ::WordToGloss
    fconfigure $fh -encoding utf-8
    set wl [list]
    set PolygraphList [list]
    unset -nocomplain ::CompressionMap
    unset -nocomplain ::ExpansionMap
    while {![eof $fh]} {
        gets $fh line
        set line [string trim $line]
        if {[string length $line] == 0} {
            continue
        }
        if {[string index $line 0] == "\#"} {
            set ll [string range $line 1 end]
            foreach s $ll {
                lappend PolygraphList $s
            }
            if {[string length $PolygraphList] > 0} {
                CreateCompressionMap $PolygraphList;
            }
        } else {
            set Parts [split $line "|"];
            set raw [string trim [lindex $Parts 0]]
            if {[info exists ::CompressionMap]} {
                set w [string map $::CompressionMap $raw]
            } else {
                set w $raw
            }
            lappend wl $w
            if {[llength $Parts] > 1} {
                set ::Pars(SimpleWordListP) 0
                set raw [string trim [lindex $Parts 1]]
                set ::WordToGloss($w) [string toupper $raw]
            }
        }
    }
    close $fh
    CreateExpansionMap
    set ::Pars(Title) \
        [string map {_ "\u0020"} [lindex [split [file rootname [file tail $fn]] "-"] 0]]
    set ::WORDS $wl
    ::Create::SetFreq $wl
    NewBoard
}

proc Init {} {
    global S B CLICK

    if {[lsearch [font names] myFont] == -1} {
        font create myFont -family Times
        font create wlFont -family Times -size 10
    }
    set size [expr {$::Opts(Rows) > $::Opts(Cols) ? $::Opts(Rows) : $::Opts(Cols)}]
    if {$size < 10} {
        set S(fontsize) 24
    } elseif {$size < 16} {
        set S(fontsize) 18
    } elseif {$size < 26} {
        set S(fontsize) 12
    } else {
        set S(fontsize) 8
    }

    font config myFont -size $S(fontsize)
    set S(cell) [font measure myFont "Wi"]
    set S(cell2) [expr {$S(cell) / 2.0}]
    set S(cell3) [expr {$S(cell) * 2 / 3.0}]
    set S(margin) [expr {$S(cell2) + 5}]

    set S(width) [expr {$S(cell) * $::Opts(Cols) + 2*$S(margin)}]
    set S(height) [expr {$S(cell) * $::Opts(Rows) + 2*$S(margin)}]
    set S(rows2) [expr {($::Opts(Rows)-1) / 2.0}]
    set S(cols2) [expr {($::Opts(Cols)-1) / 2.0}]

    if {[winfo exists .c]} {
        if {[winfo width .c] < $S(width) || [winfo height .c] < $S(height)} {
            $::CANV config -height $S(height) -width $S(width)
            wm geom . {}
        }
        NewBoard 100
    } else {
        NewBoard 0
    }
}
 
proc DoDisplay {} {
    global S B

    wm title . $::Pars(Title)
    frame .ctrl -relief ridge -bd 2 -bg $::Opts(BackgroundColor)
    frame .c -relief raised -bd 2  -bg $::Opts(BackgroundColor)
    label .c.tit -textvariable Pars(Title) -font {Helvetica 15 bold} -bg $::Opts(BackgroundColor)
    set ::CANV [canvas .c.c -relief flat -bd 2 -highlightthickness 0 \
                    -width $S(width) -height $S(height) -bg $::Opts(BackgroundColor)]
    label .c.timer -textvariable Pars(ElapsedTime) -relief sunken -border 2\
        -font {Times 12 bold} -bg $::Opts(BackgroundColor)
    pack .c.tit -side top -expand 1 -fill both -pady {0 3} -anchor c
    pack .c.c   -side top -expand 1 -fill both -pady {3 10}
    pack .c.timer -side top -expand 0 -fill none -pady {0 12}
    grid .c .ctrl -sticky news -padx 5 -pady 3
    grid rowconfigure . 0 -weight 1
    grid columnconfigure . 0 -weight 1

    bind all <Key-F2> {console show}
    bind $::CANV <Configure> {ReCenter %W %h %w}

    DoCtrlFrame
    update
}

proc DoCtrlFrame {} {
    button .rwl   -text "Read Wordlist" -command ReadWordList -bd 4
    .rwl   configure -font "[font actual [.rwl cget -font]] -weight bold"
    button .reset -text "Restart Game" -command ShowBoard -bd 4
    .reset configure -font "[font actual [.reset cget -font]] -weight bold"
    option add *Button.font [.reset cget -font]
    option add *Checkbutton.font [.reset cget -font]
    option add *Label.font [.reset cget -font]
    button .new -text "New Game" -command NewBoard -bd 4
    .new   configure -font "[font actual [.new cget -font]] -weight bold"
    button .print -text "Print" -command PrintGame -bd 4
    .print configure -font "[font actual [.print cget -font]] -weight bold"
    button .quit -text "Quit" -command {exit 0} -bd 4
    .quit configure -font "[font actual [.quit cget -font]] -weight bold"
    button .hint -text "Hint" -command Hint -bd 4
    bind .hint <Button-3> {Hint 1}
    checkbutton .bconfig -text "Configure" -command ::Config::Go -bd 4 \
        -relief raised
    button .about -text About -bd 4 -command \
        [list tk_messageBox -message "$::Pars(Title). Original program by Keith Vetter, Sept 2004.\nModified extensively by Bill Poser beginning  April, 2008 to handle bilingual word lists, polygraphs, etc.. This version was last modified on 21 September 2020. This is Tcl/Tk [info patchlevel] running under [OSName]"]
    .about configure -font "[font actual [.about cget -font]] -weight bold"
    text .tb -width $::Pars(WordListWidth) -height $::Pars(WordListHeight) -bg $::Opts(BackgroundColor) \
        -yscrollcommand {.sb set} -padx 2 \
        -font {Times 10}
    scrollbar .sb -orient vertical -command {.tb yview} -bg $::Opts(BackgroundColor)
    .tb tag configure oldfound  -background $::Pars(PreviouslyFoundColor)
    .tb tag configure oldhinted -background $::Pars(PreviouslyHintedColor)
    grid .tb .sb -in .ctrl -sticky ns -row 0
    grid rowconfigure .ctrl 0 -weight 1
    grid rowconfigure .ctrl 40 -minsize 20
    grid .rwl   - -in .ctrl -sticky ew -pady 2 -padx 2 -row 41
    grid .new - -in .ctrl -sticky ew -pady 2 -padx 2
#    grid .inv - -in .ctrl -sticky ew -pady 2 -padx 2
    grid .reset - -in .ctrl -sticky ew -pady 2 -padx 2
    grid .hint  - -in .ctrl -sticky ew -pady 2 -padx 2
    grid .print - -in .ctrl -sticky ew -pady 2 -padx 2
    grid .quit  - -in .ctrl -sticky ew -pady 2 -padx 2
    grid .about - -in .ctrl -sticky ew -pady 2 -padx 2
    grid rowconfigure .ctrl 99 -minsize 30
    grid .bconfig - -in .ctrl -sticky ew -pady {2 5} -padx 2 -row 100
    grid columnconfigure .ctrl 0 -weight 1
    grid rowconfigure .ctrl 0 -weight 1
}

# Write an image of the board, with words,  fill letters, and ellipses, to a file
# as Postscript.
proc PrintGame {} {
    $::CANV postscript -file WordSearchBoard.ps
    WriteWordList
    WriteGlossList
}
# Write the words actually used in the current puzzle to a file
proc WriteWordList {} {
    set fh [open CurrentWordList.txt w]
    fconfigure $fh -encoding utf-8
    if {[info exists ::ExpansionMap]} {
        foreach w [lsort $::CurrentWordList] {
            puts $fh [string map $::ExpansionMap $w];
        }
    } else {
        foreach w [lsort $::CurrentWordList] {
            puts $fh $w;
        }
    }
    close $fh;
}

# Write the glosses of the words actually used in the current puzzle to a file
proc WriteGlossList {} {
    if {$::Pars(SimpleWordListP) == 1} return;
    set glosses [list]
    foreach w $::CurrentWordList {
        lappend glosses $::WordToGloss($w)
    }
    set fh [open CurrentGlossList.txt w]
    fconfigure $fh -encoding utf-8
    foreach w $glosses {
        puts $fh $w;
    }
    close $fh;
}

proc DrawBoard {} {
    global S B
    $::CANV delete all

    # Outer border
    foreach {x0 y0} [GetCellXY 0 0] break
    foreach {x1 y1} [GetCellXY [expr {$::Opts(Rows)-1}] [expr {$::Opts(Cols)-1}]] break
    set x0 [expr {$x0 - $S(margin)}]
    set y0 [expr {$y0 - $S(margin)}]
    set x1 [expr {$x1 + $S(margin)}]
    set y1 [expr {$y1 + $S(margin)}]
    $::CANV create rect $x0 $y0 $x1 $y1 -width 3
    
    # The letter grid
    for {set row 0} {$row < $::Opts(Rows)} {incr row} {
        for {set col 0} {$col < $::Opts(Cols)} {incr col} {
            set xy [GetCellXY $row $col]
            set tag letter,$row,$col
            set c $B($row,$col);
            if {[info exists ::ExpansionMap]} {
                set txt [string map $::ExpansionMap $c];
            } else {
                set txt $c;
            }
            # This is where the text is actually put on the board.
            # It comes form the 2d array B.
            $::CANV create text $xy -text $txt -anchor c -font myFont \
                -tag [list letter letter,$row,$col]
        }
    }
   
    bind $::CANV <Button-1> [list BDown %x %y]
    bind $::CANV <B1-Motion> [list BMove %x %y]
    bind $::CANV <ButtonRelease-1> [list BUp %x %y]
}

proc NewBoard {{show 1}} {
    global B WL

    ::Create::Board B
    if {$show} ShowBoard
}

proc ShowBoard {} {
    global B

    set B(state) 1                              ;# Playing
    set B(found) {}
    DrawBoard
    .tb config -state normal                    ;# Add words to list box
    .tb delete 0.0 end
    if {$::Pars(SimpleWordListP)} {
        if {[info exists ::ExpansionMap]} {
            .tb insert end [string map $::ExpansionMap [join $B(words) "\n"]]
        } else {
            .tb insert end [join $B(words) "\n"]
        }
    } else {
        foreach w $B(words) {
            if {[info exists ::WordToGloss($w)]} {
                set wlw $::WordToGloss($w)
            } else {
                set wlw $w
            }
            .tb insert end [format "%s\n" $wlw]
        }
    }
    .tb config -state disabled
    set ::Pars(StartTime) [clock seconds]
    UpdateElapsedTime
}

proc GetCellXY {row col} {
    set x [expr {[expr {$col - $::S(cols2)}] * $::S(cell)}]
    set y [expr {[expr {$row - $::S(rows2)}] * $::S(cell)}]
    return [list $x $y]
}
proc GetCellBox {row col} {
    foreach {x y} [GetCellXY $row $col] break
    return [list [expr {$x - $::S(cell2)}] [expr {$y - $::S(cell2)}] \
                [expr {$x + $::S(cell2)}] [expr {$y + $::S(cell2)}]]
}
proc GetCellRowCol {x y} {
    set row [expr {int(($y+$::S(cell2)) / $::S(cell) + $::S(rows2))}]
    set col [expr {int(($x+$::S(cell2)) / $::S(cell) + $::S(cols2))}]
    return [list $row $col]
}
proc ReCenter {W h w} {                   ;# Called by configure event
    set h2 [expr {$h / 2}] ; set w2 [expr {$w / 2}]
    $W config -scrollregion [list -$w2 -$h2 $w2 $h2]
}

proc BDown {x y} {
    global CLICK B S
    if {! $B(state)} return
    set xx [$::CANV canvasx $x]
    set yy [$::CANV canvasy $y]
    foreach {row col} [GetCellRowCol $xx $yy] break
    if {$row < 0 || $col < 0 || $row >= $::Opts(Rows) || $col >= $::Opts(Cols)} return

    set CLICK(arow) $row
    set CLICK(acol) $col
    set CLICK(last) {}
    BMove $x $y
}
proc BMove {x y} {
    global CLICK B S
    if {! $B(state)} return
    set x [$::CANV canvasx $x]
    set y [$::CANV canvasy $y]
    foreach {row col} [GetCellRowCol $x $y] break
    if {$row < 0 || $col < 0 || $row >= $::Opts(Rows) || $col >= $::Opts(Cols)} return

    set CLICK(last) [AlignSelection $CLICK(arow) $CLICK(acol) $row $col]
    foreach {row col} $CLICK(last) break
    ShowSelection $CLICK(arow) $CLICK(acol) $row $col
}
# Figure out if mouse selection is horizontal, vertical or diagonal
proc AlignSelection {r0 c0 r1 c1} {
    set dr [expr {abs($r1 - $r0)}]
    set dc [expr {abs($c1 - $c0)}]
    if {$dr == 0 || $dc == 0} {return [list $r1 $c1]}
    if {$::Opts(DiagonalsP) && $dr == $dc} {return [list $r1 $c1]}

    if {! $::Opts(DiagonalsP)} {
        if {$dr < $dc} { return [list $r0 $c1] }
        return [list $r1 $c0]
    }
    # Could be improved here--snap to diagonal if close to it
    if {$dr < $dc} { return [list $r0 $c1] }
    return [list $r1 $c0]
}

proc BUp {x y} {
    global B CLICK

    if {!$B(state) || ![info exists CLICK(last)]} return
    foreach {r1 c1} $CLICK(last) break
    CheckWord $CLICK(arow) $CLICK(acol) $r1 $c1 0
}

proc CheckWord {r0 c0 r1 c1 hint} {
    global B

    set dr [expr {$r1 > $r0 ? 1 : $r1 < $r0 ? -1 : 0}]
    set dc [expr {$c1 > $c0 ? 1 : $c1 < $c0 ? -1 : 0}]

    set word ""
    set r $r0
    set c $c0
    while {1} {
        append word $B($r,$c)                   ;# Build up selected word
        if {$r == $r1 && $c == $c1} break
        incr r $dr
        incr c $dc
    }
    $::CANV delete select
    if {[FoundWord $word $hint]} {                    ;# Found a word
        ShowWord $r0 $c0 $r1 $c1 $hint          ;# Highlight found word
        Winner                                  ;# Did we win
    }
}

proc ShowSelection {r0 c0 r1 c1} {
    $::CANV delete select
    Highlight $r0 $c0 $r1 $c1 -tag select -fill $::Pars(SelectionColor)
}

proc ShowWord {r0 c0 r1 c1 {hint 0}} {
    #Change highlight color of previous word
    set len [llength $::Pars(PreviousFoundWord)]
    if {$len > 0} {
        set pid   [lindex $::Pars(PreviousFoundWord) 0]
        if {$len > 1} {
            set phint [lindex $::Pars(PreviousFoundWord) 1]
            if {$phint} {
                set color $::Pars(PreviouslyHintedColor)
            } else {
                set color $::Pars(PreviouslyFoundColor) 
            }
        } else {
            set color $::Pars(PreviouslyFoundColor) 
        }
        $::CANV itemconfigure $pid -fill $color
    }
    #Highlight new word
    set id [Highlight $r0 $c0 $r1 $c1 -tag word -fill $::Pars(NewlyFoundOrHintedColor)]
    Highlight $r0 $c0 $r1 $c1 -tag outword -fill {}
    set ::Pars(PreviousFoundWord) [list $id $hint]
}

proc Highlight {r0 c0 r1 c1 args} {
    global S

    if {$r0 != $r1 && $c0 != $c1} {             ;# Diagonal highlight
        if {$c1 < $c0} {
            foreach {r0 c0 r1 c1} [list $r1 $c1 $r0 $c0] break
        }
        foreach {x0 y0 x1 y1} [GetCellBox $r0 $c0] break
        foreach {x2 y2 x3 y3} [GetCellBox $r1 $c1] break
        if {$r0 < $r1} {                        ;# Going down
            set xy [list $x0 $y0 \
                        [expr {$x0 + $S(cell3)}] $y0 \
                        $x3 [expr {$y3 - $S(cell3)}] \
                        $x3 $y3 \
                        [expr {$x3 - $S(cell3)}] $y3 \
                        $x0 [expr {$y0 + $S(cell3)}]]
        } else {
            set xy [list $x0 $y1 \
                        $x0 [expr {$y1 - $S(cell3)}] \
                        [expr {$x3 - $S(cell3)}] $y2 \
                        $x3 $y2 \
                        $x3 [expr {$y2 + $S(cell3)}] \
                        [expr {$x0 + $S(cell3)}] $y1]
        }
        set radii [list 100 100 100 100 100 100]
    } else {                                    ;# Horizontal or vertical
        if {$r1 < $r0 || $c1 < $c0} {
            foreach {r0 c0 r1 c1} [list $r1 $c1 $r0 $c0] break
        }
        foreach {x0 y0 x1 y1} [GetCellBox $r0 $c0] break
        foreach {x2 y2 x3 y3} [GetCellBox $r1 $c1] break
        set xy [list $x0 $y0 $x3 $y0 $x3 $y3 $x0 $y3]
        set radii [list 100 100 100 100]
    }

    set n [eval RoundPoly $::CANV [list $xy] [list $radii] -outline black $args]
    $::CANV lower $n
    $::CANV lower word
    return $n
}

proc FoundWord {word hint} {
    global S B

    set n [lsearch -exact $B(words) $word]      ;# Is it a word we want???
    if {$n == -1} {                             ;# No, try backwords
        set word [Reverse $word]
        set n [lsearch -exact $B(words) $word]
        if {$n == -1} {return 0}
    }
    if {[lsearch $B(found) $word] != -1} {
        return 0
    };# Already found

    if {$hint} {
        .tb tag add oldhinted [expr {$n+1.0}] [expr {$n+2.0}]
    } else {
        .tb tag add oldfound [expr {$n+1.0}] [expr {$n+2.0}]
    }
    .tb tag delete newfound
    .tb tag add newfound [expr {$n+1.0}] [expr {$n+2.0}]
    .tb tag configure newfound -background $::Pars(NewlyFoundOrHintedColor)
    lappend B(found) $word
    return 1
}

proc Reverse {word} {
    for {set i [expr {[string length $word] - 1}]} {$i >= 0} {incr i -1} {
        append rword [string index $word $i]
    }
    return $rword
}
namespace eval ::Create {
    variable BOARD
    variable backwards 0
    variable diagonals 0
}

#Create a new FREQ array for generating random characters as fill
#from a word list.
proc ::Create::SetFreq {wl} {
    set total 0
    foreach w $wl {
        set Letters [split $w ""]
        foreach l $Letters {
            incr total
            if {[info exists cnts($l)]} {
                incr cnts($l)
            } else {
                set cnts($l) 1
            }
        }
    }
    set new [list]
    foreach c [array names cnts] {
        lappend new $c
        lappend new [expr {100.0 * double($cnts($c)) / double($total)}]
    }
    array unset ::FREQ
    array set ::FREQ $new
}

proc ::Create::Board {n_board} {
    variable BOARD
    variable backwards $::Opts(BackwardsP)
    variable diagonals $::Opts(DiagonalsP)

    upvar $n_board master

    ::Create::ClearBoard

    set words [::Create::GetWords $::Opts(Count)]
    ::Create::InsertWords $words
    ::Create::FinishBoard
    array unset master
    array set master [array get BOARD]
}

proc ::Create::InsertWords {wordlist} {
    variable BOARD
    variable backwards
    variable diagonals
    global S

    # Sort biggest word first for easier layout
    set i -1
    foreach word $wordlist {
        incr i
        lset wordlist $i [list $word [string length $word]]
    }
    set wordlist [lsort -decreasing -index 1 $wordlist]

    set dirs {r d}
    if {$backwards} {lappend dirs l u}
    if {$diagonals} {lappend dirs ne se}
    if {$backwards && $diagonals} {lappend dirs nw sw}

    set BOARD(words) {}
    set BOARD(found) {}
    foreach word $wordlist {
        set word [lindex $word 0]
        for {set try 0} {$try < 100} {incr try} {
            set row [expr {int(rand() * $::Opts(Rows))}]
            set col [expr {int(rand() * $::Opts(Cols))}]
            set dir [lindex $dirs [expr {int(rand() * [llength $dirs])}]]
            set n [::Create::TryToPlace $word $row $col $dir]
            if {$n != {}} {
                lappend BOARD(words) $word
                set BOARD(soln,$word) $n
                break
            }
        }
    }
    set BOARD(words) [lsort $BOARD(words)]
    set ::CurrentWordList $BOARD(words)
    if {$::Opts(DebugP) && [llength $BOARD(words)] != [llength $wordlist]} {
        set msg "ERROR: could only fit [llength $BOARD(words)] words"
        tk_messageBox -icon error -title "$::Pars(Title) Error" -message $msg
    }
}

proc ::Create::GetWords {cnt} {
    global WORDS

    # Shuffle the whole list--it's short enough
    set len [llength $WORDS]
    set len2 $len
    for {set i 0} {$i < $len-1} {incr i} {
        set n [expr {int($i + $len2 * rand())}]
        incr len2 -1

        # Swap elements at i & n
        set temp [lindex $WORDS $i]
        lset WORDS $i [lindex $WORDS $n]
        lset WORDS $n $temp
    }

    set myWords {}
    foreach word $WORDS {
        if {[string length $word] > $::Opts(Longest)} continue
        if {[string length $word] < $::Opts(Shortest)} continue
        lappend myWords $word
        if {[incr cnt -1] <= 0} break
    }
    return $myWords
}

proc ::Create::ClearBoard {} {
    variable BOARD
    global S

    array unset BOARD
    foreach row [list -1 $::Opts(Rows)] {
        for {set col -1} {$col <= $::Opts(Cols)} {incr col} {
            set BOARD($row,$col) -1
        }
    }
    foreach col [list -1 $::Opts(Cols)] {
        for {set row -1} {$row <= $::Opts(Rows)} {incr row} {
            set BOARD($row,$col) -1
        }
    }

}

proc ::Create::TryToPlace {word row col dir} {
    variable BOARD

    array set delta {u {-1 0} d {1 0} l {0 -1} r {0 1}}
    array set delta {nw {-1 -1} ne {-1 1} sw {1 -1} se {1 1}}
    foreach {dr dc} $delta($dir) break

    set len [string length $word]
    for {set i 0} {$i < $len} {incr i} {
        set r [expr {$row + $i*$dr}]
        set c [expr {$col + $i*$dc}]
        if {[info exists BOARD($r,$c)]} { return {}}
    }
    for {set i 0} {$i < $len} {incr i} {
        set r [expr {$row + $i*$dr}]
        set c [expr {$col + $i*$dc}]
        set BOARD($r,$c) [string index $word $i]
    }
    return [list $row $col $r $c]
}

proc ::Create::FinishBoard {} {
    variable BOARD
    global S

    for {set row 0} {$row < $::Opts(Rows)} {incr row} {
        for {set col 0} {$col < $::Opts(Cols)} {incr col} {
            if {[info exists BOARD($row,$col)]} continue
            set BOARD($row,$col) [::Create::RandomLetter]
            if {[info exists ::Opts(DebugP)] && $::Opts(DebugP)} {
                set BOARD($row,$col) "."
            }
        }
    }
}

proc ::Create::RandomLetter {} {
    set n [expr {rand() * 100}]
    set nn $n
    foreach {letter perc} [array get ::FREQ] {
        if {$n < $perc} {return $letter}
        set n [expr {$n - $perc}]
    }
    error "ERROR: RandomLetter failed: $nn"
}

# From https://wiki.tcl-lang.org/DrawingRoundedPolygons
proc RoundPoly {w xy radii args} {
    set lenXY [llength $xy]
    set lenR [llength $radii]
    if {$lenXY != 2 * $lenR} {
        error "wrong number of vertices and radii: $lenXY $lenR"
    }

    # Walk down vertices keeping previous, current and next
    foreach {x0 y0} [lrange $xy end-1 end] break
    foreach {x1 y1} $xy break
    eval lappend xy [lrange $xy 0 1]
    set knots {}                                ;# These are the control points

    for {set i 0} {$i < $lenXY} {incr i 2} {
        set radius [lindex $radii [expr {$i/2}]]
        set r [winfo pixels $w $radius]

        foreach {x2 y2} [lrange $xy [expr {$i + 2}] [expr {$i + 3}]] break
        set z [_RoundPoly2 $x0 $y0 $x1 $y1 $x2 $y2 $r]
        eval lappend knots $z

        foreach {x0 y0} [list $x1 $y1] break    ;# Current becomes previous
        foreach {x1 y1} [list $x2 $y2] break    ;# Next becomes current
    }
    set n [eval $w create polygon $knots -smooth 1 $args]
    return $n
}

proc _RoundPoly2 {x0 y0 x1 y1 x2 y2 radius} {
    set d [expr { 2 * $radius }]
    set maxr 0.75

    set v1x [expr {$x0 - $x1}]
    set v1y [expr {$y0 - $y1}]
    set v2x [expr {$x2 - $x1}]
    set v2y [expr {$y2 - $y1}]

    set vlen1 [expr {sqrt($v1x*$v1x + $v1y*$v1y)}]
    set vlen2 [expr {sqrt($v2x*$v2x + $v2y*$v2y)}]
    if {$d > $maxr * $vlen1} {
        set d [expr {$maxr * $vlen1}]
    }
    if {$d > $maxr * $vlen2} {
        set d [expr {$maxr * $vlen2}]
    }

    lappend xy [expr {$x1 + $d * $v1x/$vlen1}] [expr {$y1 + $d * $v1y/$vlen1}]
    lappend xy $x1 $y1
    lappend xy [expr {$x1 + $d * $v2x/$vlen2}] [expr {$y1 + $d * $v2y/$vlen2}]

    return $xy
}

proc Winner {} {
    global B
    if {[llength $B(words)] != [llength $B(found)]} {return 0}
    Banner "You won!"
    after cancel UpdateElapsedTime
    set bg [$::CANV cget -bg]                        ;# Blink the screen
    for {set i 0} {$i < 4} {incr i} {
        foreach color [list white $bg] {
            $::CANV config -bg $color
            update
            after 100
        }
    }
    $::CANV bind banner <Button-1> NewBoard
    $::CANV bind banner2 <Button-1> NewBoard
    after cancel UpdateElapsedTime
    update
    after 2000
    $::CANV delete banner banner2
    set B(state) 0                              ;# Not playing
    return 1
}

proc Banner {msg} {
    $::CANV create text 0 0 -tag banner -text $msg -font {Times 36 bold} -fill white
    set xy [$::CANV bbox banner]
    $::CANV create rect $xy -tag banner2 -fill black -outline gold -width 4
    $::CANV raise banner
}

proc Hint {{all 0}} {
    if {! $::B(state)} return

    foreach word $::B(words) {
        if {[lsearch $::B(found) $word] != -1} continue
        eval CheckWord $::B(soln,$word) 1
        if {! $all} break
        update
    }
}

namespace eval ::Config {
    variable C;# Local mirror of Opts. 
}

proc ::Config::Go {} {

    # Check for toggling off
    if {[winfo exists .config] && [winfo ismapped .config]} {
        grid forget .config
        return
    }

    # Here to display it
    if {! [winfo exists .config]} {
        foreach var [array names ::Opts] {set ::Config::C($var) $::Opts($var)}

        frame .config -relief ridge -bd 2 -padx 5 -pady 5

        label .config.title -text "Configuration" -bd 2 -relief raised
        label .config.rows -text "Rows:" -anchor e
        entry .config.erows -textvariable ::Config::C(Rows) -width 5 -justify c
        label .config.cols -text "Columns:" -anchor e
        entry .config.ecols -textvariable ::Config::C(Cols) -width 5 -justify c
        label .config.cnt -text "Words:" -anchor e
        entry .config.ecnt -textvariable ::Config::C(Count) -width 5 -justify c
        label .config.short -text "Shortest:" -anchor e
        entry .config.eshort -textvariable ::Config::C(Shortest) -width 5 -justify c
        label .config.long -text "Longest:" -anchor e
        entry .config.elong -textvariable ::Config::C(Longest) -width 5 -justify c

        checkbutton .config.back -text "Backwards" -anchor w -relief ridge \
            -variable ::Config::C(BackwardsP)
        checkbutton .config.diag -text "Diagonals" -anchor w -relief ridge \
            -variable ::Config::C(DiagonalsP)
        checkbutton .config.debug -text "Debug" -anchor w -relief ridge \
            -variable ::Config::C(debug)

        button .config.easy -text "Easy" -command {::Config::Preset easy}
        button .config.medium -text "Medium" -command {::Config::Preset medium}
        button .config.hard -text "Hard" -command {::Config::Preset hard}
        button .config.apply -text "Apply" -command ::Config::Apply \
            -state disabled

        grid .config.title - -sticky ew -row 0
        grid rowconfigure .config 1 -minsize 10
        grid .config.rows .config.erows -sticky ew -row 2
        grid .config.cols .config.ecols -sticky ew
        grid .config.cnt .config.ecnt -sticky ew
        grid .config.short .config.eshort -sticky ew
        grid .config.long .config.elong -sticky ew

        grid rowconfigure .config 10 -minsize 20
        grid .config.back - -sticky ew -row 11
        grid .config.diag - -sticky ew
        grid .config.debug - -sticky ew

        grid rowconfigure .config 20 -minsize 20
        grid .config.easy - -sticky ew -row 21
        grid .config.medium - -sticky ew -pady 5
        grid .config.hard - -sticky ew
        grid rowconfigure .config 30 -minsize 20
        grid .config.apply - -sticky ew -row 31

        grid rowconfigure .config 100 -weight 1
        trace add variable ::Config::C write ::Config::Tracer
    }
    grid .config -row 0 -column 2 -sticky n
}
proc ::Config::Tracer {var1 var2 op} {
    if {! [winfo exists .config.apply]} return
    .config.apply config -state disabled
    foreach var [array names ::Opts] {
        if {$::Opts($var) != $::Config::C($var)} {
            .config.apply config -state normal
            return
        }
    }
}
proc ::Config::Apply {} {
    variable C

    set resize [expr {$::Opts(Rows) != $C(Rows) || $::Opts(Cols) != $C(Cols)}]
    foreach var [array names ::Opts] {
        if {[info exists C($var)]} {
            set ::Opts($var) $C($var)
        }
    }
    set C(Count) $C(Count)                      ;# Cause trace to fire
    if {$resize} {
        Init
    } else {
        NewBoard 1
    }
}
proc ::Config::Preset {how} {
    variable C
    array set H {"easy" {8 8 10 0 1 2 4} "medium" {10 10 10 1 1 3 99}
        "hard" {15 15 20 1 1 3 99}
    }
    foreach {C(Rows) C(Cols) C(Count) C(BackwardsP) C(DiagonalsP) \
                 C(Shortest) C(Longest)} $H($how) break
    ::Config::Apply
}

# Execution begins here

# Compute the letter frequencies for the built-in word list.  
::Create::SetFreq $WORDS;

Init
DoDisplay
. configure -bg \#4444FF
if {0} {
    if {$argc == 1 && [lsearch [list "easy" "medium" "hard"] $argv] > -1} {
        ::Config::Preset $argv
    }
}
if {$argc == 1} {
    ReadWordList [lindex $argv 0]
}
ShowBoard