optimize bfs

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

package.yaml

@@ -21,6 +21,9 @@ description:         Please see the README on GitHub at <https://github.com/gith
 
 dependencies:
 - base >= 4.7 && < 5
+- unordered-containers
+- hashable
+- bytestring
 
 ghc-options:
 - -Wall

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

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
+readDictionary filepath = do
-  text <- readFile filename
+  text <- C.readFile filepath
-  let lines = L.lines text
+  let lines = C.lines text
-  let lowercaseWords = map (filter isLower) lines
+  let lowercaseWords = map (C.filter isLower) lines
-  return (L.nub lowercaseWords)
+  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.cons c word | c <- ['a' .. 'z']]
-        added = [c : word | c <- ['a' .. 'z']]
+        removed = [delete c word | c <- C.unpack word]
-        modified = [x : L.delete y word | x <- ['a' .. 'z'], y <- word, x /= y]
+        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

src/PermutationMap.hs

@@ -11,35 +11,36 @@ module PermutationMap
   )
 where
 
-import qualified Data.AssocMap as M
+import qualified Data.ByteString as BS
-import Data.List (nub, sort)
+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 :: BS.ByteString -> PermutationMap -> Bool
-member key = M.member (sort key)
+member key = M.member (BS.sort key)
 
-alter :: (Maybe [String] -> Maybe [String]) -> String -> PermutationMap -> PermutationMap
+alter :: (Maybe [BS.ByteString] -> Maybe [BS.ByteString]) -> BS.ByteString -> PermutationMap -> PermutationMap
-alter f key = M.alter f (sort key)
+alter f key = M.alter f (BS.sort key)
 
-delete :: String -> PermutationMap -> PermutationMap
+delete :: BS.ByteString -> PermutationMap -> PermutationMap
-delete key = M.delete (sort key)
+delete key = M.delete (BS.sort key)
 
-insert :: String -> [String] -> PermutationMap -> PermutationMap
+insert :: BS.ByteString -> [BS.ByteString] -> PermutationMap -> PermutationMap
-insert key = M.insert (sort key)
+insert key = M.insert (BS.sort key)
 
-lookup :: String -> PermutationMap -> Maybe [String]
+lookup :: BS.ByteString -> PermutationMap -> Maybe [BS.ByteString]
-lookup key = M.lookup (sort key)
+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