diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -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 diff --git a/Unscramble/Input.hs b/Unscramble/Input.hs deleted file mode 100644 --- a/Unscramble/Input.hs +++ /dev/null @@ -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") diff --git a/Unscramble/Output.hs b/Unscramble/Output.hs deleted file mode 100644 --- a/Unscramble/Output.hs +++ /dev/null @@ -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 diff --git a/Unscramble/Score.hs b/Unscramble/Score.hs deleted file mode 100644 --- a/Unscramble/Score.hs +++ /dev/null @@ -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 diff --git a/Unscramble/Search.hs b/Unscramble/Search.hs deleted file mode 100644 --- a/Unscramble/Search.hs +++ /dev/null @@ -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) diff --git a/Unscramble/Types.hs b/Unscramble/Types.hs deleted file mode 100644 --- a/Unscramble/Types.hs +++ /dev/null @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 diff --git a/src/Unscramble/Input.hs b/src/Unscramble/Input.hs new file mode 100644 --- /dev/null +++ b/src/Unscramble/Input.hs @@ -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 [] = [] diff --git a/src/Unscramble/Output.hs b/src/Unscramble/Output.hs new file mode 100644 --- /dev/null +++ b/src/Unscramble/Output.hs @@ -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 diff --git a/src/Unscramble/Score.hs b/src/Unscramble/Score.hs new file mode 100644 --- /dev/null +++ b/src/Unscramble/Score.hs @@ -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 diff --git a/src/Unscramble/Search.hs b/src/Unscramble/Search.hs new file mode 100644 --- /dev/null +++ b/src/Unscramble/Search.hs @@ -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 + -- + -- 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) diff --git a/src/Unscramble/Types.hs b/src/Unscramble/Types.hs new file mode 100644 --- /dev/null +++ b/src/Unscramble/Types.hs @@ -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) diff --git a/unscramble.cabal b/unscramble.cabal --- a/unscramble.cabal +++ b/unscramble.cabal @@ -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 , + Devyn Cairns +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