##+##########################################################################
#
# 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 http://wiki.tcl.tk/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
}
ShowBoardKeith 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 2013aug01This expenditure of coding energy deserves an image to show what this script hath wrought.
Getting started
Home • Recent changes • Help • Create new page • Search • Add comments
• Edit