Clarify a mapping over a Maybe for clearer syntax

src/Graph.hs

@@ -3,93 +3,86 @@
 module Graph (
       Graph(..)
     , Vertex(..)
-    , Zipper(..)
-    , editLabel
+    , editVertex
     , follow
-    , open
     , rewind
     , singleton
+    , stitch
     , weave
   ) where
 
-import Data.Map (Map)
-import qualified Data.Map as Map (delete, empty, insert, lookup, toList)
+import Data.Map ((!), Map)
+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)
-  } 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)
+    , edges :: Map edge VertexID
   } deriving (Functor, Show)
 
 data Graph edge label = Graph {
-      focus :: Vertex edge label
-    , context :: Zipper edge label
+      vertices :: Map VertexID (Vertex edge label)
+    , focus :: VertexID
+    , root :: VertexID
   } deriving (Functor, Show)
 
-instance (Ord edge, Show edge) => Tree (Graph edge) where
-  getStructure = getStructure . zipUp
+getStructureWithoutLoop :: Show edge => Set VertexID -> Graph edge String -> Structure
+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
-open focus = Graph {focus, context = Top}
+instance Show edge => Tree (Graph edge) where
+  getStructure graph = 
+    getStructureWithoutLoop (Set.singleton $ root graph) (rewind graph)
 
-zipUp :: Ord edge => Graph edge label -> Vertex edge label
-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
-          }
+vertex :: label -> Vertex edge label
+vertex label = Vertex {label, edges = Map.empty}
+
+singleton :: label -> Graph edge label
+singleton label = Graph {
+      vertices = Map.singleton 0 $ vertex label
+    , focus = 0
+    , root = 0
   }
 
-rewind :: Ord edge => Graph edge label -> Graph edge label
-rewind = open . zipUp
+rewind :: Graph edge label -> Graph edge label
+rewind graph = graph {focus = root graph}
 
 follow :: Ord edge => Graph edge label -> edge -> Maybe (Graph edge label)
-follow (Graph {focus, context}) edge =
-  Map.lookup edge (edges focus) >>= \vertex -> Just $ Graph {
-      focus = vertex
-    , context = Zipper {
-          origin = context
-        , from = label $ focus
-        , by = edge
-        , siblingEdges = Map.delete edge $ edges focus
-      }
-  }
+follow graph@(Graph {vertices, focus}) edge =
+  setFocus <$> Map.lookup edge (edges $ vertices ! focus)
+  where
+    setFocus vertexID = graph {focus = vertexID}
 
-weave :: (Monoid label, Ord edge) => Graph edge label -> [edge] -> Graph edge label
-weave = foldl $ \graph edge ->
+stitch :: (Monoid label, Ord edge) => Graph edge label -> edge -> Graph edge label
+stitch 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
-          }
+    Nothing ->
+      let newVertexID = Map.size $ vertices graph in
+      let link aVertex = aVertex {edges = Map.insert edge newVertexID $ edges aVertex} in
+      graph {
+          vertices =
+            Map.adjust link (focus graph) . Map.insert newVertexID (vertex mempty) $ vertices graph
+        , focus = newVertexID
       }
     Just newGraph -> newGraph
 
-editLabel :: Graph edge label -> (label -> label) -> Graph edge label
-editLabel graph@(Graph {focus}) labelEditor =
-  graph {focus = focus {label = labelEditor $ label focus}}
+weave :: (Monoid label, Ord edge) => Graph edge label -> [edge] -> Graph edge label
+weave = foldl stitch
+
+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/Stream.hs

@@ -16,6 +16,7 @@ instance Functor Stream where
     Stream $ (\(a, stream) -> (f a, fmap f stream)) <$> pairs
 
 instance Tree Stream where
+  getStructure (Stream []) = Leaf
   getStructure (Stream pairs) =
     Node $ (\(s, stream) -> (s, getStructure stream)) <$> pairs
 

src/Transducer.hs

@@ -5,30 +5,59 @@ 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]
+newtype Stack a = Stack [a]
+
+push :: a -> Stack a -> Stack a
+push a (Stack s) = Stack (a:s)
+
+content :: Stack a -> [a]
+content (Stack s) = reverse s
 
 empty :: Transducer input output
-empty = open $ singleton []
+empty = singleton []
 
-add :: Ord input => Transducer input output -> ([input], output) -> Transducer input output
-add transducer (path, output) =
-  rewind $ editLabel (weave transducer path) (output:)
-
-fromList :: Ord input => [([input], output)] -> Transducer input output
-fromList = foldl add empty
-
-run :: (Ord input, Eq output) => Transducer input output -> Stream input -> Stream output
-run transducer (Stream inputs) = foldl (\(Stream outputs) (input, stream) ->
-    case follow transducer input of
-      Nothing -> case context transducer of
-        Top -> run (rewind transducer) stream
-        _ -> Stream.empty
-      Just newState@(Graph {focus}) ->
-        Stream ((emit stream <$> label focus) ++ outputs) `merge` run newState stream
-  ) Stream.empty inputs
+entry :: Ord input => Transducer input output -> ([input], output) -> Transducer input output
+entry transducer (path, output) =
+  rewind $ editVertex (weave transducer path) pushLabel
   where
-    emit stream output = (output, run (rewind transducer) stream)
+    pushLabel vertex = vertex {label = output:(label vertex)}
+
+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 ([input], output)
+run transducer = runWithStack initState
+  where
+    initState = (transducer, Stack [])
+    emit stack stream output = ((content stack, output), runWithStack initState stream)
+    runWithStack (state, stack) (Stream inputs) = foldl (\outputsStream (input, stream) ->
+        case follow state input of
+          Nothing -> Stream.empty
+          Just newState@(Graph {vertices, focus}) ->
+            let newStack = push input stack in
+            let emitted = Stream $ emit newStack stream <$> label (vertices ! focus) in
+            let continue = runWithStack (newState, newStack) stream in
+            emitted `merge` continue `merge` outputsStream
+      ) Stream.empty inputs

src/Tree.hs

@@ -3,7 +3,7 @@ module Tree (
     , Structure(..)
   ) where
 
-data Structure = Node [(String, Structure)]
+data Structure = Leaf | Node [(String, Structure)]
 
 class Functor a => Tree a where
   getStructure :: a String -> Structure
@@ -12,7 +12,8 @@ class Functor a => Tree a where
   draw = unlines . getLines . getStructure . fmap show
 
 getLines :: Structure -> [String]
-getLines (Node []) = ["╼"]
+getLines Leaf = ["╼"]
+getLines (Node []) = [""]
 getLines (Node [(s, structure)]) = showBlock '─' (s, structure)
 getLines (Node ((s, structure):pairs)) = concat $
   showBlock '┬' (s, structure) : showBlocks pairs