wordle-hs/app/Main.hs

module Main where

import System.Console.ANSI
import System.IO
import Data.List
import System.Random
import Data.Char
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.Lazy    as LT
import qualified Data.Text.Lazy.IO as LT
import System.Environment
import Data.Time

maxAttempts :: Integer
maxAttempts = 6

startDate :: UTCTime
startDate = UTCTime (fromGregorian 2021 6 19) 0

err :: String -> IO ()
err s = do
  setSGR [SetColor Foreground Dull Red]
  putStr s
  setSGR [Reset]
  cursorUpLine 1
  clearLine

findGreenMatches :: Char -> String -> String -> Int
findGreenMatches c (gwc:gwt) (awc:awt) = do
  if gwc == c && gwc == awc then
    1 + findGreenMatches c gwt awt
  else
    findGreenMatches c gwt awt
findGreenMatches _ _ _ = 0

findPossibleMatches :: Char -> String -> Int
findPossibleMatches c (awc:awt) = do
  if c == awc then
    1 + findPossibleMatches c awt
  else
    findPossibleMatches c awt
findPossibleMatches _ _ = 0


doGuess :: String -> String -> Int -> IO ()
doGuess givenWord actualWord i = do
  let gwc = givenWord !! i
  let rwc = actualWord !! i
  if gwc == rwc then do
    setSGR [SetColor Background Dull Green]
    setSGR [SetColor Foreground Vivid Black]
  --else if gwc `elem` actualWord && (length $ filter (\(x, y) -> x == y) $ zip givenWord actualWord) >= 1 then do
  else if gwc `elem` actualWord && findPossibleMatches gwc actualWord /= findGreenMatches gwc givenWord actualWord then do
    setSGR [SetColor Background Dull Yellow]
    setSGR [SetColor Foreground Vivid Black]
  else if rwc == '_' then
    setSGR [Reset]
  else
    setSGR [SetColor Background Vivid Black]

  putStr [gwc]
  setSGR [Reset]

  if i == length givenWord - 1 then do
    return ()
  else
    doGuess givenWord actualWord (i + 1)

getWord :: String -> Integer -> [String] -> IO ()
getWord targetWord attempt allWords = do
  if attempt > maxAttempts then do
    putStrLn $ "you failed! the word was " ++ targetWord
  else do
    hFlush stdout
    clearFromCursorToLineEnd
    word <- getLine

    case length word of
      5 -> do
        let lowercase = map toLower word
        if ('\'' `elem` lowercase) || (lowercase `notElem` allWords) then do
          err "invalid word"
          getWord targetWord attempt allWords
        else do
          cursorUpLine 1
          doGuess lowercase targetWord 0
          if lowercase == targetWord then do
            cursorDownLine 1
            putStrLn "you guessed it! :)"
          else do
            cursorDownLine 1
            putStr "\n"
            cursorUpLine 1
            getWord targetWord (attempt + 1) allWords
      0 -> do
        cursorUpLine 1
        clearLine
        getWord targetWord attempt allWords
      _ -> do
        err "invalid word length! must be 5 chars long"
        getWord targetWord attempt allWords

getRandomElem :: StdGen -> [a] -> a
getRandomElem g list = list !! fst (randomR (0, length list - 1) g)

withWordsFile f k = do
  h <- openFile f ReadMode
  k h

wordsIO :: String -> IO [Text]
wordsIO f = withWordsFile f $
  fmap (dropWhile T.null . map (T.concat . LT.toChunks) . LT.lines)
  . LT.hGetContents

main :: IO ()
main = do
  args <- getArgs

  setSGR [SetConsoleIntensity BoldIntensity]
  putStrLn "\n          - wordlehs -          "
  setSGR [Reset]
  putStrLn "guess a 5-letter word by making guesses"

  putStr " - "
  setSGR [SetColor Background Vivid Black]
  putStr "gray"
  setSGR [Reset]
  putStrLn ": no matches found"

  putStr " - "
  setSGR [SetColor Background Dull Yellow]
  setSGR [SetColor Foreground Vivid Black]
  putStr "yellow"
  setSGR [Reset]
  putStrLn ": letter is in word, but in a different location"

  putStr " - "
  setSGR [SetColor Background Dull Green]
  setSGR [SetColor Foreground Vivid Black]
  putStr "green"
  setSGR [Reset]
  putStrLn ": correct letter and location"

  setSGR [SetConsoleIntensity BoldIntensity]
  putStrLn "\n          - examples -          "
  setSGR [Reset]

  putStr " "
  doGuess "weary" "w____" 0
  putStrLn "\nthe letter W is in the word and in the correct spot"
  putStr " "
  doGuess "pills" "_____i" 0
  putStrLn "\nthe letter I is in the word but in the wrong spot"
  putStr " "
  doGuess "vague" "___j_" 0
  putStrLn "\nthe letter U is not in the word in any spot\n"

  cursorDownLine 1
  putStr "\n"
  cursorUpLine 1
  g <- getStdGen

  randomWords <- wordsIO "randomwords"
  validWords <- wordsIO "validwords"

  if "--daily" `elem` args then do
    c <- getCurrentTime
    let day = round (diffUTCTime c startDate / nominalDay)
    putStrLn $ "wordle " ++ show day ++ "\n"
    getWord (T.unpack $ randomWords !! (day `mod` length randomWords)) 1 (map T.unpack validWords)
  else do
    putStrLn "now you give it a try!\n"
    let randWord = map toLower $ getRandomElem g $ filter (\x -> length x == 5 && '\'' `notElem` x) (map T.unpack randomWords)
    getWord randWord 1 (map T.unpack validWords)