├── .gitignore ├── Setup.hs ├── test ├── Spec.hs ├── doctests.hs └── Algorithm │ └── SearchSpec.hs ├── stack.yaml ├── .travis.yml ├── bench └── bench.hs ├── CONTRIBUTING.md ├── LICENSE ├── CHANGELOG.md ├── search-algorithms.cabal ├── README.md └── src └── Algorithm └── Search.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *.tar.gz 3 | *.lock 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.40 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /test/doctests.hs: -------------------------------------------------------------------------------- 1 | import Test.DocTest 2 | 3 | main :: IO () 4 | main = doctest ["-isrc", "src/Algorithm/Search.hs"] 5 | -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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. -------------------------------------------------------------------------------- /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.4] - 2025-06-28 8 | - Add `dijkstraAssocCost` and `dijstraAssocCostM`, which make it easier to 9 | handle path-dependent costs. 10 | - Fix bug in `dijkstraAssocM`, where the prior cost was not propagated to new states. 11 | 12 | ## [0.3.3] - 2024-11-08 13 | - Add `pruningAssoc` and `pruningAssocM`, which allow for easy pruning of states based on cost. 14 | - Add monadic versions of `dijkstraAssoc` and `astarAssoc` 15 | 16 | ## [0.3.2] - 2021-12-27 17 | - Add two new functions, `dijkstraAssoc` and `aStarAssoc`. These allow for the simultaneous 18 | computation of neighboring states and their costs. (Thank you to 19 | [nagydani](https://github.com/nagydani)) 20 | 21 | ## [0.3.1] - 2010-08-19 22 | - Dependencies version bump 23 | 24 | ## [0.3.0] - 2017-11-29 25 | ### Added 26 | - Monadic versions of search algorithms and helper functions 27 | 28 | ## [0.2.0] - 2017-05-13 29 | ### Changed 30 | - BREAKING CHANGE: Simplified return type of `dijkstra` and `aStar`. 31 | - This should make these functions more ergonomic. 32 | - Introduced new `incrementalCosts` function to compensate. 33 | - BREAKING CHANGE: Replaced searches' `prunes` arguments with `pruning` combinator. 34 | - BREAKING CHANGE: Split searches' `next` arguments into multiple arguments for `dijkstra` and `aStar`. 35 | - This should make these functions more ergonomic. 36 | - `next` arguments now only require a way of generating `Foldable`s, instead of lists specifically. 37 | 38 | ## 0.1.0 - 2017-03-07 39 | - Initial release 40 | 41 | [0.3.4]: https://github.com/devonhollowood/search-algorithms/compare/v0.3.3...v0.3.4 42 | [0.3.3]: https://github.com/devonhollowood/search-algorithms/compare/v0.3.2...v0.3.3 43 | [0.3.2]: https://github.com/devonhollowood/search-algorithms/compare/v0.3.1...v0.3.2 44 | [0.3.1]: https://github.com/devonhollowood/search-algorithms/compare/v0.3.0...v0.3.1 45 | [0.3.0]: https://github.com/devonhollowood/search-algorithms/compare/v0.2.0...v0.3.0 46 | [0.2.0]: https://github.com/devonhollowood/search-algorithms/compare/v0.1.0...v0.2.0 47 | -------------------------------------------------------------------------------- /search-algorithms.cabal: -------------------------------------------------------------------------------- 1 | name: search-algorithms 2 | version: 0.3.4 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 "dijkstra with cost" $ do 109 | let new_cost old_cost (char, step_cost) = (char, old_cost * 10 + step_cost) 110 | next (char, cost) = map (new_cost cost) (cyclicWeightedGraph Map.! char) 111 | isChar char1 (char2, _cost) = char1 == char2 112 | it "performs dijkstra's algorithm" $ 113 | dijkstraAssocCost next (== 'd') 'a' 114 | `shouldBe` Just (15, ['b', 'd']) 115 | it "handles pruning" $ 116 | dijkstraAssocCost (next `pruning` isChar 'b') (== 'd') 'a' 117 | `shouldBe` Just (22, ['c', 'd']) 118 | it "returns Nothing when no path is possible" $ 119 | dijkstraAssocCost (next `pruning` isChar 'b' `pruning` isChar 'c') (== 'd') 'a' 120 | `shouldBe` Nothing 121 | it "handles zero-length solutions" $ 122 | dijkstraAssocCost next (== 'd') 'd' `shouldBe` Just (0, []) 123 | describe "aStar" $ do 124 | let start = (0, 0) 125 | end = (2, 0) 126 | it "performs the A* algorithm" $ 127 | aStar taxicabNeighbors taxicabDistance (taxicabDistance end) (== end) 128 | start 129 | `shouldBe` Just (2, [(1, 0), (2, 0)]) 130 | it "handles pruning" $ 131 | aStar (taxicabNeighbors `pruning` isWall) taxicabDistance 132 | (taxicabDistance end) (== end) start 133 | `shouldBe` Just (6, [(0, 1), (0, 2), (1, 2), (2, 2), (2, 1), (2, 0)]) 134 | it "returns Nothing when no path is possible" $ 135 | aStar 136 | (taxicabNeighbors 137 | `pruning` isWall 138 | `pruning` (\ p -> taxicabDistance p (0,0) > 1) 139 | ) 140 | taxicabDistance 141 | (taxicabDistance end) 142 | (== end) 143 | start 144 | `shouldBe` Nothing 145 | it "handles zero-length solutions" $ 146 | aStar taxicabNeighbors taxicabDistance (taxicabDistance end) (== start) 147 | start 148 | `shouldBe` Just (0, []) 149 | describe "bfsM" $ do 150 | let start = (0, 0) 151 | end = (2, 0) 152 | it "performs monadic breadth-first search" $ do 153 | bfsM taxicabNeighborsBounded (return . (== end)) start 154 | `shouldBe` Just (Just [(1, 0), (2, 0)]) 155 | bfsM 156 | (taxicabNeighborsBounded `pruningM` (return . isWall)) 157 | (return . (== end)) 158 | start 159 | `shouldBe` Just (Just [(0,1),(0,2),(1,2),(2,2),(2,1),(2,0)]) 160 | it "handles cyclic graphs" $ do 161 | let nextM = return . map fst . (cyclicWeightedGraph Map.!) 162 | bfsM nextM (return . (== 'd')) 'a' 163 | `shouldBe` Just (Just ['b', 'd']) 164 | it "correctly handles monadic behavior" $ do 165 | bfsM 166 | (taxicabNeighborsBounded `pruningM` (return . isBigWall)) 167 | (return . (== end)) 168 | start 169 | `shouldBe` Nothing 170 | bfsM taxicabNeighborsBounded (const Nothing) start 171 | `shouldBe` Nothing 172 | describe "dfsM" $ do 173 | let start = (0, 0) 174 | end = (2, 0) 175 | it "performs monadic depth-first search" $ 176 | dfsM taxicabNeighborsBounded (return . (== end)) start 177 | `shouldBe` Just (Just [(1, 0), (2, 0)]) 178 | it "handles doubly-inserted nodes" $ do 179 | let nextM = return . (acyclicUnweightedGraph Map.!) 180 | dfsM nextM (return . (== 4)) 0 `shouldBe` Just (Just [1, 4]) 181 | it "correctly handles monadic behavior" $ do 182 | dfsM 183 | (taxicabNeighborsBounded `pruningM` (return . isBigWall)) 184 | (return . (== end)) 185 | start 186 | `shouldBe` Nothing 187 | dfsM taxicabNeighborsBounded (const Nothing) start 188 | `shouldBe` Nothing 189 | describe "dijkstraM" $ do 190 | let start = (0, 0) 191 | end = (2, 0) 192 | it "performs monadic dijkstra's algorithm" $ 193 | dijkstraM 194 | taxicabNeighborsBounded 195 | taxicabDistanceBounded 196 | (return . (== end)) 197 | start 198 | `shouldBe` Just (Just (2, [(1, 0), (2, 0)])) 199 | it "handles cyclic graphs" $ do 200 | let nextM = return . map fst . (cyclicWeightedGraph Map.!) 201 | costM a b = lookup b $ cyclicWeightedGraph Map.! a 202 | dijkstraM nextM costM (return . (== 'd')) 'a' 203 | `shouldBe` Just (Just (4, ['c', 'd'])) 204 | dijkstraM (nextM `pruningM` (return . (== 'c'))) costM 205 | (return . (== 'd')) 'a' 206 | `shouldBe` Just (Just (6, ['b', 'd'])) 207 | it "handles zero-length solutions" $ do 208 | let nextM = return . map fst . (cyclicWeightedGraph Map.!) 209 | costM a b = lookup b $ cyclicWeightedGraph Map.! a 210 | dijkstraM nextM costM (return . (== 'd')) 'd' 211 | `shouldBe` Just (Just (0, [])) 212 | it "correctly handles monadic behavior" $ do 213 | dijkstraM 214 | (taxicabNeighborsBounded `pruningM` (return . isBigWall)) 215 | taxicabDistanceBounded 216 | (return . (== end)) 217 | start 218 | `shouldBe` Nothing 219 | dijkstraM 220 | taxicabNeighborsBounded 221 | ((const . const) Nothing :: (Int, Int) -> (Int, Int) -> Maybe Int) 222 | (return . (== end)) 223 | start 224 | `shouldBe` Nothing 225 | dijkstraM 226 | (taxicabNeighborsBounded `pruningM` (return . isBigWall)) 227 | taxicabDistanceBounded 228 | (const Nothing) 229 | start 230 | `shouldBe` Nothing 231 | describe "dijkstraAssocCostM" $ do 232 | let start = (0, 0) 233 | end = (2, 0) 234 | taxicabNeighborsBounded' (from, cost1) = do 235 | tos <- taxicabNeighborsBounded from 236 | cost2s <- mapM (taxicabDistanceBounded from) tos 237 | pure $ zip tos $ (cost1 +) <$> cost2s 238 | it "performs monadic dijkstra's algorithm" $ 239 | dijkstraAssocCostM 240 | taxicabNeighborsBounded' 241 | (return . (== end)) 242 | start 243 | `shouldBe` Just (Just (2, [(1, 0), (2, 0)])) 244 | it "handles cyclic graphs" $ do 245 | let nextM (char, cost) = return $ fmap (cost +) <$> (cyclicWeightedGraph Map.! char) 246 | isChar char1 (char2, _cost) = char1 == char2 247 | dijkstraAssocCostM nextM (return . (== 'd')) 'a' 248 | `shouldBe` Just (Just (4, ['c', 'd'])) 249 | dijkstraAssocCostM (nextM `pruningM` (return . isChar 'c')) 250 | (return . (== 'd')) 'a' 251 | `shouldBe` Just (Just (6, ['b', 'd'])) 252 | it "handles zero-length solutions" $ do 253 | let nextM (char, cost) = return $ fmap (cost +) <$> (cyclicWeightedGraph Map.! char) 254 | dijkstraAssocCostM nextM (return . (== 'd')) 'd' 255 | `shouldBe` Just (Just (0, [])) 256 | it "correctly handles monadic behavior" $ do 257 | dijkstraAssocCostM 258 | (taxicabNeighborsBounded' `pruningM` (return . isBigWall . fst)) 259 | (return . (== end)) 260 | start 261 | `shouldBe` Nothing 262 | dijkstraAssocCostM 263 | (taxicabNeighborsBounded' `pruningM` (return . isBigWall . fst)) 264 | (const Nothing) 265 | start 266 | `shouldBe` Nothing 267 | describe "aStarM" $ do 268 | let start = (0, 0) 269 | end = (2, 0) 270 | it "performs a monadic A* algorithm" $ 271 | aStarM 272 | (taxicabNeighborsBounded `pruningM` (return . isWall)) 273 | taxicabDistanceBounded 274 | (taxicabDistanceBounded end) 275 | (return . (== end)) 276 | start 277 | `shouldBe` 278 | Just (Just (6, [(0, 1), (0, 2), (1, 2), (2, 2), (2, 1), (2, 0)])) 279 | it "handles zero-length solutions" $ 280 | aStarM taxicabNeighborsBounded taxicabDistanceBounded 281 | (taxicabDistanceBounded end) (return . (== start)) start 282 | `shouldBe` Just (Just (0, [])) 283 | it "correctly handles monadic behavior" $ do 284 | aStarM 285 | (taxicabNeighborsBounded `pruningM` (return . isBigWall)) 286 | taxicabDistanceBounded 287 | (taxicabDistanceBounded end) 288 | (return . (== end)) 289 | start 290 | `shouldBe` Nothing 291 | aStarM 292 | taxicabNeighborsBounded 293 | ((const . const) Nothing :: (Int, Int) -> (Int, Int) -> Maybe Int) 294 | (taxicabDistanceBounded end) 295 | (return . (== end)) 296 | start 297 | `shouldBe` Nothing 298 | aStarM 299 | taxicabNeighborsBounded 300 | taxicabDistanceBounded 301 | (const Nothing) 302 | (return . (== end)) 303 | start 304 | `shouldBe` Nothing 305 | aStarM 306 | taxicabNeighborsBounded 307 | taxicabDistanceBounded 308 | (taxicabDistanceBounded end) 309 | (const Nothing) 310 | start 311 | `shouldBe` Nothing 312 | describe "incrementalCosts" $ do 313 | let cost a b = fromJust . lookup b $ cyclicWeightedGraph Map.! a 314 | it "gives the incremental costs along a path" $ 315 | incrementalCosts cost ['a', 'b', 'd'] `shouldBe` [1, 5] 316 | it "handles zero-length paths" $ do 317 | incrementalCosts cost [] `shouldBe` [] 318 | incrementalCosts cost ['a'] `shouldBe` [] 319 | describe "incrementalCostsM" $ do 320 | let costM a b = lookup b $ cyclicWeightedGraph Map.! a 321 | it "gives monadic incremental costs along a path" $ 322 | incrementalCostsM costM ['a', 'b', 'd'] `shouldBe` Just [1, 5] 323 | it "handles zero-length paths" $ do 324 | incrementalCostsM costM [] `shouldBe` Just [] 325 | incrementalCostsM costM ['a'] `shouldBe` Just [] 326 | it "correctly handles monadic behavior" $ 327 | incrementalCostsM costM ['a', 'd'] `shouldBe` Nothing 328 | describe "pruning" $ do 329 | it "filters according to its predicate" $ 330 | ((\x -> [x, 2*x, 3*x]) `pruning` even) 3 `shouldBe` [3, 9] 331 | describe "pruningAssoc" $ do 332 | it "filters according to its predicate" $ 333 | ((\x -> [(x, 1), (2*x, 2)]) `pruningAssoc` (\(_, cost) -> cost > 1)) 3 `shouldBe` [(3, 1)] 334 | describe "pruningM" $ do 335 | it "filters according to its predicate" $ 336 | ((\x -> (Just [x, 2*x, 3*x])) `pruningM` (\x -> Just (even x))) 3 `shouldBe` Just [3, 9] 337 | describe "pruningAssocM" $ do 338 | it "filters according to its predicate" $ 339 | ((\x -> Just [(x, 1), (2*x, 2)]) `pruningAssocM` (\(_, cost) -> Just (cost > 1))) 3 `shouldBe` Just [(3, 1)] 340 | -------------------------------------------------------------------------------- /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 | dijkstraAssocCost, 18 | aStar, 19 | aStarAssoc, 20 | -- * Monadic Searches 21 | -- $monadic 22 | bfsM, 23 | dfsM, 24 | dijkstraM, 25 | dijkstraAssocM, 26 | dijkstraAssocCostM, 27 | aStarM, 28 | aStarAssocM, 29 | -- * Utility 30 | incrementalCosts, 31 | incrementalCostsM, 32 | pruning, 33 | pruningAssoc, 34 | pruningM, 35 | pruningAssocM 36 | ) where 37 | 38 | import qualified Data.Map as Map 39 | import qualified Data.Sequence as Seq 40 | import qualified Data.Set as Set 41 | import qualified Data.List as List 42 | import qualified Data.Foldable as Foldable 43 | import Data.Functor.Identity (Identity(..)) 44 | import Control.Monad (filterM, zipWithM) 45 | import Data.Tuple (swap) 46 | 47 | -- | @bfs next found initial@ performs a breadth-first search over a set of 48 | -- states, starting with @initial@, and generating neighboring states with 49 | -- @next@. It returns a path to a state for which @found@ returns 'True'. 50 | -- Returns 'Nothing' if no path is possible. 51 | -- 52 | -- === Example: Making change problem 53 | -- 54 | -- >>> :{ 55 | -- countChange target = bfs (add_one_coin `pruning` (> target)) (== target) 0 56 | -- where 57 | -- add_one_coin amt = map (+ amt) coins 58 | -- coins = [25, 10, 5, 1] 59 | -- :} 60 | -- 61 | -- >>> countChange 67 62 | -- Just [25,50,60,65,66,67] 63 | bfs :: (Foldable f, Ord state) 64 | => (state -> f state) 65 | -- ^ Function to generate "next" states given a current state 66 | -> (state -> Bool) 67 | -- ^ Predicate to determine if solution found. 'bfs' returns a path to the 68 | -- first state for which this predicate returns 'True'. 69 | -> state 70 | -- ^ Initial state 71 | -> Maybe [state] 72 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 73 | -- such path exists. 74 | bfs next found = 75 | -- BFS is a generalized search using a queue, which directly compares states, 76 | -- and which always uses the first path found to a state 77 | runIdentity . bfsM (Identity . next) (Identity . found) 78 | 79 | 80 | -- | @dfs next found initial@ performs a depth-first search over a set 81 | -- of states, starting with @initial@ and generating neighboring states with 82 | -- @next@. It returns a depth-first path to a state for which @found@ returns 83 | -- 'True'. Returns 'Nothing' if no path is possible. 84 | -- 85 | -- === Example: Simple directed graph search 86 | -- 87 | -- >>> import qualified Data.Map as Map 88 | -- 89 | -- >>> graph = Map.fromList [(1, [2, 3]), (2, [4]), (3, [4]), (4, [])] 90 | -- 91 | -- >>> dfs (graph Map.!) (== 4) 1 92 | -- Just [3,4] 93 | dfs :: (Foldable f, Ord state) 94 | => (state -> f state) 95 | -- ^ Function to generate "next" states given a current state. These should be 96 | -- given in the order in which states should be pushed onto the stack, i.e. 97 | -- the "last" state in the Foldable will be the first one visited. 98 | -> (state -> Bool) 99 | -- ^ Predicate to determine if solution found. 'dfs' returns a path to the 100 | -- first state for which this predicate returns 'True'. 101 | -> state 102 | -- ^ Initial state 103 | -> Maybe [state] 104 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 105 | -- such path exists. 106 | dfs next found = 107 | -- DFS is a generalized search using a stack, which directly compares states, 108 | -- and which always uses the most recent path found to a state 109 | runIdentity . dfsM (Identity . next) (Identity . found) 110 | 111 | 112 | -- | @dijkstra next cost found initial@ performs a shortest-path search over 113 | -- a set of states using Dijkstra's algorithm, starting with @initial@, 114 | -- generating neighboring states with @next@, and their incremental costs with 115 | -- @costs@. This will find the least-costly path from an initial state to a 116 | -- state for which @found@ returns 'True'. Returns 'Nothing' if no path to a 117 | -- solved state is possible. 118 | -- 119 | -- === Example: Making change problem, with a twist 120 | -- 121 | -- >>> :{ 122 | -- -- Twist: dimes have a face value of 10 cents, but are actually rare 123 | -- -- misprints which are worth 10 dollars 124 | -- countChange target = 125 | -- dijkstra (add_coin `pruning` (> target)) true_cost (== target) 0 126 | -- where 127 | -- coin_values = [(25, 25), (10, 1000), (5, 5), (1, 1)] 128 | -- add_coin amt = map ((+ amt) . snd) coin_values 129 | -- true_cost low high = 130 | -- case lookup (high - low) coin_values of 131 | -- Just val -> val 132 | -- Nothing -> error $ "invalid costs: " ++ show high ++ ", " ++ show low 133 | -- :} 134 | -- 135 | -- >>> countChange 67 136 | -- Just (67,[1,2,7,12,17,42,67]) 137 | dijkstra :: (Foldable f, Num cost, Ord cost, Ord state) 138 | => (state -> f state) 139 | -- ^ Function to generate list of neighboring states given the current state 140 | -> (state -> state -> cost) 141 | -- ^ Function to generate transition costs between neighboring states. This is 142 | -- only called for adjacent states, so it is safe to have this function be 143 | -- partial for non-neighboring states. 144 | -> (state -> Bool) 145 | -- ^ Predicate to determine if solution found. 'dijkstra' returns the shortest 146 | -- path to the first state for which this predicate returns 'True'. 147 | -> state 148 | -- ^ Initial state 149 | -> Maybe (cost, [state]) 150 | -- ^ (Total cost, list of steps) for the first path found which 151 | -- satisfies the given predicate 152 | dijkstra next cost found = 153 | -- This API to Dijkstra's algorithm is useful when the state transition 154 | -- function and the cost function are logically separate. 155 | -- It is implemented by using @dijkstraAssoc@ with appropriate mapping of 156 | -- arguments. 157 | runIdentity . dijkstraM (Identity . next) (identity2 cost) (Identity . found) 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 = 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 | runIdentity . dijkstraAssocM (Identity . next) (Identity . found) 188 | 189 | -- | @dijkstraAssocCost next found initial@ performs a shortest-path search over 190 | -- a set of states using Dijkstra's algorithm, starting with @initial@, 191 | -- generating neighboring states with associated path costs with @next@ (this 192 | -- means that the path of a cost is not the sum of the previous cost and the 193 | -- cost of the current transition, @next@ can do arbitrary computations using 194 | -- those two costs, like a weighted sum or a probability combination). This will 195 | -- find the least-costly path from an initial state to a state for which @found@ 196 | -- returns 'True'. Returns 'Nothing' if no path to a solved state is possible. 197 | dijkstraAssocCost :: (Num cost, Ord cost, Ord state) 198 | => ((state, cost) -> [(state, cost)]) 199 | -- ^ function to generate list of neighboring states with associated 200 | -- transition costs given the current state 201 | -> (state -> Bool) 202 | -- ^ Predicate to determine if solution found. 'dijkstraAssoc' returns the 203 | -- shortest path to the first state for which this predicate returns 'True'. 204 | -> state 205 | -- ^ Initial state 206 | -> Maybe (cost, [state]) 207 | -- ^ (Total cost, list of steps) for the first path found which 208 | -- satisfies the given predicate 209 | dijkstraAssocCost next found = 210 | -- This API to Dijkstra's algoritm is useful in the common case when next 211 | -- states and their associated transition costs are generated together. 212 | -- 213 | -- Dijkstra's algorithm can be viewed as a generalized search, with the search 214 | -- container being a heap, with the states being compared without regard to 215 | -- cost, with the shorter paths taking precedence over longer ones, and with 216 | -- the stored state being (cost so far, state). 217 | -- This implementation makes that transformation, then transforms that result 218 | -- back into the desired result from @dijkstraAssoc@ 219 | runIdentity . dijkstraAssocCostM (Identity . next) (Identity . found) 220 | 221 | 222 | -- | @aStar next cost remaining found initial@ performs a best-first search 223 | -- using the A* search algorithm, starting with the state @initial@, generating 224 | -- neighboring states with @next@, their cost with @cost@, and an estimate of 225 | -- the remaining cost with @remaining@. This returns a path to a state for which 226 | -- @found@ returns 'True'. If @remaining@ is strictly a lower bound on the 227 | -- remaining cost to reach a solved state, then the returned path is the 228 | -- shortest path. Returns 'Nothing' if no path to a solved state is possible. 229 | -- 230 | -- === Example: Path finding in taxicab geometry 231 | -- 232 | -- >>> :{ 233 | -- neighbors (x, y) = [(x, y + 1), (x - 1, y), (x + 1, y), (x, y - 1)] 234 | -- dist (x1, y1) (x2, y2) = abs (y2 - y1) + abs (x2 - x1) 235 | -- start = (0, 0) 236 | -- end = (0, 2) 237 | -- isWall = (== (0, 1)) 238 | -- :} 239 | -- 240 | -- >>> aStar (neighbors `pruning` isWall) dist (dist end) (== end) start 241 | -- Just (4,[(1,0),(1,1),(1,2),(0,2)]) 242 | aStar :: (Foldable f, Num cost, Ord cost, Ord state) 243 | => (state -> f state) 244 | -- ^ Function to generate list of neighboring states given the current state 245 | -> (state -> state -> cost) 246 | -- ^ Function to generate transition costs between neighboring states. This is 247 | -- only called for adjacent states, so it is safe to have this function be 248 | -- partial for non-neighboring states. 249 | -> (state -> cost) 250 | -- ^ Estimate on remaining cost given a state 251 | -> (state -> Bool) 252 | -- ^ Predicate to determine if solution found. 'aStar' returns the shortest 253 | -- path to the first state for which this predicate returns 'True'. 254 | -> state 255 | -- ^ Initial state 256 | -> Maybe (cost, [state]) 257 | -- ^ (Total cost, list of steps) for the first path found which satisfies the 258 | -- given predicate 259 | aStar next cost remaining found = 260 | -- This API to A* search is useful when the state transition 261 | -- function and the cost function are logically separate. 262 | -- It is implemented by using @aStarAssoc@ with appropriate mapping of 263 | -- arguments. 264 | runIdentity . aStarM (Identity . next) (identity2 cost) (Identity . remaining) (Identity . found) 265 | 266 | 267 | -- | @aStarAssoc next remaining found initial@ performs a best-first search 268 | -- using the A* search algorithm, starting with the state @initial@, generating 269 | -- neighboring states and their associated costs with @next@, and an estimate of 270 | -- the remaining cost with @remaining@. This returns a path to a state for which 271 | -- @found@ returns 'True'. If @remaining@ is strictly a lower bound on the 272 | -- remaining cost to reach a solved state, then the returned path is the 273 | -- shortest path. Returns 'Nothing' if no path to a solved state is possible. 274 | aStarAssoc :: (Num cost, Ord cost, Ord state) 275 | => (state -> [(state, cost)]) 276 | -- ^ function to generate list of neighboring states with associated 277 | -- transition costs given the current state 278 | -> (state -> cost) 279 | -- ^ Estimate on remaining cost given a state 280 | -> (state -> Bool) 281 | -- ^ Predicate to determine if solution found. 'aStar' returns the shortest 282 | -- path to the first state for which this predicate returns 'True'. 283 | -> state 284 | -- ^ Initial state 285 | -> Maybe (cost, [state]) 286 | -- ^ (Total cost, list of steps) for the first path found which satisfies the 287 | -- given predicate 288 | aStarAssoc next remaining found = 289 | -- This API to A* search is useful in the common case when next 290 | -- states and their associated transition costs are generated together. 291 | -- 292 | -- A* can be viewed as a generalized search, with the search container being a 293 | -- heap, with the states being compared without regard to cost, with the 294 | -- shorter paths taking precedence over longer ones, and with 295 | -- the stored state being (total cost estimate, (cost so far, state)). 296 | -- This implementation makes that transformation, then transforms that result 297 | -- back into the desired result from @aStarAssoc@ 298 | runIdentity . aStarAssocM (Identity . next) (Identity . remaining) (Identity . found) 299 | 300 | -- $monadic 301 | -- Note that for all monadic searches, it is up to the user to ensure that 302 | -- side-effecting monads do not logically change the structure of the graph. 303 | -- For example, if the list of neighbors is being read from a file, the user 304 | -- must ensure that those values do not change between reads. 305 | 306 | -- | @bfsM@ is a monadic version of 'bfs': it has support for monadic @next@ and 307 | -- @found@ parameters. 308 | bfsM :: (Monad m, Foldable f, Ord state) 309 | => (state -> m (f state)) 310 | -- ^ Function to generate "next" states given a current state 311 | -> (state -> m Bool) 312 | -- ^ Predicate to determine if solution found. 'bfsM' returns a path to the 313 | -- first state for which this predicate returns 'True'. 314 | -> state 315 | -- ^ Initial state 316 | -> m (Maybe [state]) 317 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 318 | -- such path exists. 319 | bfsM = generalizedSearchM Seq.empty id (\_ _ -> False) 320 | 321 | 322 | -- | @dfsM@ is a monadic version of 'dfs': it has support for monadic @next@ and 323 | -- @found@ parameters. 324 | dfsM :: (Monad m, Foldable f, Ord state) 325 | => (state -> m (f state)) 326 | -- ^ Function to generate "next" states given a current state 327 | -> (state -> m Bool) 328 | -- ^ Predicate to determine if solution found. 'dfsM' returns a path to the 329 | -- first state for which this predicate returns 'True'. 330 | -> state 331 | -- ^ Initial state 332 | -> m (Maybe [state]) 333 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 334 | -- such path exists. 335 | dfsM = 336 | generalizedSearchM [] id (\_ _ -> True) 337 | 338 | -- | @dijkstraM@ is a monadic version of 'dijkstra': it has support for monadic 339 | -- @next@, @cost@, and @found@ parameters. 340 | dijkstraM :: (Monad m, Foldable f, Num cost, Ord cost, Ord state) 341 | => (state -> m (f state)) 342 | -- ^ Function to generate list of neighboring states given the current state 343 | -> (state -> state -> m cost) 344 | -- ^ Function to generate list of costs between neighboring states. This is 345 | -- only called for adjacent states, so it is safe to have this function be 346 | -- partial for non-neighboring states. 347 | -> (state -> m Bool) 348 | -- ^ Predicate to determine if solution found. 'dijkstraM' returns the 349 | -- shortest path to the first state for which this predicate returns 'True'. 350 | -> state 351 | -- ^ Initial state 352 | -> m (Maybe (cost, [state])) 353 | -- ^ (Total cost, list of steps) for the first path found which 354 | -- satisfies the given predicate 355 | dijkstraM nextM costM foundM initial = 356 | fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd leastCostly nextM' 357 | (foundM . snd) (0, initial) 358 | where 359 | nextM' (old_cost, old_st) = do 360 | new_states <- Foldable.toList <$> nextM old_st 361 | incr_costs <- sequence $ costM old_st <$> new_states 362 | let new_costs = (+ old_cost) <$> incr_costs 363 | return $ zip new_costs new_states 364 | unpack [] = (0, []) 365 | unpack packed_states = (fst . last $ packed_states, map snd packed_states) 366 | 367 | 368 | -- | @dijkstraAssocM@ is a monadic version of 'dijkstraAssoc': it has support 369 | -- for monadic @next@ and @found@ parameters. 370 | dijkstraAssocM :: (Monad m, Num cost, Ord cost, Ord state) 371 | => (state -> m [(state, cost)]) 372 | -- ^ Function to generate list of neighboring states with associated 373 | -- transition costs given the current state 374 | -> (state -> m Bool) 375 | -- ^ Predicate to determine if solution found. 'dijkstraM' returns the 376 | -- shortest path to the first state for which this predicate returns 'True'. 377 | -> state 378 | -- ^ Initial state 379 | -> m (Maybe (cost, [state])) 380 | -- ^ (Total cost, list of steps) for the first path found which 381 | -- satisfies the given predicate 382 | dijkstraAssocM nextM foundM initial = 383 | fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd leastCostly nextM' 384 | (foundM . snd) (0, initial) 385 | where 386 | nextM' (old_cost, old_st) = do 387 | new_states <- nextM old_st 388 | return $ map (update_st old_cost) new_states 389 | update_st old_cost (new_st, new_cost) = (old_cost + new_cost, new_st) 390 | unpack [] = (0, []) 391 | unpack packed_states = (fst . last $ packed_states, map snd packed_states) 392 | 393 | 394 | -- | @dijkstraAssocCostM@ is a monadic version of 'dijkstraAssocCost': it has 395 | -- support for monadic @next@ and @found@ parameters. 396 | dijkstraAssocCostM :: (Monad m, Num cost, Ord cost, Ord state) 397 | => ((state, cost) -> m [(state, cost)]) 398 | -- ^ Function to generate list of neighboring states with associated 399 | -- path costs given the current state 400 | -> (state -> m Bool) 401 | -- ^ Predicate to determine if solution found. 'dijkstraM' returns the 402 | -- shortest path to the first state for which this predicate returns 'True'. 403 | -> state 404 | -- ^ Initial state 405 | -> m (Maybe (cost, [state])) 406 | -- ^ (Total cost, list of steps) for the first path found which 407 | -- satisfies the given predicate 408 | dijkstraAssocCostM nextM foundM initial = 409 | fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd leastCostly nextM' 410 | (foundM . snd) (0, initial) 411 | where 412 | nextM' = fmap2 swap . nextM . swap 413 | unpack [] = (0, []) 414 | unpack packed_states = (fst . last $ packed_states, map snd packed_states) 415 | 416 | 417 | -- | @aStarM@ is a monadic version of 'aStar': it has support for monadic 418 | -- @next@, @cost@, @remaining@, and @found@ parameters. 419 | aStarM :: (Monad m, Foldable f, Num cost, Ord cost, Ord state) 420 | => (state -> m (f state)) 421 | -- ^ function to generate list of neighboring states with associated 422 | -- transition costs given the current state 423 | -> (state -> state -> m cost) 424 | -- ^ Function to generate list of costs between neighboring states. This is 425 | -- only called for adjacent states, so it is safe to have this function be 426 | -- partial for non-neighboring states. 427 | -> (state -> m cost) 428 | -- ^ Estimate on remaining cost given a state 429 | -> (state -> m Bool) 430 | -- ^ Predicate to determine if solution found. 'aStarM' returns the shortest 431 | -- path to the first state for which this predicate returns 'True'. 432 | -> state 433 | -- ^ Initial state 434 | -> m (Maybe (cost, [state])) 435 | -- ^ (Total cost, list of steps) for the first path found which satisfies the 436 | -- given predicate 437 | aStarM nextM costM remainingM foundM initial = do 438 | remaining_init <- remainingM initial 439 | fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd2 leastCostly nextM' 440 | (foundM . snd2) (remaining_init, (0, initial)) 441 | where 442 | nextM' (_, (old_cost, old_st)) = do 443 | new_states <- Foldable.toList <$> nextM old_st 444 | sequence $ update_stateM <$> new_states 445 | where 446 | update_stateM new_st = do 447 | remaining <- remainingM new_st 448 | cost <- costM old_st new_st 449 | let new_cost = old_cost + cost 450 | new_est = new_cost + remaining 451 | return (new_est, (new_cost, new_st)) 452 | unpack [] = (0, []) 453 | unpack packed_states = 454 | (fst . snd . last $ packed_states, map snd2 packed_states) 455 | snd2 = snd . snd 456 | 457 | 458 | -- | @aStarAssocM@ is a monadic version of 'aStarAssoc': it has support for 459 | -- monadic @next@, @remaining@, and @found@ parameters. 460 | aStarAssocM :: (Monad m, Num cost, Ord cost, Ord state) 461 | => (state -> m [(state, cost)]) 462 | -- ^ function to generate list of neighboring states with associated 463 | -- transition costs given the current state 464 | -> (state -> m cost) 465 | -- ^ Estimate on remaining cost given a state 466 | -> (state -> m Bool) 467 | -- ^ Predicate to determine if solution found. 'aStarM' returns the shortest 468 | -- path to the first state for which this predicate returns 'True'. 469 | -> state 470 | -- ^ Initial state 471 | -> m (Maybe (cost, [state])) 472 | -- ^ (Total cost, list of steps) for the first path found which satisfies the 473 | -- given predicate 474 | aStarAssocM nextM remainingM foundM initial = do 475 | remaining_init <- remainingM initial 476 | fmap2 unpack $ generalizedSearchM emptyLIFOHeap snd2 leastCostly nextM' 477 | (foundM . snd2) (remaining_init, (0, initial)) 478 | where 479 | nextM' (_, (old_cost, old_st)) = do 480 | new_states <- nextM old_st 481 | sequence $ update_stateM <$> new_states 482 | where 483 | update_stateM new_st = do 484 | remaining <- remainingM (fst new_st) 485 | let new_cost = old_cost + (snd new_st) 486 | new_est = new_cost + remaining 487 | return (new_est, (new_cost, fst new_st)) 488 | unpack [] = (0, []) 489 | unpack packed_states = 490 | (fst . snd . last $ packed_states, map snd2 packed_states) 491 | snd2 = snd . snd 492 | 493 | 494 | -- | @incrementalCosts cost_fn states@ gives a list of the incremental costs 495 | -- going from state to state along the path given in @states@, using the cost 496 | -- function given by @cost_fn@. Note that the paths returned by the searches 497 | -- in this module do not include the initial state, so if you want the 498 | -- incremental costs along a @path@ returned by one of these searches, you 499 | -- want to use @incrementalCosts cost_fn (initial : path)@. 500 | -- 501 | -- === Example: Getting incremental costs from dijkstra 502 | -- 503 | -- >>> import Data.Maybe (fromJust) 504 | -- 505 | -- >>> :{ 506 | -- cyclicWeightedGraph :: Map.Map Char [(Char, Int)] 507 | -- cyclicWeightedGraph = Map.fromList [ 508 | -- ('a', [('b', 1), ('c', 2)]), 509 | -- ('b', [('a', 1), ('c', 2), ('d', 5)]), 510 | -- ('c', [('a', 1), ('d', 2)]), 511 | -- ('d', []) 512 | -- ] 513 | -- start = (0, 0) 514 | -- end = (0, 2) 515 | -- cost a b = fromJust . lookup b $ cyclicWeightedGraph Map.! a 516 | -- :} 517 | -- 518 | -- >>> incrementalCosts cost ['a', 'b', 'd'] 519 | -- [1,5] 520 | incrementalCosts :: 521 | (state -> state -> cost) 522 | -- ^ Function to generate list of costs between neighboring states. This is 523 | -- only called for adjacent states in the `states` list, so it is safe to have 524 | -- this function be partial for non-neighboring states. 525 | -> [state] 526 | -- ^ A path, given as a list of adjacent states, along which to find the 527 | -- incremental costs 528 | -> [cost] 529 | -- ^ List of incremental costs along given path 530 | incrementalCosts cost_fn states = zipWith cost_fn states (tail states) 531 | 532 | -- | @incrementalCostsM@ is a monadic version of 'incrementalCosts': it has 533 | -- support for a monadic @const_fn@ parameter. 534 | incrementalCostsM :: 535 | (Monad m) => 536 | (state -> state -> m cost) 537 | -- ^ Function to generate list of costs between neighboring states. This is 538 | -- only called for adjacent states in the `states` list, so it is safe to have 539 | -- this function be partial for non-neighboring states. 540 | -> [state] 541 | -- ^ A path, given as a list of adjacent states, along which to find the 542 | -- incremental costs 543 | -> m [cost] 544 | -- ^ List of incremental costs along given path 545 | incrementalCostsM costM states = zipWithM costM states (tail states) 546 | 547 | 548 | -- | @next \`pruning\` predicate@ streams the elements generate by @next@ into a 549 | -- list, removing elements which satisfy @predicate@. This is useful for the 550 | -- common case when you want to logically separate your search's `next` function 551 | -- from some way of determining when you've reached a dead end. 552 | -- 553 | -- === Example: Pruning a Set 554 | -- 555 | -- >>> import qualified Data.Set as Set 556 | -- 557 | -- >>> ((\x -> Set.fromList [0..x]) `pruning` even) 10 558 | -- [1,3,5,7,9] 559 | -- 560 | -- === Example: depth-first search, avoiding certain nodes 561 | -- 562 | -- >>> import qualified Data.Map as Map 563 | -- 564 | -- >>> :{ 565 | -- graph = Map.fromList [ 566 | -- ('a', ['b', 'c', 'd']), 567 | -- ('b', [undefined]), 568 | -- ('c', ['e']), 569 | -- ('d', [undefined]), 570 | -- ('e', []) 571 | -- ] 572 | -- :} 573 | -- 574 | -- >>> dfs ((graph Map.!) `pruning` (`elem` "bd")) (== 'e') 'a' 575 | -- Just "ce" 576 | pruning :: 577 | (Foldable f) 578 | => (a -> f a) 579 | -- ^ Function to generate next states 580 | -> (a -> Bool) 581 | -- ^ Predicate to prune on 582 | -> (a -> [a]) 583 | -- ^ Version of @next@ which excludes elements satisfying @predicate@ 584 | next `pruning` predicate = 585 | (filter (not . predicate) . Foldable.toList) <$> next 586 | 587 | 588 | -- | @pruningAssoc@ is a version of 'pruning' that works with the `Assoc` variants of searches. 589 | pruningAssoc :: 590 | (Foldable f) 591 | => (state -> f (state, cost)) 592 | -- ^ Function to generate next states 593 | -> ((state, cost) -> Bool) 594 | -- ^ Predicate to prune on 595 | -> (state -> [(state, cost)]) 596 | -- ^ Version of @next@ which excludes elements satisfying @predicate@ 597 | next `pruningAssoc` predicate = 598 | (filter (not . predicate) . Foldable.toList) <$> next 599 | 600 | -- | @pruningM@ is a monadic version of 'pruning': it has support for monadic 601 | -- @next@ and @predicate@ parameters 602 | pruningM :: 603 | (Monad m, Foldable f) 604 | => (a -> m (f a)) 605 | -- ^ Function to generate next states 606 | -> (a -> m Bool) 607 | -- ^ Predicate to prune on 608 | -> (a -> m [a]) 609 | -- ^ Version of @next@ which excludes elements satisfying @predicate@ 610 | pruningM nextM predicateM a = do 611 | next_states <- nextM a 612 | filterM (fmap not . predicateM) $ Foldable.toList next_states 613 | 614 | -- | @pruningAssocM@ is a monadic version of 'pruningAssoc': it has support for monadic 615 | -- @next@ and @predicate@ parameters 616 | pruningAssocM :: 617 | (Monad m, Foldable f) 618 | => (state -> m (f (state, cost))) 619 | -- ^ Function to generate next states 620 | -> ((state, cost) -> m Bool) 621 | -- ^ Predicate to prune on 622 | -> (state -> m [(state, cost)]) 623 | -- ^ Version of @next@ which excludes elements satisfying @predicate@ 624 | pruningAssocM nextM predicateM a = do 625 | next_states <- nextM a 626 | filterM (fmap not . predicateM) $ Foldable.toList next_states 627 | 628 | 629 | -- | A @SearchState@ represents the state of a generalized search at a given 630 | -- point in an algorithms execution. The advantage of this abstraction is that 631 | -- it can be used for things like bidirectional searches, where you want to 632 | -- stop and start a search part-way through. 633 | data SearchState container stateKey state = SearchState { 634 | current :: state, 635 | queue :: container, 636 | visited :: Set.Set stateKey, 637 | paths :: Map.Map stateKey [state] 638 | } 639 | 640 | -- | @nextSearchState@ moves from one @searchState@ to the next in the 641 | -- generalized search algorithm 642 | nextSearchStateM :: 643 | (Monad m, Foldable f, SearchContainer container, Ord stateKey, 644 | Elem container ~ state) 645 | => ([state] -> [state] -> Bool) 646 | -> (state -> stateKey) 647 | -> (state -> m (f state)) 648 | -> SearchState container stateKey state 649 | -> m (Maybe (SearchState container stateKey state)) 650 | nextSearchStateM better mk_key nextM old = do 651 | (new_queue, new_paths) <- new_queue_paths_M 652 | let new_state_May = mk_search_state new_paths <$> pop new_queue 653 | case new_state_May of 654 | Just new_state -> 655 | if mk_key (current new_state) `Set.member` visited old 656 | then nextSearchStateM better mk_key nextM new_state 657 | else return (Just new_state) 658 | Nothing -> return Nothing 659 | where 660 | mk_search_state new_paths (new_current, remaining_queue) = SearchState { 661 | current = new_current, 662 | queue = remaining_queue, 663 | visited = Set.insert (mk_key new_current) (visited old), 664 | paths = new_paths 665 | } 666 | new_queue_paths_M = 667 | List.foldl' update_queue_paths (queue old, paths old) 668 | <$> nextM (current old) 669 | update_queue_paths (old_queue, old_paths) st = 670 | if mk_key st `Set.member` visited old 671 | then (old_queue, old_paths) 672 | else 673 | case Map.lookup (mk_key st) old_paths of 674 | Just old_path -> 675 | if better old_path (st : steps_so_far) 676 | then (q', ps') 677 | else (old_queue, old_paths) 678 | Nothing -> (q', ps') 679 | where 680 | steps_so_far = paths old Map.! mk_key (current old) 681 | q' = push old_queue st 682 | ps' = Map.insert (mk_key st) (st : steps_so_far) old_paths 683 | 684 | 685 | -- | Workhorse simple search algorithm, generalized over search container 686 | -- and path-choosing function. The idea here is that many search algorithms are 687 | -- at their core the same, with these details substituted. By writing these 688 | -- searches in terms of this function, we reduce the chances of errors sneaking 689 | -- into each separate implementation. 690 | generalizedSearchM :: 691 | (Monad m, Foldable f, SearchContainer container, Ord stateKey, 692 | Elem container ~ state) 693 | => container 694 | -- ^ Empty @SearchContainer@ 695 | -> (state -> stateKey) 696 | -- ^ Function to turn a @state@ into a key by which states will be compared 697 | -- when determining whether a state has be enqueued and / or visited 698 | -> ([state] -> [state] -> Bool) 699 | -- ^ Function @better old new@, which when given a choice between an @old@ and 700 | -- a @new@ path to a state, returns True when @new@ is a "better" path than 701 | -- old and should thus be inserted 702 | -> (state -> m (f state)) 703 | -- ^ Function to generate "next" states given a current state 704 | -> (state -> m Bool) 705 | -- ^ Predicate to determine if solution found. @generalizedSearch@ returns a 706 | -- path to the first state for which this predicate returns 'True'. 707 | -> state 708 | -- ^ Initial state 709 | -> m (Maybe [state]) 710 | -- ^ First path found to a state matching the predicate, or 'Nothing' if no 711 | -- such path exists. 712 | generalizedSearchM empty mk_key better nextM foundM initial = do 713 | let initial_state = 714 | SearchState initial empty (Set.singleton $ mk_key initial) 715 | (Map.singleton (mk_key initial) []) 716 | end_May <- findIterateM (nextSearchStateM better mk_key nextM) 717 | (foundM . current) initial_state 718 | return $ fmap (reverse . get_steps) end_May 719 | where 720 | get_steps search_st = paths search_st Map.! mk_key (current search_st) 721 | 722 | 723 | newtype LIFOHeap k a = LIFOHeap (Map.Map k [a]) 724 | 725 | 726 | emptyLIFOHeap :: LIFOHeap k a 727 | emptyLIFOHeap = LIFOHeap Map.empty 728 | 729 | 730 | -- | The @SearchContainer@ class abstracts the idea of a container to be used in 731 | -- @generalizedSearch@ 732 | class SearchContainer container where 733 | type Elem container 734 | pop :: container -> Maybe (Elem container, container) 735 | push :: container -> Elem container -> container 736 | 737 | instance SearchContainer (Seq.Seq a) where 738 | type Elem (Seq.Seq a) = a 739 | pop s = 740 | case Seq.viewl s of 741 | Seq.EmptyL -> Nothing 742 | (x Seq.:< xs) -> Just (x, xs) 743 | push s a = s Seq.|> a 744 | 745 | instance SearchContainer [a] where 746 | type Elem [a] = a 747 | pop list = 748 | case list of 749 | [] -> Nothing 750 | (x : xs) -> Just (x, xs) 751 | push list a = a : list 752 | 753 | instance Ord k => SearchContainer (LIFOHeap k a) where 754 | type Elem (LIFOHeap k a) = (k, a) 755 | pop (LIFOHeap inner) 756 | | Map.null inner = Nothing 757 | | otherwise = case Map.findMin inner of 758 | (k, [a]) -> Just ((k, a), LIFOHeap $ Map.deleteMin inner) 759 | (k, a : _) -> Just ((k, a), LIFOHeap $ Map.updateMin (Just . tail) inner) 760 | (_, []) -> pop (LIFOHeap $ Map.deleteMin inner) 761 | -- Logically, this should never happen 762 | push (LIFOHeap inner) (k, a) = LIFOHeap $ Map.insertWith (++) k [a] inner 763 | 764 | 765 | -- | @findIterateM@ is a monadic version of @findIterate@ 766 | findIterateM :: Monad m => (a -> m (Maybe a)) -> (a -> m Bool) -> a -> m (Maybe a) 767 | findIterateM nextM foundM initial = do 768 | found <- foundM initial 769 | if found 770 | then return $ Just initial 771 | else nextM initial >>= maybe (return Nothing) (findIterateM nextM foundM) 772 | 773 | 774 | -- | @leastCostly paths_a paths_b@ is a utility function to be used with 775 | -- 'dijkstra'-like functions. It returns True when the cost of @paths_a@ 776 | -- is less than the cost of @paths_b@, where the total costs are the first 777 | -- elements in each tuple in each path 778 | leastCostly :: Ord a => [(a, b)] -> [(a, b)] -> Bool 779 | leastCostly ((cost_a, _):_) ((cost_b, _):_) = cost_b < cost_a 780 | -- logically this never happens, because if you have a 781 | -- zero-length path a point, you already visited it 782 | -- and thus do not consider other paths to it 783 | leastCostly [] _ = False 784 | -- logically this never happens, because you cannot find 785 | -- a new zero-length path to a point 786 | leastCostly _ [] = True 787 | 788 | 789 | -- | This is just a convenience function which @fmap@s two deep 790 | fmap2 :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b) 791 | fmap2 = fmap . fmap 792 | 793 | -- | This applies Identity to the result of a function of two arguments 794 | identity2 :: (a -> b ->c) -> a -> b -> Identity c 795 | identity2 f a b = Identity $ f a b 796 | --------------------------------------------------------------------------------