search-algorithms 0.2.0 → 0.3.0

raw patch · 3 files changed

+408/−9 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• search-algorithms.cabal +1/−1
• src/Algorithm/Search.hs +252/−6
• test/Algorithm/SearchSpec.hs +155/−2

@@ -1,5 +1,5 @@ name:                search-algorithms-version:             0.2.0+version:             0.3.0 synopsis:            Common graph search algorithms description:         Library containing common graph search algorithms,                      including depth-first and breadth-first searches,

@@ -13,9 +13,17 @@   dfs,   dijkstra,   aStar,+  -- * Monadic Searches+  -- $monadic+  bfsM,+  dfsM,+  dijkstraM,+  aStarM,   -- * Utility   incrementalCosts,-  pruning+  incrementalCostsM,+  pruning,+  pruningM   ) where  import qualified Data.Map as Map@@ -23,6 +31,7 @@ import qualified Data.Set as Set import qualified Data.List as List import qualified Data.Foldable as Foldable+import Control.Monad (filterM, zipWithM)  -- | @bfs next found initial@ performs a breadth-first search over a set of -- states, starting with @initial@, and generating neighboring states with@@ -72,7 +81,9 @@ -- Just [3,4] dfs :: (Foldable f, Ord state)   => (state -> f state)-  -- ^ Function to generate "next" states given a current state+  -- ^ Function to generate "next" states given a current state. These should be+  -- given in the order in which states should be pushed onto the stack, i.e.+  -- the "last" state in the Foldable will be the first one visited.   -> (state -> Bool)   -- ^ Predicate to determine if solution found. 'dfs' returns a path to the   -- first state for which this predicate returns 'True'.@@ -125,7 +136,7 @@   -> state   -- ^ Initial state   -> Maybe (cost, [state])-  -- (Total cost, list of steps) for the first path found which+  -- ^ (Total cost, list of steps) for the first path found which   -- satisfies the given predicate dijkstra next cost found initial =   -- Dijkstra's algorithm can be viewed as a generalized search, with the search@@ -145,8 +156,8 @@     unpack packed_states = (fst . last $ packed_states, map snd packed_states)  --- | @aStar next cost remaining found initial@ performs a best-first search using--- the A* search algorithm, starting with the state @initial@, generating+-- | @aStar next cost remaining found initial@ performs a best-first search+-- using the A* search algorithm, starting with the state @initial@, generating -- neighboring states with @next@, their cost with @cost@, and an estimate of -- the remaining cost with @remaining@. This returns a path to a state for which -- @found@ returns 'True'. If @remaining@ is strictly a lower bound on the@@ -182,7 +193,7 @@   -> state   -- ^ Initial state   -> Maybe (cost, [state])-  -- (Total cost, list of steps) for the first path found which satisfies the+  -- ^ (Total cost, list of steps) for the first path found which satisfies the   -- given predicate aStar next cost remaining found initial =   -- A* can be viewed as a generalized search, with the search container being a@@ -206,7 +217,116 @@       (fst . snd . last $ packed_states, map snd2 packed_states)     snd2 = snd . snd +-- $monadic+-- Note that for all monadic searches, it is up to the user to ensure that+-- side-effecting monads do not logically change the structure of the graph.+-- For example, if the list of neighbors is being read from a file, the user+-- must ensure that those values do not change between reads. +-- | @bfsM@ is a monadic version of 'bfs': it has support for monadic @next@ and+-- @found@ parameters.+bfsM :: (Monad m, Foldable f, Ord state)+  => (state -> m (f state))+  -- ^ Function to generate "next" states given a current state+  -> (state -> m Bool)+  -- ^ Predicate to determine if solution found. 'bfsM' returns a path to the+  -- first state for which this predicate returns 'True'.+  -> state+  -- ^ Initial state+  -> m (Maybe [state])+  -- ^ First path found to a state matching the predicate, or 'Nothing' if no+  -- such path exists.+bfsM = generalizedSearchM Seq.empty id (\_ _ -> False)+++-- | @dfsM@ is a monadic version of 'dfs': it has support for monadic @next@ and+-- @found@ parameters.+dfsM :: (Monad m, Foldable f, Ord state)+  => (state -> m (f state))+  -- ^ Function to generate "next" states given a current state+  -> (state -> m Bool)+  -- ^ Predicate to determine if solution found. 'dfsM' returns a path to the+  -- first state for which this predicate returns 'True'.+  -> state+  -- ^ Initial state+  -> m (Maybe [state])+  -- ^ First path found to a state matching the predicate, or 'Nothing' if no+  -- such path exists.+dfsM =+  generalizedSearchM [] id (\_ _ -> True)++-- | @dijkstraM@ is a monadic version of 'dijkstra': it has support for monadic+-- @next@, @cost@, and @found@ parameters.+dijkstraM :: (Monad m, Foldable f, Num cost, Ord cost, Ord state)+  => (state -> m (f state))+  -- ^ Function to generate list of neighboring states given the current state+  -> (state -> state -> m cost)+  -- ^ Function to generate list of costs between neighboring states. This is+  -- only called for adjacent states, so it is safe to have this function be+  -- partial for non-neighboring states.+  -> (state -> m Bool)+  -- ^ Predicate to determine if solution found. 'dijkstraM' returns the+  -- shortest path to the first state for which this predicate returns 'True'.+  -> state+  -- ^ Initial state+  -> m (Maybe (cost, [state]))+  -- ^ (Total cost, list of steps) for the first path found which+  -- satisfies the given predicate+dijkstraM nextM costM foundM initial =+  fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd leastCostly nextM'+    (foundM . snd) (0, initial)+  where+    nextM' (old_cost, old_st) = do+      new_states <- Foldable.toList <$> nextM old_st+      incr_costs <- sequence $ costM old_st <$> new_states+      let new_costs = (+ old_cost) <$> incr_costs+      return $ zip new_costs new_states+    unpack [] = (0, [])+    unpack packed_states = (fst . last $ packed_states, map snd packed_states)+++-- | @aStarM@ is a monadic version of 'aStar': it has support for monadic+-- @next@, @cost@, @remaining@, and @found@ parameters.+aStarM :: (Monad m, Foldable f, Num cost, Ord cost, Ord state)+  => (state -> m (f state))+  -- ^ Function which, when given the current state, produces a list whose+  -- elements are (incremental cost to reach neighboring state,+  -- estimate on remaining cost from said state, said state).+  -> (state -> state -> m cost)+  -- ^ Function to generate list of costs between neighboring states. This is+  -- only called for adjacent states, so it is safe to have this function be+  -- partial for non-neighboring states.+  -> (state -> m cost)+  -- ^ Estimate on remaining cost given a state+  -> (state -> m Bool)+  -- ^ Predicate to determine if solution found. 'aStarM' returns the shortest+  -- path to the first state for which this predicate returns 'True'.+  -> state+  -- ^ Initial state+  -> m (Maybe (cost, [state]))+  -- ^ (Total cost, list of steps) for the first path found which satisfies the+  -- given predicate+aStarM nextM costM remainingM foundM initial = do+  remaining_init <- remainingM initial+  fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd2 leastCostly nextM'+    (foundM . snd2) (remaining_init, (0, initial))+  where+    nextM' (_, (old_cost, old_st)) = do+      new_states <- Foldable.toList <$> nextM old_st+      sequence $ update_stateM <$> new_states+      where+        update_stateM new_st = do+          remaining <- remainingM new_st+          cost <- costM old_st new_st+          let new_cost = old_cost + cost+              new_est = new_cost + remaining+          return (new_est, (new_cost, new_st))+    unpack [] = (0, [])+    unpack packed_states =+      (fst . snd . last $ packed_states, map snd2 packed_states)+    snd2 = snd . snd++ -- | @incrementalCosts cost_fn states@ gives a list of the incremental costs -- going from state to state along the path given in @states@, using the cost -- function given by @cost_fn@. Note that the paths returned by the searches@@ -245,7 +365,22 @@   -- ^ List of incremental costs along given path incrementalCosts cost_fn states = zipWith cost_fn states (tail states) +-- | @incrementalCostsM@ is a monadic version of 'incrementalCosts': it has+-- support for a monadic @const_fn@ parameter.+incrementalCostsM ::+  (Monad m) =>+  (state -> state -> m cost)+  -- ^ Function to generate list of costs between neighboring states. This is+  -- only called for adjacent states in the `states` list, so it is safe to have+  -- this function be partial for non-neighboring states.+  -> [state]+  -- ^ A path, given as a list of adjacent states, along which to find the+  -- incremental costs+  -> m [cost]+  -- ^ List of incremental costs along given path+incrementalCostsM costM states = zipWithM costM states (tail states) + -- | @next \`pruning\` predicate@ streams the elements generate by @next@ into a -- list, removing elements which satisfy @predicate@. This is useful for the -- common case when you want to logically separate your search's `next` function@@ -286,6 +421,21 @@   (filter (not . predicate) . Foldable.toList) <$> next  +-- | @pruningM@ is a monadic version of 'pruning': it has support for monadic+-- @next@ and @predicate@ parameters+pruningM ::+  (Monad m, Foldable f)+  => (a -> m (f a))+  -- ^ Function to generate next states+  -> (a -> m Bool)+  -- ^ Predicate to prune on+  -> (a -> m [a])+  -- ^ Version of @next@ which excludes elements satisfying @predicate@+pruningM nextM predicateM a = do+  next_states <- nextM a+  filterM (fmap not. predicateM) $ Foldable.toList next_states++ -- | A @SearchState@ represents the state of a generalized search at a given -- point in an algorithms execution. The advantage of this abstraction is that -- it can be used for things like bidirectional searches, where you want to@@ -371,11 +521,93 @@      $ SearchState initial empty (Set.singleton $ mk_key initial)        (Map.singleton (mk_key initial) []) ++-- | @nextSearchState@ moves from one @searchState@ to the next in the+-- generalized search algorithm+nextSearchStateM ::+  (Monad m, Foldable f, SearchContainer container, Ord stateKey,+   Elem container ~ state)+  => ([state] -> [state] -> Bool)+  -> (state -> stateKey)+  -> (state -> m (f state))+  -> SearchState container stateKey state+  -> m (Maybe (SearchState container stateKey state))+nextSearchStateM better mk_key nextM old = do+  (new_queue, new_paths) <- new_queue_paths_M+  let new_state_May = mk_search_state new_paths <$> pop new_queue+  case new_state_May of+    Just new_state ->+      if mk_key (current new_state) `Set.member` visited old+      then nextSearchStateM better mk_key nextM new_state+      else return (Just new_state)+    Nothing -> return Nothing+  where+    mk_search_state new_paths (new_current, remaining_queue) = SearchState {+      current = new_current,+      queue = remaining_queue,+      visited = Set.insert (mk_key new_current) (visited old),+      paths = new_paths+      }+    new_queue_paths_M =+      List.foldl' update_queue_paths (queue old, paths old)+        <$> nextM (current old)+    update_queue_paths (old_queue, old_paths) st =+      if mk_key st `Set.member` visited old+      then (old_queue, old_paths)+      else+        case Map.lookup (mk_key st) old_paths of+          Just old_path ->+            if better old_path (st : steps_so_far)+            then (q', ps')+            else (old_queue, old_paths)+          Nothing -> (q', ps')+        where+          steps_so_far = paths old Map.! mk_key (current old)+          q' = push old_queue st+          ps' = Map.insert (mk_key st) (st : steps_so_far) old_paths+++-- | @generalizedSearchM@ is a monadic version of generalizedSearch+generalizedSearchM ::+  (Monad m, Foldable f, SearchContainer container, Ord stateKey,+   Elem container ~ state)+  => container+  -- ^ Empty @SearchContainer@+  -> (state -> stateKey)+  -- ^ Function to turn a @state@ into a key by which states will be compared+  -- when determining whether a state has be enqueued and / or visited+  -> ([state] -> [state] -> Bool)+  -- ^ Function @better old new@, which when given a choice between an @old@ and+  -- a @new@ path to a state, returns True when @new@ is a "better" path than+  -- old and should thus be inserted+  -> (state -> m (f state))+  -- ^ Function to generate "next" states given a current state+  -> (state -> m Bool)+  -- ^ Predicate to determine if solution found. @generalizedSearch@ returns a+  -- path to the first state for which this predicate returns 'True'.+  -> state+  -- ^ Initial state+  -> m (Maybe [state])+  -- ^ First path found to a state matching the predicate, or 'Nothing' if no+  -- such path exists.+generalizedSearchM empty mk_key better nextM foundM initial = do+  let initial_state =+        SearchState initial empty (Set.singleton $ mk_key initial)+        (Map.singleton (mk_key initial) [])+  end_May <- findIterateM (nextSearchStateM better mk_key nextM)+    (foundM . current) initial_state+  return $ fmap (reverse . get_steps) end_May+  where+    get_steps search_st = paths search_st Map.! mk_key (current search_st)++ newtype LIFOHeap k a = LIFOHeap (Map.Map k [a]) + emptyLIFOHeap :: LIFOHeap k a emptyLIFOHeap = LIFOHeap Map.empty + -- | The @SearchContainer@ class abstracts the idea of a container to be used in -- @generalizedSearch@ class SearchContainer container where@@ -419,6 +651,15 @@   | otherwise = next initial >>= findIterate next found  +-- | @findIterateM@ is a monadic version of @findIterate@+findIterateM :: Monad m => (a -> m (Maybe a)) -> (a -> m Bool) -> a -> m (Maybe a)+findIterateM nextM foundM initial = do+  found <- foundM initial+  if found+  then return $ Just initial+  else nextM initial >>= maybe (return Nothing) (findIterateM nextM foundM)++ -- | @leastCostly paths_a paths_b@ is a utility function to be used with -- 'dijkstra'-like functions. It returns True when the cost of @paths_a@ -- is less than the cost of @paths_b@, where the total costs are the first@@ -432,3 +673,8 @@ -- logically this never happens, because you cannot find -- a new zero-length path to a point leastCostly _ [] = True+++-- | This is just a convenience function which @fmap@s two deep+fmap2 :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)+fmap2 = fmap . fmap

