From 40923c7d8426ff392a6367d8662c67b04c6a35d2 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 20 Sep 2018 16:57:02 +0000 Subject: [PATCH] Implement the algorithm and cli --- app/Main.hs | 180 ++++++++++++++++++++++++++++++++++++++++++++++++++- package.yaml | 4 ++ src/Jotto.hs | 169 +++++++++++++++++++++++++++++++++++++++++++++++ src/Lib.hs | 6 -- 4 files changed, 351 insertions(+), 8 deletions(-) create mode 100644 src/Jotto.hs delete mode 100644 src/Lib.hs diff --git a/app/Main.hs b/app/Main.hs index de1c1ab..a220612 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,182 @@ module Main where -import Lib +import Control.Monad +import Data.List +import Data.Char +import System.Environment +import System.Exit + +import Control.Monad.Trans.Class +import Control.Monad.Trans.State.Strict +import qualified Data.Text as T +import qualified System.Console.Haskeline as H + +import Jotto + +rjust :: Int -> Char -> String -> String +rjust n c = T.unpack . T.justifyRight n c . T.pack + +numberjust :: String -> String +numberjust = rjust 9 ' ' + +type Console = H.InputT (StateT GuessState IO) + +cmdQuit :: Console () +cmdQuit = H.outputStrLn "Goodbye." + +cmdHelp :: Console () +cmdHelp = do + H.outputStrLn "help - show this help (alias: h, ?)" + H.outputStrLn "quit - close the program (alias: q)" + H.outputStrLn "guess - add a guess (alias: g)" + H.outputStrLn "unguess - remove a previous guess (alias: u)" + H.outputStrLn "possible - show all words not yet ruled out (alias: p)" + H.outputStrLn "reset - reset solve state (alias: r)" + H.outputStrLn "status - show current solve state (alias: s)" + H.outputStrLn "what - what words to guess next (alias: w)" + H.outputStrLn "" + +readMaybe :: Read a => String -> Maybe a +readMaybe s = + case reads s of + [(x, "")] -> Just x + _ -> Nothing + +cmdGuess :: String -> String -> Console () +cmdGuess w n = do + let word = map toLower w + case readMaybe n of + Just number -> do + lift $ modify $ removeGuess word + lift $ modify $ addGuess (Guess word number) + H.outputStrLn $ "Added guess: " ++ word ++ " - " ++ show number + Nothing -> H.outputStrLn "Incorrect number format." + H.outputStrLn "" + +cmdUnguess :: String -> Console () +cmdUnguess w = do + let word = map toLower w + lift $ modify $ removeGuess word + H.outputStrLn $ "Removed guess: " ++ w + H.outputStrLn "" + +cmdPossible :: Console () +cmdPossible = do + g <- lift get + let classes = sortOn length $ possible g + showWords = intercalate ", " + mapM_ (H.outputStrLn . showWords) classes + H.outputStrLn "" + +cmdReset :: Console () +cmdReset = do + lift $ modify resetGuesses + H.outputStrLn "Reset all guesses." + H.outputStrLn "" + +cmdStats :: Console () +cmdStats = do + g <- lift get + let cTotal = numberjust $ show $ classesTotal g + wTotal = numberjust $ show $ wordsTotal g + cLeft = numberjust $ show $ classesLeft g + wLeft = numberjust $ show $ wordsLeft g + H.outputStrLn "Using:" + H.outputStrLn $ wTotal ++ " words" + H.outputStrLn $ cTotal ++ " classes" + H.outputStrLn "Possible: " + H.outputStrLn $ wLeft ++ " words" + H.outputStrLn $ cLeft ++ " classes" + H.outputStrLn "" + + H.outputStrLn "Guesses:" + let printGuess (Guess word n) = " " ++ word ++ " - " ++ show n + mapM_ (H.outputStrLn . printGuess) $ reverse $ guesses g + H.outputStrLn "" + +cmdWhat :: Console () +cmdWhat = do + g <- lift get + let next = nextGuesses g + showWords = intercalate ", " + showNextGuess (score, w) = numberjust (show score) ++ ": " ++ showWords w + mapM_ (H.outputStrLn . showNextGuess) next + H.outputStrLn "" + +loop :: Console () +loop = do + line <- H.getInputLine "jotto> " + case words <$> line of + Nothing -> cmdQuit + Just ["quit"] -> cmdQuit + Just ["q"] -> cmdQuit + Just ["help"] -> cmdHelp >> loop + Just ["h"] -> cmdHelp >> loop + Just ["?"] -> cmdHelp >> loop + Just ["guess", word, n] -> cmdGuess word n >> loop + Just ["g", word, n] -> cmdGuess word n >> loop + Just ["unguess", word] -> cmdUnguess word >> loop + Just ["u" , word] -> cmdUnguess word >> loop + Just ["possible"] -> cmdPossible >> loop + Just ["p"] -> cmdPossible >> loop + Just ["reset"] -> cmdReset >> loop + Just ["r"] -> cmdReset >> loop + Just ["status"] -> cmdStats >> loop + Just ["s"] -> cmdStats >> loop + Just ["what"] -> cmdWhat >> loop + Just ["w"] -> cmdWhat >> loop + Just [] -> loop + Just _ -> H.outputStrLn "Command not recognized." >> H.outputStrLn "" >> loop + +runLoop :: GuessState -> IO GuessState +runLoop = execStateT (H.runInputT H.defaultSettings loop) + +loadAndRun :: [FilePath] -> IO () +loadAndRun files = do + wordlists <- mapM readFile files + let wordlist = concatMap lines wordlists + cmap = buildClassMap (Just 5) wordlist + g = guessState cmap + + let wordCount = numberjust $ show $ length wordlist + putStrLn "Found:" + putStrLn $ wordCount ++ " words" + putStrLn "" + + void $ runLoop g + +{- + +loadAndRun :: FilePath -> IO () +loadAndRun file = do + -- Read file + content <- lines <$> readFile file + let words' = map head . group . sort . map (map toLower) $ content + wordNumber = show (length words') + putStrLn $ "Found: " ++ rjust 9 ' ' wordNumber ++ " words" + + -- Load words + let cmap = buildClassMap 5 words' + wordLoadedNumber = show . sum . M.map length $ cmap + putStrLn $ "Using: " ++ rjust 9 ' ' wordLoadedNumber ++ " words" + + -- Enter previous guesses + -- Create GuessState + -- Receive input + -- - next -> calculate a few optimal guesses (alias: n) + -- - guess word number -> add guess (alias: g) + -- - remove word -> remove word from list of words (alias: rm) + -- - restart -> reset GuessState back to initial word list (alias: r) + -- - quit -> quit the program (alias: q) +-} main :: IO () -main = someFunc +main = do + args <- getArgs + case args of + [] -> do + name <- getProgName + putStrLn " USAGE:" + putStrLn $ name ++ " " + die "Error: No dictionary given." + files -> loadAndRun files diff --git a/package.yaml b/package.yaml index 258966e..d8947f8 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,10 @@ description: Please see the README on GitHub at = 4.7 && < 5 +- containers +- haskeline +- text +- transformers library: source-dirs: src diff --git a/src/Jotto.hs b/src/Jotto.hs new file mode 100644 index 0000000..994ba40 --- /dev/null +++ b/src/Jotto.hs @@ -0,0 +1,169 @@ +module Jotto + ( Guess(..) + , Class + , ClassMap + -- * Loading words + , buildClassMap + , classMapWordCount + , GuessState + , guessState + -- * Stats + , guesses + , possible + , classesTotal + , wordsTotal + , classesLeft + , wordsLeft + -- * The Algorithm + , addGuess + , removeGuess + , resetGuesses + , nextGuesses + ) where + +import Data.List +import Data.Char + +import qualified Data.Map as M +import qualified Data.Set as S + +data Guess = Guess String Int + deriving (Show) + +-- type Word = String -- Can't do that, because a Word already exists in the prelude +type Class = S.Set Char +type ClassMap = M.Map Class [String] + +alphabet :: Class +alphabet = S.fromList ['a'..'z'] + +{- Loading words -} + +toClass :: Maybe Int -> String -> Maybe Class +toClass Nothing word = Just $ S.fromList word +toClass (Just n) word = + let set = S.intersection (S.fromList word) alphabet + in if length word == n && S.size set == n + then Just set + else Nothing + +preprocessWords :: [String] -> [String] +preprocessWords = map head . group . sort . map (map toLower) + +buildClassMap :: Maybe Int -> [String] -> ClassMap +buildClassMap n = foldr addWord M.empty . preprocessWords + where + addWord :: String -> ClassMap -> ClassMap + addWord word cmap = + case toClass n word of + Nothing -> cmap + Just set -> M.alter (appendWord word) set cmap + appendWord :: String -> Maybe [String] -> Maybe [String] + appendWord word Nothing = Just [word] + appendWord word (Just ws) = Just $ word : ws + +classMapWordCount :: ClassMap -> Int +classMapWordCount = sum . M.map length + +{- Basic guessing operations -} + +data GuessState = GuessState + { guessed :: [Guess] + , allWords :: ClassMap + } deriving (Show) + +score :: Class -> Class -> Int +score a b = S.size $ S.intersection a b + +{- +maxScore :: Class -> Class -> Int +maxScore a b = min (S.size a) (S.size b) +-} + +filterClassMap :: Guess -> ClassMap -> ClassMap +filterClassMap (Guess word n) cmap = + let c = S.fromList word + in M.filterWithKey (\k _ -> score c k == n) cmap + +{- +filterClassSet :: Guess -> S.Set Class -> S.Set Class +filterClassSet (Guess word n) cset = + let c = S.fromList word + in S.filter (\e -> score c e == n) cset +-} + +possibleWords :: GuessState -> ClassMap +possibleWords g = foldr filterClassMap (allWords g) (guessed g) + +guessState :: ClassMap -> GuessState +guessState cmap = GuessState{guessed=[], allWords=cmap} + +addGuess :: Guess -> GuessState -> GuessState +addGuess guess g = g{guessed=guess : (guessed g)} + +removeGuess :: String -> GuessState -> GuessState +removeGuess w g = + let shouldStay (Guess word _) = word /= w + in g{guessed=filter shouldStay (guessed g)} + +resetGuesses :: GuessState -> GuessState +resetGuesses g = g{guessed=[]} + +{- Stats -} + +guesses :: GuessState -> [Guess] +guesses = guessed + +possible :: GuessState -> [[String]] +possible = M.elems . possibleWords + +classesTotal :: GuessState -> Int +classesTotal = M.size . allWords + +wordsTotal :: GuessState -> Int +wordsTotal = classMapWordCount . allWords + +classesLeft :: GuessState -> Int +classesLeft = M.size . possibleWords + +wordsLeft :: GuessState -> Int +wordsLeft = classMapWordCount . possibleWords + +{- Behold, THE ALGORITHM -} + +-- Based on: +-- A - set of all classes +-- S - set of all possible solution classes +-- +-- 1. for each class a in A, calculate the worst-case score +-- +-- 1.1 for each possible score, calculate how many WORDS (not classes) from S yield this score +-- 1.2 select the maximum score (i. e. the score that eliminates the least words s) +-- 1.3 subtract the maximum score from the size of S to obtain the worst-case score +-- +-- 2. sort A by the following criteria (more important first): +-- +-- * highest worst-case score (higher is better) +-- * a is element of S (if a is in S, it's better) +-- * word count of a (higher is better) + +worstCase :: Class -> M.Map Class Int -> Int +worstCase c cmap = + let solutions = M.mapKeysWith (+) (score c) cmap + zeroes = M.fromList $ zip [1..S.size c] (repeat 0) + solutionsWithZeroes = M.union solutions zeroes + maxHitCount = maximum solutionsWithZeroes + minEliminated = M.size cmap - maxHitCount + in minEliminated + +nextGuesses :: GuessState -> [(Int, [String])] +nextGuesses g = + let pwords = possibleWords g + lpwords = M.map length $ pwords + pclasses = M.keysSet pwords + options1 = M.assocs $ allWords g + options2 = map (\(set, w) -> (set, worstCase set lpwords, w)) options1 + options3 = sortOn (\(_,_,w) -> length w) options2 + options4 = sortOn (\(s,_,_) -> S.member s pclasses) options3 + options5 = sortOn (\(_,c,_) -> c) options4 + in map (\(_,c,w) -> (c,w)) options5 diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index d36ff27..0000000 --- a/src/Lib.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Lib - ( someFunc - ) where - -someFunc :: IO () -someFunc = putStrLn "someFunc"