Verba 0.1.0.0 → 0.1.0.1

raw patch · 7 files changed

+228/−1 lines, 7 files

Files

• Verba.cabal +7/−1
• src/Verba/CLI.hs +57/−0
• src/Verba/Dictionary.hs +28/−0
• src/Verba/Formatting.hs +10/−0
• src/Verba/Puzzle.hs +96/−0
• src/Verba/Solver.hs +24/−0
• src/Verba/Utils.hs +6/−0

@@ -1,5 +1,5 @@ name:                Verba-version:             0.1.0.0+version:             0.1.0.1 synopsis:            A solver for the WordBrain game description:         A solver for the WordBrain game license:             MIT@@ -16,6 +16,12 @@  executable Verba     main-is:            Main.hs+    other-modules:      Verba.CLI,+                        Verba.Dictionary,+                        Verba.Formatting,+                        Verba.Puzzle,+                        Verba.Solver,+                        Verba.Utils     build-depends:      base >= 4.8 && < 4.9,                         matrix >= 0.3 && < 0.4,                         containers >= 0.5 && < 0.6

@@ -0,0 +1,57 @@+module Verba.CLI (runCLI) where++import Data.List (intersperse, intercalate)+import System.IO (hFlush, stdout)+import Verba.Solver (solve)+import Verba.Dictionary (Dictionary)+import Verba.Puzzle (Puzzle)+import Verba.Formatting+import Verba.Utils+import qualified Verba.Dictionary as Dictionary+import qualified Verba.Puzzle as Puzzle++runCLI :: FilePath -> IO ()+runCLI dictFile = do+    putStrLn $ blue "Matrix (row by row):"+    puz <- Puzzle.ask+    putStr $ blue "Word lengths (separated by space): "+    hFlush stdout+    lengths <- getLine >>= (return . map read . words)+    putStr $ blue "Known correct words (separated by space): "+    hFlush stdout+    knownWords <- getLine >>= (return . words)+    dict <- Dictionary.load (maximum lengths) dictFile+    let sols = solve dict lengths puz+    putStrLn "---------------------------------"+    let initFilter = filter (supersetOf knownWords) sols+    confirmSolutions (length lengths) knownWords initFilter++putGuess :: String -> [String] -> [String] -> IO ()+putGuess guessedWord correctOnes guess = do+    let styledWords = map (\w -> if (w `elem` correctOnes)+            then green w+            else if w == guessedWord+                then orange w+                else w) guess+    putStr $ (intercalate " " styledWords) ++ "? "++-- Takes a list of known solutions and a +-- list of grouped solutions (pair of first word and +-- rest of the solutions) and returns the list of confirmed solutions+-- going deep as long as the user confirms.+-- Once all options are exhausted, it returns back the list+-- of confirmed solutions up until now.+confirmSolutions :: Int -> [String] -> [[String]] -> IO ()+confirmSolutions _ _ [] = return ()+confirmSolutions n correctOnes (sol:sols) = do+    let guessedWord = head $ filter (not . (`elem` correctOnes)) sol+    putGuess guessedWord correctOnes sol+    hFlush stdout+    answer <- getLine+    if answer == "y"+        then +            let newCorrectOnes = guessedWord:correctOnes in+            if length newCorrectOnes == n+                then putStrLn "My job here is done! :)"+                else confirmSolutions n newCorrectOnes (filter (elem guessedWord) sols)+        else confirmSolutions n correctOnes (filter (not . elem guessedWord) sols)

@@ -0,0 +1,28 @@+module Verba.Dictionary where++import Data.Map (Map)+import Data.Maybe (fromMaybe)+import qualified Data.Map as Map+import System.IO++type Dictionary = Map Int [String]++-- Pushes a word in the right bucket+-- based on its length.+insertWord :: String -> Dictionary -> Dictionary+insertWord w = Map.alter fn (length w)+    where fn Nothing = Just []+          fn (Just lst) = Just $ w : lst++-- Loads the dictionary so that only words up to+-- the specified length are loaded.+load :: Int -> FilePath -> IO Dictionary+load n file = withFile file ReadMode $ (\handle -> do+    hSetEncoding handle latin1+    contents <- hGetContents handle+    let wordList = takeWhile ((<= n) . length) $ words contents+    return $! foldr insertWord Map.empty wordList)++-- Gets all the words with a certain length.+wordsWithLength :: Int -> Dictionary -> [String]+wordsWithLength n = fromMaybe [] . Map.lookup n

@@ -0,0 +1,10 @@+module Verba.Formatting where++blue :: String -> String+blue str = "\o33[1;34m" ++ str ++ "\o33[0m"++green :: String -> String+green str = "\o33[0;32m" ++ str ++ "\o33[0m"++orange :: String -> String+orange str = "\o33[0;33m" ++ str ++ "\o33[0m"

