Reimplementing Graph as an adjacency matrix and adding loops on transducers

src/Graph.hs

@@ -3,93 +3,86 @@
 module Graph (
       Graph(..)
     , Vertex(..)
-    , Zipper(..)
+    , editVertex
-    , editLabel
     , follow
-    , open
     , rewind
     , singleton
+    , stitch
     , weave
   ) where
 
-import Data.Map (Map)
+import Data.Map ((!), Map)
-import qualified Data.Map as Map (delete, empty, insert, lookup, toList)
+import qualified Data.Map as Map (adjust, empty, insert, lookup, singleton, size, toList)
+import Data.Set (Set)
+import qualified Data.Set as Set (insert, member, singleton)
 import Tree (Tree(..), Structure(..))
 
+type VertexID = Int
+
 data Vertex edge label = Vertex {
       label :: label
-    , edges :: Map edge (Vertex edge label)
+    , edges :: Map edge VertexID
-  } deriving (Functor, Show)
-
-instance Show edge => Tree (Vertex edge) where
-  getStructure (Vertex {label, edges}) = Node [
-      ("(" ++ label ++ ")", Node $ recurseOnEdge <$> Map.toList edges)
-    ]
-    where
-      recurseOnEdge (edge, vertex) = (show edge, getStructure vertex)
-
-singleton :: label -> Vertex edge label
-singleton label = Vertex {label, edges = Map.empty}
-
-data Zipper edge label = Top | Zipper {
-      origin :: Zipper edge label
-    , from :: label
-    , by :: edge
-    , siblingEdges :: Map edge (Vertex edge label)
   } deriving (Functor, Show)
 
 data Graph edge label = Graph {
-      focus :: Vertex edge label
+      vertices :: Map VertexID (Vertex edge label)
-    , context :: Zipper edge label
+    , focus :: VertexID
+    , root :: VertexID
   } deriving (Functor, Show)
 
-instance (Ord edge, Show edge) => Tree (Graph edge) where
+getStructureWithoutLoop :: Show edge => Set VertexID -> Graph edge String -> Structure
-  getStructure = getStructure . zipUp
+getStructureWithoutLoop visitedIDs graph@(Graph {focus, vertices}) = Node [(
+      "(" ++ show focus ++ ":" ++ label ++ ")"
+    , Node $ recurseOnEdge <$> Map.toList edges
+  )]
+  where
+    Vertex label edges = vertices ! focus
+    recurseOnEdge (edge, vertexID) = (
+          show edge
+        , if Set.member vertexID visitedIDs
+          then Node [("(:" ++ show vertexID ++ ")", Node [])]
+          else getStructureWithoutLoop (Set.insert vertexID visitedIDs) $ graph {focus = vertexID}
+      )
 
-open :: Vertex edge label -> Graph edge label
+instance Show edge => Tree (Graph edge) where
-open focus = Graph {focus, context = Top}
+  getStructure graph = 
+    getStructureWithoutLoop (Set.singleton $ root graph) (rewind graph)
 
