src/Graph.hs

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

src/Stream.hs

@@ -16,7 +16,6 @@ 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,59 +5,30 @@ 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 = singleton []
+empty = open $ singleton []
 
-entry :: Ord input => Transducer input output -> ([input], output) -> Transducer input output
-entry transducer (path, output) =
-  rewind $ editVertex (weave transducer path) pushLabel
-  where
-    pushLabel vertex = vertex {label = output:(label vertex)}
+add :: Ord input => Transducer input output -> ([input], output) -> Transducer input output
+add transducer (path, output) =
+  rewind $ editLabel (weave transducer path) (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 :: Ord input => [([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
+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
   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
+    emit stream output = (output, run (rewind transducer) stream)

src/Tree.hs

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