diff --git a/ladder.cabal b/ladder.cabal index 94ea2d3..249c396 100644 --- a/ladder.cabal +++ b/ladder.cabal @@ -38,6 +38,9 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , bytestring + , hashable + , unordered-containers default-language: Haskell2010 executable ladder-exe @@ -51,7 +54,10 @@ executable ladder-exe ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , bytestring + , hashable , ladder + , unordered-containers default-language: Haskell2010 test-suite ladder-test @@ -66,5 +72,8 @@ test-suite ladder-test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , bytestring + , hashable , ladder + , unordered-containers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 480771a..870912b 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,9 @@ description: Please see the README on GitHub at = 4.7 && < 5 +- unordered-containers +- hashable +- bytestring ghc-options: - -Wall diff --git a/src/Graph.hs b/src/Graph.hs index 7d80cf7..ee523d5 100644 --- a/src/Graph.hs +++ b/src/Graph.hs @@ -22,57 +22,58 @@ module Graph ) where -import qualified Data.AssocMap as M import Data.Bifunctor (second) import Data.Function ((&)) +import qualified Data.HashMap.Lazy as M +import Data.Hashable (Hashable) import qualified Data.List as L -type DiGraph a = M.AssocMap a [a] +type DiGraph a = M.HashMap a [a] empty :: DiGraph a empty = M.empty -hasNode :: (Eq a) => DiGraph a -> a -> Bool +hasNode :: (Hashable a) => DiGraph a -> a -> Bool hasNode = flip M.member -addNode :: (Eq a) => DiGraph a -> a -> DiGraph a +addNode :: (Hashable a) => DiGraph a -> a -> DiGraph a addNode graph node = M.insert node [] graph -addEdge :: (Eq a) => (a, a) -> DiGraph a -> DiGraph a +addEdge :: (Hashable a) => (a, a) -> DiGraph a -> DiGraph a addEdge (node, child) = M.alter insertEdge node where insertEdge Nothing = Just [child] insertEdge (Just nodes) = Just $ L.nub (child : nodes) -addEdges :: (Eq a) => [(a, a)] -> DiGraph a -> DiGraph a +addEdges :: (Hashable a) => [(a, a)] -> DiGraph a -> DiGraph a addEdges edges graph = foldr addEdge graph edges -buildDiGraph :: (Eq a) => [(a, [a])] -> DiGraph a +buildDiGraph :: (Hashable a) => [(a, [a])] -> DiGraph a buildDiGraph = foldr (\(node, childs) -> M.insert node (L.nub childs)) M.empty -children :: (Eq a) => a -> DiGraph a -> [a] +children :: (Hashable a) => a -> DiGraph a -> [a] children = M.findWithDefault [] -deleteNode :: (Eq a) => a -> DiGraph a -> DiGraph a +deleteNode :: (Hashable a) => a -> DiGraph a -> DiGraph a deleteNode = M.delete -deleteNodes :: (Eq a) => [a] -> DiGraph a -> DiGraph a +deleteNodes :: (Hashable a) => [a] -> DiGraph a -> DiGraph a deleteNodes nodes graph = foldr deleteNode graph nodes -deleteEdge :: (Eq a) => (a, a) -> DiGraph a -> DiGraph a +deleteEdge :: (Hashable a) => (a, a) -> DiGraph a -> DiGraph a deleteEdge (node, child) = M.alter aux node where aux Nothing = Nothing aux (Just nodes) = Just (L.delete child nodes) -deleteEdges :: (Eq a) => [(a, a)] -> DiGraph a -> DiGraph a +deleteEdges :: (Hashable a) => [(a, a)] -> DiGraph a -> DiGraph a deleteEdges edges graph = foldr deleteEdge graph edges type SearchState a = ([a], DiGraph a, DiGraph a) type SearchResult a = Maybe (DiGraph a) -bfsSearch :: forall a. (Eq a) => DiGraph a -> a -> a -> Maybe [a] +bfsSearch :: forall a. (Hashable a) => DiGraph a -> a -> a -> Maybe [a] bfsSearch initialGraph start end | start == end = Just [start] | otherwise = findSolution <$> bfsSearch' ([start], initialGraph, empty) @@ -113,7 +114,7 @@ bfsSearch initialGraph start end else bfsSearch' (frontier', graph', predecessors') -dfsSearch :: forall a. (Eq a) => DiGraph a -> a -> a -> Maybe [a] +dfsSearch :: forall a. (Hashable a) => DiGraph a -> a -> a -> Maybe [a] dfsSearch initialGraph start end = case dfsSearch' initialGraph start of Right path -> Just path diff --git a/src/Ladder.hs b/src/Ladder.hs index 0a0cb93..44f7dd5 100644 --- a/src/Ladder.hs +++ b/src/Ladder.hs @@ -1,39 +1,47 @@ module Ladder (readDictionary, ladderSolve) where +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C import Data.Char (isLower) import qualified Data.List as L import qualified Graph as G import qualified PermutationMap as PM import Prelude hiding (lines, words) -type Dictionary = [String] +type Dictionary = [BS.ByteString] -ladderSolve :: Dictionary -> String -> String -> Maybe [String] +ladderSolve :: Dictionary -> String -> String -> Maybe [BS.ByteString] ladderSolve dict start end = let graph = mkLadderGraph dict - in G.bfsSearch graph start end + in G.bfsSearch graph (C.pack start) (C.pack end) readDictionary :: String -> IO Dictionary -readDictionary filename = do - text <- readFile filename - let lines = L.lines text - let lowercaseWords = map (filter isLower) lines - return (L.nub lowercaseWords) +readDictionary filepath = do + text <- C.readFile filepath + let lines = C.lines text + let lowercaseWords = map (C.filter isLower) lines + return lowercaseWords -mkLadderGraph :: Dictionary -> G.DiGraph String +mkLadderGraph :: Dictionary -> G.DiGraph BS.ByteString mkLadderGraph dict = G.buildDiGraph [(word, computeCandidates word) | word <- dict] where permMap = PM.createPermutationMap dict - computeCandidates :: String -> [String] + computeCandidates :: BS.ByteString -> [BS.ByteString] computeCandidates word = -- Delete the original word from the permutations list L.delete word permutations where - removed = [L.delete c word | c <- word] - added = [c : word | c <- ['a' .. 'z']] - modified = [x : L.delete y word | x <- ['a' .. 'z'], y <- word, x /= y] + added = [C.cons c word | c <- ['a' .. 'z']] + removed = [delete c word | c <- C.unpack word] + modified = + [C.cons x (delete y word) | x <- ['a' .. 'z'], y <- C.unpack word, x /= y] -- Sort and deduplicate all the candidates - candidates = L.nub $ map L.sort (added ++ removed ++ modified ++ [word]) + candidates = added ++ removed ++ modified ++ [word] -- For each candidate, lookup all its permutations permutations = L.concatMap (\w -> PM.findWithDefault [] w permMap) candidates + + delete :: Char -> BS.ByteString -> BS.ByteString + delete ch string = case C.uncons string of + Just (x, xs) -> if ch == x then xs else C.cons x (delete ch xs) + Nothing -> C.empty diff --git a/src/PermutationMap.hs b/src/PermutationMap.hs index d9b8a99..5d21612 100644 --- a/src/PermutationMap.hs +++ b/src/PermutationMap.hs @@ -11,35 +11,36 @@ module PermutationMap ) where -import qualified Data.AssocMap as M -import Data.List (nub, sort) +import qualified Data.ByteString as BS +import qualified Data.HashMap.Lazy as M +import Data.List (nub) import Data.Maybe (fromMaybe) import Prelude hiding (lookup) -type PermutationMap = M.AssocMap String [String] +type PermutationMap = M.HashMap BS.ByteString [BS.ByteString] empty :: PermutationMap empty = M.empty -member :: String -> PermutationMap -> Bool -member key = M.member (sort key) +member :: BS.ByteString -> PermutationMap -> Bool +member key = M.member (BS.sort key) -alter :: (Maybe [String] -> Maybe [String]) -> String -> PermutationMap -> PermutationMap -alter f key = M.alter f (sort key) +alter :: (Maybe [BS.ByteString] -> Maybe [BS.ByteString]) -> BS.ByteString -> PermutationMap -> PermutationMap +alter f key = M.alter f (BS.sort key) -delete :: String -> PermutationMap -> PermutationMap -delete key = M.delete (sort key) +delete :: BS.ByteString -> PermutationMap -> PermutationMap +delete key = M.delete (BS.sort key) -insert :: String -> [String] -> PermutationMap -> PermutationMap -insert key = M.insert (sort key) +insert :: BS.ByteString -> [BS.ByteString] -> PermutationMap -> PermutationMap +insert key = M.insert (BS.sort key) -lookup :: String -> PermutationMap -> Maybe [String] -lookup key = M.lookup (sort key) +lookup :: BS.ByteString -> PermutationMap -> Maybe [BS.ByteString] +lookup key = M.lookup (BS.sort key) -findWithDefault :: [String] -> String -> PermutationMap -> [String] +findWithDefault :: [BS.ByteString] -> BS.ByteString -> PermutationMap -> [BS.ByteString] findWithDefault defaultValue key pmap = fromMaybe defaultValue (PermutationMap.lookup key pmap) -createPermutationMap :: [String] -> PermutationMap +createPermutationMap :: [BS.ByteString] -> PermutationMap createPermutationMap = aux empty where aux permMap [] = permMap