diff --git a/Logic/Graph.hs b/Logic/Graph.hs new file mode 100644 index 0000000..0aa3be4 --- /dev/null +++ b/Logic/Graph.hs @@ -0,0 +1,27 @@ +module Logic.Graph where + +bfs :: Eq a => a -> a -> (a -> [(edge, a)]) -> Maybe [edge] +bfs goal start getEdges = reverse <$> aux [([], start)] [] + where + aux [] _ = Nothing + aux ((path, vertex):queue) visited + | vertex == goal = Just path + | otherwise = + let new = getUnvisitedAdjacent vertex visited + in + case filter (\(_, v) -> v == goal) new of + [] -> + let queue' = queue ++ map (\(edge, next) -> (edge:path, next)) new + in aux queue' (vertex:visited) + ((edge, _):_) -> Just (edge:path) + + getUnvisitedAdjacent vertex visited = + filter (\(edge, next) -> 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"] +-}