From 5954c12c30a989cc484b337f581e9375da62b60d Mon Sep 17 00:00:00 2001 From: Tissevert Date: Thu, 9 May 2019 17:14:56 +0200 Subject: [PATCH] Reimplementing Graph as an adjacency matrix and adding loops on transducers --- src/Graph.hs | 125 ++++++++++++++++++++++------------------------ src/Transducer.hs | 42 +++++++++++----- 2 files changed, 89 insertions(+), 78 deletions(-) diff --git a/src/Graph.hs b/src/Graph.hs index 1acbfef..09a2f7d 100644 --- a/src/Graph.hs +++ b/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} -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 {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 - } +singleton :: label -> Graph edge label +singleton label = Graph { + vertices = Map.singleton 0 $ vertex label + , focus = 0 + , root = 0 } -weave :: (Monoid label, Ord edge) => Graph edge label -> [edge] -> Graph edge label -weave = foldl $ \graph edge -> +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@(Graph {vertices, focus}) edge = + Map.lookup edge (edges $ vertices ! focus) >>= \vertexID -> Just $ graph { + focus = vertexID + } + +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} diff --git a/src/Transducer.hs b/src/Transducer.hs index a6f26d6..1d00a51 100644 --- a/src/Transducer.hs +++ b/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 -add transducer (path, output) = - rewind $ editLabel (weave transducer path) (output:) +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)} -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 - Top -> run (rewind transducer) stream - _ -> Stream.empty - Just newState@(Graph {focus}) -> - Stream ((emit stream <$> label focus) ++ outputs) `merge` run newState stream + Nothing -> Stream.empty + Just newState@(Graph {vertices, focus}) -> + let emitted = Stream $ emit stream <$> label (vertices ! focus) in + emitted `merge` outputsStream `merge` run newState stream ) Stream.empty inputs where emit stream output = (output, run (rewind transducer) stream)