unscramble 0.1 → 0.2
raw patch · 6 files changed
+336/−1 lines, 6 files
Files
- Unscramble/Input.hs +63/−0
- Unscramble/Output.hs +54/−0
- Unscramble/Score.hs +74/−0
- Unscramble/Search.hs +56/−0
- Unscramble/Types.hs +87/−0
- unscramble.cabal +2/−1
+ Unscramble/Input.hs view
@@ -0,0 +1,63 @@+module Unscramble.Input (+ readGrid,+ readMult+) where++import Control.Applicative+import Control.Arrow+import Control.Lens+import Data.Char+import qualified Data.HashMap as H+import Data.List+import Data.Maybe+import System.IO+import Text.Printf+import Unscramble.Types++readMult :: IO Multiplier+readMult = do+ dls <- putStrLn "Enter coordinates for double letters, in\+ \ the form 'x y'. The lower left corner is '1 1'\+ \ and the top right is '4 4'. Press enter after each\+ \ set of coordinates. If there are no double\+ \ letters, press enter." >> getCoords+ dws <- putStrLn "Enter coordinates for double words. If there\+ \ are no double words, press enter." >> getCoords+ tls <- putStrLn "Enter coordinates for triple letters. If there\+ \ are no triple letters, press enter." >> getCoords+ tws <- putStrLn "Enter coordinates for triple words. If there\+ \ are no triple words, press enter." >> getCoords+ return $ Multiplier dls (listToMaybe dws) tls (listToMaybe tws)+ where+ getCoords = do+ eo <- isEOF+ if eo+ then return []+ else do+ r <- getLine+ case words r of+ [a,b] -> do+ l <- getCoords+ return $ (4 - read b, read a - 1):l+ [] -> return []+ _ -> putStrLn "Invalid coordinates." >> return []++readGrid :: Int -> IO Grid+readGrid n = do+ _ <- printf "Enter a %dx%d grid. Remember:\n\+ \- Input only letters and press enter after each line.\n\+ \- You may enter a 'qu' tile as 'qu'.\n" n n+ lines' <- sequence $ replicate n (filter isLetter <$> getLine)+ putStrLn "Received grid."+ return $ parseGrid lines'++parseGrid :: [String] -> Grid+parseGrid input = uncurry Grid+ . (letterMap &&& coordMap)+ . itoListOf (ifolded <.> ifolded)+ $ map tokenize input+ where+ letterMap [] = H.empty+ letterMap (((x,y),str):xs) = H.insertWith (++) str [(x,y)] $! letterMap xs+ coordMap = foldr (uncurry H.insert) H.empty+ tokenize = groupBy (\x y -> [x,y] == "qu")
+ Unscramble/Output.hs view
@@ -0,0 +1,54 @@+module Unscramble.Output (+ display+) where++import Control.Lens+import qualified Data.HashMap as H+import Text.Printf+import Unscramble.Types++-- words are already sorted by score+display :: [(Score, String, [Coordinate])]+ -> Grid+ -> Multiplier+ -> ScrambleOpts+ -> IO ()+display xs g m (ScrambleOpts _ _ ds)+ | ds == OneLine = (showTotal >>) $ mapM_ (\x -> putStr ((_2 ^$ x) ++ " ")) xs+ | ds == Chunked = (showTotal >>) $ mapM_ (\ns -> do+ mapM_ (displayGrid g m) ns+ putStrLn "\nPress enter for more, or ctrl-c to quit."+ getLine) $ chunk xs+ where+ showTotal = do+ let points = sum . map (_1 ^$) $ xs+ printf "%d total words for %d points.\n" (length xs) points+ chunk (a:b:c:es) = [a,b,c]:chunk es+ chunk x = [x]+display _ _ _ (ScrambleOpts _ _ _) = error "what?"++displayGrid :: Grid+ -> Multiplier+ -> (Score, String, [Coordinate])+ -> IO ()+displayGrid (Grid _ gs) (Multiplier dl dw tl tw) (sc, word, cs)+ = (putStrLn ("\n\27[1m" ++ word ++ "\27[0m: " ++ show sc) >>)+ . mapM_ (putStr . render) $ idxs+ where+ idxs = [(a,b) | a <- [0..3], b <- [0..3]]+ render n+ | head cs == n = "\27[44m" ++ pad letter n True ++ "\27[49m" ++ nl+ | n `elem` cs = "\27[107m" ++ pad letter n True ++ "\27[49m" ++ nl+ | otherwise = pad letter n False ++ nl+ where+ letter = H.findWithDefault undefined n gs+ nl = if snd n == 3 then "\n" else ""+ pad [x] n t = " " ++ highlight [x] n t ++ " "+ pad x n t = ' ':highlight x n t+ highlight x n t+ | n `elem` dl = "\27[36;1m" ++ x ++ "\27[39;22m"+ | Just n == dw = "\27[31;1m" ++ x ++ "\27[39;22m"+ | n `elem` tl = "\27[32;1m" ++ x ++ "\27[39;22m"+ | Just n == tw = "\27[33;1m" ++ x ++ "\27[39;22m"+ | t = "\27[30m" ++ x ++ "\27[39;22m"+ | otherwise = x
+ Unscramble/Score.hs view
@@ -0,0 +1,74 @@+module Unscramble.Score (+ ScoringSystem(..),+ score+) where++import Control.Lens+import qualified Data.HashMap as H+import Data.Maybe+import Unscramble.Types++score :: ScoringSystem -> [Coordinate] -> Search Int+score Boggle = scoreBoggle+score SWF = scoreSWF+score WordWars = scoreWordWars++scoreBoggle :: [Coordinate] -> Search Int+scoreBoggle xs = return $ case length xs of+ 3 -> 1+ 4 -> 1+ 5 -> 2+ 6 -> 3+ 7 -> 5+ x | x >= 8 -> 11+ _ -> 0++scoreWordWars :: [Coordinate] -> Search Int+scoreWordWars xs = do+ g <- view (grid.coords)+ let lets = map (\x -> H.findWithDefault undefined x g) xs+ return . sum . map (\x -> fromMaybe 0 $ lookup x scores) $ lets+ where+ scores = [ ("a", 1), ("b", 4), ("c", 3), ("d", 2)+ , ("e", 1), ("f", 2), ("g", 3), ("h", 3)+ , ("i", 1), ("j", 6), ("k", 5), ("l", 2)+ , ("m", 4), ("n", 2), ("o", 1), ("p", 4)+ , ("qu", 8), ("r", 1), ("s", 1), ("t", 1)+ , ("u", 3), ("v", 4), ("w", 4), ("x", 8)+ , ("y", 2), ("z", 8) ]+ +scoreSWF :: [Coordinate] -> Search Int+scoreSWF cs = if length cs == 2+ then return 1+ else do+ (Multiplier dl dw tl tw) <- view mult+ (Grid _ gs) <- view grid+ let dwm = case dw of+ Nothing -> id+ Just r -> if r `elem` cs then (*2) else id+ twm = case tw of+ Nothing -> id+ Just r -> if r `elem` cs then (*3) else id+ scoreOf n = dlm . tlm $ baseScore n+ where+ baseScore q = fromJust $ H.lookup q gs >>= (`lookup` scores)+ dlm = if n `elem` dl then (*2) else id+ tlm = if n `elem` tl then (*3) else id+ + return . (+ lengthBonus (length cs)) . dwm . twm . sum+ $ map scoreOf cs+ where+ scores = [ ("a", 1), ("b", 4), ("c", 4), ("d", 2)+ , ("e", 1), ("f", 4), ("g", 3), ("h", 3)+ , ("i", 1), ("j", 10), ("k", 5), ("l", 2)+ , ("m", 4), ("n", 2), ("o", 1), ("p", 4)+ , ("qu", 10), ("r", 1), ("s", 1), ("t", 1)+ , ("u", 2), ("v", 5), ("w", 4), ("x", 8)+ , ("y", 3), ("z", 10) ]+ lengthBonus 5 = 3+ lengthBonus 6 = 6+ lengthBonus 7 = 10+ lengthBonus 8 = 15+ lengthBonus 9 = 20+ lengthBonus x | x >= 10 = 25+ lengthBonus _ = 0
+ Unscramble/Search.hs view
@@ -0,0 +1,56 @@+module Unscramble.Search (+ searchGrid+) where++import Control.Applicative+import Control.Lens+import Control.Monad.RWS+import qualified Data.HashMap as H+import Data.List+import Data.Ord+import Unscramble.Score+import Unscramble.Types++searchGrid :: String+ -> Grid+ -> Multiplier+ -> ScoringSystem+ -> Maybe (Score, String, [Coordinate])+searchGrid s g m sys = fmap (\(a,b) -> (a,s,b)) . fst+ $ evalRWS (search (tokenize s)) (g, m, sys) ([],[])++tokenize :: String -> [String]+tokenize = groupBy (\x y -> [x,y] == "qu")++isNeighbor :: Coordinate -> Coordinate -> Bool+isNeighbor (x1,y1) (x2,y2) = deltax <= 1 && deltay <= 1 && deltax + deltay > 0+ where+ deltax = abs $ x2 - x1+ deltay = abs $ y2 - y1++search :: [String] -> Search (Maybe (Score, [Coordinate]))+search (x:xs) = do+ startCoords <- use start+ l <- view (grid.letters)+ let valid' = filter (\y -> null startCoords || any (isNeighbor y) startCoords)+ $ H.findWithDefault [] x l+ if null valid'+ then return Nothing+ else do+ start .= valid' -- set the new starting coordinates to valid ones+ valid %= (valid':) -- add the starting coordinates to the list+ search xs+search [] = validate++validate :: Search (Maybe (Score, [Coordinate]))+validate = do+ xs <- use valid+ scoreSys <- view ss+ let validSequences = map reverse+ . filter (\n -> n == nub n+ && and (zipWith isNeighbor `ap` tail $ n))+ $ sequence xs+ scords <- mapM (\c -> (,c) <$> score scoreSys c) validSequences+ case reverse $ sortBy (comparing fst) scords of+ [] -> return Nothing+ ((a,b):_) -> return $ Just (a, b)
+ Unscramble/Types.hs view
@@ -0,0 +1,87 @@+module Unscramble.Types (+ ScrambleOpts(..),+ + Coordinate,+ Multiplier(..),+ Grid(..),+ letters,+ coords,+ + grid,+ mult,+ ss,+ start,+ valid,+ + ScoringSystem(..),+ Score,+ + DisplayStyle(..),+ + Search+) where++import Control.Lens+import Control.Monad.RWS+import Data.Char+import qualified Data.HashMap as H+import Data.List++data ScrambleOpts = ScrambleOpts { gridSize :: Int+ , scoreSystem :: ScoringSystem+ , displayStyle :: DisplayStyle+ }++data ScoringSystem = Boggle | SWF | WordWars++data DisplayStyle = Chunked | OneLine deriving (Eq)++type Score = Int++instance Read ScoringSystem where+ readsPrec _ x+ | "boggle" `isPrefixOf` y = wrap Boggle $ drop 6 y+ | "swf" `isPrefixOf` y = wrap SWF $ drop 3 y+ | "scramble" `isPrefixOf` y = wrap SWF $ drop 8 y+ | "wordwars" `isPrefixOf` y = wrap WordWars $ drop 8 y+ | "word-wars" `isPrefixOf` y = wrap WordWars $ drop 9 y+ | otherwise = []+ where+ y = map toLower x+ wrap= (return .) . (,)++instance Read DisplayStyle where+ readsPrec _ x+ | "chunked" `isPrefixOf` y = wrap Chunked $ drop 7 y+ | "one-line" `isPrefixOf` y = wrap OneLine $ drop 8 y+ | otherwise = []+ where+ y = map toLower x+ wrap = (return .) . (,)++type Coordinate = (Int,Int)++data Multiplier = Multiplier { doubleLetter :: [Coordinate]+ , doubleWord :: Maybe Coordinate+ , tripleLetter :: [Coordinate]+ , tripleWord :: Maybe Coordinate+ }++data Grid = Grid { _letters :: H.Map String [Coordinate]+ , _coords :: H.Map Coordinate String+ }+ +makeLenses ''Grid++type Search = RWS (Grid, Multiplier, ScoringSystem) () ([Coordinate], [[Coordinate]])++grid :: Simple Lens (Grid, Multiplier, ScoringSystem) Grid+grid = _1+mult :: Simple Lens (Grid, Multiplier, ScoringSystem) Multiplier+mult = _2+ss :: Simple Lens (Grid, Multiplier, ScoringSystem) (ScoringSystem)+ss = _3+start :: Simple Lens ([Coordinate], [[Coordinate]]) [Coordinate]+start = _1+valid :: Simple Lens ([Coordinate], [[Coordinate]]) [[Coordinate]]+valid = _2
unscramble.cabal view
@@ -1,7 +1,7 @@ Name: unscramble Category: Utils Synopsis: Solve Boggle-like word games-Version: 0.1+Version: 0.2 Description: Solve Boggle-like word games License: GPL Author: Joel Taylor@@ -12,6 +12,7 @@ Executable unscramble Main-is: Main.hs+ Other-modules: Unscramble.Input, Unscramble.Output, Unscramble.Score, Unscramble.Search, Unscramble.Types Build-Depends: base == 4.*, hashmap == 1.3.*, lens == 3.7.*, mtl == 2.1.*, optparse-applicative == 0.4.* Default-extensions: TemplateHaskell, TupleSections Default-Language: Haskell2010