diff --git a/src/Search/EpsilonElimination.hs b/src/Search/EpsilonElimination.hs index 84ef7c6ebcdfb1d0925fd4a0daff967483f0cf95..11771d22d47f3f6c95fbd6df597e2b416d9e779b 100644 --- a/src/Search/EpsilonElimination.hs +++ b/src/Search/EpsilonElimination.hs @@ -80,8 +80,10 @@ removeUnreachableNodes start graph = S.foldr M.delete graph unreachable where - getReachable visited node = - S.foldr (\succ visited' -> getReachable visited' succ) (S.insert node visited) (successors node) + getReachable visited node + | node `S.member` visited = visited + | otherwise = + S.foldr (\succ visited' -> getReachable visited' succ) (S.insert node visited) (successors node) successors node = S.map edgeTo $ graph M.! node -- | Return true iff the edge is an ɛ-transition diff --git a/src/Search/Search2.hs b/src/Search/Search2.hs index 148207ba9ca43207f59c0b8f4dac61a383252cbc..07840d86d47c419294a3d141fc6fcf3ef24f2230 100644 --- a/src/Search/Search2.hs +++ b/src/Search/Search2.hs @@ -10,7 +10,6 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import Data.Monoid -import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -24,6 +23,7 @@ import Data.Aeson import Protocol import Search.Types +import Search.EpsilonElimination type DecisionNumber = Int type Decision = (Vertex, DecisionNumber) @@ -86,7 +86,7 @@ driver' prog startVertex = do findOpenDecision <$> readIORef state >>= \case Nothing -> do s <- readIORef state - T.putStrLn (graph2Dot (graph s)) + T.putStrLn (graph2Dot (eliminateEpsilons startVertex $ graph s)) exitSuccess Just trace -> oneProgRun prog state (Just $ reverse trace) diff --git a/test/Search/EpsilonEliminationSpec.hs b/test/Search/EpsilonEliminationSpec.hs index 25f7b324dec5b8956988ba84bffbc3f71c4d0d09..e68691dda1dd25b4f3ceaa0a95d4033ac95a263e 100644 --- a/test/Search/EpsilonEliminationSpec.hs +++ b/test/Search/EpsilonEliminationSpec.hs @@ -23,6 +23,37 @@ spec = do describe "removeEpsilonEdges" removeEpsilonEdgesSpec describe "removeUnreachableNodes" removeUnreachableNodesSpec +eliminateEpsilonsSpec :: Spec +eliminateEpsilonsSpec = do + it "Does nothing without epsilon transitions" $ + let graph = mkGraph [ ("A", edges [(Just "a", "B"), (Just "c", "C")]) + , ("B", edges [(Just "b", "C")]) + , ("C", []) + ] + in eliminateEpsilons (mkVertex "A") graph `shouldBe` graph + + it "Correctly transforms a graph in the presence of epsilon transitions" $ + let + graph1 = mkGraph [ ("A", edges [(Nothing, "B"), (Just "c", "C")]) + , ("B", edges [(Just "b", "C")]) + , ("C", []) + ] + graph2 = mkGraph [ ("A", edges [(Just "b", "C"), (Just "c", "C")]) + , ("C", []) + ] + in eliminateEpsilons (mkVertex "A") graph1 `shouldBe` graph2 + + it "Works on cyclic graphs" $ + let + graph1 = mkGraph [ ("A", edges [(Nothing, "B"), (Just "c", "C")]) + , ("B", edges [(Just "b", "C")]) + , ("C", edges [(Just "d", "A")]) + ] + graph2 = mkGraph [ ("A", edges [(Just "b", "C"), (Just "c", "C")]) + , ("C", edges [(Just "d", "A")]) + ] + in eliminateEpsilons (mkVertex "A") graph1 `shouldBe` graph2 + epsilonClosureSpec :: Spec epsilonClosureSpec = do it "Returns the identity map for a graph without epsilons" $ @@ -49,26 +80,18 @@ epsilonClosureSpec = do ] in epsilonClosure graph `shouldBe` closureMap - -eliminateEpsilonsSpec :: Spec -eliminateEpsilonsSpec = do - it "Does nothing without epsilon transitions" $ - let graph = mkGraph [ ("A", edges [(Just "a", "B"), (Just "c", "C")]) - , ("B", edges [(Just "b", "C")]) - , ("C", []) - ] - in eliminateEpsilons (mkVertex "A") graph `shouldBe` graph - - it "Correctly transforms a graph in the presence of epsilon transitions" $ + it "works on cyclic graphs" $ let - graph1 = mkGraph [ ("A", edges [(Nothing, "B"), (Just "c", "C")]) - , ("B", edges [(Just "b", "C")]) - , ("C", []) - ] - graph2 = mkGraph [ ("A", edges [(Just "b", "C"), (Just "c", "C")]) - , ("C", []) - ] - in eliminateEpsilons (mkVertex "A") graph1 `shouldBe` graph2 + graph = mkGraph [ ("A", edges [(Nothing, "B"), (Just "c", "C")]) + , ("B", edges [(Just "c", "C")]) + , ("C", edges [(Just "d", "A")]) + ] + closureMap = mkClosure [ ("A", ["A", "B"]) + , ("B", ["B"]) + , ("C", ["C"]) + ] + in epsilonClosure graph `shouldBe` closureMap + addTransitiveEdgesSpec :: Spec addTransitiveEdgesSpec = do @@ -101,6 +124,22 @@ addTransitiveEdgesSpec = do in addTransitiveEdges graph1 closureMap `shouldBe` graph2 + it "works on cyclic graphs" $ + let + graph1 = mkGraph [ ("A", edges [(Nothing, "B"), (Just "c", "C")]) + , ("B", edges [(Just "b", "C")]) + , ("C", edges [(Just "d", "A")]) + ] + graph2 = mkGraph [ ("A", edges [(Nothing, "B"), (Just "b", "C"), (Just "c", "C")]) + , ("B", edges [(Just "b", "C")]) + , ("C", edges [(Just "d", "A")]) + ] + closureMap = mkClosure [ ("A", ["A", "B"]) + , ("B", ["B"]) + , ("C", ["C"]) + ] + in addTransitiveEdges graph1 closureMap `shouldBe` graph2 + removeEpsilonEdgesSpec :: Spec removeEpsilonEdgesSpec = do it "does nothing without epsilon transitions" $ @@ -125,6 +164,18 @@ removeEpsilonEdgesSpec = do in removeEpsilonEdges graph1 `shouldBe` graph2 + it "works on cyclic graphs" $ + let + graph1 = mkGraph [ ("A", edges [(Nothing, "B"), (Just "c", "C")]) + , ("B", edges [(Nothing, "C")]) + , ("C", edges [(Just "d", "A")]) + ] + graph2 = mkGraph [ ("A", edges [(Just "c", "C")]) + , ("B", edges []) + , ("C", edges [(Just "d", "A")]) + ] + in + removeEpsilonEdges graph1 `shouldBe` graph2 removeUnreachableNodesSpec :: Spec removeUnreachableNodesSpec = do @@ -149,6 +200,18 @@ removeUnreachableNodesSpec = do in removeUnreachableNodes (mkVertex "A") graph1 `shouldBe` graph2 + it "works on cyclic graphs" $ + let + graph1 = mkGraph [ ("A", edges [(Just "c", "C")]) + , ("B", edges [(Just "b", "C")]) + , ("C", edges [(Just "a", "A")]) + ] + graph2 = mkGraph [ ("A", edges [(Just "c", "C")]) + , ("C", edges [(Just "a", "A")]) + ] + in + removeUnreachableNodes (mkVertex "A") graph1 `shouldBe` graph2 + mkGraph :: [(Text, [Edge])] -> Graph mkGraph = M.fromList . map (\(v, es) -> (mkVertex v, S.fromList es))