@@ -0,0 +1,96 @@+module Verba.Puzzle (Puzzle, consume, ask, fromLists) where++import Data.Matrix (Matrix, (!), setElem, ncols, nrows)+import qualified Data.Matrix as Matrix+import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Control.Monad (replicateM)++-- The size of the puzzle needs to be at least 2x2.+newtype Puzzle = Puzzle { getMatrix :: Matrix (Maybe Char) }++instance Show Puzzle where+    show = map (fromMaybe ' ') . intercalate [Just '\n'] . Matrix.toLists . getMatrix++-- Moves the element in the specified position+-- down one cell and puts nothing in its place if the+-- current element has something and the cell below doesn't.+sortWithBelow :: (Int, Int) -> Puzzle -> Puzzle+sortWithBelow current@(i, j) puz@(Puzzle mat) = +    let below = (i + 1, j) in+    if mat ! current /= Nothing && mat ! below == Nothing then+        Puzzle $ setElem Nothing current $ setElem (mat ! current) below mat+    else puz++-- If the above cell contains something and the below+-- one doesn't, it drops the above cell down+fixColumnCell :: (Int, Int) -> Puzzle -> Puzzle+fixColumnCell (1, _) puz = puz +fixColumnCell (i, j) puz =+    let calcIx x = (x, j) in+    foldr sortWithBelow puz (reverse . map calcIx $ [1..(i - 1)])++-- Takes a column index and applies gravity+-- to the column from the bottom up. +fixColumn :: Int -> Puzzle -> Puzzle+fixColumn j puz@(Puzzle mat) = +    let calcIx i = (i, j) in+    foldr fixColumnCell puz (reverse . map calcIx $ [1..nrows mat])++-- Drops a character if the underlying cell+-- is empty.+applyGravity :: Puzzle -> Puzzle+applyGravity puz@(Puzzle mat) = foldr fixColumn puz [1..ncols mat]++-- Function that takes a puzzle and a position+-- and returns all valid neightbours from that position.+getNeightbours :: (Int, Int) -> Puzzle -> [(Int, Int)]+getNeightbours (i, j) (Puzzle puz) =+    let allNeightbours = [(i - 1, j - 1), (i - 1, j), (i - 1, j + 1),+                          (i    , j - 1),             (i    , j + 1),+                          (i + 1, j - 1), (i + 1, j), (i + 1, j + 1)] in+    filter isValid allNeightbours+        where isValid (i, j) = i > 0 && i <= nrows puz && j > 0 && j <= ncols puz++-- Generates a list of all indices in the+-- puzzle matrix.+allPositions :: Puzzle -> [(Int, Int)]+allPositions (Puzzle puz) = +    let (r, c) = (nrows puz, ncols puz) in+    map (fn c) [0..(r * c) - 1]+        where fn nc i = ((i `div` nc) + 1, (i `mod` nc) + 1)++-- Consumes a character in the specified location+-- and drops the characters above that one.+consumeChar :: (Int, Int) -> Puzzle -> Puzzle+consumeChar ix (Puzzle puz) = Puzzle $ setElem Nothing ix puz++-- Tries to consume the string starting at the +-- specified position.+consumeAt :: String -> Puzzle -> (Int, Int) -> [Puzzle]+consumeAt (ch : rest) (Puzzle puz) ix =+    if (puz ! ix) == (Just ch) then +        let newPuz = consumeChar ix (Puzzle puz)+            neightbours = getNeightbours ix (Puzzle puz) in+        if rest /= [] then+            concatMap (consumeAt rest newPuz) neightbours+        else [newPuz]+    else []++-- Tries to consume the string and returns+-- a list of resulting puzzles from the consumption+-- of said string.+consume :: String -> Puzzle -> [Puzzle]+consume str puz = map applyGravity $ concatMap (consumeAt str puz) (allPositions puz)++-- Asks for a matrix in the form of +-- rows of strings.+ask :: IO Puzzle+ask = do+    hd <- getLine+    tl <- replicateM (length hd - 1) getLine+    return . Puzzle . Matrix.fromLists . map (map Just) $ hd : tl++-- Constructs a puzzle from a list of list+-- of characters.o+fromLists = Puzzle . Matrix.fromLists

@@ -0,0 +1,24 @@+module Verba.Solver (solve) where++import Data.List (permutations)+import Verba.Dictionary (Dictionary)+import Verba.Puzzle (Puzzle)+import qualified Verba.Dictionary as Dictionary+import qualified Verba.Puzzle as Puzzle++-- Reduces to a list of puzzles starting from+-- the given puzzle.+reduce :: Dictionary -> [Int] -> (Puzzle, [String]) -> [(Puzzle, [String])]+reduce _ [] puz = [puz]+reduce dict (i:is) (puz, ws) =+    let fn w = map (\x -> (x, w:ws)) (Puzzle.consume w puz)+        puzs = concatMap fn (Dictionary.wordsWithLength i dict) in+    concatMap (reduce dict is) puzs+    ++-- Takes a list of word lengths, and a puzzle and+-- generates all strings that result in an empty puzzle.+solve :: Dictionary -> [Int] -> Puzzle -> [[String]]+solve dict is puz = +    let allLengths = permutations is in+    concatMap (\ls -> map (reverse . snd) (reduce dict ls (puz, []))) allLengths

@@ -0,0 +1,6 @@+module Verba.Utils where++-- Checks if the first list is contained in the+-- second list.+supersetOf :: (Eq a) => [a] -> [a] -> Bool+supersetOf set maybeSs = all (\x -> x `elem` maybeSs) set