Title:        Word Jumble
Date:         7 Jun 2006 11:41:17 GMT
Site:        81.231.32.23

[Keith Vetter] 2003-11-11 : Here's a fun little anagram game. It scrambles and displays
the letters of a 6-letter word, and you have to find all 3, 4, 5 and 6 letter words that
can be created from those letters within a time limit.

You can play the game either with a mouse--click on a letter to select it, right-click
to undo, click on buttons as needed--or with the keyboard (see help for details).

'''Word List''': ''Word Jumble'' has built into it a small 1,200 word list that should
suffices for a short while. I also have a larger 15,000 word list of just 3-6 letter
words but thought its 100k size was too big for a Wiki page (although such a resource
I find quite valuable). Instead, you can download the word list from [http://www.klimb.org/tcl/wordlist36.eng] (just name it "wordlist36.eng" and save
it in the same directory as this code). Actually you can any word list that you may
have (in any language) as long as the data is parsable with ''foreach''.
----
[KPV] 2004-04-20 : Alas, Google found my wordlist web site and now that page is getting lots
of bogus hits--my page contains all the words in the query so it comes up often.
It's kind of interesting (in a sick way) to see what some people are
searching for, such as "''free men seducing there (pet doges) links''". Anyway, I renamed
the wordlist file and instructed the various crawlers to ignore it so the problem
should go away. 

One consequences is that I had to update the code to know about the new wordlist
file name, and while I was at it I added two new features: '''auto plural''' -- when you
enter a word, it will also check for that word with an "''S''" appended is also valid; and
'''Three letter words''' -- you can chooses whether to include 3-letter words in the 
list of anagrams--see '''LES''''s comment below.

----
[LES]: Cool. I used to have that game in a Franklin handheld dictionary and wasted many hours of my life playing it. Now I wish the code provided a more straightforward method for determining the minimum and maximum length of the words. In my experience, 3 is not a good minimum because it generates too many words that make you go "heck, I'd '''never''' have thought of that". A bit too frustrating, I mean.

----
FB: You can quickly generate a huge word list of over 100,000 English words if you have the aspell package on your Linux system.  This command will give you a nice word list:
     aspell dump master | sort > words.txt  
Red Hat Linux 9 returns about 110,000 words.  Fedora Core 6 provides over 135,000 words.
Possessives and duplicates can be removed with:
     aspell dump master | grep -v "'" | sort | uniq > words.txt

