diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Greedy.hs | 89 | ||||
| -rw-r--r-- | src/Main.hs | 76 | ||||
| -rw-r--r-- | src/Wordle.hs | 21 |
3 files changed, 185 insertions, 1 deletions
diff --git a/src/Greedy.hs b/src/Greedy.hs new file mode 100644 index 0000000..67a0324 --- /dev/null +++ b/src/Greedy.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE ExistentialQuantification, RankNTypes, GADTs #-} +module Greedy (greedyAI) where + +import Wordle + +import Text.Printf +import Data.List (nub, maximumBy) +import Data.Ord (comparing) +import Data.Set (Set) +import Data.Map (Map) +import Data.Maybe (fromMaybe) + +import qualified Data.Set as Set +import qualified Data.Map as Map + +newtype GreedyState = GreedyState [String] + +greedyAI :: Environment -> AI +greedyAI env = AI + (GreedyState (Set.toList $ wordList env)) + greedyGuess + greedyUpdate + +greedyUpdate :: GreedyState -> Hints -> IO GreedyState +greedyUpdate (GreedyState possibleWords) (Hints hints) = do + let state' = filter matchesHints possibleWords + return $ GreedyState state' + + -- Filters out all the words it can't possibly be base on the hints returned. + where matchesHints word = + flip all (zip hints word) $ \((c, h), w) -> do + case h of + -- The secret word contains the character c, but not in this + -- position. + Contains -> c `elem` word && c /= w + + -- The secret word contains the character c in this position. + Correct -> w == c + + -- The secret word does not contain this character. + DoesNotContain -> c `notElem` word + +greedyGuess :: GreedyState -> Environment -> IO String +greedyGuess (GreedyState possibleWords) env = + case possibleWords of + -- Only one thing left to guess. Go ahead and guess it. + [guess] -> return guess + + -- Return the highest ranked word in the wordList. If there are no words + -- that give any more information (i.e. all possible words left are anagrams + -- of each other), then return an arbitrary word in the possibleWords list. + (h:_) -> + let ans = maximumBy (comparing rankWord) (Set.toList $ wordList env) in + if rankWord ans == 0 + then return h -- Pick an arbitrary one + else return ans + + -- No words left to guess? This is theoretically not possible. + [] -> do + putStrLn "Impossible!!!" + return "" + + where + -- Map of letters to their rankings. Used as a cache. + letterRanks = Map.fromList $ map (\l -> (l, rankLetter l)) ['a'..'z'] + + -- This attempts to rank a word based on how much information that word can + -- offer to the guessing engine. Namely the power of that word to eliminate + -- possible words from the possibleWords list. + -- + -- This is just the sum of the individual rankings for each letter in the + -- word. + rankWord = + sum . + map (\l -> fromMaybe 0 (Map.lookup l letterRanks)) . + nub + + -- A letter's rank is based on how much "elimination power." A letter where + -- exactly half the words contain it and the other half do not is said to + -- have the highest elimination power because it is guaranteed that it will + -- narrow down the options by at least half. + rankLetter l = + let numApplied = + sum $ map + (\word -> if l `elem` word then 1 else 0) + possibleWords + + x = fromIntegral numApplied / fromIntegral (length possibleWords) in + 1 - (x * 2 - 1) ** 2 diff --git a/src/Main.hs b/src/Main.hs index 2d51f8d..5a85849 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,2 +1,76 @@ +{-# LANGUAGE ExistentialQuantification, RankNTypes, GADTs #-} +module Main where -main = putStrLn "Hello, World!" +import Text.Printf +import System.Environment +import Data.Set (Set) +import qualified Data.Set as Set +import System.IO + +import Wordle +import Greedy + +main :: IO () +main = do + argv <- getArgs + + case argv of + (word:_) -> do + env <- + Environment (length word) . + Set.fromList . + filter (\w -> length w == length word) . + lines <$> readFile "nounlist.txt" + + if word `notElem` wordList env + then putStrLn "Word not in wordList" + else runMain 6 env word (greedyAI env) + + _ -> putStrLn "Need one argument" + +playerAI :: AI +playerAI = AI () (\_ env -> do + putStr $ printf "%s\r" (replicate (wordLength env) '.') + hFlush stdout + getLine) (\_ _ -> return ()) + +runMain :: Int -> Environment -> String -> AI -> IO () +runMain round env secretWord (AI state doGuess doUpdate) = do + if round == 0 + then gameOver + else continue + + where + + gameOver = putStrLn "Gave Over" + + continue = do + + guess <- doGuess state env + + if not (guess `Set.member` wordList env) + then do + putStrLn "Word not in wordList" + runMain round env secretWord (AI state doGuess doUpdate) + + else do + let hints = Hints $ zipWith (\g w -> ( + g, + if g == w + then Correct + else if g `elem` secretWord + then Contains + else DoesNotContain)) guess secretWord + + putStrLn $ printHints hints + if guess == secretWord + then putStrLn "Correct!" + else do + newState <- doUpdate state hints + runMain (round - 1) env secretWord (AI newState doGuess doUpdate) + + where printHints (Hints h) = flip concatMap h $ \(c, h) -> + (case h of + Correct -> printf "\x1b[01;7;32m%c\x1b[0m" + Contains -> printf "\x1b[01;7;33m%c\x1b[0m" + _ -> printf "%c") c diff --git a/src/Wordle.hs b/src/Wordle.hs new file mode 100644 index 0000000..d722ffa --- /dev/null +++ b/src/Wordle.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ExistentialQuantification, RankNTypes, GADTs #-} +module Wordle where + +import Data.Set (Set) +import qualified Data.Set as Set + +data Environment = Environment { + wordLength :: Int, + wordList :: Set String +} + +newtype Hints = Hints [(Char, Hint)] + +data Hint = Correct | Contains | DoesNotContain + +data AI where + AI :: forall s. { + internalState :: s, + guessWord :: s -> Environment -> IO String, + updateHints :: s -> Hints -> IO s + } -> AI |