Wordle puzzle game in TCL by [[FrBa]], based on the popular online game found on http://www.powerlanguage.co.uk/wordle%|%Wordle%|%web site and mobile app.

A game similar to Mastermind, but with a five letter word as the hidden solution. The player has six guesses to solve the puzzle. Correct letters in the correct position are highlighted in green, correct letters in the incorrect position are highlighted in yellow. Unmatched letters are a dark gray.

The script needs an external word dictionary words.txt that is not included here. This can be found online or from most any linux system at path /usr/share/dict/linux.words

======
#!/bin/sh
# \
exec wish "$0" "$@"

if 0 {
Wordle in TCL/TK, based on web game found at url www.powerlanguage.co.uk/wordle
started 2022-01-16 Frank Bannon
updated 2022-01-21 FB
six guesses of five-letter word
correct guess letter and position turns green
correct guess of letter but wrong position turns yellow
keyboard input shows unused letters dark, used letters green
word dictionary can be found on Linux under /usr/share/dict/linux.words
guessed word must be in word list to be accepted, no random letters accepted
Future updates to add:
flip animation on letters
add hints if selected
add Share button to hide letters but keep colors
add random compliment to each guess level
add Hard mode to force use of partial correct letters on later guesses
}

#catch {console show}

# global variables
array set var {
        wordlen 5
        guesses 6
        font_guess {Arial 30}
        font_keyboard {Arial 18}
        file_words words.txt
        delay 300
        word ""
}
# guesses
array set table {}
# colors
array set color {
        font white
        new gray70
        match green3
        close yellow3
        no gray40
        bg gray20
}

# prefer widgets to canvas
wm title . "TclWordle v0.4 by Frank Bannon 2022-01-21"
#catch {wm iconbitmap . -default wordle.ico}
wm resizable . 0 0
. configure -bg $color(bg)
# create the board of empty guesses
for {set row 1} {$row <= $var(guesses)} {incr row} {
        grid rowconfigure . $row -pad 8
        for {set col 1} {$col <= $var(wordlen)}  {incr col} {
                grid columnconfigure . $col -pad 8
                label .${row}_$col -textvariable table($row,$col) -width 2 \
                        -bg $color(new) -fg $color(font) -font $var(font_guess) \
                        -justify center -relief flat
                grid .${row}_$col -row $row -column $col
        }
}
label .status -bg $color(bg) -fg $color(font) -font $var(font_keyboard)
grid .status -column 1 -columnspan $var(wordlen)
# create the keyboard at bottom
frame .key -border 0 -bg $color(bg)
grid .key -column 1 -columnspan $var(wordlen)
# QWERTY LAYOUT, must find a better method
set row 1
set col 1
foreach k {Q W E R T Y U I O P} {
        label .key.k$k -text $k -width 2 -bg $color(new) -fg $color(font) \
                -font $var(font_keyboard) -justify center -relief flat
        grid .key.k$k -row $row -column $col -padx 2 -pady 1
        incr col
}
incr row
set col 1
foreach k {A S D F G H J K L} {
        label .key.k$k -text $k -width 2 -bg $color(new) -fg $color(font) \
                -font $var(font_keyboard) -justify center -relief flat
        grid .key.k$k -row $row -column $col -padx 2 -pady 1
        incr col
}
incr row
set col 1
foreach k {Z X C V B N M} {
        label .key.k$k -text $k -width 2 -bg $color(new) -fg $color(font) \
                -font $var(font_keyboard) -justify center -relief flat
        grid .key.k$k -row $row -column $col -padx 2 -pady 1
        incr col
}

button .key.new -text New -command new_game -bg $color(bg) -fg $color(font)
grid .key.new -row $row -column 10