I found this method of making word lists while working on a script to unscramble words, such as in Jumble and Scrabble games.  The working script and the word list are available for download from [http://www.geocities.com/frankbannon/].

----
======
 ##+##########################################################################
 #
 # Word Jumble
 # http://www.gamehouse.com/affiliates/template.jsp?AID=1406
 # by Keith Vetter, November 2003
 #
 # BUGS: palest & prates overflow display area
 # TODO: pause, help about left click & double click, click on up letter
 # 2004-04-20: added auto plural, three letter & wordlist36.eng
 #
 package require Tk
 
 set S(title) "Word Jumble"
 set S(lm) 20                                    ;# Left margin
 set S(sp) 20                                    ;# Word spacing
 set S(state) 1
 set S(color) #248c7c
 set S(wordlist) "wordlist3_6.eng"
 set S(wordlist2) "wordlist36.eng"
 set S(autoPlural) 1
 set S(three) 1
 array set S {score,3 90 score,4 160 score,5 250 score,6 1360}
 
 proc DoDisplay {} {
    global S
 
    wm title . $S(title)
    foreach font [font names] { font delete $font }
    font create bigFont   -family Times -size 24
    font create midFont   -family Times -size 18
    font create smallFont -family Times -size 12
    font create tinyFont  -family Helvetica -size 8 -weight bold
    font create scoreFont -family Times -size 12 -weight bold
    catch {font config scoreFont -family {Monotype Corsiva} -weight bold -size 14}
 
    set S(cell) [expr {[font measure bigFont "W"] + 10}]
    set S(cell2) [expr {$S(cell) / 2}]
 
    menu .m -tearoff 0
    . configure -menu .m
    .m add cascade -menu .m.game -label "Game" -underline 0
    .m add cascade -menu .m.help -label "Help" -underline 0
    menu .m.game -tearoff 0
    .m.game add checkbutton -label "Three letter words" -variable S(three) \
        -command Three
    .m.game add checkbutton -label "Auto Plurals" -variable S(autoPlural)
    .m.game add separator
    .m.game add command -label "End Round" -command [list EndRound "gaveup"]
    .m.game add separator
    .m.game add command -label "Exit" -command exit -underline 1
 
    menu .m.help -tearoff 0
    .m.help add command -label "Help" -command Help
    .m.help add separator
    .m.help add command -label "About" -command About
 
    canvas .c -width 770 -height 380
    .c create rect -100 -100 1000 1000 -tag scrim -fill $S(color)
    pack .c -fill both -expand 1
    frame .f -bg $S(color)
    button .doit -text "End Word" -padx 3 -pady 5 -command EndWord
    .doit configure  -font "[font actual [.doit cget -font]] -size 10"
    option add *Button.font [.doit cget -font]
    button .clear -text "Clear" -padx 3 -pady 5 -command Clear
    button .jumble -text "Jumble" -padx 3 -pady 5 -command Jumble
    button .bgiveup -text "End Round" -padx 3 -pady 5 \
        -command [list EndRound "gaveup"]
 
    set x 250 ; set y 10
    .c create text $S(lm) $y -tag title -font scoreFont -fill white -anchor nw \
        -text "Word\nJumble"
    .c create text $x $y -tag score -font scoreFont -anchor nw -fill white
    foreach {x0 y0 x1 y1} [.c bbox score] { set dy [expr {$y1 - $y0}] }
    incr y $dy
    .c create text $x $y -tag round -font scoreFont -anchor nw -fill white
    incr y $dy
    .c create text $x $y -tag time -font scoreFont -anchor nw -fill white
    .c create text 180 200 -tag msg -fill red -font midFont
 
    set x1 [expr {$S(lm) + $S(cell2)}]          ;# Random letter row
    set y1 260
    set x2 [expr {$S(lm) + $S(cell2)}]          ;# Selected letter row
    set y2 150
    for {set n 0} {$n < 6} {incr n} {
        set xy [box $x1 $y1 $S(cell2)]
        .c create rect $xy -fill black -tag [list l l$n s$n]
        .c move s$n -7 7
        .c create rect $xy -fill [GetColor] -outline black -tag [list l l$n r$n]
        .c create text $x1 $y1 -font bigFont -tag [list l l$n t$n]
        .c bind l$n <Button-1> [list DoClick $n]
 
        # Row where selected letters go
        set xy [box $x2 $y2 $S(cell2)]
        .c create rect $xy -fill cyan -outline white -width 3 -tag [list b b$n]
        .c create text $x2 $y2 -font bigFont -tag [list b b$n bt$n]
 
        incr x1 [expr {$S(cell) + $S(sp)}]
        incr x2 [expr {$S(cell) + 5}]
    }
    set x [lindex [.c bbox l] 2]
    set S(rm) [expr {$x + $S(lm)}]
    .c create line $S(rm) -100 $S(rm) 1000
 
    .c create window [expr {$x+5}] 345 -window .f -tag window -anchor e
    pack .jumble .clear .doit .bgiveup -in .f -side left -padx 2
 
    bind all <Button-3> Do3Click
    bind all <KeyPress> [list KeyPress %A %K]
    .c bind scrim <Double-Button-1> EndWord
 
    # Debugging bindings
    bind .c <Control-Button-1> {puts "point %x %y"}
    bind all <Key-F2> {console show}
    bind .doit <Control-Button-2> {if {$S(state) == 0} {set ::S(time) 10}}
    bind .clear <Control-Button-2> {FillGrid 0}
 
    trace variable S(score) w Tracer
    trace variable S(time) w Tracer
    trace variable S(round) w Tracer
 }
 
 # KeyPress - handle all keypresses, filtering out what we want
 proc KeyPress {char sym} {
    global L B W S
 
    if {$S(state) != 0} return
    if {$sym == "Return"} {                     ;# Return == EndWord
        if {$B(end) == 0 && $W(last) != ""} {
            set chars [split [string toupper $W(last)] ""]
        } else {
            if {$B(end) >= [expr {$S(three) ? 3 : 4}]} EndWord
            return
        }
    } elseif {$sym == "BackSpace" || $sym == "Delete"} { ;# Backspace == undo
        Do3Click
        return
    } elseif {$sym == "space"} {                ;# Space == jumble
        Jumble
        return
    } elseif {$sym == "Escape" || $char == "\x15"} {
        Clear
        return
    } elseif {$char == "\x13"} {                ;# Ctrl-S
        if {$B(end) != 0 || $W(last) == ""} return
        set n1 [regsub -all {s} $W(last) {s} .]
        set n2 [regsub -all {s} $W(word) {s} .]
        if {$n2 <= $n1} return
        set chars [split [string toupper $W(last)] ""]
        lappend chars "S"
    } else {
        set chars [string toupper $char]        ;# Find first matching letter
    }
 
    # Chars is the list of characters to put up
    foreach char $chars {
        for {set i 0} {$i < 6} {incr i} {       ;# Find which tile it is
            if {$L($i,hid) == 1} continue
            if {$L($i) == $char} {
                DoClick $i
                break
            }
        }
    }
 }
 ##+##########################################################################
 #
 # NewGame -- starts a new games, resetting score and round
 #
 proc NewGame {} {
    set ::S(score) 0
    set ::S(round) 0
    NewRound
 }
 proc NewRound {{word {}}} {
    global S
 
    PickWord $word                              ;# Pick word to play with
    ShowWord                                    ;# Create its letters
    MakeGrid                                    ;# And its answer grid
 
    set S(state) 0                              ;# Play mode
    set S(time) 120                             ;# Time remaining
    set S(timer,last) 0
    incr S(round)
    Warn ""
    Timer                                       ;# Start the clock
 }
 ##+##########################################################################
 #
 # EndRound -- handles when time is up or all words are found.
 #
 proc EndRound {{how ""}} {
    global S W
 
    Timer 1                                     ;# Be safe and turn off timer
    Clear                                       ;# Return all letters
    set S(state) 1                              ;# Disable all interactions
    FillGrid 0                                  ;# Show answers
 
    if {$how eq "three"} {
        Dialog 6
        NewGame
        return
    }
 
    set got6 0                                  ;# Did we get a 6 letter word
    foreach word $W(found) {
        if {[string length $word] == 6} {
            set got6 1
            break
        }
    }
 
    if {[llength $W(found)] == $W(cnt)} {       ;# Got all the words
        incr S(score) 3000
        Dialog 1
    } elseif {$got6} {                          ;# Timed out, but next round
        Dialog 2
    } else {                                    ;# Game over
        Dialog [expr {$how eq "gaveup" ? 5 : 3}]
        NewGame
        return
    }
    NewRound
 }
 ##+##########################################################################
 #
 # Tracer -- variable trace to update display of score, time and round
 #
 proc Tracer {var1 var2 op} {
    global S
 
    if {$var1 != "S" && $var1 != "::S"} return
    switch $var2 {
        score {.c itemconfig score -text "Score:  [comma $::S(score)]"}
        time {
            set s [clock format $::S(time) -format "%M:%S"]
            set fill [expr {$::S(time) < 10 ? "red" : "white"}]
            .c itemconfig time -text "Time: [string range $s 1 end]" -fill $fill
        }
        round {.c itemconfig round -text "Round: $::S(round)"}
    }
 }
 ##+##########################################################################
 #
 # ShowWord -- puts current word into the letter squares
 #
 proc ShowWord {} {
    global W L B S
 
    .c raise l                                  ;# Make word visible
    for {set i 0} {$i < 6} {incr i} {
        set L($i) [string toupper [string index $W(display) $i]]
        set L($i,hid) 0
        set L($i,up) -1
        .c itemconfig t$i -text $L($i)
        .c itemconfig r$i -fill [GetColor]
        .c itemconfig bt$i -text {}
    }
    set B(end) 0
    .doit config -state disabled
    .clear config -state disabled
 }
 ##+##########################################################################
 #
 # MakeGrid -- makes the boxes for the anagram words
 #
 proc MakeGrid {} {
    global W S
 
    .c delete grid
 
    array unset GRID
    set lines [split [Wrap $W(all) 23] "\n"]
 
    set cell [expr {[font measure tinyFont "m"] + 3}]
    set cell2 [expr {$cell / 2}]
    set blank $cell
    if {[llength $lines] > 25} { set blank $cell2 }
    set rm [expr {$S(rm) + $S(lm)/2 + $cell2}]
 
    set y 20
    set idx 0
    foreach line $lines {
        if {$line == {}} {                      ;# Blank line
            incr y $blank
            continue
        }
        set x $rm
        foreach word $line {
            foreach letter [split $word ""] {
                set xy [box $x $y $cell2]
                .c create rect $xy -fill white -outline black \
                    -tag [list grid gb gb$idx]
                .c create text $x $y -tag [list grid g$idx] -font tinyFont
                incr idx
                incr x $cell
            }
            incr x $cell2                       ;# Interword spacing
        }
        incr y $cell
    }
    return
 }
 ##+##########################################################################
 #
 # DoClick -- handles clicking on a letter
 #
 proc DoClick {who} {
    global B L S
 
    if {$S(state) != 0} return                  ;# Inactive
    Warn ""
    .c lower l$who                              ;# Make letter disappear
    set L($who,hid) 1
 
    set B($B(end)) $L($who)
    set B($B(end),undo) $who
    set L($who,up) $B(end)
    .c itemconfig bt$B(end) -text $L($who) -fill black
    incr B(end)
    if {$B(end) >= [expr {$S(three) ? 3 : 4}]} {
        .doit config -state normal
    }
    .clear config -state normal
 }
 ##+##########################################################################
 #
 # Do3Click -- handles left click on a word which is undo
 #
 proc Do3Click {} {
    global B L S
    if {$S(state) != 0} return
    Warn ""
    if {$B(end) == 0} return
    incr B(end) -1
    set who $B($B(end),undo)
    .c raise l$who                              ;# Make visible again
    set L($who,hid) 0
 
    #.c itemconfig b$B(end) -fill {}
    .c itemconfig bt$B(end) -text ""
 
    if {$B(end) < 3} {
        .doit config -state disabled
    }
    if {$B(end) == 0} {
        .clear config -state disabled
    }
 }
 ##+##########################################################################
 #
 # shuffle -- randomly shufffles a list
 #
 proc shuffle { list } {
    set len [llength $list]
    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 $list $i]
        lset list $i [lindex $list $n]
        lset list $n $temp
    }
    return $list
 }
 ##+##########################################################################
 #
 # PickWord -- randomly pick a word for this round
 #
 proc PickWord {{word {}}} {
    global sixes W
 
    array unset W
    set W(found) ""
    set W(last) ""
    set W(word) $word
    if {$word == {}} {
        set n [expr {int (rand() * [llength $sixes])}]
        set W(word) [lindex $sixes $n]
    }
 
    set tmp [split $W(word) ""]
    set W(display) [join [shuffle $tmp] ""]
    set W(ana) [join [lsort $tmp] ""]
    BuildWordList
 }
 proc Three {} {
    EndRound three
 }
 ##+##########################################################################
 #
 # BuildWordList -- creates the master list of all legal subwords
 #
 proc BuildWordList {} {
    global ANA W S
    set subwords [subwords $W(ana)]
 
    foreach n {3 4 5 6 all} {set W($n) {}; set W($n,cnt) 0}
    foreach word $subwords {
        if {! [info exists ANA($word)]} continue;# Not in our dictionary
        set n [string length $word]
        set W($n) [concat $W($n) $ANA($word)]   ;# Handle duplicates later
    }
    set W(cnt) 0
    if {! $S(three)} {
        set W(3) {}
    }
    foreach n {3 4 5 6} {
        set W($n) [lsort -unique $W($n)]
        set W(all) [concat $W(all) $W($n)]
        set W($n,cnt) [llength $W($n)]
        incr W(cnt) $W($n,cnt)
    }
 }
 ##+##########################################################################
 #
 # MakeAnaDict -- creates our anagram dictionary from a word list file
 #
 proc MakeAnaDict {{fname ""}} {
    global ANA sixes S
 
    array unset ANA
    set sixes {}
    set data {}
 
    if {$fname == ""} {
        if {[file readable $S(wordlist)]} {
            set fname $S(wordlist)
        } elseif {[file readable $S(wordlist2)]} {
            set fname $S(wordlist2)
        } else {
            set data $::ShortWordList
        }
    }
    if {$fname != ""} {
        set FIN [open $fname r]
        set data [read $FIN]
        close $FIN
    }
    foreach word $data {
        set len [string length $word]
        if {$len < 3 || $len > 6} continue
        if {$len == 6} {lappend sixes $word}
        set word2 [join [lsort [split $word ""]] ""]
        lappend ANA($word2) $word
    }
 }
 ##+##########################################################################
 #
 # subwords -- returns list of all 3+ letter combinations of word
 #
 proc subwords {word} {
    # Build up all possible subsets (as individual lists)
    set subsets [list [list]]
    foreach e [split $word ""] {
        foreach subset $subsets {
            lappend subsets [lappend subset $e]
        }
    }
 
    # Turn subset lists into strings and filter out too short subsets
    set subsets2 {}
    foreach e $subsets {
        if {[llength $e] < 3} continue
        lappend subsets2 [join $e ""]
    }
    return $subsets2
 }
 ##+##########################################################################
 #
 # EndWord -- handles when a user signals that a word is complete
 #
 proc EndWord {} {
    global B W S
 
    if {$S(state) != 0} return
    set word ""
    for {set i 0} {$i < $B(end)} {incr i} {     ;# This is the user's word
        append word $B($i)
    }
    set word [string tolower $word]
    set n [lsearch $W(found) $word]
    if {$n != -1} {return [Warn "\"$word\" used already"]}
    set n [lsearch $W(all) $word]
    if {$n == -1} {return [Warn "What is \"$word\"?"]}
    Warn ""
 
    set W(last) $word
    incr S(score) $S(score,[string length $word])
    set W(found) [concat $W(found) $word]
    AutoPlural
    FillGrid 1                                  ;# Show word in answer grid
    Clear                                       ;# Return letters back down
    if {[llength $W(found)] == $W(cnt)} EndRound;# Did we find all the words?
 }
 proc AutoPlural {} {
    global W S
 
    if {! $S(autoPlural)} return
    set n1 [regsub -all {s} $W(last) {s} .]     ;# Number of "s" in current word
    set n2 [regsub -all {s} $W(word) {s} .]     ;# Number of "s" in jumble
    if {$n2 <= $n1} return
 
    set word "$W(last)s"
    if {[lsearch $W(found) $word] != -1} return ;# Already used
    if {[lsearch $W(all) $word] == -1} return   ;# Bad word
 
    # Here on a valid word
    incr S(score) $S(score,[string length $word])
    set W(found) [concat $W(found) $word]
 }
 proc Clear {} {
    global B S
    if {$S(state) != 0} return
    while {$B(end) > 0} Do3Click                ;# Put letter back down
 }
 ##+##########################################################################
 #
 # Jumble -- rearranges the order of the letters. All up letter go to the end
 #
 proc Jumble {} {
    global L B S
    if {$S(state) != 0} return
 
    set hid {}
    set new {}
    foreach i {0 1 2 3 4 5} {
        if {$L($i,hid)} {
            lappend hid $i
        } else {
            lappend new $i
        }
    }
    set len [llength $new]
    set new2 [shuffle [lrange {0 1 2 3 4 5} 0 [expr {$len - 1}]]]
    set hid2 [shuffle [lrange {0 1 2 3 4 5} $len end]]
 
    set l1 [concat $new $hid]
    set l2 [concat $new2 $hid2]
 
    foreach o $l1 n $l2 {
        set LL($n) $L($o)
        set LL($n,hid) $L($o,hid)
        set LL($n,up) $L($o,up)
        if {$L($o,hid)} {                       ;# Is this one selected
            set B($L($o,up),undo) $n            ;# Update its return location
        }
        .c itemconfig t$n -text $LL($n)
        .c itemconfig r$n -fill [GetColor]
        .c [expr {$LL($n,hid) ? "lower" : "raise"}] l$n
    }
    array set L [array get LL]
 }
 
 proc Wrap {words length} {
    set result ""
    set line ""
    set len 0
    foreach word $words {
        set len2 [string length $word]
        if {$len2 != $len} {                    ;# New width
            if {$line != ""} { append line "\n" }
            append result $line "\n"
            set line ""
        }
        set len $len2
        if {$line == ""} {
            set line $word
        } else {
            set line2 "$line $word"
            if {[string length $line2] > $length} {
                append result $line "\n"
                set line2 $word
            }
            set line $line2
        }
    }
    if {$line != ""} {
        append result $line
    }
    return [string trim $result]
 }
 ##+##########################################################################
 #
 # FillGrid -- shows all the words the user has either found or not found
 #
 proc FillGrid {found} {
    if {$found} {                               ;# Want found list
        set l [FoundList]
        set fill white
    } else {
        set l [MissingList]                     ;# Want not found words
        set fill yellow
    }
    set idx -1
    foreach word $l {
        foreach letter [split $word ""] {
            incr idx
            if {$letter == "?"} {
                if {! $found} continue
                set letter ""
            }
            .c itemconfig g$idx -text $letter
            .c itemconfig gb$idx -fill $fill
        }
    }
 }
 ##+##########################################################################
 #
 # FoundList -- merges the words the user has found w/ the complete list
 # but unfound word's letters are replaced with question marks.
 #
 proc FoundList {} {
    global W
 
    foreach len {3 4 5 6} { set r($len) {}}
    foreach word $W(found) {lappend r([string length $word]) $word}
    foreach len {3 4 5 6} {
        set r($len) [lsort $r($len)]
        set n [expr {$W($len,cnt) - [llength $r($len)]}]
        while {[incr n -1] >= 0} {
            lappend r($len) [string repeat "?" $len]
        }
    }
    return [concat $r(3) $r(4) $r(5) $r(6)]
 }
 ##+##########################################################################
 #
 # MissingList -- like FoundList but w/ "?" for the found words
 #
 proc MissingList {} {
    global W
 
    foreach len {3 4 5 6} { set r($len) {}}
    foreach word $W(found) {
        set len [string length $word]
        lappend r($len) [string repeat "?" $len]
    }
    foreach len {3 4 5 6} {
        foreach word $W($len) {
            if {[lsearch $W(found) $word] >= 0} continue
            lappend r($len) $word
        }
    }
    return [concat $r(3) $r(4) $r(5) $r(6)]
 }
 proc Missing {} {
    global W
 
    set result {}
    foreach word $W(all) {
        if {[lsearch $W(found) $word] == -1} {
            lappend result $word
        }
    }
    Wrap $result 60
 }
 proc GetColor {{v .7}} {
    set light [expr {255 * $v}]                 ;# What we consider "light"
    while {1} {
        set r [expr {int (255 * rand())}]
        set g [expr {int (255 * rand())}]
        set b [expr {int (255 * rand())}]
        if {$r > $light || $g > $light || $b > $light} break
    }
    return [format "\#%02x%02x%02x" $r $g $b]
 }
 
 proc Warn {msg} {
    .c itemconfig msg -text $msg
 }
 proc box {x y n} {
    list [expr {$x - $n}] [expr {$y - $n}] [expr {$x + $n}] [expr {$y + $n}]
 }
 proc comma {num} {
    while {[regsub {^([-+]?\d+)(\d\d\d)} $num "\\1,\\2" num]} {}
    return $num
 }
 proc Timer {{off 0}} {
    global S
 
    foreach aid [after info] {after cancel $aid};# Be safe
    if {$off} return
    if {$S(state) != 0} return
 
    set last $S(timer,last)
    set S(timer,last) [clock seconds]
 
    if {$last > 0} {
        set delta [expr {$last - $S(timer,last)}]
        incr S(time) $delta
        if {$S(time) <= 0} { set S(time) 0 }
    }
    if {$S(time) <= 0} {
        EndRound
    } else {
        after 1000 Timer
    }
 }
 proc Dialog {type} {
    array set msgs {
        1,l1 "Congratulations!"
        1,l2 "You got all the words\n3,000 point bonus"
        1,b "Next Round"
        2,l1 "End of Round"
        2,l2 "You qualify for the next round"
        2,b "Next Round"
        3,l1 "   Game over   "
        3,l2 "Out of time"
        3,b "New Game"
        4,l1 "Click to start\nnew game"
        4,l2 ""
        4,b "New Game"
        5,l1 "   Game over   "
        5,l2 "You gave up"
        5,b "New Game"
        6,l1 "   Game over   "
        6,l2 ""
        6,b "New Game"
    }
    destroy .top
    toplevel .top
    wm geom .top +8888+8888
    wm transient .top .
    wm title .top $::S(title)
 
    set col $::S(color)
    set col2 [::tk::Darken $col 90]
    .top config -bg $col
    frame .top.top -bd 2 -relief ridge -bg $col
    label .top.title -text "Word\nJumble" -font scoreFont -padx 10 -pady 10 \
        -fg white -bg $col
    label .top.l1 -text $msgs($type,l1) -font midFont -bg $col -padx 10
    label .top.l2 -text $msgs($type,l2) -font smallFont -bg $col -padx 10
    button .top.b -text $msgs($type,b) -command {destroy .top} -bg $col \
        -activebackground $col2 -highlightthickness 0 -default disabled
 
    pack .top.top -side top -fill x
    grid .top.title .top.l1 -in .top.top -sticky n
    grid  ^ .top.l2 -in .top.top
    if {$msgs($type,l2) == ""} {destroy .top.l2}
    pack .top.b -pady 10
    if {$type == 4} {update idletasks}
    CenterWindow .top
    focus .top.b
    tkwait window .top
 }
 ##+##########################################################################
 #
 # CenterWindow -- places a toplevel window where we want it
 #
 proc CenterWindow {w} {
    update idletasks
    set wh [winfo reqheight $w]        ; set ww [winfo reqwidth $w]
    set sh [winfo height .]            ; #set sw [winfo width .]
    set sy [winfo y .]                 ; set sx [winfo x .]
    set sw $::S(rm)
 
    set x [expr {$sx + ($sw - $ww)/2}] ; set y [expr {$sy + ($sh - $wh)/2}]
    if {$x < 0} { set x 0 }            ; if {$y < 0} {set y 0}
    wm geometry $w +$x+$y
 }
 
 proc About {} {
    set m "$::S(title)\nby Keith Vetter\nNovember, 2003"
    append m "\n\n[llength $::sixes] words in the word list."
    tk_messageBox -icon info -title "About $::S(title)" -message $m -parent .
    
 }
 proc Help {} {
    catch {destroy .help}
    toplevel .help
    wm transient .help .
    wm title .help "$::S(title) Help"
    if {[regexp {(\+[0-9]+)(\+[0-9]+)$} [wm geom .] => wx wy]} {
        wm geom .help "+[expr {$wx+$::S(rm)+20}]+[expr {$wy+35}]"
    }
    set w .help.t
    text $w -wrap word -width 70 -height 21 -pady 10 -padx 5
    button .help.quit -text Dismiss -command {catch {destroy .help}}
    pack .help.quit -side bottom
    pack $w -side top -fill both -expand 1
 
    $w tag config header -justify center -font bold -foreground red
    $w tag config header2  -justify center -font bold
    set margin [font measure [$w cget -font] " o "]
    set margin2 [font measure [$w cget -font] " o - "]
    $w tag config header3 -lmargin2 $margin
    $w tag config header3 -font "[font actual [$w cget -font]] -weight bold"
    $w tag config n -lmargin1 $margin -lmargin2 $margin
    $w tag config bold -font "[font actual [$w cget -font]] -weight bold" \
        -lmargin1 $margin -lmargin2 $margin
    $w tag config indent -lmargin1 [expr {2*$margin}]
 
    $w delete 1.0 end
    $w insert end "Word Jumble" header "\nby Keith Vetter\n\n" header2
 
    set m "The goal of the game is to form as many words possible from "
    append m "the letters given. To advance to the next round you must form "
    append m "at least one word using all the letters. Longer words score "
    append m "more points and there's a bonus if you find all the words.\n\n"
    $w insert end "Overview\n" header3 $m n
 
    set m "Click on the letters to form words then press '''End Word'''. Click "
    append m "the right button to undo. If "
    append m "you get stuck, press '''Jumble''' to rearrangle the letters. You "
    append m "can also use the keyboard to enter letters:\n"
    $w insert end "How to Play\n" header3 $m n
 
    $w insert end " '''Alpha''' - Enter that letter\n" indent
    $w insert end " '''Enter''' - Enter word or repeat last word\n" indent
    $w insert end " '''Backspace''' - Delete last letter\n" indent
    $w insert end " '''Esc''' - Clear\n" indent
    $w insert end " '''Space''' - Jumble\n" indent
    $w insert end " '''Ctrl-s''' - mystery\n" indent
 
    while {1} {
        set n [$w search -count cnt -regexp {'''.*?'''} 1.0]
        if {$n == ""} break
        set txt [$w get $n "$n + $cnt chars"]
        $w delete $n "$n + $cnt chars"
        $w insert $n [string trim $txt "'"] bold
    }
    $w config -state disabled
 }
 set ShortWordList {
    aba abbe abed able abuse ace aced aces acne acnes acorn act actor
    actors acts acyl add adds ade adept ado ads age aged aging agley
    ago ague aid aide ail ails aim air akin alb albs ale alee ales all
    alley allot allots ally alms also alto alum amulet ana anas and
    anise anode ant ante anted ants anus ape aped apt arc arcs are arm
    arming art arts ascot ash ass assn ate atoll atolls aught august
    aunt aunts auto awe awed awes awing awn axe axed aye baa babe bad
    bade bald bale baled bales ball balled ban bane banner bantam bar
    bare barn base bat batman bead bean bear beau beaus bed bee beef
    beer beers bees beet beg begin begins begs being beings bell belt
    belted bet betel big bin binge binges bingo bins blab blade bled
    bleed blue blues bog bogs bole boles bone bong bonnie boo boom
    booms boos bosom bosomy box boxing boy bra brae bran bus cad can
    cane caned canes canoe canoed cans cant canto cantor car cars cart
    carton carts case casein cast castor cat cats cavity cavy cay cays
    cee cheep cheeps chi chin chink chinks chins city class classy
    clay clays clog cloggy cloy coast coat coats cod coda code coed
    cog col con cone contra corn cost cot cots coy crag craggy crier
    criers cries cry dab dabble dad dads dale dam dame dance dart dash
    date day deacon dead deal dealt dean deans debt deck dee deign
    dell delta demo den dens dent dents dew dice dick dickey did die
    died diet dig dike dim dimly dimply din dine ding dip dire dirt
    dive diver divert diving doc dodo doe dome don done dope dory dot
    dour dourly draw dried drip drive dry due duet duly duo durst dust
    dusty duty dye ear earn east eat eats ebb edge edit eel eft efts
    egad ego egos eke ekes elate elated elf ell ells elm elms ember
    embers emit emu end ends entad eon era ere erg err errs eta etas
    eve eves evoke evokes fee feeble feel fetor fie fir fire fires
    firs first fist fit fits flee flex flu flue flues flux fluxes foe
    foes for fore fores forest fort forte fortes forts foster free
    fret frets fries fro frost fuel fuels fugue fugues fuse gad gag
    gain gained gait gal gale gam game gamely gamin gamy gang gar gas
    gate gaunt gay gee gel geld gels gem gene get giant gibe gibes gig
    gilt gin gins girl girlie gleam glee glen glint glob globe globes
    globs gnat gnaw gnu goat gob gobs goes gone got gout grain gram
    gray grim grin grins gun gust gut guts gym had hag hah hale haled
    halve halved hang has hash hast haste hat hate hates hath hating
    hats haunt have haw hawed haws head heads heal heat heath heaths
    heats held helium helm hem hen hens hep her hero hew hewing hewn
    hews hex hexing hey hick hicks hie hies hilum him hinge hinges
    hint his hit hoax hoaxed hod hoe hoed hoer hood hooded hot hue hug
    hum hung hunt hut ice iced ices icy idea idly ifs ileum ill ills
    imp imply impute incase inch ink inks inn ins ion ire ires iris
    item its ivy jet jib jibing jig jitney jut jute jutted kayo kayoed
    key kid kin king kiosk kiosks kiss kisses lab label labs lac lacy
    lad lade ladle lag lain lam lame lass last late lately lave laved
    lay lays lea lead leas led ledge lee leer leg legend legit legs
    lei lend less let lid lie lien lieu lilt lilts lime limn limp limy
    line ling lint lip list lists lit loam loams loan loans lob lobe
    lobes lobs log loge loges logs logy lord lose lost lot lots loud
    lube lubes lump lumps lust lute lye lyes lying mad made magi main
    making male malt malty man mans manta mar margin mason mat mate
    maul maw may mead meadow meal mealy meat meaty melt men meow meows
    mere meres met metal mew mid mien mil mild mile min mine mingle
    mink mite moan moans mob mobs mod mode mol mols mono moo moon moos
    mop mope moped mopped mow mowed mule muss mute muzzle nab nag nail
    nails nap nape naught neap near neat nebs nee need neigh neighs
    neon nest net nets new nib nibs nice nick nicks nigh night nil
    nine nip nit nix nod node non none nor not nth nun nuns nut nuts
    oak oar oars oat oats obi ocean odd ode oft ogle ogles okay okayed
    old ole once one onyx ore ores ort orts other our out outage over
    overs owe owed oxen oxygen pad pan pane pant panted pat pate paten
    pea peat pedant pee pees peg pelt pen pend pent pep per pert peso
    pet pie pied pier pig piglet pile pin pip pippin pit pits pitter
    plum plums plus ply pod poem pomp pompon poop pop pope pore pores
    pose poser pride prided pried prose prove proves pry psi purist
    pus puss put puts quilt quilts quit quits racy rag rain ram ran
    rang rant rat rats raw ray red reds reef reel ref refit refits
    reflex refs rend rends rent rents rep resift rest ret rets rev
    revs rex rho rice rices rid ride rife rift rifts rig rigs rile rim
    ring rings rip ripe rips rise riser rising rite rites rive rived
    rivet road roan roast roc rocs rod roe roes rope ropes rose rot
    rote rots rove roves row run runs runt runts rusk rust rusty rut
    ruts rye sable sac sacs sad sadden sag sail sails sale salmon
    salon salt sand sanded sane sans sat sate saw sawed say says scaly
    scan scar scat scrota sea seal seat sedan see seek seem seep seer
    self sell sells send sent sere serf serif servo set seta sew sex
    shad shade shah shaw she sheath shed sheep shin shine sic sick
    sift sifter sigh sign sill sills silt silts sin since sine sing
    singe sink sins sip sir sire siring sis sisal sit site sits ski
    skies skin skis slab slain slam slat slay slays slit slits slob
    sloe slog slot slue slum slump slumps slums slut sly smell smelly
    snail snails soar sob soft softer sol sole son sop sore sort sot
    soy spec speech spell spells spit spore spry spur spurt spy stag
    stall star stern still stills stir store strife strip stud study
    stun stunk stunt sturdy sty sub sue suit sum sums sun sunk suntan
    sup sups surd syrup syrupy tab tad tag tags tale tall tally tam
    tame tamely tan tang tans tao tap tape taped tar tarn taro tars
    tat tats tau taunt taunts taut tea teal team teas ted teds tee
    teed tell temp tempi ten tend tends tens tern terns than the
    theory they thin thing throe thug thy tic tide tie tied tier tiers
    ties tile tiling till tills time tin tine tingly tiny tip tips
    tire tired tires tit toad toe toes tog toga toll tolls ton tor
    tore torn tow toward toy trend trends tried tries trip tripe trips
    trite trod troy trunk trunks try tsar tug tugs tun tuna tunas tung
    tuns turd turn turns tusk two tying tyro ump umps ups uptime urn urns
    usable use vade vale vat vatic veal vee vees vela verso vet via
    vie vied vita wad wade wades wads wag waging wan war ward wart was
    wash washed wed weds weigh wen when whine wig win wine wing woad
    woe word yak yam yea yell yells yen yes yet yip yoke yoked yon
    yore you your yurt yurts
 }
 
 ################################################################
 
 
 MakeAnaDict
 DoDisplay
 NewGame                                         ;# Looks nicer
 Timer 1                                         ;# Quit this game
 FillGrid 0                                      ;# and show the answers
 Dialog 4
 NewGame
 return
======
<<categories>> Games | Application | Tcl/Tk Games