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.
##+##########################################################################
#
# 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
}
ShowBoardbillposer - 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