@@ -46,14 +46,31 @@  -- | Example for taxicab path finding taxicabNeighbors :: (Int, Int) -> [(Int, Int)]-taxicabNeighbors (x, y) = [(x, y + 1), (x - 1, y), (x + 1, y), (x, y - 1)]+-- the ordering here is important--for dfs, last state will be visited first+taxicabNeighbors (x, y) = [(x, y + 1), (x - 1, y), (x, y - 1), (x + 1, y)]  isWall :: (Int, Int) -> Bool-isWall(x,y)=x==1&&(-2)<=y&&y<=1+isWall (x, y) = x == 1 && ((-2) <= y && y <= 1)  taxicabDistance :: (Int, Int) -> (Int, Int) -> Int taxicabDistance (x1, y1) (x2, y2) = abs (x2 - x1) + abs (y2 - y1) +taxicabNeighborsBounded :: (Int, Int) -> Maybe [(Int, Int)]+taxicabNeighborsBounded (x, y)+  | outOfBounds (x, y) = Nothing+  | otherwise = Just $ taxicabNeighbors (x, y)++taxicabDistanceBounded :: (Int, Int) -> (Int, Int) -> Maybe Int+taxicabDistanceBounded (x1, y1) (x2, y2)+  | outOfBounds (x1, y1) || outOfBounds (x2, y2) = Nothing+  | otherwise = Just $ taxicabDistance (x1, y1) (x2, y2)++outOfBounds :: (Int, Int) -> Bool+outOfBounds (x, y) = abs x + abs y > 10++isBigWall :: (Int, Int) -> Bool+isBigWall (x, y) = x == 1 && ((-10) <= y && y <= 10)+ spec :: Spec spec = do   describe "bfs" $ do@@ -114,6 +131,133 @@       aStar taxicabNeighbors taxicabDistance (taxicabDistance end) (== start)         start         `shouldBe` Just (0, [])+  describe "bfsM" $ do+    let start = (0, 0)+        end = (2, 0)+    it "performs monadic breadth-first search" $ do+      bfsM taxicabNeighborsBounded (return . (== end)) start+        `shouldBe` Just (Just [(1, 0), (2, 0)])+      bfsM+        (taxicabNeighborsBounded `pruningM` (return . isWall))+        (return . (== end))+        start+        `shouldBe` Just (Just [(0,1),(0,2),(1,2),(2,2),(2,1),(2,0)])+    it "handles cyclic graphs" $ do+      let nextM = return . map fst . (cyclicWeightedGraph Map.!)+      bfsM nextM (return . (== 'd')) 'a'+        `shouldBe` Just (Just ['b', 'd'])+    it "correctly handles monadic behavior" $ do+      bfsM+        (taxicabNeighborsBounded `pruningM` (return . isBigWall))+        (return . (== end))+        start+        `shouldBe` Nothing+      bfsM taxicabNeighborsBounded (const Nothing) start+        `shouldBe` Nothing+  describe "dfsM" $ do+    let start = (0, 0)+        end = (2, 0)+    it "performs monadic depth-first search" $+      dfsM taxicabNeighborsBounded (return . (== end)) start+        `shouldBe` Just (Just [(1, 0), (2, 0)])+    it "handles doubly-inserted nodes" $ do+      let nextM = return . (acyclicUnweightedGraph Map.!)+      dfsM nextM (return . (== 4)) 0 `shouldBe` Just (Just [1, 4])+    it "correctly handles monadic behavior" $ do+      dfsM+        (taxicabNeighborsBounded `pruningM` (return . isBigWall))+        (return . (== end))+        start+        `shouldBe` Nothing+      dfsM taxicabNeighborsBounded (const Nothing) start+        `shouldBe` Nothing+  describe "dijkstraM" $ do+    let start = (0, 0)+        end = (2, 0)+    it "performs monadic dijkstra's algorithm" $+      dijkstraM+        taxicabNeighborsBounded+        taxicabDistanceBounded+        (return . (== end))+        start+        `shouldBe` Just (Just (2, [(1, 0), (2, 0)]))+    it "handles cyclic graphs" $ do+      let nextM = return . map fst . (cyclicWeightedGraph Map.!)+          costM a b = lookup b $ cyclicWeightedGraph Map.! a+      dijkstraM nextM costM (return . (== 'd')) 'a'+        `shouldBe` Just (Just (4, ['c', 'd']))+      dijkstraM (nextM `pruningM` (return . (== 'c'))) costM+        (return . (== 'd')) 'a'+        `shouldBe` Just (Just (6, ['b', 'd']))+    it "handles zero-length solutions" $ do+      let nextM = return . map fst . (cyclicWeightedGraph Map.!)+          costM a b = lookup b $ cyclicWeightedGraph Map.! a+      dijkstraM nextM costM (return . (== 'd')) 'd'+        `shouldBe` Just (Just (0, []))+    it "correctly handles monadic behavior" $ do+      dijkstraM+        (taxicabNeighborsBounded `pruningM` (return . isBigWall))+        taxicabDistanceBounded+        (return . (== end))+        start+        `shouldBe` Nothing+      dijkstraM+        taxicabNeighborsBounded+        ((const . const) Nothing :: (Int, Int) -> (Int, Int) -> Maybe Int)+        (return . (== end))+        start+        `shouldBe` Nothing+      dijkstraM+        (taxicabNeighborsBounded `pruningM` (return . isBigWall))+        taxicabDistanceBounded+        (const Nothing)+        start+        `shouldBe` Nothing+  describe "aStarM" $ do+    let start = (0, 0)+        end = (2, 0)+    it "performs a monadic A* algorithm" $+      aStarM+        (taxicabNeighborsBounded `pruningM` (return . isWall))+        taxicabDistanceBounded+        (taxicabDistanceBounded end)+        (return . (== end))+        start+        `shouldBe`+        Just (Just (6, [(0, 1), (0, 2), (1, 2), (2, 2), (2, 1), (2, 0)]))+    it "handles zero-length solutions" $+      aStarM taxicabNeighborsBounded taxicabDistanceBounded+        (taxicabDistanceBounded end) (return . (== start)) start+        `shouldBe` Just (Just (0, []))+    it "correctly handles monadic behavior" $ do+      aStarM+        (taxicabNeighborsBounded `pruningM` (return . isBigWall))+        taxicabDistanceBounded+        (taxicabDistanceBounded end)+        (return . (== end))+        start+        `shouldBe` Nothing+      aStarM+        taxicabNeighborsBounded+        ((const . const) Nothing :: (Int, Int) -> (Int, Int) -> Maybe Int)+        (taxicabDistanceBounded end)+        (return . (== end))+        start+        `shouldBe` Nothing+      aStarM+        taxicabNeighborsBounded+        taxicabDistanceBounded+        (const Nothing)+        (return . (== end))+        start+        `shouldBe` Nothing+      aStarM+        taxicabNeighborsBounded+        taxicabDistanceBounded+        (taxicabDistanceBounded end)+        (const Nothing)+        start+        `shouldBe` Nothing   describe "incrementalCosts" $ do     let cost a b = fromJust . lookup b $ cyclicWeightedGraph Map.! a     it "gives the incremental costs along a path" $@@ -121,3 +265,12 @@     it "handles zero-length paths" $ do       incrementalCosts cost [] `shouldBe` []       incrementalCosts cost ['a'] `shouldBe` []+  describe "incrementalCostsM" $ do+    let costM a b = lookup b $ cyclicWeightedGraph Map.! a+    it "gives monadic incremental costs along a path" $+      incrementalCostsM costM ['a', 'b', 'd'] `shouldBe` Just [1, 5]+    it "handles zero-length paths" $ do+      incrementalCostsM costM [] `shouldBe` Just []+      incrementalCostsM costM ['a'] `shouldBe` Just []+    it "correctly handles monadic behavior" $+      incrementalCostsM costM ['a', 'd'] `shouldBe` Nothing