├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── Setup.hs ├── bench └── bench.hs ├── search-algorithms.cabal ├── src └── Algorithm │ └── Search.hs ├── stack.yaml └── test ├── Algorithm └── SearchSpec.hs ├── Spec.hs └── doctests.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *.tar.gz 3 | *.lock 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Taken from https://docs.haskellstack.org/en/stable/travis_ci/ 2 | 3 | sudo: false 4 | language: generic 5 | cache: 6 | directories: 7 | - $HOME/.stack 8 | addons: 9 | apt: 10 | packages: 11 | - libgmp-dev 12 | 13 | before_install: 14 | - mkdir -p ~/.local/bin 15 | - export PATH=$HOME/.local/bin:$PATH 16 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 17 | 18 | install: 19 | - stack --no-terminal --install-ghc test --only-dependencies 20 | 21 | script: 22 | - stack --no-terminal test --haddock --no-haddock-deps 23 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. 3 | 4 | The format is based on [Keep a Changelog](http://keepachangelog.com/) 5 | and this project adheres to [Semantic Versioning](http://semver.org/). 6 | 7 | ## [0.3.2] - 2021-12-27 8 | - Add two new functions, `dijkstraAssoc` and `aStarAssoc`. These allow for the simultaneous 9 | computation of neighboring states and their costs. (Thank you to 10 | [nagydani](https://github.com/nagydani)) 11 | 12 | ## [0.3.1] - 2010-08-19 13 | - Dependencies version bump 14 | 15 | ## [0.3.0] - 2017-11-29 16 | ### Added 17 | - Monadic versions of search algorithms and helper functions 18 | 19 | ## [0.2.0] - 2017-05-13 20 | ### Changed 21 | - BREAKING CHANGE: Simplified return type of `dijkstra` and `aStar`. 22 | - This should make these functions more ergonomic. 23 | - Introduced new `incrementalCosts` function to compensate. 24 | - BREAKING CHANGE: Replaced searches' `prunes` arguments with `pruning` combinator. 25 | - BREAKING CHANGE: Split searches' `next` arguments into multiple arguments for `dijkstra` and `aStar`. 26 | - This should make these functions more ergonomic. 27 | - `next` arguments now only require a way of generating `Foldable`s, instead of lists specifically. 28 | 29 | ## 0.1.0 - 2017-03-07 30 | - Initial release 31 | 32 | [0.3.2]: https://github.com/devonhollowood/search-algorithms/compare/v0.3.1...v0.3.2 33 | [0.3.1]: https://github.com/devonhollowood/search-algorithms/compare/v0.3.0...v0.3.1 34 | [0.3.0]: https://github.com/devonhollowood/search-algorithms/compare/v0.2.0...v0.3.0 35 | [0.2.0]: https://github.com/devonhollowood/search-algorithms/compare/v0.1.0...v0.2.0 36 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | ## Bugs 4 | If you find any bugs in this library, please submit an issue here on GitHub and I'll try to fix it ASAP. If you want to fix it yourself, go ahead and submit a pull request in addition to the issue. I will be very grateful. 5 | 6 | ## Feature Requests 7 | If you have a feature that you'd like added to this library, submit an issue here on GitHub. We can talk about feasibility, whether it fits in with the rest of the library, etc. If you'd like to try implementing the feature yourself after we decide that it is a good addition, let me know and then feel free to submit a pull request! I also don't have anything against drive-by pull requests, but it's probably best to check via an issue first to make sure that it's a good idea and that no one else is working on it before you put in the time. 8 | 9 | ## Making Changes 10 | After submitting an issue for your bug / feature request, if you want to make a pull request, go ahead! The code should be fairly well-documented, and if it's not well-documented and you find it very confusing, let me know and I'll try to improve the documentation. Adding tests for your changes is preferred when practical, and any new functions or features should be documented. When modifying the current code, you'll notice that most of the searches use the same `generalizedSearch` function at their core. Feel free to not do this with your submitted code--I would rather have more algorithms, implemented separately and with code duplication, than to have less algorithms and "more elegant" code. 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Devon Hollowood (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Devon Hollowood nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # search-algorithms 2 | Haskell library containing common graph search algorithms 3 | 4 | [![Build Status](https://travis-ci.org/devonhollowood/search-algorithms.svg?branch=master)](https://travis-ci.org/devonhollowood/search-algorithms) 5 | 6 | Lots of problems can be modeled as graphs, but oftentimes one doesn't want to use an explicit graph structure to represent the problem. Maybe the graph would be too big (or is infinite), maybe making an explicit graph is unwieldy for the problem at hand, or maybe one just wants to generalize over graph implementations. That's where this library comes in: this is a collection of generalized search algorithms, so that one doesn't have to make the graphs explicit. In general, this means that one provides each search function with a function to generate neighboring states, possibly some functions to generate additional information for the search, a predicate which tells when the search is complete, and an initial state to start from. The result is a path from the initial state to a "solved" state, or `Nothing` if no such path is possible. 7 | 8 | ## Documentation 9 | Documentation is hosted on [Hackage](http://hackage.haskell.org/package/search-algorithms). 10 | 11 | ## Acknowledgements 12 | This library shares a similar functionality with the [astar](http://hackage.haskell.org/package/astar) library (which I was unaware of when I released the first version of this library). `astar`'s interface has since influenced the development of this library's interface, and this library owes a debt of gratitude to `astar` for that reason. 13 | 14 | 15 | ## Examples 16 | ### Change-making problem 17 | ```haskell 18 | import Algorithm.Search (bfs) 19 | 20 | countChange target = bfs (add_one_coin `pruning` (> target)) (== target) 0 21 | where 22 | add_one_coin amt = map (+ amt) coins 23 | coins = [1, 5, 10, 25] 24 | 25 | -- countChange gives the subtotals along the way to the end: 26 | -- >>> countChange 67 27 | -- Just [1, 2, 7, 17, 42, 67] 28 | ``` 29 | 30 | ### Simple directed acyclic graph: 31 | ```haskell 32 | import Algorithm.Search (dfs) 33 | import qualified Data.Map as Map 34 | 35 | graph = Map.fromList [ 36 | (1, [2, 3]), 37 | (2, [4]), 38 | (3, [4]), 39 | (4, []) 40 | ] 41 | 42 | -- Run dfs on the graph: 43 | -- >>> dfs (graph Map.!) (== 4) 1 44 | -- Just [3,4] 45 | ``` 46 | 47 | ### Using A* to find a path in an area with a wall: 48 | ```haskell 49 | import Algorithm.Search (aStar) 50 | 51 | taxicabNeighbors :: (Int, Int) -> [(Int, Int)] 52 | taxicabNeighbors (x, y) = [(x, y + 1), (x - 1, y), (x + 1, y), (x, y - 1)] 53 | 54 | isWall :: (Int, Int) -> Bool 55 | isWall (x, y) = x == 1 && (-2) <= y && y <= 1 56 | 57 | taxicabDistance :: (Int, Int) -> (Int, Int) -> Int 58 | taxicabDistance (x1, y1) (x2, y2) = abs (x2 - x1) + abs (y2 - y1) 59 | 60 | findPath :: (Int, Int) -> (Int, Int) -> Maybe (Int, [(Int, (Int, Int))]) 61 | findPath start end = 62 | let next = taxicabNeighbors 63 | cost = taxicabDistance 64 | remaining = (taxicabDistance end) 65 | in aStar (next `pruning` isWall) cost remaining (== end) start 66 | 67 | -- findPath p1 p2 finds a path between p1 and p2, avoiding the wall 68 | -- >>> findPath (0, 0) (2, 0) 69 | -- Just (6,[(0,1),(0,2),(1,2),(2,2),(2,1),(2,0)]) 70 | -- 71 | -- This correctly goes up and around the wall 72 | ``` 73 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/bench.hs: -------------------------------------------------------------------------------- 1 | import Criterion.Main 2 | import Algorithm.Search 3 | 4 | type Position = (Int, Int) 5 | 6 | wall :: Int -> Position -> Bool 7 | wall height (x, y) = x == 0 && abs y <= height 8 | 9 | neighbors :: Position -> [Position] 10 | neighbors (x, y) = [ 11 | (x - 1, y), 12 | (x, y - 1), 13 | (x + 1, y), 14 | (x, y + 1) 15 | ] 16 | 17 | dist :: Position -> Position -> Int 18 | dist (x1, y1) (x2, y2) = abs (x2 - x1) + abs (y2 - y1) 19 | 20 | aStarWall :: Int -> Maybe (Int, [Position]) 21 | aStarWall height = aStar 22 | (neighbors `pruning` wall height) -- next 23 | (\_ _ -> 1) -- cost 24 | (dist end) -- remaining 25 | (== end) -- at end 26 | start -- initial 27 | where 28 | start = (-3, 0) 29 | end = (3, 0) 30 | 31 | main :: IO () 32 | main = defaultMain [ 33 | bgroup "aStar Wall Benchmark" [ 34 | bench "Size 2 wall" $ nf aStarWall 2, 35 | bench "Size 4 wall" $ nf aStarWall 4, 36 | bench "Size 8 wall" $ nf aStarWall 8, 37 | bench "Size 16 wall" $ nf aStarWall 16, 38 | bench "Size 32 wall" $ nf aStarWall 32, 39 | bench "Size 64 wall" $ nf aStarWall 64 40 | ] 41 | ] 42 | -------------------------------------------------------------------------------- /search-algorithms.cabal: -------------------------------------------------------------------------------- 1 | name: search-algorithms 2 | version: 0.3.3 3 | synopsis: Common graph search algorithms 4 | description: Library containing common graph search algorithms, 5 | including depth-first and breadth-first searches, 6 | Dijkstra's algorithm, and A* 7 | homepage: https://github.com/devonhollowood/search-algorithms#readme 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Devon Hollowood 11 | maintainer: devonhollowood@gmail.com 12 | copyright: 2017 Devon Hollowood 13 | category: Algorithm 14 | build-type: Simple 15 | extra-source-files: README.md 16 | , CHANGELOG.md 17 | cabal-version: >=1.10 18 | 19 | library 20 | hs-source-dirs: src 21 | exposed-modules: Algorithm.Search 22 | build-depends: base >= 4.7 && < 5 23 | , containers >= 0.5 && < 0.8 24 | ghc-options: -Wall 25 | default-language: Haskell2010 26 | 27 | test-suite search-algorithms-test 28 | type: exitcode-stdio-1.0 29 | hs-source-dirs: test 30 | main-is: Spec.hs 31 | other-modules: Algorithm.SearchSpec 32 | build-depends: base 33 | , search-algorithms 34 | , containers >= 0.5 35 | , hspec >= 2.2 36 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 37 | default-language: Haskell2010 38 | 39 | test-suite doc-test 40 | type: exitcode-stdio-1.0 41 | hs-source-dirs: test 42 | main-is: doctests.hs 43 | build-depends: base 44 | , search-algorithms 45 | , containers >= 0.5 46 | , doctest >= 0.8 47 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 48 | default-language: Haskell2010 49 | 50 | benchmark search-algorithms-benchmark 51 | type: exitcode-stdio-1.0 52 | hs-source-dirs: bench 53 | main-is: bench.hs 54 | build-depends: base 55 | , search-algorithms 56 | , criterion 57 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 58 | default-language: Haskell2010 59 | 60 | source-repository head 61 | type: git 62 | location: https://github.com/devonhollowood/search-algorithms 63 | -------------------------------------------------------------------------------- /src/Algorithm/Search.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | -- | This module contains a collection of generalized graph search algorithms, 7 | -- for when you don't want to explicitly represent your data as a graph. The 8 | -- general idea is to provide these algorithms with a way of generating "next" 9 | -- states, a way of generating associated information, a way of determining 10 | -- when you have found a solution, and an initial state. 11 | module Algorithm.Search ( 12 | -- * Searches 13 | bfs, 14 | dfs, 15 | dijkstra, 16 | dijkstraAssoc, 17 | aStar, 18 | aStarAssoc, 19 | -- * Monadic Searches 20 | -- $monadic 21 | bfsM, 22 | dfsM, 23 | dijkstraM, 24 | dijkstraAssocM, 25 | aStarM, 26 | aStarAssocM, 27 | -- * Utility 28 | incrementalCosts, 29 | incrementalCostsM, 30 | pruning, 31 | pruningAssoc, 32 | pruningM, 33 | pruningAssocM 34 | ) where 35 | 36 | import qualified Data.Map as Map 37 | import qualified Data.Sequence as Seq 38 | import qualified Data.Set as Set 39 | import qualified Data.List as List 40 | import qualified Data.Foldable as Foldable 41 | import Data.Functor.Identity (Identity(..)) 42 | import Control.Monad (filterM, zipWithM) 43 | 44 | -- | @bfs next found initial@ performs a breadth-first search over a set of 45 | -- states, starting with @initial@, and generating neighboring states with 46 | -- @next@. It returns a path to a state for which @found@ returns 'True'. 47 | -- Returns 'Nothing' if no path is possible. 48 | -- 49 | -- === Example: Making change problem 50 | -- 51 | -- >>> :{ 52 | -- countChange target = bfs (add_one_coin `pruning` (> target)) (== target) 0 53 | -- where 54 | -- add_one_coin amt = map (+ amt) coins 55 | -- coins = [25, 10, 5, 1] 56 | -- :} 57 | -- 58 | -- >>> countChange 67 59 | -- Just [25,50,60,65,66,67] 60 | bfs :: (Foldable f, Ord state) 61 | => (state -> f state) 62 | -- ^ Function to generate "next" states given a current state 63 | -> (state -> Bool) 64 | -- ^ Predicate to determine if solution found. 'bfs' returns a path to the 65 | -- first state for which this predicate returns 'True'. 66 | -> state 67 | -- ^ Initial state 68 | -> Maybe [state] 69 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 70 | -- such path exists. 71 | bfs = 72 | -- BFS is a generalized search using a queue, which directly compares states, 73 | -- and which always uses the first path found to a state 74 | generalizedSearch Seq.empty id (\_ _ -> False) 75 | 76 | 77 | -- | @dfs next found initial@ performs a depth-first search over a set 78 | -- of states, starting with @initial@ and generating neighboring states with 79 | -- @next@. It returns a depth-first path to a state for which @found@ returns 80 | -- 'True'. Returns 'Nothing' if no path is possible. 81 | -- 82 | -- === Example: Simple directed graph search 83 | -- 84 | -- >>> import qualified Data.Map as Map 85 | -- 86 | -- >>> graph = Map.fromList [(1, [2, 3]), (2, [4]), (3, [4]), (4, [])] 87 | -- 88 | -- >>> dfs (graph Map.!) (== 4) 1 89 | -- Just [3,4] 90 | dfs :: (Foldable f, Ord state) 91 | => (state -> f state) 92 | -- ^ Function to generate "next" states given a current state. These should be 93 | -- given in the order in which states should be pushed onto the stack, i.e. 94 | -- the "last" state in the Foldable will be the first one visited. 95 | -> (state -> Bool) 96 | -- ^ Predicate to determine if solution found. 'dfs' returns a path to the 97 | -- first state for which this predicate returns 'True'. 98 | -> state 99 | -- ^ Initial state 100 | -> Maybe [state] 101 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 102 | -- such path exists. 103 | dfs = 104 | -- DFS is a generalized search using a stack, which directly compares states, 105 | -- and which always uses the most recent path found to a state 106 | generalizedSearch [] id (\_ _ -> True) 107 | 108 | 109 | -- | @dijkstra next cost found initial@ performs a shortest-path search over 110 | -- a set of states using Dijkstra's algorithm, starting with @initial@, 111 | -- generating neighboring states with @next@, and their incremental costs with 112 | -- @costs@. This will find the least-costly path from an initial state to a 113 | -- state for which @found@ returns 'True'. Returns 'Nothing' if no path to a 114 | -- solved state is possible. 115 | -- 116 | -- === Example: Making change problem, with a twist 117 | -- 118 | -- >>> :{ 119 | -- -- Twist: dimes have a face value of 10 cents, but are actually rare 120 | -- -- misprints which are worth 10 dollars 121 | -- countChange target = 122 | -- dijkstra (add_coin `pruning` (> target)) true_cost (== target) 0 123 | -- where 124 | -- coin_values = [(25, 25), (10, 1000), (5, 5), (1, 1)] 125 | -- add_coin amt = map ((+ amt) . snd) coin_values 126 | -- true_cost low high = 127 | -- case lookup (high - low) coin_values of 128 | -- Just val -> val 129 | -- Nothing -> error $ "invalid costs: " ++ show high ++ ", " ++ show low 130 | -- :} 131 | -- 132 | -- >>> countChange 67 133 | -- Just (67,[1,2,7,12,17,42,67]) 134 | dijkstra :: (Foldable f, Num cost, Ord cost, Ord state) 135 | => (state -> f state) 136 | -- ^ Function to generate list of neighboring states given the current state 137 | -> (state -> state -> cost) 138 | -- ^ Function to generate transition costs between neighboring states. This is 139 | -- only called for adjacent states, so it is safe to have this function be 140 | -- partial for non-neighboring states. 141 | -> (state -> Bool) 142 | -- ^ Predicate to determine if solution found. 'dijkstra' returns the shortest 143 | -- path to the first state for which this predicate returns 'True'. 144 | -> state 145 | -- ^ Initial state 146 | -> Maybe (cost, [state]) 147 | -- ^ (Total cost, list of steps) for the first path found which 148 | -- satisfies the given predicate 149 | dijkstra next cost found initial = 150 | -- This API to Dijkstra's algorithm is useful when the state transition 151 | -- function and the cost function are logically separate. 152 | -- It is implemented by using @dijkstraAssoc@ with appropriate mapping of 153 | -- arguments. 154 | dijkstraAssoc next' found initial 155 | where 156 | next' st = map (\new_st -> (new_st, cost st new_st)) $ 157 | Foldable.toList (next st) 158 | 159 | -- | @dijkstraAssoc next found initial@ performs a shortest-path search over 160 | -- a set of states using Dijkstra's algorithm, starting with @initial@, 161 | -- generating neighboring states with associated incremenal costs with 162 | -- @next@. This will find the least-costly path from an initial state to a 163 | -- state for which @found@ returns 'True'. Returns 'Nothing' if no path to a 164 | -- solved state is possible. 165 | dijkstraAssoc :: (Num cost, Ord cost, Ord state) 166 | => (state -> [(state, cost)]) 167 | -- ^ function to generate list of neighboring states with associated 168 | -- transition costs given the current state 169 | -> (state -> Bool) 170 | -- ^ Predicate to determine if solution found. 'dijkstraAssoc' returns the 171 | -- shortest path to the first state for which this predicate returns 'True'. 172 | -> state 173 | -- ^ Initial state 174 | -> Maybe (cost, [state]) 175 | -- ^ (Total cost, list of steps) for the first path found which 176 | -- satisfies the given predicate 177 | dijkstraAssoc next found initial = 178 | -- This API to Dijkstra's algoritm is useful in the common case when next 179 | -- states and their associated transition costs are generated together. 180 | -- 181 | -- Dijkstra's algorithm can be viewed as a generalized search, with the search 182 | -- container being a heap, with the states being compared without regard to 183 | -- cost, with the shorter paths taking precedence over longer ones, and with 184 | -- the stored state being (cost so far, state). 185 | -- This implementation makes that transformation, then transforms that result 186 | -- back into the desired result from @dijkstraAssoc@ 187 | unpack <$> 188 | generalizedSearch emptyLIFOHeap snd leastCostly next' (found . snd) 189 | (0, initial) 190 | where 191 | next' (old_cost, st) = 192 | (\(new_st, new_cost) -> (new_cost + old_cost, new_st)) 193 | <$> (next st) 194 | unpack [] = (0, []) 195 | unpack packed_states = (fst . last $ packed_states, map snd packed_states) 196 | 197 | 198 | -- | @aStar next cost remaining found initial@ performs a best-first search 199 | -- using the A* search algorithm, starting with the state @initial@, generating 200 | -- neighboring states with @next@, their cost with @cost@, and an estimate of 201 | -- the remaining cost with @remaining@. This returns a path to a state for which 202 | -- @found@ returns 'True'. If @remaining@ is strictly a lower bound on the 203 | -- remaining cost to reach a solved state, then the returned path is the 204 | -- shortest path. Returns 'Nothing' if no path to a solved state is possible. 205 | -- 206 | -- === Example: Path finding in taxicab geometry 207 | -- 208 | -- >>> :{ 209 | -- neighbors (x, y) = [(x, y + 1), (x - 1, y), (x + 1, y), (x, y - 1)] 210 | -- dist (x1, y1) (x2, y2) = abs (y2 - y1) + abs (x2 - x1) 211 | -- start = (0, 0) 212 | -- end = (0, 2) 213 | -- isWall = (== (0, 1)) 214 | -- :} 215 | -- 216 | -- >>> aStar (neighbors `pruning` isWall) dist (dist end) (== end) start 217 | -- Just (4,[(1,0),(1,1),(1,2),(0,2)]) 218 | aStar :: (Foldable f, Num cost, Ord cost, Ord state) 219 | => (state -> f state) 220 | -- ^ Function to generate list of neighboring states given the current state 221 | -> (state -> state -> cost) 222 | -- ^ Function to generate transition costs between neighboring states. This is 223 | -- only called for adjacent states, so it is safe to have this function be 224 | -- partial for non-neighboring states. 225 | -> (state -> cost) 226 | -- ^ Estimate on remaining cost given a state 227 | -> (state -> Bool) 228 | -- ^ Predicate to determine if solution found. 'aStar' returns the shortest 229 | -- path to the first state for which this predicate returns 'True'. 230 | -> state 231 | -- ^ Initial state 232 | -> Maybe (cost, [state]) 233 | -- ^ (Total cost, list of steps) for the first path found which satisfies the 234 | -- given predicate 235 | aStar next cost remaining found initial = 236 | -- This API to A* search is useful when the state transition 237 | -- function and the cost function are logically separate. 238 | -- It is implemented by using @aStarAssoc@ with appropriate mapping of 239 | -- arguments. 240 | aStarAssoc next' remaining found initial 241 | where 242 | next' st = map (\new_st -> (new_st, cost st new_st)) $ 243 | Foldable.toList (next st) 244 | 245 | -- | @aStarAssoc next remaining found initial@ performs a best-first search 246 | -- using the A* search algorithm, starting with the state @initial@, generating 247 | -- neighboring states and their associated costs with @next@, and an estimate of 248 | -- the remaining cost with @remaining@. This returns a path to a state for which 249 | -- @found@ returns 'True'. If @remaining@ is strictly a lower bound on the 250 | -- remaining cost to reach a solved state, then the returned path is the 251 | -- shortest path. Returns 'Nothing' if no path to a solved state is possible. 252 | aStarAssoc :: (Num cost, Ord cost, Ord state) 253 | => (state -> [(state, cost)]) 254 | -- ^ function to generate list of neighboring states with associated 255 | -- transition costs given the current state 256 | -> (state -> cost) 257 | -- ^ Estimate on remaining cost given a state 258 | -> (state -> Bool) 259 | -- ^ Predicate to determine if solution found. 'aStar' returns the shortest 260 | -- path to the first state for which this predicate returns 'True'. 261 | -> state 262 | -- ^ Initial state 263 | -> Maybe (cost, [state]) 264 | -- ^ (Total cost, list of steps) for the first path found which satisfies the 265 | -- given predicate 266 | aStarAssoc next remaining found initial = 267 | -- This API to A* search is useful in the common case when next 268 | -- states and their associated transition costs are generated together. 269 | -- 270 | -- A* can be viewed as a generalized search, with the search container being a 271 | -- heap, with the states being compared without regard to cost, with the 272 | -- shorter paths taking precedence over longer ones, and with 273 | -- the stored state being (total cost estimate, (cost so far, state)). 274 | -- This implementation makes that transformation, then transforms that result 275 | -- back into the desired result from @aStarAssoc@ 276 | unpack <$> generalizedSearch emptyLIFOHeap snd2 leastCostly next' 277 | (found . snd2) (remaining initial, (0, initial)) 278 | where 279 | next' (_, (old_cost, old_st)) = 280 | update_state <$> (next old_st) 281 | where 282 | update_state (new_st, cost) = 283 | let new_cost = old_cost + cost 284 | new_est = new_cost + remaining new_st 285 | in (new_est, (new_cost, new_st)) 286 | unpack [] = (0, []) 287 | unpack packed_states = 288 | (fst . snd . last $ packed_states, map snd2 packed_states) 289 | snd2 = snd . snd 290 | 291 | -- $monadic 292 | -- Note that for all monadic searches, it is up to the user to ensure that 293 | -- side-effecting monads do not logically change the structure of the graph. 294 | -- For example, if the list of neighbors is being read from a file, the user 295 | -- must ensure that those values do not change between reads. 296 | 297 | -- | @bfsM@ is a monadic version of 'bfs': it has support for monadic @next@ and 298 | -- @found@ parameters. 299 | bfsM :: (Monad m, Foldable f, Ord state) 300 | => (state -> m (f state)) 301 | -- ^ Function to generate "next" states given a current state 302 | -> (state -> m Bool) 303 | -- ^ Predicate to determine if solution found. 'bfsM' returns a path to the 304 | -- first state for which this predicate returns 'True'. 305 | -> state 306 | -- ^ Initial state 307 | -> m (Maybe [state]) 308 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 309 | -- such path exists. 310 | bfsM = generalizedSearchM Seq.empty id (\_ _ -> False) 311 | 312 | 313 | -- | @dfsM@ is a monadic version of 'dfs': it has support for monadic @next@ and 314 | -- @found@ parameters. 315 | dfsM :: (Monad m, Foldable f, Ord state) 316 | => (state -> m (f state)) 317 | -- ^ Function to generate "next" states given a current state 318 | -> (state -> m Bool) 319 | -- ^ Predicate to determine if solution found. 'dfsM' returns a path to the 320 | -- first state for which this predicate returns 'True'. 321 | -> state 322 | -- ^ Initial state 323 | -> m (Maybe [state]) 324 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 325 | -- such path exists. 326 | dfsM = 327 | generalizedSearchM [] id (\_ _ -> True) 328 | 329 | -- | @dijkstraM@ is a monadic version of 'dijkstra': it has support for monadic 330 | -- @next@, @cost@, and @found@ parameters. 331 | dijkstraM :: (Monad m, Foldable f, Num cost, Ord cost, Ord state) 332 | => (state -> m (f state)) 333 | -- ^ Function to generate list of neighboring states given the current state 334 | -> (state -> state -> m cost) 335 | -- ^ Function to generate list of costs between neighboring states. This is 336 | -- only called for adjacent states, so it is safe to have this function be 337 | -- partial for non-neighboring states. 338 | -> (state -> m Bool) 339 | -- ^ Predicate to determine if solution found. 'dijkstraM' returns the 340 | -- shortest path to the first state for which this predicate returns 'True'. 341 | -> state 342 | -- ^ Initial state 343 | -> m (Maybe (cost, [state])) 344 | -- ^ (Total cost, list of steps) for the first path found which 345 | -- satisfies the given predicate 346 | dijkstraM nextM costM foundM initial = 347 | fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd leastCostly nextM' 348 | (foundM . snd) (0, initial) 349 | where 350 | nextM' (old_cost, old_st) = do 351 | new_states <- Foldable.toList <$> nextM old_st 352 | incr_costs <- sequence $ costM old_st <$> new_states 353 | let new_costs = (+ old_cost) <$> incr_costs 354 | return $ zip new_costs new_states 355 | unpack [] = (0, []) 356 | unpack packed_states = (fst . last $ packed_states, map snd packed_states) 357 | 358 | 359 | -- | @dijkstraAssocM@ is a monadic version of 'dijkstraAssoc': it has support 360 | -- for monadic @next@ and @found@ parameters. 361 | dijkstraAssocM :: (Monad m, Num cost, Ord cost, Ord state) 362 | => (state -> m [(state, cost)]) 363 | -- ^ Function to generate list of neighboring states with associated 364 | -- transition costs given the current state 365 | -> (state -> m Bool) 366 | -- ^ Predicate to determine if solution found. 'dijkstraM' returns the 367 | -- shortest path to the first state for which this predicate returns 'True'. 368 | -> state 369 | -- ^ Initial state 370 | -> m (Maybe (cost, [state])) 371 | -- ^ (Total cost, list of steps) for the first path found which 372 | -- satisfies the given predicate 373 | dijkstraAssocM nextM foundM initial = 374 | fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd leastCostly nextM' 375 | (foundM . snd) (0, initial) 376 | where 377 | nextM' (old_cost, old_st) = do 378 | new_states <- nextM old_st 379 | return $ map (\(x, y) -> (y, x)) new_states 380 | unpack [] = (0, []) 381 | unpack packed_states = (fst . last $ packed_states, map snd packed_states) 382 | 383 | 384 | -- | @aStarM@ is a monadic version of 'aStar': it has support for monadic 385 | -- @next@, @cost@, @remaining@, and @found@ parameters. 386 | aStarM :: (Monad m, Foldable f, Num cost, Ord cost, Ord state) 387 | => (state -> m (f state)) 388 | -- ^ function to generate list of neighboring states with associated 389 | -- transition costs given the current state 390 | -> (state -> state -> m cost) 391 | -- ^ Function to generate list of costs between neighboring states. This is 392 | -- only called for adjacent states, so it is safe to have this function be 393 | -- partial for non-neighboring states. 394 | -> (state -> m cost) 395 | -- ^ Estimate on remaining cost given a state 396 | -> (state -> m Bool) 397 | -- ^ Predicate to determine if solution found. 'aStarM' returns the shortest 398 | -- path to the first state for which this predicate returns 'True'. 399 | -> state 400 | -- ^ Initial state 401 | -> m (Maybe (cost, [state])) 402 | -- ^ (Total cost, list of steps) for the first path found which satisfies the 403 | -- given predicate 404 | aStarM nextM costM remainingM foundM initial = do 405 | remaining_init <- remainingM initial 406 | fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd2 leastCostly nextM' 407 | (foundM . snd2) (remaining_init, (0, initial)) 408 | where 409 | nextM' (_, (old_cost, old_st)) = do 410 | new_states <- Foldable.toList <$> nextM old_st 411 | sequence $ update_stateM <$> new_states 412 | where 413 | update_stateM new_st = do 414 | remaining <- remainingM new_st 415 | cost <- costM old_st new_st 416 | let new_cost = old_cost + cost 417 | new_est = new_cost + remaining 418 | return (new_est, (new_cost, new_st)) 419 | unpack [] = (0, []) 420 | unpack packed_states = 421 | (fst . snd . last $ packed_states, map snd2 packed_states) 422 | snd2 = snd . snd 423 | 424 | 425 | -- | @aStarAssocM@ is a monadic version of 'aStarAssoc': it has support for 426 | -- monadic @next@, @remaining@, and @found@ parameters. 427 | aStarAssocM :: (Monad m, Num cost, Ord cost, Ord state) 428 | => (state -> m [(state, cost)]) 429 | -- ^ function to generate list of neighboring states with associated 430 | -- transition costs given the current state 431 | -> (state -> m cost) 432 | -- ^ Estimate on remaining cost given a state 433 | -> (state -> m Bool) 434 | -- ^ Predicate to determine if solution found. 'aStarM' returns the shortest 435 | -- path to the first state for which this predicate returns 'True'. 436 | -> state 437 | -- ^ Initial state 438 | -> m (Maybe (cost, [state])) 439 | -- ^ (Total cost, list of steps) for the first path found which satisfies the 440 | -- given predicate 441 | aStarAssocM nextM remainingM foundM initial = do 442 | remaining_init <- remainingM initial 443 | fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd2 leastCostly nextM' 444 | (foundM . snd2) (remaining_init, (0, initial)) 445 | where 446 | nextM' (_, (old_cost, old_st)) = do 447 | new_states <- nextM old_st 448 | sequence $ update_stateM <$> new_states 449 | where 450 | update_stateM new_st = do 451 | remaining <- remainingM (fst new_st) 452 | let new_cost = old_cost + (snd new_st) 453 | new_est = new_cost + remaining 454 | return (new_est, (new_cost, fst new_st)) 455 | unpack [] = (0, []) 456 | unpack packed_states = 457 | (fst . snd . last $ packed_states, map snd2 packed_states) 458 | snd2 = snd . snd 459 | 460 | 461 | -- | @incrementalCosts cost_fn states@ gives a list of the incremental costs 462 | -- going from state to state along the path given in @states@, using the cost 463 | -- function given by @cost_fn@. Note that the paths returned by the searches 464 | -- in this module do not include the initial state, so if you want the 465 | -- incremental costs along a @path@ returned by one of these searches, you 466 | -- want to use @incrementalCosts cost_fn (initial : path)@. 467 | -- 468 | -- === Example: Getting incremental costs from dijkstra 469 | -- 470 | -- >>> import Data.Maybe (fromJust) 471 | -- 472 | -- >>> :{ 473 | -- cyclicWeightedGraph :: Map.Map Char [(Char, Int)] 474 | -- cyclicWeightedGraph = Map.fromList [ 475 | -- ('a', [('b', 1), ('c', 2)]), 476 | -- ('b', [('a', 1), ('c', 2), ('d', 5)]), 477 | -- ('c', [('a', 1), ('d', 2)]), 478 | -- ('d', []) 479 | -- ] 480 | -- start = (0, 0) 481 | -- end = (0, 2) 482 | -- cost a b = fromJust . lookup b $ cyclicWeightedGraph Map.! a 483 | -- :} 484 | -- 485 | -- >>> incrementalCosts cost ['a', 'b', 'd'] 486 | -- [1,5] 487 | incrementalCosts :: 488 | (state -> state -> cost) 489 | -- ^ Function to generate list of costs between neighboring states. This is 490 | -- only called for adjacent states in the `states` list, so it is safe to have 491 | -- this function be partial for non-neighboring states. 492 | -> [state] 493 | -- ^ A path, given as a list of adjacent states, along which to find the 494 | -- incremental costs 495 | -> [cost] 496 | -- ^ List of incremental costs along given path 497 | incrementalCosts cost_fn states = zipWith cost_fn states (tail states) 498 | 499 | -- | @incrementalCostsM@ is a monadic version of 'incrementalCosts': it has 500 | -- support for a monadic @const_fn@ parameter. 501 | incrementalCostsM :: 502 | (Monad m) => 503 | (state -> state -> m cost) 504 | -- ^ Function to generate list of costs between neighboring states. This is 505 | -- only called for adjacent states in the `states` list, so it is safe to have 506 | -- this function be partial for non-neighboring states. 507 | -> [state] 508 | -- ^ A path, given as a list of adjacent states, along which to find the 509 | -- incremental costs 510 | -> m [cost] 511 | -- ^ List of incremental costs along given path 512 | incrementalCostsM costM states = zipWithM costM states (tail states) 513 | 514 | 515 | -- | @next \`pruning\` predicate@ streams the elements generate by @next@ into a 516 | -- list, removing elements which satisfy @predicate@. This is useful for the 517 | -- common case when you want to logically separate your search's `next` function 518 | -- from some way of determining when you've reached a dead end. 519 | -- 520 | -- === Example: Pruning a Set 521 | -- 522 | -- >>> import qualified Data.Set as Set 523 | -- 524 | -- >>> ((\x -> Set.fromList [0..x]) `pruning` even) 10 525 | -- [1,3,5,7,9] 526 | -- 527 | -- === Example: depth-first search, avoiding certain nodes 528 | -- 529 | -- >>> import qualified Data.Map as Map 530 | -- 531 | -- >>> :{ 532 | -- graph = Map.fromList [ 533 | -- ('a', ['b', 'c', 'd']), 534 | -- ('b', [undefined]), 535 | -- ('c', ['e']), 536 | -- ('d', [undefined]), 537 | -- ('e', []) 538 | -- ] 539 | -- :} 540 | -- 541 | -- >>> dfs ((graph Map.!) `pruning` (`elem` "bd")) (== 'e') 'a' 542 | -- Just "ce" 543 | pruning :: 544 | (Foldable f) 545 | => (a -> f a) 546 | -- ^ Function to generate next states 547 | -> (a -> Bool) 548 | -- ^ Predicate to prune on 549 | -> (a -> [a]) 550 | -- ^ Version of @next@ which excludes elements satisfying @predicate@ 551 | next `pruning` predicate = 552 | (filter (not . predicate) . Foldable.toList) <$> next 553 | 554 | 555 | -- | @pruningAssoc@ is a version of 'pruning' that works with the `Assoc` variants of searches. 556 | pruningAssoc :: 557 | (Foldable f) 558 | => (state -> f (state, cost)) 559 | -- ^ Function to generate next states 560 | -> ((state, cost) -> Bool) 561 | -- ^ Predicate to prune on 562 | -> (state -> [(state, cost)]) 563 | -- ^ Version of @next@ which excludes elements satisfying @predicate@ 564 | next `pruningAssoc` predicate = 565 | (filter (not . predicate) . Foldable.toList) <$> next 566 | 567 | -- | @pruningM@ is a monadic version of 'pruning': it has support for monadic 568 | -- @next@ and @predicate@ parameters 569 | pruningM :: 570 | (Monad m, Foldable f) 571 | => (a -> m (f a)) 572 | -- ^ Function to generate next states 573 | -> (a -> m Bool) 574 | -- ^ Predicate to prune on 575 | -> (a -> m [a]) 576 | -- ^ Version of @next@ which excludes elements satisfying @predicate@ 577 | pruningM nextM predicateM a = do 578 | next_states <- nextM a 579 | filterM (fmap not . predicateM) $ Foldable.toList next_states 580 | 581 | -- | @pruningAssocM@ is a monadic version of 'pruningAssoc': it has support for monadic 582 | -- @next@ and @predicate@ parameters 583 | pruningAssocM :: 584 | (Monad m, Foldable f) 585 | => (state -> m (f (state, cost))) 586 | -- ^ Function to generate next states 587 | -> ((state, cost) -> m Bool) 588 | -- ^ Predicate to prune on 589 | -> (state -> m [(state, cost)]) 590 | -- ^ Version of @next@ which excludes elements satisfying @predicate@ 591 | pruningAssocM nextM predicateM a = do 592 | next_states <- nextM a 593 | filterM (fmap not . predicateM) $ Foldable.toList next_states 594 | 595 | 596 | -- | A @SearchState@ represents the state of a generalized search at a given 597 | -- point in an algorithms execution. The advantage of this abstraction is that 598 | -- it can be used for things like bidirectional searches, where you want to 599 | -- stop and start a search part-way through. 600 | data SearchState container stateKey state = SearchState { 601 | current :: state, 602 | queue :: container, 603 | visited :: Set.Set stateKey, 604 | paths :: Map.Map stateKey [state] 605 | } 606 | 607 | -- | Workhorse simple search algorithm, generalized over search container 608 | -- and path-choosing function. The idea here is that many search algorithms are 609 | -- at their core the same, with these details substituted. By writing these 610 | -- searches in terms of this function, we reduce the chances of errors sneaking 611 | -- into each separate implementation. 612 | generalizedSearch :: 613 | (Foldable f, SearchContainer container, Ord stateKey, Elem container ~ state) 614 | => container 615 | -- ^ Empty @SearchContainer@ 616 | -> (state -> stateKey) 617 | -- ^ Function to turn a @state@ into a key by which states will be compared 618 | -- when determining whether a state has be enqueued and / or visited 619 | -> ([state] -> [state] -> Bool) 620 | -- ^ Function @better old new@, which when given a choice between an @old@ and 621 | -- a @new@ path to a state, returns True when @new@ is a "better" path than 622 | -- old and should thus be inserted 623 | -> (state -> f state) 624 | -- ^ Function to generate "next" states given a current state 625 | -> (state -> Bool) 626 | -- ^ Predicate to determine if solution found. @generalizedSearch@ returns a 627 | -- path to the first state for which this predicate returns 'True'. 628 | -> state 629 | -- ^ Initial state 630 | -> Maybe [state] 631 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 632 | -- such path exists. 633 | generalizedSearch empty mk_key better next found initial = runIdentity $ 634 | generalizedSearchM empty mk_key better (Identity . next) (Identity . found) initial 635 | 636 | -- | @nextSearchState@ moves from one @searchState@ to the next in the 637 | -- generalized search algorithm 638 | nextSearchStateM :: 639 | (Monad m, Foldable f, SearchContainer container, Ord stateKey, 640 | Elem container ~ state) 641 | => ([state] -> [state] -> Bool) 642 | -> (state -> stateKey) 643 | -> (state -> m (f state)) 644 | -> SearchState container stateKey state 645 | -> m (Maybe (SearchState container stateKey state)) 646 | nextSearchStateM better mk_key nextM old = do 647 | (new_queue, new_paths) <- new_queue_paths_M 648 | let new_state_May = mk_search_state new_paths <$> pop new_queue 649 | case new_state_May of 650 | Just new_state -> 651 | if mk_key (current new_state) `Set.member` visited old 652 | then nextSearchStateM better mk_key nextM new_state 653 | else return (Just new_state) 654 | Nothing -> return Nothing 655 | where 656 | mk_search_state new_paths (new_current, remaining_queue) = SearchState { 657 | current = new_current, 658 | queue = remaining_queue, 659 | visited = Set.insert (mk_key new_current) (visited old), 660 | paths = new_paths 661 | } 662 | new_queue_paths_M = 663 | List.foldl' update_queue_paths (queue old, paths old) 664 | <$> nextM (current old) 665 | update_queue_paths (old_queue, old_paths) st = 666 | if mk_key st `Set.member` visited old 667 | then (old_queue, old_paths) 668 | else 669 | case Map.lookup (mk_key st) old_paths of 670 | Just old_path -> 671 | if better old_path (st : steps_so_far) 672 | then (q', ps') 673 | else (old_queue, old_paths) 674 | Nothing -> (q', ps') 675 | where 676 | steps_so_far = paths old Map.! mk_key (current old) 677 | q' = push old_queue st 678 | ps' = Map.insert (mk_key st) (st : steps_so_far) old_paths 679 | 680 | 681 | -- | @generalizedSearchM@ is a monadic version of generalizedSearch 682 | generalizedSearchM :: 683 | (Monad m, Foldable f, SearchContainer container, Ord stateKey, 684 | Elem container ~ state) 685 | => container 686 | -- ^ Empty @SearchContainer@ 687 | -> (state -> stateKey) 688 | -- ^ Function to turn a @state@ into a key by which states will be compared 689 | -- when determining whether a state has be enqueued and / or visited 690 | -> ([state] -> [state] -> Bool) 691 | -- ^ Function @better old new@, which when given a choice between an @old@ and 692 | -- a @new@ path to a state, returns True when @new@ is a "better" path than 693 | -- old and should thus be inserted 694 | -> (state -> m (f state)) 695 | -- ^ Function to generate "next" states given a current state 696 | -> (state -> m Bool) 697 | -- ^ Predicate to determine if solution found. @generalizedSearch@ returns a 698 | -- path to the first state for which this predicate returns 'True'. 699 | -> state 700 | -- ^ Initial state 701 | -> m (Maybe [state]) 702 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 703 | -- such path exists. 704 | generalizedSearchM empty mk_key better nextM foundM initial = do 705 | let initial_state = 706 | SearchState initial empty (Set.singleton $ mk_key initial) 707 | (Map.singleton (mk_key initial) []) 708 | end_May <- findIterateM (nextSearchStateM better mk_key nextM) 709 | (foundM . current) initial_state 710 | return $ fmap (reverse . get_steps) end_May 711 | where 712 | get_steps search_st = paths search_st Map.! mk_key (current search_st) 713 | 714 | 715 | newtype LIFOHeap k a = LIFOHeap (Map.Map k [a]) 716 | 717 | 718 | emptyLIFOHeap :: LIFOHeap k a 719 | emptyLIFOHeap = LIFOHeap Map.empty 720 | 721 | 722 | -- | The @SearchContainer@ class abstracts the idea of a container to be used in 723 | -- @generalizedSearch@ 724 | class SearchContainer container where 725 | type Elem container 726 | pop :: container -> Maybe (Elem container, container) 727 | push :: container -> Elem container -> container 728 | 729 | instance SearchContainer (Seq.Seq a) where 730 | type Elem (Seq.Seq a) = a 731 | pop s = 732 | case Seq.viewl s of 733 | Seq.EmptyL -> Nothing 734 | (x Seq.:< xs) -> Just (x, xs) 735 | push s a = s Seq.|> a 736 | 737 | instance SearchContainer [a] where 738 | type Elem [a] = a 739 | pop list = 740 | case list of 741 | [] -> Nothing 742 | (x : xs) -> Just (x, xs) 743 | push list a = a : list 744 | 745 | instance Ord k => SearchContainer (LIFOHeap k a) where 746 | type Elem (LIFOHeap k a) = (k, a) 747 | pop (LIFOHeap inner) 748 | | Map.null inner = Nothing 749 | | otherwise = case Map.findMin inner of 750 | (k, [a]) -> Just ((k, a), LIFOHeap $ Map.deleteMin inner) 751 | (k, a : _) -> Just ((k, a), LIFOHeap $ Map.updateMin (Just . tail) inner) 752 | (_, []) -> pop (LIFOHeap $ Map.deleteMin inner) 753 | -- Logically, this should never happen 754 | push (LIFOHeap inner) (k, a) = LIFOHeap $ Map.insertWith (++) k [a] inner 755 | 756 | 757 | -- | @findIterateM@ is a monadic version of @findIterate@ 758 | findIterateM :: Monad m => (a -> m (Maybe a)) -> (a -> m Bool) -> a -> m (Maybe a) 759 | findIterateM nextM foundM initial = do 760 | found <- foundM initial 761 | if found 762 | then return $ Just initial 763 | else nextM initial >>= maybe (return Nothing) (findIterateM nextM foundM) 764 | 765 | 766 | -- | @leastCostly paths_a paths_b@ is a utility function to be used with 767 | -- 'dijkstra'-like functions. It returns True when the cost of @paths_a@ 768 | -- is less than the cost of @paths_b@, where the total costs are the first 769 | -- elements in each tuple in each path 770 | leastCostly :: Ord a => [(a, b)] -> [(a, b)] -> Bool 771 | leastCostly ((cost_a, _):_) ((cost_b, _):_) = cost_b < cost_a 772 | -- logically this never happens, because if you have a 773 | -- zero-length path a point, you already visited it 774 | -- and thus do not consider other paths to it 775 | leastCostly [] _ = False 776 | -- logically this never happens, because you cannot find 777 | -- a new zero-length path to a point 778 | leastCostly _ [] = True 779 | 780 | 781 | -- | This is just a convenience function which @fmap@s two deep 782 | fmap2 :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b) 783 | fmap2 = fmap . fmap 784 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.40 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /test/Algorithm/SearchSpec.hs: -------------------------------------------------------------------------------- 1 | module Algorithm.SearchSpec ( 2 | main, 3 | spec 4 | ) where 5 | 6 | import Test.Hspec 7 | import Algorithm.Search 8 | import qualified Data.Map as Map 9 | import Data.Maybe (fromJust) 10 | 11 | main :: IO () 12 | main = hspec spec 13 | 14 | -- | Example cyclic directed unweighted graph 15 | cyclicUnweightedGraph :: Map.Map Int [Int] 16 | cyclicUnweightedGraph = Map.fromList [ 17 | (0, [1, 2, 3]), 18 | (1, [4, 6]), 19 | (2, [0, 1, 6, 8]), 20 | (3, [1, 2]), 21 | (4, [0]), 22 | (5, [4]), 23 | (6, [4]), 24 | (8, [0, 5]) 25 | ] 26 | 27 | -- | Example acyclic directed unweighted graph 28 | acyclicUnweightedGraph :: Map.Map Int [Int] 29 | acyclicUnweightedGraph = Map.fromList [ 30 | (0, [1, 2, 3]), 31 | (1, [4]), 32 | (2, [5]), 33 | (3, [2]), 34 | (4, []), 35 | (5, []) 36 | ] 37 | 38 | -- | Example cyclic directed weighted graph 39 | cyclicWeightedGraph :: Map.Map Char [(Char, Int)] 40 | cyclicWeightedGraph = Map.fromList [ 41 | ('a', [('b', 1), ('c', 2)]), 42 | ('b', [('a', 1), ('c', 2), ('d', 5)]), 43 | ('c', [('a', 1), ('d', 2)]), 44 | ('d', []) 45 | ] 46 | 47 | -- | Example for taxicab path finding 48 | taxicabNeighbors :: (Int, Int) -> [(Int, Int)] 49 | -- the ordering here is important--for dfs, last state will be visited first 50 | taxicabNeighbors (x, y) = [(x, y + 1), (x - 1, y), (x, y - 1), (x + 1, y)] 51 | 52 | isWall :: (Int, Int) -> Bool 53 | isWall (x, y) = x == 1 && ((-2) <= y && y <= 1) 54 | 55 | taxicabDistance :: (Int, Int) -> (Int, Int) -> Int 56 | taxicabDistance (x1, y1) (x2, y2) = abs (x2 - x1) + abs (y2 - y1) 57 | 58 | taxicabNeighborsBounded :: (Int, Int) -> Maybe [(Int, Int)] 59 | taxicabNeighborsBounded (x, y) 60 | | outOfBounds (x, y) = Nothing 61 | | otherwise = Just $ taxicabNeighbors (x, y) 62 | 63 | taxicabDistanceBounded :: (Int, Int) -> (Int, Int) -> Maybe Int 64 | taxicabDistanceBounded (x1, y1) (x2, y2) 65 | | outOfBounds (x1, y1) || outOfBounds (x2, y2) = Nothing 66 | | otherwise = Just $ taxicabDistance (x1, y1) (x2, y2) 67 | 68 | outOfBounds :: (Int, Int) -> Bool 69 | outOfBounds (x, y) = abs x + abs y > 10 70 | 71 | isBigWall :: (Int, Int) -> Bool 72 | isBigWall (x, y) = x == 1 && ((-10) <= y && y <= 10) 73 | 74 | spec :: Spec 75 | spec = do 76 | describe "bfs" $ do 77 | let next = (cyclicUnweightedGraph Map.!) 78 | it "performs breadth-first search" $ 79 | bfs next (== 4) 0 `shouldBe` Just [1, 4] 80 | it "handles pruning" $ 81 | bfs (next `pruning` odd) (== 4) 0 `shouldBe` Just [2, 6, 4] 82 | it "returns Nothing when no path is possible" $ 83 | bfs (next `pruning` odd `pruning` (== 6)) (== 4) 0 `shouldBe` Nothing 84 | describe "dfs" $ do 85 | let next = (cyclicUnweightedGraph Map.!) 86 | it "performs depth-first search" $ 87 | dfs next (== 4) 0 `shouldBe` Just [3, 2, 8, 5, 4] 88 | it "handles pruning" $ 89 | dfs (next `pruning` odd) (== 4) 0 `shouldBe` Just [2, 6, 4] 90 | it "returns Nothing when no path is possible" $ 91 | dfs (next `pruning` odd `pruning` (== 6)) (== 4) 0 `shouldBe` Nothing 92 | it "handles doubly-inserted nodes" $ 93 | dfs (acyclicUnweightedGraph Map.!) (==4) 0 `shouldBe` Just [1, 4] 94 | describe "dijkstra" $ do 95 | let next = map fst . (cyclicWeightedGraph Map.!) 96 | cost a b = fromJust . lookup b $ cyclicWeightedGraph Map.! a 97 | it "performs dijkstra's algorithm" $ 98 | dijkstra next cost (== 'd') 'a' 99 | `shouldBe` Just (4, ['c', 'd']) 100 | it "handles pruning" $ 101 | dijkstra (next `pruning` (== 'c')) cost (== 'd') 'a' 102 | `shouldBe` Just (6, ['b', 'd']) 103 | it "returns Nothing when no path is possible" $ 104 | dijkstra (next `pruning` (== 'b') `pruning` (== 'c')) cost (== 'd') 'a' 105 | `shouldBe` Nothing 106 | it "handles zero-length solutions" $ 107 | dijkstra next cost (== 'd') 'd' `shouldBe` Just (0, []) 108 | describe "aStar" $ do 109 | let start = (0, 0) 110 | end = (2, 0) 111 | it "performs the A* algorithm" $ 112 | aStar taxicabNeighbors taxicabDistance (taxicabDistance end) (== end) 113 | start 114 | `shouldBe` Just (2, [(1, 0), (2, 0)]) 115 | it "handles pruning" $ 116 | aStar (taxicabNeighbors `pruning` isWall) taxicabDistance 117 | (taxicabDistance end) (== end) start 118 | `shouldBe` Just (6, [(0, 1), (0, 2), (1, 2), (2, 2), (2, 1), (2, 0)]) 119 | it "returns Nothing when no path is possible" $ 120 | aStar 121 | (taxicabNeighbors 122 | `pruning` isWall 123 | `pruning` (\ p -> taxicabDistance p (0,0) > 1) 124 | ) 125 | taxicabDistance 126 | (taxicabDistance end) 127 | (== end) 128 | start 129 | `shouldBe` Nothing 130 | it "handles zero-length solutions" $ 131 | aStar taxicabNeighbors taxicabDistance (taxicabDistance end) (== start) 132 | start 133 | `shouldBe` Just (0, []) 134 | describe "bfsM" $ do 135 | let start = (0, 0) 136 | end = (2, 0) 137 | it "performs monadic breadth-first search" $ do 138 | bfsM taxicabNeighborsBounded (return . (== end)) start 139 | `shouldBe` Just (Just [(1, 0), (2, 0)]) 140 | bfsM 141 | (taxicabNeighborsBounded `pruningM` (return . isWall)) 142 | (return . (== end)) 143 | start 144 | `shouldBe` Just (Just [(0,1),(0,2),(1,2),(2,2),(2,1),(2,0)]) 145 | it "handles cyclic graphs" $ do 146 | let nextM = return . map fst . (cyclicWeightedGraph Map.!) 147 | bfsM nextM (return . (== 'd')) 'a' 148 | `shouldBe` Just (Just ['b', 'd']) 149 | it "correctly handles monadic behavior" $ do 150 | bfsM 151 | (taxicabNeighborsBounded `pruningM` (return . isBigWall)) 152 | (return . (== end)) 153 | start 154 | `shouldBe` Nothing 155 | bfsM taxicabNeighborsBounded (const Nothing) start 156 | `shouldBe` Nothing 157 | describe "dfsM" $ do 158 | let start = (0, 0) 159 | end = (2, 0) 160 | it "performs monadic depth-first search" $ 161 | dfsM taxicabNeighborsBounded (return . (== end)) start 162 | `shouldBe` Just (Just [(1, 0), (2, 0)]) 163 | it "handles doubly-inserted nodes" $ do 164 | let nextM = return . (acyclicUnweightedGraph Map.!) 165 | dfsM nextM (return . (== 4)) 0 `shouldBe` Just (Just [1, 4]) 166 | it "correctly handles monadic behavior" $ do 167 | dfsM 168 | (taxicabNeighborsBounded `pruningM` (return . isBigWall)) 169 | (return . (== end)) 170 | start 171 | `shouldBe` Nothing 172 | dfsM taxicabNeighborsBounded (const Nothing) start 173 | `shouldBe` Nothing 174 | describe "dijkstraM" $ do 175 | let start = (0, 0) 176 | end = (2, 0) 177 | it "performs monadic dijkstra's algorithm" $ 178 | dijkstraM 179 | taxicabNeighborsBounded 180 | taxicabDistanceBounded 181 | (return . (== end)) 182 | start 183 | `shouldBe` Just (Just (2, [(1, 0), (2, 0)])) 184 | it "handles cyclic graphs" $ do 185 | let nextM = return . map fst . (cyclicWeightedGraph Map.!) 186 | costM a b = lookup b $ cyclicWeightedGraph Map.! a 187 | dijkstraM nextM costM (return . (== 'd')) 'a' 188 | `shouldBe` Just (Just (4, ['c', 'd'])) 189 | dijkstraM (nextM `pruningM` (return . (== 'c'))) costM 190 | (return . (== 'd')) 'a' 191 | `shouldBe` Just (Just (6, ['b', 'd'])) 192 | it "handles zero-length solutions" $ do 193 | let nextM = return . map fst . (cyclicWeightedGraph Map.!) 194 | costM a b = lookup b $ cyclicWeightedGraph Map.! a 195 | dijkstraM nextM costM (return . (== 'd')) 'd' 196 | `shouldBe` Just (Just (0, [])) 197 | it "correctly handles monadic behavior" $ do 198 | dijkstraM 199 | (taxicabNeighborsBounded `pruningM` (return . isBigWall)) 200 | taxicabDistanceBounded 201 | (return . (== end)) 202 | start 203 | `shouldBe` Nothing 204 | dijkstraM 205 | taxicabNeighborsBounded 206 | ((const . const) Nothing :: (Int, Int) -> (Int, Int) -> Maybe Int) 207 | (return . (== end)) 208 | start 209 | `shouldBe` Nothing 210 | dijkstraM 211 | (taxicabNeighborsBounded `pruningM` (return . isBigWall)) 212 | taxicabDistanceBounded 213 | (const Nothing) 214 | start 215 | `shouldBe` Nothing 216 | describe "aStarM" $ do 217 | let start = (0, 0) 218 | end = (2, 0) 219 | it "performs a monadic A* algorithm" $ 220 | aStarM 221 | (taxicabNeighborsBounded `pruningM` (return . isWall)) 222 | taxicabDistanceBounded 223 | (taxicabDistanceBounded end) 224 | (return . (== end)) 225 | start 226 | `shouldBe` 227 | Just (Just (6, [(0, 1), (0, 2), (1, 2), (2, 2), (2, 1), (2, 0)])) 228 | it "handles zero-length solutions" $ 229 | aStarM taxicabNeighborsBounded taxicabDistanceBounded 230 | (taxicabDistanceBounded end) (return . (== start)) start 231 | `shouldBe` Just (Just (0, [])) 232 | it "correctly handles monadic behavior" $ do 233 | aStarM 234 | (taxicabNeighborsBounded `pruningM` (return . isBigWall)) 235 | taxicabDistanceBounded 236 | (taxicabDistanceBounded end) 237 | (return . (== end)) 238 | start 239 | `shouldBe` Nothing 240 | aStarM 241 | taxicabNeighborsBounded 242 | ((const . const) Nothing :: (Int, Int) -> (Int, Int) -> Maybe Int) 243 | (taxicabDistanceBounded end) 244 | (return . (== end)) 245 | start 246 | `shouldBe` Nothing 247 | aStarM 248 | taxicabNeighborsBounded 249 | taxicabDistanceBounded 250 | (const Nothing) 251 | (return . (== end)) 252 | start 253 | `shouldBe` Nothing 254 | aStarM 255 | taxicabNeighborsBounded 256 | taxicabDistanceBounded 257 | (taxicabDistanceBounded end) 258 | (const Nothing) 259 | start 260 | `shouldBe` Nothing 261 | describe "incrementalCosts" $ do 262 | let cost a b = fromJust . lookup b $ cyclicWeightedGraph Map.! a 263 | it "gives the incremental costs along a path" $ 264 | incrementalCosts cost ['a', 'b', 'd'] `shouldBe` [1, 5] 265 | it "handles zero-length paths" $ do 266 | incrementalCosts cost [] `shouldBe` [] 267 | incrementalCosts cost ['a'] `shouldBe` [] 268 | describe "incrementalCostsM" $ do 269 | let costM a b = lookup b $ cyclicWeightedGraph Map.! a 270 | it "gives monadic incremental costs along a path" $ 271 | incrementalCostsM costM ['a', 'b', 'd'] `shouldBe` Just [1, 5] 272 | it "handles zero-length paths" $ do 273 | incrementalCostsM costM [] `shouldBe` Just [] 274 | incrementalCostsM costM ['a'] `shouldBe` Just [] 275 | it "correctly handles monadic behavior" $ 276 | incrementalCostsM costM ['a', 'd'] `shouldBe` Nothing 277 | describe "pruning" $ do 278 | it "filters according to its predicate" $ 279 | ((\x -> [x, 2*x, 3*x]) `pruning` even) 3 `shouldBe` [3, 9] 280 | describe "pruningAssoc" $ do 281 | it "filters according to its predicate" $ 282 | ((\x -> [(x, 1), (2*x, 2)]) `pruningAssoc` (\(_, cost) -> cost > 1)) 3 `shouldBe` [(3, 1)] 283 | describe "pruningM" $ do 284 | it "filters according to its predicate" $ 285 | ((\x -> (Just [x, 2*x, 3*x])) `pruningM` (\x -> Just (even x))) 3 `shouldBe` Just [3, 9] 286 | describe "pruningAssocM" $ do 287 | it "filters according to its predicate" $ 288 | ((\x -> Just [(x, 1), (2*x, 2)]) `pruningAssocM` (\(_, cost) -> Just (cost > 1))) 3 `shouldBe` Just [(3, 1)] 289 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/doctests.hs: -------------------------------------------------------------------------------- 1 | import Test.DocTest 2 | 3 | main :: IO () 4 | main = doctest ["-isrc", "src/Algorithm/Search.hs"] 5 | --------------------------------------------------------------------------------