diff --git a/src/MA/Dot.hs b/src/MA/Dot.hs index f37f2a01aa3b76cdeb47e7a20014aa1825c8446c..b11b3c1029b73de20da4633b35a5f68adbcd0b67 100644 --- a/src/MA/Dot.hs +++ b/src/MA/Dot.hs @@ -20,20 +20,67 @@ import qualified Data.MorphismEncoding as Encoding import MA.Coalgebra.Parser (SymbolTable(..)) import MA.FunctorExpression.Sorts (Sort, Sorted(..)) import MA.PrettyShow +import Data.Partition (Partition) +import qualified Data.Partition as Part -printDot :: (PrettyShow label, PrettyShow h1) => SymbolTable -> Encoding label (Sorted h1) -> IO () -printDot symbolTable = LazyIO.putStr . Build.toLazyText . dot symbolTable +printDot :: + (PrettyShow label, PrettyShow h1) + => SymbolTable + -> Encoding label (Sorted h1) + -> Maybe Partition + -> IO () +printDot symbolTable encoding maybePartition = + LazyIO.putStr (Build.toLazyText (dot symbolTable encoding maybePartition)) -writeDot :: (PrettyShow label, PrettyShow h1) => FilePath -> SymbolTable -> Encoding label (Sorted h1) -> IO () -writeDot file symbolTable = LazyIO.writeFile file . Build.toLazyText . dot symbolTable +writeDot :: + (PrettyShow label, PrettyShow h1) + => FilePath + -> SymbolTable + -> Encoding label (Sorted h1) + -> Maybe Partition + -> IO () +writeDot file symbolTable encoding maybePartition = + (LazyIO.writeFile + file + (Build.toLazyText (dot symbolTable encoding maybePartition))) -dot :: (PrettyShow label, PrettyShow h1) => SymbolTable -> Encoding label (Sorted h1) -> Builder -dot symbolTable encoding = - "digraph {\n" <> nodes symbolTable (Encoding.structure encoding) <> - transitions (Encoding.edges encoding) <> "}\n" +dot :: + (PrettyShow label, PrettyShow h1) + => SymbolTable + -> Encoding label (Sorted h1) + -> Maybe Partition + -> Builder +dot symbolTable encoding maybePartition = + let clusters = + case maybePartition of + Nothing -> + nodes + symbolTable + (Encoding.structure encoding) + (Encoding.states encoding) + Just partition -> + foldMap + (uncurry (cluster symbolTable (Encoding.structure encoding))) + (zip [0..] (Part.toBlocks partition)) + in "digraph {\n" <> " compound=true;\n" <> clusters <> + transitions (Encoding.edges encoding) <> + "}\n" -nodes :: PrettyShow h1 => SymbolTable -> Vector (Sorted h1) -> Builder -nodes symbolTable = V.ifoldl (\s i n -> s <> node i (getSymbol i) n <> "\n") "" +cluster :: + PrettyShow h1 + => SymbolTable + -> Vector (Sorted h1) + -> Int + -> [Int] + -> Builder +cluster symbolTable structure block states = + "subgraph cluster" <> Build.decimal block <> " {\n" <> + nodes symbolTable structure states <> + "}\n" + +nodes :: PrettyShow h1 => SymbolTable -> Vector (Sorted h1) -> [Int] -> Builder +nodes symbolTable structure = + foldMap (\i -> node i (getSymbol i) (structure V.! i) <> "\n") where getSymbol i = HM.lookup i (fromSymbolTable symbolTable) diff --git a/src/main/Main.hs b/src/main/Main.hs index 6425e7672a1daa0e34d68cf85ee78c347b325496..f292b36afad956f04ebf91bff059b92504759eae 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -126,6 +126,7 @@ data GraphOptions = GraphOptions { graphInputFile :: Maybe FilePath , graphOutputFile :: Maybe FilePath , graphFunctor :: Maybe (FunctorExpression SomeFunctor Sort) + , graphDrawPartition :: Bool } graphHelp :: Doc AnsiStyle @@ -165,8 +166,13 @@ graphOptions = do (option functorReader (long "functor" <> short 'f' <> metavar "FUNCTOR_EXPR" <> - help "Functor for the input coalgebra. This is normally the first line of \ + help + "Functor for the input coalgebra. This is normally the first line of \ \the input, but can also alternatively be given here.")) + graphDrawPartition <- + switch + (long "draw-partition" <> short 'P' <> + help "Calculate partition (see refine) and group nodes accordingly.") pure GraphOptions {..} functorReader :: ReadM (FunctorExpression SomeFunctor Sort) @@ -296,15 +302,20 @@ main = do finalizeStats stats (GraphCommand r) -> do - (_, (symbolTable, encoding)) <- do + (f, (symbolTable, encoding)) <- do readCoalgebra (graphFunctor r) (graphInputFile r) >>= \case Left err -> hPutStrLn stderr err >> exitFailure Right res -> evaluate $ res + part <- + if graphDrawPartition r + then (Just <$> stToIO (refine f encoding)) + else return Nothing + case graphOutputFile r of - Nothing -> printDot symbolTable encoding - Just "-" -> printDot symbolTable encoding - Just file -> writeDot file symbolTable encoding + Nothing -> printDot symbolTable encoding part + Just "-" -> printDot symbolTable encoding part + Just file -> writeDot file symbolTable encoding part printHelp :: HelpCommand -> IO () printHelp HelpListFunctors =