Wordle assistant

wordle.hs

{-
HOWTO: use 'tellWords' to find possible inputs, guess, and then update 'rules'.
-}
module Main where

import System.IO
import Control.Monad.ST
import Data.Array.MArray
import GHC.Arr

import Data.List
import Data.Char
import Control.Monad
import Data.Ord
import Debug.Trace
import GHC.Stack (HasCallStack)

dictPath :: FilePath
dictPath = "./words.txt"

onlyValidWords :: [String] -> [String]
onlyValidWords = filter (all isLower) . filter (\s -> length s == 5)

loadDict :: IO [String]
loadDict = nub . onlyValidWords . map (map toLower) . lines <$> readFile dictPath

has :: Char -> [String] -> [String]
has c = filter (elem c)

hasn't :: Char -> [String] -> [String]
hasn't c = filter (notElem c)

at :: Char -> Int -> [String] -> [String]
c `at` i = filter (\s -> s!!(i-1) == c)

notat :: Char -> Int -> [String] -> [String]
c `notat` i = filter (\s -> s!!(i-1) /= c) . has c

rules :: [String] -> [String]
rules = hasn't 's' . hasn't 'w' . hasn't 'e' . hasn't 'a' . ('r' `notat` 5)
  . ('r' `at` 2) . hasn't 't' . hasn't 'u' . hasn't 'n' . hasn't 'k'
  . ('p' `notat` 1) . ('i' `at` 3) . ('c' `notat` 4) . hasn't 'y'

tellWords :: IO [String]
tellWords = rules <$> loadDict

-- guess the word that contains the most different characters.
guess :: [String] -> String
guess = maximumBy (comparing (length . nub))

judge :: String -> String -> [String] -> [String]
judge answer input = foldr (.) id (zipWith (curry judgeChar) [0..] input)
  where judgeChar :: (Int, Char) -> [String] -> [String]
        judgeChar (i, c)
          | c == answer!!i = c `at` (i+1)
          | c /= answer!!i && c `elem` answer = c `notat` (i+1)
          | c `notElem` answer = hasn't c
          | otherwise = error "unreachable"

step :: String -> [String] -> [String]
step answer words =
  let g = guess words
  in judge answer g words

solve :: [String] -> String -> Int
solve words answer = (+1) . length . takeWhile (\l -> length l /= 1) $ iterate (step answer) words

-- test :: String -> IO [String]
-- test word = do
--   dict <- loadDict
--   return $ solve dict word

findUnsolvable :: IO [(String, Int)]
findUnsolvable = do
  dict <- loadDict
  let n_steps = zip dict $ map (solve dict) dict
  return $ filter ((>6) . snd) n_steps

main :: IO ()
main = do
  h <- openFile "result.txt" WriteMode
  unsolvables <- findUnsolvable
  mapM_ (hPrint h) unsolvables
  hClose h