unscramble 0.3 → 1.0
raw patch · 14 files changed
+416/−413 lines, 14 filesdep +arraydep +stream-fusiondep +unordered-containersdep −hashmapdep −lensdep −mtldep ~optparse-applicative
Dependencies added: array, stream-fusion, unordered-containers
Dependencies removed: hashmap, lens, mtl
Dependency ranges changed: optparse-applicative
Files
- LICENSE +21/−0
- Main.hs +0/−59
- Unscramble/Input.hs +0/−63
- Unscramble/Output.hs +0/−57
- Unscramble/Score.hs +0/−74
- Unscramble/Search.hs +0/−56
- Unscramble/Types.hs +0/−87
- src/Main.hs +57/−0
- src/Unscramble/Input.hs +61/−0
- src/Unscramble/Output.hs +54/−0
- src/Unscramble/Score.hs +68/−0
- src/Unscramble/Search.hs +57/−0
- src/Unscramble/Types.hs +66/−0
- unscramble.cabal +32/−17
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2013 Joel Taylor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
− Main.hs
@@ -1,59 +0,0 @@-import Control.Lens hiding ((&), value)-import Data.List-import Data.Maybe-import Data.Ord-import Options.Applicative-import Paths_unscramble-import System.IO-import Unscramble.Input-import Unscramble.Output-import Unscramble.Score-import Unscramble.Search-import Unscramble.Types--parseOpts :: Parser ScrambleOpts-parseOpts = ScrambleOpts- <$> option- ( long "size" - & short 's'- & metavar "SIZE"- & help "Grid size (default 4)"- & value 4)- <*> option- ( long "score"- & metavar "SYSTEM"- & help "Scoring system (one of \27[1mswf\27[0m (default),\- \ \27[1mboggle\27[0m, \27[1mword-wars\27[0m)"- & value SWF)- <*> option- ( long "display"- & short 'd'- & metavar "STYLE"- & help "Display style: \27[1mone-line\27[0m to print all\- \ the words in order on one line, or \27[1mchunked\27[0m\- \ to display three-at-a-time with a board diagram for each."- & value Chunked)--main :: IO ()-main = do- sopts <- execParser opts- grid' <- readGrid (gridSize sopts)- mult' <- case scoreSystem sopts of- SWF -> readMult- _ -> return $ Multiplier [] Nothing [] Nothing- filepath <- getDataFileName "lists/enable.txt"- withFile filepath ReadMode $ \h -> do- cont <- hGetContents h- let foundWords = sortBy ((invert .) . comparing (_1 ^$))- . mapMaybe (\a ->- searchGrid a grid' mult' (scoreSystem sopts))- $ lines cont- display foundWords grid' mult' sopts- where- opts = info (helper <*> parseOpts)- ( fullDesc- & progDesc "Solve a Boggle-like word game"- & header "unscramble")- invert LT = GT- invert GT = LT- invert x = x
− Unscramble/Input.hs
@@ -1,63 +0,0 @@-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
@@ -1,57 +0,0 @@-module Unscramble.Output (- display-) where--import Control.Lens-import qualified Data.HashMap as H-import Data.List-import Data.Ord-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- max' = fst . maximumBy (comparing fst) $ H.keys gs- idxs = [(a,b) | a <- [0..max'], b <- [0..max']]- 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 == max' 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
@@ -1,74 +0,0 @@-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
@@ -1,56 +0,0 @@-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
@@ -1,87 +0,0 @@-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
+ src/Main.hs view
@@ -0,0 +1,57 @@+import Data.List+import Data.Maybe+import Data.Ord+import Options.Applicative+import Paths_unscramble+import System.IO+import Unscramble.Input+import Unscramble.Output+import Unscramble.Score+import Unscramble.Search+import Unscramble.Types++parseOpts :: Parser ScrambleOpts+parseOpts = ScrambleOpts+ <$> option+ ( long "size" + <> short 's'+ <> metavar "SIZE"+ <> help "Grid size (default 4)"+ <> value 4)+ <*> option+ ( long "score"+ <> metavar "SYSTEM"+ <> help "Scoring system (one of \27[1mswf\27[0m (default),\+ \ \27[1mboggle\27[0m, \27[1mword-wars\27[0m)"+ <> value SWF)+ <*> option+ ( long "display"+ <> short 'd'+ <> metavar "STYLE"+ <> help "Display style: \27[1mone-line\27[0m to print all\+ \ the words in order on one line, or \27[1mchunked\27[0m\+ \ to display three-at-a-time with a board diagram for each."+ <> value Chunked)++main :: IO ()+main = do+ sopts <- execParser opts+ grid' <- readGrid (gridSize sopts)+ mult' <- case scoreSystem sopts of+ SWF -> readMult+ _ -> return $ Multiplier [] Nothing [] Nothing+ filepath <- getDataFileName "lists/enable.txt"+ withFile filepath ReadMode $ \h -> do+ cont <- hGetContents h+ let foundWords = sortBy ((invert .) . comparing (\(a,_,_) -> a))+ . mapMaybe (search (grid',mult') (scoreSystem sopts))+ $ lines cont+ display foundWords grid' mult' sopts+ where+ opts = info (helper <*> parseOpts)+ ( fullDesc+ <> progDesc "Solve a Boggle-like word game"+ <> header "unscramble")+ invert LT = GT+ invert GT = LT+ invert x = x
+ src/Unscramble/Input.hs view
@@ -0,0 +1,61 @@+module Unscramble.Input (+ readGrid,+ readMult+) where++import Control.Applicative+import Control.Monad+import Data.Array+import Data.Char+import qualified Data.HashMap.Strict 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' <- replicateM n (filter isLetter <$> getLine)+ putStrLn "Received grid."+ return $ arraign lines'++arraign :: [String] -> Grid+arraign grid = Grid (hash ar) ar+ where ar = array ((0,0),(len,len)) . redist . zip [0..]+ $ map (zip [0..] . groupBy (\x y -> [x,y] == "qu")) grid+ hash a = foldr (\(i,k) h -> H.insertWith (flip (++)) k [i] h) H.empty (assocs a)+ len = pred . length $ head grid+ redist ((x,ys):xs) = map (\(a,b) -> ((a,x),b)) ys ++ redist xs+ redist [] = []
+ src/Unscramble/Output.hs view
@@ -0,0 +1,54 @@+module Unscramble.Output (+ display+) where++import Data.Array+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 (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 (\(a,_,_) -> a) $ 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+ (_,(maxx',maxy')) = bounds gs+ idxs = [(a,b) | a <- [0..maxx'], b <- [0..maxy']]+ 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 = gs ! n+ nl = if snd n == maxx' 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
+ src/Unscramble/Score.hs view
@@ -0,0 +1,68 @@+module Unscramble.Score (+ ScoringSystem(..),+ score+) where++import Data.Array ((!))+import Data.Maybe+import Unscramble.Types++score :: ScoringSystem -> Search -> [Coordinate] -> Int+score Boggle _ = scoreBoggle+score SWF s = scoreSWF s+score WordWars s = scoreWordWars s++scoreBoggle :: [Coordinate] -> Int+scoreBoggle xs = case length xs of+ 3 -> 1+ 4 -> 1+ 5 -> 2+ 6 -> 3+ 7 -> 5+ x | x >= 8 -> 11+ _ -> 0++scoreWordWars :: Search -> [Coordinate] -> Int+scoreWordWars (Grid _ cs,_) xs = sum . map (\x -> fromMaybe 0 $ lookup x scores) $ lets+ where+ lets = map (cs !) xs+ 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 :: Search -> [Coordinate] -> Int+scoreSWF (Grid _ gs, Multiplier dl dw tl tw) cs = if length cs == 2+ then 1+ else 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 $ lookup (gs ! q) scores+ dlm = if n `elem` dl then (*2) else id+ tlm = if n `elem` tl then (*3) else id++ in (+ 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
+ src/Unscramble/Search.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TupleSections #-}++module Unscramble.Search (search) where++import Control.Monad+import qualified Data.HashMap.Strict as H+import Data.List.Stream+import Data.Maybe+import Data.Ord+import Prelude hiding (map, filter, reverse, head, concatMap)+import Unscramble.Score+import Unscramble.Types++tokenize :: String -> [String]+tokenize = groupBy (\x y -> [x,y] == "qu")++search :: Search+ -> ScoringSystem+ -> String+ -> Maybe (Score, String, [Coordinate])++search s@(grid,_) system word = putWordIn . reversePath . chooseBestPath $+ walk firstPaths tokens+ where putWordIn = fmap $ \(a, b) -> (a, word, b)+ reversePath = fmap $ \(score, path) -> (score, reverse path)+ (firstToken : tokens) = tokenize word+ lets = letters grid+ firstTokenPositions = H.lookupDefault [] firstToken lets+ firstPaths = map (: []) firstTokenPositions++ chooseBestPath :: [[Coordinate]] -> Maybe (Score, [Coordinate])++ chooseBestPath paths =+ listToMaybe . sortBy (comparing fst) $+ map (\path -> (score system s path, path)) paths++ -- new and improved algorithm written by Devyn Cairns+ -- <devyn.cairns@gmail.com>+ -- thanks buddy+ walk :: [[Coordinate]] -> [String] -> [[Coordinate]]++ walk [] _ = []+ walk paths [] = paths+ walk paths (token : remaining) =+ let tokenPositions = H.lookupDefault [] token lets+ branch path =+ map (: path) $+ filter (isNeighbor (head path)) (tokenPositions \\ path)+ paths' = concatMap branch paths+ in walk paths' remaining++isNeighbor :: Coordinate -> Coordinate -> Bool+isNeighbor (x,y) (a,b)+ | (x,y) == (a,b) = False+ | otherwise = let xa = x - a+ yb = y - b+ in (xa >= -1 && xa <= 1) && (yb >= -1 && yb <= 1)
+ src/Unscramble/Types.hs view
@@ -0,0 +1,66 @@+module Unscramble.Types (+ ScrambleOpts(..),++ Coordinate,+ Multiplier(..),+ Grid(..),+ Search,++ ScoringSystem(..),+ Score,++ DisplayStyle(..)+) where++import Data.Array+import Data.Char+import qualified Data.HashMap.Strict as H+import Data.List++type Tile = String++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.HashMap Tile [Coordinate]+ , coords :: Array (Int,Int) Tile+ }++type Search = (Grid, Multiplier)
unscramble.cabal view
@@ -1,18 +1,33 @@-Name: unscramble-Category: Utils-Synopsis: Solve Boggle-like word games-Version: 0.3-Description: Solve Boggle-like word games-License: GPL-Author: Joel Taylor-Maintainer: barebonesgraphics@gmail.com-Build-Type: Simple-Cabal-Version: >=1.10-Data-Files: lists/enable.txt+name: unscramble+category: Text+synopsis: Solve Boggle-like word games+description: Solve Boggle-like word games+version: 1.0+license: MIT+license-file: LICENSE+author: Joel Taylor, Devyn Cairns+maintainer: Joel Taylor <me@joelt.io>,+ Devyn Cairns <devyn.cairns@gmail.com>+build-type: Simple+cabal-version: >=1.10+data-files: lists/enable.txt -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+executable unscramble+ main-is: Main.hs+ other-modules: Unscramble.Input+ , Unscramble.Output+ , Unscramble.Score+ , Unscramble.Search+ , Unscramble.Types+ hs-source-dirs: src+ build-depends: base == 4.*+ , array+ , optparse-applicative+ , stream-fusion+ , unordered-containers+ default-extensions: TupleSections+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/joelteon/unscramble.git