-zipUp :: Ord edge => Graph edge label -> Vertex edge label
+vertex :: label -> Vertex edge label
-zipUp graph =
+vertex label = Vertex {label, edges = Map.empty}
-  case context graph of
+
-    Top -> focus graph
+singleton :: label -> Graph edge label
-    Zipper {origin, from, by, siblingEdges} -> zipUp $ Graph {
+singleton label = Graph {
-          context = origin
+      vertices = Map.singleton 0 $ vertex label
-        , focus = Vertex {
+    , focus = 0
-              label = from
+    , root = 0
-            , edges = Map.insert by (focus graph) siblingEdges
-          }
   }
 
-rewind :: Ord edge => Graph edge label -> Graph edge label
+rewind :: Graph edge label -> Graph edge label
-rewind = open . zipUp
+rewind graph = graph {focus = root graph}
 
 follow :: Ord edge => Graph edge label -> edge -> Maybe (Graph edge label)
-follow (Graph {focus, context}) edge =
+follow graph@(Graph {vertices, focus}) edge =
-  Map.lookup edge (edges focus) >>= \vertex -> Just $ Graph {
+  Map.lookup edge (edges $ vertices ! focus) >>= \vertexID -> Just $ graph {
-      focus = vertex
+      focus = vertexID
-    , context = Zipper {
-          origin = context
-        , from = label $ focus
-        , by = edge
-        , siblingEdges = Map.delete edge $ edges focus
-      }
     }
 
-weave :: (Monoid label, Ord edge) => Graph edge label -> [edge] -> Graph edge label
+stitch :: (Monoid label, Ord edge) => Graph edge label -> edge -> Graph edge label
-weave = foldl $ \graph edge ->
+stitch graph edge =
   case graph `follow` edge of
-    Nothing -> Graph {
+    Nothing ->
-          focus = singleton mempty
+      let newVertexID = Map.size $ vertices graph in
-        , context = Zipper {
+      let link aVertex = aVertex {edges = Map.insert edge newVertexID $ edges aVertex} in
-              origin = context graph
+      graph {
-            , from = label $ focus graph
+          vertices =
-            , by = edge
+            Map.adjust link (focus graph) . Map.insert newVertexID (vertex mempty) $ vertices graph
-            , siblingEdges = edges $ focus graph
+        , focus = newVertexID
-          }
       }
     Just newGraph -> newGraph
 
-editLabel :: Graph edge label -> (label -> label) -> Graph edge label
+weave :: (Monoid label, Ord edge) => Graph edge label -> [edge] -> Graph edge label
-editLabel graph@(Graph {focus}) labelEditor =
+weave = foldl stitch
-  graph {focus = focus {label = labelEditor $ label focus}}
+
+editVertex :: Graph edge label -> (Vertex edge label -> Vertex edge label) -> Graph edge label
+editVertex graph@(Graph {vertices, focus}) vertexEditor =
+  graph {vertices = Map.adjust vertexEditor focus vertices}

src/Transducer.hs

@@ -5,30 +5,48 @@ module Transducer (
     , run
   ) where
 
+import Data.Map ((!), insert)
+import Graph (Graph(..), Vertex(..), editVertex, follow, rewind, singleton, weave)
 import Stream (Stream(..), merge)
 import qualified Stream (empty)
-import Graph (Graph(..), Vertex(..), Zipper(..), editLabel, follow, open, rewind, singleton, weave)
 
 type Transducer input output = Graph input [output]
 
 empty :: Transducer input output
-empty = open $ singleton []
+empty = singleton []
 
-add :: Ord input => Transducer input output -> ([input], output) -> Transducer input output
+entry :: Ord input => Transducer input output -> ([input], output) -> Transducer input output
-add transducer (path, output) =
+entry transducer (path, output) =
-  rewind $ editLabel (weave transducer path) (output:)
+  rewind $ editVertex (weave transducer path) pushLabel
+  where
+    pushLabel vertex = vertex {label = output:(label vertex)}
 
-fromList :: Ord input => [([input], output)] -> Transducer input output
+loop :: Ord input => Transducer input output -> ([input], [input]) -> Transducer input output
+loop transducer ([], loopPath) =
+  case splitAt (length loopPath - 1) loopPath of
+    (_, []) -> transducer
+    (loopBegining, lastInput:_) ->
+      let end = weave transducer loopBegining in
+      rewind $
+        editVertex end $ tieKnot lastInput
+  where
+    tieKnot input vertex =
+      vertex {edges = insert input (focus transducer) $ edges vertex}
+loop transducer (prefix, loopPath) = loop (weave transducer prefix) ([], loopPath)
+
+fromList :: Ord input => [([input], Either [input] output)] -> Transducer input output
 fromList = foldl add empty
+  where
+    add transducer (path, Left loopPath) = loop transducer (path, loopPath)
+    add transducer (path, Right output) = entry transducer (path, output)
 
 run :: (Ord input, Eq output) => Transducer input output -> Stream input -> Stream output
-run transducer (Stream inputs) = foldl (\(Stream outputs) (input, stream) ->
+run transducer (Stream inputs) = foldl (\outputsStream (input, stream) ->
     case follow transducer input of
-      Nothing -> case context transducer of
+      Nothing -> Stream.empty
-        Top -> run (rewind transducer) stream
+      Just newState@(Graph {vertices, focus}) ->
-        _ -> Stream.empty
+        let emitted = Stream $ emit stream <$> label (vertices ! focus) in
-      Just newState@(Graph {focus}) ->
+        emitted `merge` outputsStream `merge` run newState stream
-        Stream ((emit stream <$> label focus) ++ outputs) `merge` run newState stream
   ) Stream.empty inputs
   where
     emit stream output = (output, run (rewind transducer) stream)