55 lines
1.7 KiB
Haskell
55 lines
1.7 KiB
Haskell
module Logic.Graph where
|
|
|
|
import Data.Set (Set, insert)
|
|
|
|
type GetEdges vertex edge = vertex -> [(vertex, edge)]
|
|
type GetEdgesCosts vertex edge cost = vertex -> [((vertex, edge), cost)]
|
|
|
|
bfs
|
|
:: (Eq vertex, Ord vertex)
|
|
=> GetEdges vertex edge
|
|
-> vertex
|
|
-> vertex
|
|
-> Maybe [edge]
|
|
bfs getEdges goal start = reverse <$> aux [(start, [])] mempty
|
|
where
|
|
aux [] _ = Nothing
|
|
aux ((vertex, path):queue) visited
|
|
| vertex == goal = Just path
|
|
| otherwise =
|
|
let new = getUnvisitedAdjacent vertex visited
|
|
in
|
|
case filter (\(v, _) -> v == goal) new of
|
|
[] ->
|
|
let queue' = queue ++ map (\(next, edge) -> (next, edge:path)) new
|
|
in aux queue' $ insert vertex visited
|
|
((_, edge):_) -> Just (edge:path)
|
|
|
|
getUnvisitedAdjacent vertex visited =
|
|
filter (\(next, edge) -> not $ next `elem` visited) $
|
|
getEdges vertex
|
|
|
|
{-
|
|
ghci> bfs 10 0 (\x -> [("pred", x-1), ("succ", x+1)])
|
|
Just ["succ","succ","succ","succ","succ","succ","succ","succ","succ","succ"]
|
|
ghci> bfs 13 0 (\x -> [("double", x+x), ("add", x+1)])
|
|
Just ["add","double","add","double","double","add"]
|
|
-}
|
|
|
|
data VerifyPathError vertex edge
|
|
= NoSuchEdge vertex edge
|
|
|
|
verifyPath
|
|
:: (Eq vertex, Ord vertex, Eq edge)
|
|
=> GetEdges vertex edge
|
|
-> vertex
|
|
-> vertex
|
|
-> [edge]
|
|
-> Either (VerifyPathError vertex edge) Bool
|
|
verifyPath getEdges goal start path =
|
|
case path of
|
|
[] -> Right $ start == goal
|
|
(thisEdge:nextEdges) ->
|
|
case map fst $ filter (\(next, realEdge) -> realEdge == thisEdge) $ getEdges start of
|
|
[] -> Left $ NoSuchEdge start thisEdge
|
|
(next:_) -> verifyPath getEdges goal next nextEdges
|