68 lines
2 KiB
Haskell
68 lines
2 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
|
|
| GoalNotReached [vertex]
|
|
deriving Show
|
|
|
|
verifyPath
|
|
:: (Eq vertex, Ord vertex, Eq edge)
|
|
=> GetEdges vertex edge
|
|
-> vertex
|
|
-> vertex
|
|
-> [edge]
|
|
-> Either (VerifyPathError vertex edge) [vertex]
|
|
verifyPath getEdges goal start path =
|
|
case aux start path of
|
|
Right (vertices, True) -> Right vertices
|
|
Right (vertices, False) -> Left $ GoalNotReached vertices
|
|
Left x -> Left x
|
|
where
|
|
aux vertex path' = cons vertex <$>
|
|
case path' of
|
|
[] -> Right $
|
|
if vertex == goal
|
|
then ([], True)
|
|
else ([], False)
|
|
(thisEdge:nextEdges) ->
|
|
case map fst $ filter (\(next, realEdge) -> realEdge == thisEdge) $ getEdges vertex of
|
|
[] -> Left $ NoSuchEdge vertex thisEdge
|
|
(next:_) -> aux next nextEdges
|
|
|
|
cons vertex (vertices, bool) = (vertex:vertices, bool)
|