From 98c06b95cefd45fb5fee89294d30259c36b737c3 Mon Sep 17 00:00:00 2001
From: Tissevert <tissevert+devel@marvid.fr>
Date: Sun, 5 May 2019 12:27:50 +0200
Subject: [PATCH] Add a Graph module with a graph zipper

---
 Mainate.cabal |  4 ++-
 src/Graph.hs  | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 77 insertions(+), 1 deletion(-)
 create mode 100644 src/Graph.hs

diff --git a/Mainate.cabal b/Mainate.cabal
index 8db51e3..e42a709 100644
--- a/Mainate.cabal
+++ b/Mainate.cabal
@@ -18,9 +18,11 @@ build-type:          Simple
 extra-source-files:  CHANGELOG.md
 
 library
-  exposed-modules:   Stream
+  exposed-modules:   Graph
+                   , Stream
   -- other-modules:
   -- other-extensions:
   build-depends:       base >=4.9 && <4.13
+                     , containers
   hs-source-dirs:      src
   default-language:    Haskell2010
diff --git a/src/Graph.hs b/src/Graph.hs
new file mode 100644
index 0000000..b9460b1
--- /dev/null
+++ b/src/Graph.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Graph (
+    Graph(..)
+  ) where
+
+import Data.Map (Map, (!?))
+import qualified Data.Map as Map (delete, empty, insert)
+
+data Vertex label edge = Vertex {
+      label :: label
+    , edges :: Map edge (Vertex label edge)
+  } deriving Show
+
+singleton :: label -> Vertex label edge
+singleton label = Vertex {label, edges = Map.empty}
+
+data Zipper label edge = Top | Zipper {
+      origin :: Zipper label edge
+    , from :: label
+    , by :: edge
+    , siblingEdges :: Map edge (Vertex label edge)
+  } deriving Show
+
+data Graph label edge = Graph {
+      focus :: Vertex label edge
+    , context :: Zipper label edge
+  } deriving Show
+
+open :: Vertex label edge -> Graph label edge
+open focus = Graph {focus, context = Top}
+
+zipUp :: Ord edge => Graph label edge -> Vertex label edge
+zipUp graph =
+  case context graph of
+    Top -> focus graph
+    Zipper {origin, from, by, siblingEdges} -> zipUp $ Graph {
+          context = origin
+        , focus = Vertex {
+              label = from
+            , edges = Map.insert by (focus graph) siblingEdges
+          }
+      }
+
+rewind :: Ord edge => Graph label edge -> Graph label edge
+rewind = open . zipUp
+
+follow :: Ord edge => Graph label edge -> edge -> Maybe (Graph label edge)
+follow (Graph {focus, context}) edge =
+  edges focus !? edge >>= \vertex -> Just $ Graph {
+      focus = vertex
+    , context = Zipper {
+          origin = context
+        , from = label $ focus
+        , by = edge
+        , siblingEdges = Map.delete edge $ edges focus
+      }
+  }
+
+weave :: (Monoid label, Ord edge) => Graph label edge -> [edge] -> Graph label edge
+weave = foldl $ \graph edge ->
+  case graph `follow` edge of
+    Nothing -> Graph {
+          focus = singleton mempty
+        , context = Zipper {
+              origin = context graph
+            , from = label $ focus graph
+            , by = edge
+            , siblingEdges = edges $ focus graph
+          }
+      }
+    Just newGraph -> newGraph
+
+setLabel :: Graph label edge -> label -> Graph label edge
+setLabel graph newLabel = graph {focus = (focus graph) {label = newLabel}}