Solve variable word length jotto

This commit is contained in:
Joscha 2018-09-21 07:46:59 +00:00
parent 31d83323c8
commit 56c4fce80a
2 changed files with 30 additions and 23 deletions

View file

@ -8,6 +8,7 @@ import System.Exit
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict import Control.Monad.Trans.State.Strict
import qualified Data.Set as S
import qualified Data.Text as T import qualified Data.Text as T
import qualified System.Console.Haskeline as H import qualified System.Console.Haskeline as H
@ -99,11 +100,15 @@ cmdWhat = do
g <- lift get g <- lift get
let showWords = intercalate ", " let showWords = intercalate ", "
case possible g of case possible g of
[ws] -> do [] -> H.outputStrLn "No words are possible."
let guesswords = map (\(Guess w _) -> w) $ filter (\(Guess w n) -> n == length w) $ guesses g [wordlist] -> do
possibleWords = ws \\ guesswords case wordlist of
[] -> H.outputStrLn "No words are possible."
ws@(w:_) -> do
let guesswords = filter (\a -> S.fromList a == S.fromList w) $ map (\(Guess x _) -> x) $ guesses g
possiblewords = ws \\ guesswords
H.outputStrLn "The word is one of the following words:" H.outputStrLn "The word is one of the following words:"
H.outputStrLn $ " " ++ showWords possibleWords H.outputStrLn $ " " ++ showWords possiblewords
H.outputStrLn "These words were already guessed:" H.outputStrLn "These words were already guessed:"
H.outputStrLn $ " " ++ showWords guesswords H.outputStrLn $ " " ++ showWords guesswords
_ -> do _ -> do
@ -140,11 +145,11 @@ loop = do
runLoop :: GuessState -> IO GuessState runLoop :: GuessState -> IO GuessState
runLoop = execStateT (H.runInputT H.defaultSettings loop) runLoop = execStateT (H.runInputT H.defaultSettings loop)
loadAndRun :: Int -> [FilePath] -> IO () loadAndRun :: Int -> Int -> [FilePath] -> IO ()
loadAndRun n files = do loadAndRun a b files = do
wordlists <- mapM readFile files wordlists <- mapM readFile files
let wordlist = concatMap lines wordlists let wordlist = concatMap lines wordlists
cmap = buildClassMap (Just n) wordlist cmap = buildClassMap a b wordlist
g = guessState cmap g = guessState cmap
let wordCount = numberjust $ show $ length wordlist let wordCount = numberjust $ show $ length wordlist
@ -183,8 +188,8 @@ wrongArgs :: IO ()
wrongArgs = do wrongArgs = do
name <- getProgName name <- getProgName
putStrLn " USAGE:" putStrLn " USAGE:"
putStrLn $ name ++ " <word length> <dictionary files>" putStrLn $ name ++ " <min word length> [<max word length>] <dictionary files>"
die "Error: No word length or dictionary given." die "Error: Incorrect arguments"
main :: IO () main :: IO ()
main = do main = do
@ -192,6 +197,8 @@ main = do
case args of case args of
[] -> wrongArgs [] -> wrongArgs
[_] -> wrongArgs [_] -> wrongArgs
(n:files) -> case readMaybe n of (a:b:files) ->
Nothing -> wrongArgs case (readMaybe a, readMaybe b) of
Just number -> loadAndRun number files (Just na, Just nb) -> loadAndRun (min na nb) (max na nb) files
(Just na, Nothing) -> loadAndRun na na (b:files)
_ -> wrongArgs

View file

@ -40,23 +40,23 @@ alphabet = S.fromList ['a'..'z']
{- Loading words -} {- Loading words -}
toClass :: Maybe Int -> String -> Maybe Class toClass :: Int -> Int -> String -> Maybe Class
toClass Nothing word = Just $ S.fromList word --toClass Nothing word = Just $ S.fromList word
toClass (Just n) word = toClass a b word =
let set = S.intersection (S.fromList word) alphabet let set = S.intersection (S.fromList word) alphabet
in if length word == n && S.size set == n in if length word == S.size set && length word >= a && length word <= b
then Just set then Just set
else Nothing else Nothing
preprocessWords :: [String] -> [String] preprocessWords :: [String] -> [String]
preprocessWords = map head . group . sort . map (map toLower) preprocessWords = map head . group . sort . map (map toLower)
buildClassMap :: Maybe Int -> [String] -> ClassMap buildClassMap :: Int -> Int -> [String] -> ClassMap
buildClassMap n = foldr addWord M.empty . preprocessWords buildClassMap a b = foldr addWord M.empty . preprocessWords
where where
addWord :: String -> ClassMap -> ClassMap addWord :: String -> ClassMap -> ClassMap
addWord word cmap = addWord word cmap =
case toClass n word of case toClass a b word of
Nothing -> cmap Nothing -> cmap
Just set -> M.alter (appendWord word) set cmap Just set -> M.alter (appendWord word) set cmap
appendWord :: String -> Maybe [String] -> Maybe [String] appendWord :: String -> Maybe [String] -> Maybe [String]