diff --git a/search-algorithms.cabal b/search-algorithms.cabal --- a/search-algorithms.cabal +++ b/search-algorithms.cabal @@ -1,5 +1,5 @@ name: search-algorithms -version: 0.3.2 +version: 0.3.3 synopsis: Common graph search algorithms description: Library containing common graph search algorithms, including depth-first and breadth-first searches, @@ -20,7 +20,7 @@ hs-source-dirs: src exposed-modules: Algorithm.Search build-depends: base >= 4.7 && < 5 - , containers >= 0.5 && < 0.7 + , containers >= 0.5 && < 0.8 ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Algorithm/Search.hs b/src/Algorithm/Search.hs --- a/src/Algorithm/Search.hs +++ b/src/Algorithm/Search.hs @@ -1,6 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | This module contains a collection of generalized graph search algorithms, -- for when you don't want to explicitly represent your data as a graph. The @@ -20,12 +21,16 @@ bfsM, dfsM, dijkstraM, + dijkstraAssocM, aStarM, + aStarAssocM, -- * Utility incrementalCosts, incrementalCostsM, pruning, - pruningM + pruningAssoc, + pruningM, + pruningAssocM ) where import qualified Data.Map as Map @@ -351,13 +356,37 @@ unpack packed_states = (fst . last $ packed_states, map snd packed_states) +-- | @dijkstraAssocM@ is a monadic version of 'dijkstraAssoc': it has support +-- for monadic @next@ and @found@ parameters. +dijkstraAssocM :: (Monad m, Num cost, Ord cost, Ord state) + => (state -> m [(state, cost)]) + -- ^ Function to generate list of neighboring states with associated + -- transition costs given the current state + -> (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 +dijkstraAssocM nextM foundM initial = + fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd leastCostly nextM' + (foundM . snd) (0, initial) + where + nextM' (old_cost, old_st) = do + new_states <- nextM old_st + return $ map (\(x, y) -> (y, x)) 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). + -- ^ function to generate list of neighboring states with associated + -- transition costs 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 @@ -393,6 +422,42 @@ snd2 = snd . snd +-- | @aStarAssocM@ is a monadic version of 'aStarAssoc': it has support for +-- monadic @next@, @remaining@, and @found@ parameters. +aStarAssocM :: (Monad m, Num cost, Ord cost, Ord state) + => (state -> m [(state, cost)]) + -- ^ function to generate list of neighboring states with associated + -- transition costs given the current state + -> (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 +aStarAssocM nextM 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 <- nextM old_st + sequence $ update_stateM <$> new_states + where + update_stateM new_st = do + remaining <- remainingM (fst new_st) + let new_cost = old_cost + (snd new_st) + new_est = new_cost + remaining + return (new_est, (new_cost, fst 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 @@ -487,6 +552,18 @@ (filter (not . predicate) . Foldable.toList) <$> next +-- | @pruningAssoc@ is a version of 'pruning' that works with the `Assoc` variants of searches. +pruningAssoc :: + (Foldable f) + => (state -> f (state, cost)) + -- ^ Function to generate next states + -> ((state, cost) -> Bool) + -- ^ Predicate to prune on + -> (state -> [(state, cost)]) + -- ^ Version of @next@ which excludes elements satisfying @predicate@ +next `pruningAssoc` predicate = + (filter (not . predicate) . Foldable.toList) <$> next + -- | @pruningM@ is a monadic version of 'pruning': it has support for monadic -- @next@ and @predicate@ parameters pruningM :: @@ -499,7 +576,21 @@ -- ^ 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 + filterM (fmap not . predicateM) $ Foldable.toList next_states + +-- | @pruningAssocM@ is a monadic version of 'pruningAssoc': it has support for monadic +-- @next@ and @predicate@ parameters +pruningAssocM :: + (Monad m, Foldable f) + => (state -> m (f (state, cost))) + -- ^ Function to generate next states + -> ((state, cost) -> m Bool) + -- ^ Predicate to prune on + -> (state -> m [(state, cost)]) + -- ^ Version of @next@ which excludes elements satisfying @predicate@ +pruningAssocM 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 diff --git a/test/Algorithm/SearchSpec.hs b/test/Algorithm/SearchSpec.hs --- a/test/Algorithm/SearchSpec.hs +++ b/test/Algorithm/SearchSpec.hs @@ -274,3 +274,15 @@ incrementalCostsM costM ['a'] `shouldBe` Just [] it "correctly handles monadic behavior" $ incrementalCostsM costM ['a', 'd'] `shouldBe` Nothing + describe "pruning" $ do + it "filters according to its predicate" $ + ((\x -> [x, 2*x, 3*x]) `pruning` even) 3 `shouldBe` [3, 9] + describe "pruningAssoc" $ do + it "filters according to its predicate" $ + ((\x -> [(x, 1), (2*x, 2)]) `pruningAssoc` (\(_, cost) -> cost > 1)) 3 `shouldBe` [(3, 1)] + describe "pruningM" $ do + it "filters according to its predicate" $ + ((\x -> (Just [x, 2*x, 3*x])) `pruningM` (\x -> Just (even x))) 3 `shouldBe` Just [3, 9] + describe "pruningAssocM" $ do + it "filters according to its predicate" $ + ((\x -> Just [(x, 1), (2*x, 2)]) `pruningAssocM` (\(_, cost) -> Just (cost > 1))) 3 `shouldBe` Just [(3, 1)]