# read the raw word dictionary, save only words of length 5
# could create a custom dictionary of only desired words
proc read_dict {args} {
        global var words dict_size
        set dict_size 0
        set whole_size 0
        set words {}
        if {[catch {set fid [open $var(file_words) r]} result]} {
                set msg "Dictionary file $var(file_words) not found."
                puts $msg
                tk_messageBox -default ok -icon error -type ok \
                -message $msg -title "Error reading word dictionary"
                exit
        } else {
                puts "Reading dictionary file $var(file_words)"
                catch {. configure -cursor watch}
                update
                while {[gets $fid word] > -1} {
                        # discard blank lines
                        if {[string length $word] < 1} {continue}
                        incr whole_size
                        # discard words of unneeded length
                        if {[string length $word] != $var(wordlen)} {continue}
                        # discard pronouns
                        if {[string is upper [string index $word 0]]} {continue}
                        # discard numbers and non-letter symbols
                        if {![string is alpha $word]} {continue}
                        # repeat letters are allowed in words
                        # discard words with repeated letters, compare unique chars wih word length
                #        if {[llength [lsort -unique [split $word ""]]] != [string length $word]} {continue}
                        # save word to list
                        lappend words $word
                        incr dict_size
                }
                puts "$whole_size words in dictionary file $var(file_words)"
                puts "$dict_size words of length $var(wordlen)"
                catch {. configure -cursor {}}
                close $fid
        }
        analyze
}
# analyze word database
proc analyze {args} {
        global words freq
        if {![info exists words]} {
                puts "No words database found."
                return
        }
        # overall data
        set numwords [llength $words]
        puts "Word database:"
        puts [format "%-10d %s" $numwords Words]
        puts "Top letters in each position:"
        array set c {}
        foreach word $words {
                set col 1
                foreach char [split $word ""] {
                        if {![info exists c($col,$char)]} {set c($col,$char) 1} else {incr c($col,$char)}
                        incr col
                }
        }
        catch {array unset freq}
        array set freq {}        
        for {set col 1} {$col <= [string length $word]} {incr col} {
                set data [lsort -decreasing -index 1 -dict -stride 2 [array get c $col,*]]
                foreach {l n} $data {
                        set l [lindex [split $l ,] end]
                        lappend freq($col) $l
                }
        }
        parray freq
}
# save reduced list of acceptable words
proc save_words {args} {
        global var words
        set fid [open $var(file_words) w]
        foreach w $words {if {[string length $w] > 1]} {puts $fid $w}}
        close $fid
        puts "wrote [llength $words] words to $var(file_words)"
}
# user enters guess, make uppercase on input, display on input
bind . <Key> {add_input %K}
bind . <Return> check

proc status {str} {
        if {[string length $str]} {puts $str}
        catch {.status configure -text $str}
}

proc add_input {str} {
        global var row col table
        # check if game over
        if {$row > $var(guesses)} {return}
        set str [string trim [string toupper $str]]
        # remove a character
        if {($str == "BACKSPACE" ) || ($str == "DELETE")} {
                if {$col < 2} {return}
                incr col -1
                set table($row,$col) ""
                return
        }
        if {$col > $var(wordlen)} {return}
        # special char
        if {[string length $str] > 1} {return}
        # extra chars are discarded
        if {$col > $var(wordlen)} {return}
        if {![string is alpha $str]} {return}
        status ""
        # display
        set table($row,$col) $str
        incr col
}

# check guess against hidden word
proc check {args} {
        global var row col table color words
        # check if game over
        if {$row > $var(guesses)} {return}
        # check last entry in row is filled
        if {[string length $table($row,$var(wordlen))] < 1} {return}
        # check guess is a valid word, not random letters
        set word ""
        # grab guess letters and construct a word
        for {set col 1} {$col <= $var(wordlen)} {incr col} {
                append word $table($row,$col)
        }
        if {[lsearch $words [string tolower $word]] < 0} {
                # clear guess
                for {set col 1} {$col <= $var(wordlen)} {incr col} {
                        set table($row,$col) ""
                }
                set col 1
                status "$word not a valid guess"
                return
        }
        # check letters against hidden word
        set match 0
        for {set col 1} {$col <= $var(wordlen)} {incr col} {
                # mark with colors
                # slow animated so user can follow
                after $var(delay)
                set char $table($row,$col)
                if {[string match $char [string index $var(word) $col-1]]} {
                        incr match
                        .${row}_$col configure -bg $color(match)
                        .key.k$char configure -bg $color(match)
                } elseif {[string first $char $var(word)] > -1} {
                        .${row}_$col configure -bg $color(close)
                        .key.k$char configure -bg $color(close)
                } else {
                        .${row}_$col configure -bg $color(no)
                        .key.k$char configure -bg $color(no)
                }
                update idletasks
        }
        status "Guess #$row $word"
        if {$match == $var(wordlen)} {
                # win
                status "WIN in $row guesses!"
                # prevent further play
                set row $var(guesses)
        } else {
                # game continues
                if {$row > $var(guesses)} {status "GAME OVER, the word was $var(word)"}
        }
        incr row
        set col 1        
}

proc random {{num 10}} {return [expr {int(rand() * $num)}]}
# new game
proc new_game {args} {
        global var row col table color words freq
        status "New Game"
        # select random word
        set num [random [llength $words]]
        set var(word) [string toupper [lindex $words $num]]
        puts "word is number $num in words list"
        # clear the board
        for {set row 1} {$row <= $var(guesses)} {incr row} {
                for {set col 1} {$col <= $var(wordlen)}  {incr col} {
                        set table($row,$col) ""
                        .${row}_$col configure -bg $color(new)
                }
        }
        # clear the keyboard
        foreach w [winfo children .key] {$w configure -bg $color(new)}
        .key.new configure -bg $color(bg) -fg $color(font)
        set row 1
        set col 1
}

read_dict
new_game
======