Initial AI Commit.HEADmaster

5 files changed, 188 insertions, 3 deletions

diff --git a/package.yaml b/package.yaml
index 3041f00..68dcea4 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,4 +1,4 @@
-name: jrahm-xmonad
+name: wordleai
 version: 0.0.1
 
 executables:
@@ -8,3 +8,4 @@ executables:
 
 dependencies:
   - base >= 4.0.0
+  - containers
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
diff --git a/stack.yaml b/stack.yaml
index e42fa74..ee1a3a7 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-14.22
+resolver: lts-17.4
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.