Implement the algorithm and cli

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 <word> <number> - add a guess                      (alias: g)"
+  H.outputStrLn "unguess <word>        - 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 ++ " <dictionary>"
+      die "Error: No dictionary given."
+    files -> loadAndRun files

package.yaml

@@ -21,6 +21,10 @@ description:         Please see the README on GitHub at <https://github.com/Garm
 
 dependencies:
 - base >= 4.7 && < 5
+- containers
+- haskeline
+- text
+- transformers
 
 library:
   source-dirs: src

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

src/Lib.hs

@@ -1,6 +0,0 @@
-module Lib
-    ( someFunc
-    ) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"