diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,35 @@ +# Changelog +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/) +and this project adheres to [Semantic Versioning](http://semver.org/). + +## [0.3.2] - 2021-12-27 +- Add two new functions, `dijkstraAssoc` and `aStarAssoc`. These allow for the simultaneous + computation of neighboring states and their costs. (Thank you to + [nagydani](https://github.com/nagydani)) + +## [0.3.1] - 2010-08-19 +- Dependencies version bump + +## [0.3.0] - 2017-11-29 +### Added +- Monadic versions of search algorithms and helper functions + +## [0.2.0] - 2017-05-13 +### Changed +- BREAKING CHANGE: Simplified return type of `dijkstra` and `aStar`. + - This should make these functions more ergonomic. + - Introduced new `incrementalCosts` function to compensate. +- BREAKING CHANGE: Replaced searches' `prunes` arguments with `pruning` combinator. +- BREAKING CHANGE: Split searches' `next` arguments into multiple arguments for `dijkstra` and `aStar`. + - This should make these functions more ergonomic. +- `next` arguments now only require a way of generating `Foldable`s, instead of lists specifically. + +## 0.1.0 - 2017-03-07 +- Initial release + +[0.3.2]: https://github.com/devonhollowood/search-algorithms/compare/v0.3.1...v0.3.2 +[0.3.1]: https://github.com/devonhollowood/search-algorithms/compare/v0.3.0...v0.3.1 +[0.3.0]: https://github.com/devonhollowood/search-algorithms/compare/v0.2.0...v0.3.0 +[0.2.0]: https://github.com/devonhollowood/search-algorithms/compare/v0.1.0...v0.2.0 diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -0,0 +1,41 @@ +import Criterion.Main +import Algorithm.Search + +type Position = (Int, Int) + +wall :: Int -> Position -> Bool +wall height (x, y) = x == 0 && abs y <= height + +neighbors :: Position -> [Position] +neighbors (x, y) = [ + (x - 1, y), + (x, y - 1), + (x + 1, y), + (x, y + 1) + ] + +dist :: Position -> Position -> Int +dist (x1, y1) (x2, y2) = abs (x2 - x1) + abs (y2 - y1) + +aStarWall :: Int -> Maybe (Int, [Position]) +aStarWall height = aStar + (neighbors `pruning` wall height) -- next + (\_ _ -> 1) -- cost + (dist end) -- remaining + (== end) -- at end + start -- initial + where + start = (-3, 0) + end = (3, 0) + +main :: IO () +main = defaultMain [ + bgroup "aStar Wall Benchmark" [ + bench "Size 2 wall" $ nf aStarWall 2, + bench "Size 4 wall" $ nf aStarWall 4, + bench "Size 8 wall" $ nf aStarWall 8, + bench "Size 16 wall" $ nf aStarWall 16, + bench "Size 32 wall" $ nf aStarWall 32, + bench "Size 64 wall" $ nf aStarWall 64 + ] + ] 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.1 +version: 0.3.2 synopsis: Common graph search algorithms description: Library containing common graph search algorithms, including depth-first and breadth-first searches, @@ -13,6 +13,7 @@ category: Algorithm build-type: Simple extra-source-files: README.md + , CHANGELOG.md cabal-version: >=1.10 library @@ -43,6 +44,16 @@ , search-algorithms , containers >= 0.5 , doctest >= 0.8 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +benchmark search-algorithms-benchmark + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: bench.hs + build-depends: base + , search-algorithms + , criterion ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 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 @@ -12,7 +12,9 @@ bfs, dfs, dijkstra, + dijkstraAssoc, aStar, + aStarAssoc, -- * Monadic Searches -- $monadic bfsM, @@ -31,6 +33,7 @@ import qualified Data.Set as Set import qualified Data.List as List import qualified Data.Foldable as Foldable +import Data.Functor.Identity (Identity(..)) import Control.Monad (filterM, zipWithM) -- | @bfs next found initial@ performs a breadth-first search over a set of @@ -127,7 +130,7 @@ => (state -> f state) -- ^ Function to generate list of neighboring states given the current state -> (state -> state -> cost) - -- ^ Function to generate list of costs between neighboring states. This is + -- ^ Function to generate transition 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 -> Bool) @@ -139,19 +142,50 @@ -- ^ (Total cost, list of steps) for the first path found which -- satisfies the given predicate dijkstra next cost found initial = + -- This API to Dijkstra's algorithm is useful when the state transition + -- function and the cost function are logically separate. + -- It is implemented by using @dijkstraAssoc@ with appropriate mapping of + -- arguments. + dijkstraAssoc next' found initial + where + next' st = map (\new_st -> (new_st, cost st new_st)) $ + Foldable.toList (next st) + +-- | @dijkstraAssoc next found initial@ performs a shortest-path search over +-- a set of states using Dijkstra's algorithm, starting with @initial@, +-- generating neighboring states with associated incremenal costs with +-- @next@. This will find the least-costly path from an initial state to a +-- state for which @found@ returns 'True'. Returns 'Nothing' if no path to a +-- solved state is possible. +dijkstraAssoc :: (Num cost, Ord cost, Ord state) + => (state -> [(state, cost)]) + -- ^ function to generate list of neighboring states with associated + -- transition costs given the current state + -> (state -> Bool) + -- ^ Predicate to determine if solution found. 'dijkstraAssoc' returns the + -- shortest path to the first state for which this predicate returns 'True'. + -> state + -- ^ Initial state + -> Maybe (cost, [state]) + -- ^ (Total cost, list of steps) for the first path found which + -- satisfies the given predicate +dijkstraAssoc next found initial = + -- This API to Dijkstra's algoritm is useful in the common case when next + -- states and their associated transition costs are generated together. + -- -- Dijkstra's algorithm can be viewed as a generalized search, with the search -- container being a heap, with the states being compared without regard to -- cost, with the shorter paths taking precedence over longer ones, and with -- the stored state being (cost so far, state). -- This implementation makes that transformation, then transforms that result - -- back into the desired result from @dijkstra@ + -- back into the desired result from @dijkstraAssoc@ unpack <$> generalizedSearch emptyLIFOHeap snd leastCostly next' (found . snd) (0, initial) where next' (old_cost, st) = - (\new_st -> (cost st new_st + old_cost, new_st)) - <$> Foldable.toList (next st) + (\(new_st, new_cost) -> (new_cost + old_cost, new_st)) + <$> (next st) unpack [] = (0, []) unpack packed_states = (fst . last $ packed_states, map snd packed_states) @@ -178,11 +212,9 @@ -- Just (4,[(1,0),(1,1),(1,2),(0,2)]) aStar :: (Foldable f, Num cost, Ord cost, Ord state) => (state -> 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 given the current state -> (state -> state -> cost) - -- ^ Function to generate list of costs between neighboring states. This is + -- ^ Function to generate transition 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 -> cost) @@ -196,20 +228,54 @@ -- ^ (Total cost, list of steps) for the first path found which satisfies the -- given predicate aStar next cost remaining found initial = + -- This API to A* search is useful when the state transition + -- function and the cost function are logically separate. + -- It is implemented by using @aStarAssoc@ with appropriate mapping of + -- arguments. + aStarAssoc next' remaining found initial + where + next' st = map (\new_st -> (new_st, cost st new_st)) $ + Foldable.toList (next st) + +-- | @aStarAssoc next remaining found initial@ performs a best-first search +-- using the A* search algorithm, starting with the state @initial@, generating +-- neighboring states and their associated costs with @next@, 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 +-- remaining cost to reach a solved state, then the returned path is the +-- shortest path. Returns 'Nothing' if no path to a solved state is possible. +aStarAssoc :: (Num cost, Ord cost, Ord state) + => (state -> [(state, cost)]) + -- ^ function to generate list of neighboring states with associated + -- transition costs given the current state + -> (state -> cost) + -- ^ Estimate on remaining cost given a state + -> (state -> Bool) + -- ^ Predicate to determine if solution found. 'aStar' returns the shortest + -- path to the first state for which this predicate returns 'True'. + -> state + -- ^ Initial state + -> Maybe (cost, [state]) + -- ^ (Total cost, list of steps) for the first path found which satisfies the + -- given predicate +aStarAssoc next remaining found initial = + -- This API to A* search is useful in the common case when next + -- states and their associated transition costs are generated together. + -- -- A* can be viewed as a generalized search, with the search container being a -- heap, with the states being compared without regard to cost, with the -- shorter paths taking precedence over longer ones, and with -- the stored state being (total cost estimate, (cost so far, state)). -- This implementation makes that transformation, then transforms that result - -- back into the desired result from @aStar@ + -- back into the desired result from @aStarAssoc@ unpack <$> generalizedSearch emptyLIFOHeap snd2 leastCostly next' (found . snd2) (remaining initial, (0, initial)) where next' (_, (old_cost, old_st)) = - update_state <$> Foldable.toList (next old_st) + update_state <$> (next old_st) where - update_state new_st = - let new_cost = old_cost + cost old_st new_st + update_state (new_st, cost) = + let new_cost = old_cost + cost new_est = new_cost + remaining new_st in (new_est, (new_cost, new_st)) unpack [] = (0, []) @@ -447,47 +513,6 @@ paths :: Map.Map stateKey [state] } - --- | @nextSearchState@ moves from one @searchState@ to the next in the --- generalized search algorithm -nextSearchState :: - (Foldable f, SearchContainer container, Ord stateKey, Elem container ~ state) - => ([state] -> [state] -> Bool) - -> (state -> stateKey) - -> (state -> f state) - -> SearchState container stateKey state - -> Maybe (SearchState container stateKey state) -nextSearchState better mk_key next old = do - new_state <- mk_search_state <$> pop new_queue - if mk_key (current new_state) `Set.member` visited old - then nextSearchState better mk_key next new_state - else Just new_state - where - mk_search_state (new_current, remaining_queue) = SearchState { - current = new_current, - queue = remaining_queue, - visited = Set.insert (mk_key new_current) (visited old), - paths = new_paths - } - new_states = next (current old) - (new_queue, new_paths) = - List.foldl' update_queue_paths (queue old, paths old) new_states - 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 - - -- | Workhorse simple search algorithm, generalized over search container -- and path-choosing function. The idea here is that many search algorithms are -- at their core the same, with these details substituted. By writing these @@ -514,13 +539,8 @@ -> Maybe [state] -- ^ First path found to a state matching the predicate, or 'Nothing' if no -- such path exists. -generalizedSearch empty mk_key better next found initial = - let get_steps search_st = paths search_st Map.! mk_key (current search_st) - in fmap (reverse . get_steps) - . findIterate (nextSearchState better mk_key next) (found . current) - $ SearchState initial empty (Set.singleton $ mk_key initial) - (Map.singleton (mk_key initial) []) - +generalizedSearch empty mk_key better next found initial = runIdentity $ + generalizedSearchM empty mk_key better (Identity . next) (Identity . found) initial -- | @nextSearchState@ moves from one @searchState@ to the next in the -- generalized search algorithm @@ -641,14 +661,6 @@ (_, []) -> pop (LIFOHeap $ Map.deleteMin inner) -- Logically, this should never happen push (LIFOHeap inner) (k, a) = LIFOHeap $ Map.insertWith (++) k [a] inner - - --- | @findIterate found next initial@ takes an initial seed value and applies --- @next@ to it until either @found@ returns True or @next@ returns @Nothing@ -findIterate :: (a -> Maybe a) -> (a -> Bool) -> a -> Maybe a -findIterate next found initial - | found initial = Just initial - | otherwise = next initial >>= findIterate next found -- | @findIterateM@ is a monadic version of @findIterate@