176 lines
4.8 KiB
Haskell
176 lines
4.8 KiB
Haskell
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) 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)
|