cabal

only doing this because Data.Set is not in the stdlib

lib/Logic/Graph.hs

@@ -0,0 +1,68 @@
+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)