{-# LANGUAGE MonadComprehensions, MultiParamTypeClasses #-}
module Data.GraphViz.Algorithms
(
CanonicaliseOptions(..)
, defaultCanonOptions
, dotLikeOptions
, canonicalise
, canonicaliseOptions
, transitiveReduction
, transitiveReductionOptions
) where
import Data.GraphViz.Attributes.Complete (Attributes, defaultAttributeValue)
import Data.GraphViz.Attributes.Same
import Data.GraphViz.Internal.Util (bool)
import Data.GraphViz.Types
import Data.GraphViz.Types.Canonical
import Data.GraphViz.Types.Internal.Common
import Control.Arrow (first, second, (***))
import Control.Monad (unless)
import Control.Monad.State (State, execState, gets, modify)
import qualified Data.DList as DList
import qualified Data.Foldable as F
import Data.Function (on)
import Data.List (deleteBy, groupBy, partition, sortBy,
(\\))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
data CanonicaliseOptions = COpts {
CanonicaliseOptions -> Bool
edgesInClusters :: Bool
, CanonicaliseOptions -> Bool
groupAttributes :: Bool
}
deriving (CanonicaliseOptions -> CanonicaliseOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c/= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
== :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c== :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
Eq, Eq CanonicaliseOptions
CanonicaliseOptions -> CanonicaliseOptions -> Bool
CanonicaliseOptions -> CanonicaliseOptions -> Ordering
CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
$cmin :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
max :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
$cmax :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
>= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c>= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
> :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c> :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
<= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c<= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
< :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c< :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
compare :: CanonicaliseOptions -> CanonicaliseOptions -> Ordering
$ccompare :: CanonicaliseOptions -> CanonicaliseOptions -> Ordering
Ord, Int -> CanonicaliseOptions -> ShowS
[CanonicaliseOptions] -> ShowS
CanonicaliseOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CanonicaliseOptions] -> ShowS
$cshowList :: [CanonicaliseOptions] -> ShowS
show :: CanonicaliseOptions -> String
$cshow :: CanonicaliseOptions -> String
showsPrec :: Int -> CanonicaliseOptions -> ShowS
$cshowsPrec :: Int -> CanonicaliseOptions -> ShowS
Show, ReadPrec [CanonicaliseOptions]
ReadPrec CanonicaliseOptions
Int -> ReadS CanonicaliseOptions
ReadS [CanonicaliseOptions]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CanonicaliseOptions]
$creadListPrec :: ReadPrec [CanonicaliseOptions]
readPrec :: ReadPrec CanonicaliseOptions
$creadPrec :: ReadPrec CanonicaliseOptions
readList :: ReadS [CanonicaliseOptions]
$creadList :: ReadS [CanonicaliseOptions]
readsPrec :: Int -> ReadS CanonicaliseOptions
$creadsPrec :: Int -> ReadS CanonicaliseOptions
Read)
defaultCanonOptions :: CanonicaliseOptions
defaultCanonOptions :: CanonicaliseOptions
defaultCanonOptions = COpts { edgesInClusters :: Bool
edgesInClusters = Bool
True
, groupAttributes :: Bool
groupAttributes = Bool
True
}
dotLikeOptions :: CanonicaliseOptions
dotLikeOptions :: CanonicaliseOptions
dotLikeOptions = COpts { edgesInClusters :: Bool
edgesInClusters = Bool
True
, groupAttributes :: Bool
groupAttributes = Bool
False
}
canonicalise :: (DotRepr dg n) => dg n -> DotGraph n
canonicalise :: forall (dg :: * -> *) n. DotRepr dg n => dg n -> DotGraph n
canonicalise = forall (dg :: * -> *) n.
DotRepr dg n =>
CanonicaliseOptions -> dg n -> DotGraph n
canonicaliseOptions CanonicaliseOptions
defaultCanonOptions
canonicaliseOptions :: (DotRepr dg n) => CanonicaliseOptions
-> dg n -> DotGraph n
canonicaliseOptions :: forall (dg :: * -> *) n.
DotRepr dg n =>
CanonicaliseOptions -> dg n -> DotGraph n
canonicaliseOptions CanonicaliseOptions
opts dg n
dg = DotGraph n
cdg { strictGraph :: Bool
strictGraph = forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsStrict dg n
dg
, directedGraph :: Bool
directedGraph = forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsDirected dg n
dg
}
where
cdg :: DotGraph n
cdg = forall n.
Ord n =>
CanonicaliseOptions
-> Maybe GraphID
-> GlobalAttributes
-> ClusterLookup
-> NodeLookup n
-> [DotEdge n]
-> DotGraph n
createCanonical CanonicaliseOptions
opts (forall (dg :: * -> *) n. DotRepr dg n => dg n -> Maybe GraphID
getID dg n
dg) GlobalAttributes
gas ClusterLookup
cl NodeLookup n
nl [DotEdge n]
es
(GlobalAttributes
gas, ClusterLookup
cl) = forall (dg :: * -> *) n.
DotRepr dg n =>
dg n -> (GlobalAttributes, ClusterLookup)
graphStructureInformationClean dg n
dg
nl :: NodeLookup n
nl = forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> NodeLookup n
nodeInformationClean Bool
True dg n
dg
es :: [DotEdge n]
es = forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> [DotEdge n]
edgeInformationClean Bool
True dg n
dg
type NodePath n = ([Maybe GraphID], DotNode n)
type NodePaths n = [NodePath n]
type EdgeClusters n = Map (Maybe GraphID) [DotEdge n]
type EdgeLocations n = (EdgeClusters n, [DotEdge n])
data CanonControl n = CC { forall n. CanonControl n -> CanonicaliseOptions
cOpts :: !CanonicaliseOptions
, forall n. CanonControl n -> Bool
isGraph :: !Bool
, forall n. CanonControl n -> ClusterLookup
clusters :: !ClusterLookup
, forall n. CanonControl n -> EdgeLocations n
clustEs :: !(EdgeLocations n)
, forall n. CanonControl n -> Maybe GraphID
topID :: !(Maybe GraphID)
, forall n. CanonControl n -> Attributes
topAttrs :: !Attributes
}
createCanonical :: (Ord n) => CanonicaliseOptions -> Maybe GraphID -> GlobalAttributes
-> ClusterLookup -> NodeLookup n -> [DotEdge n] -> DotGraph n
createCanonical :: forall n.
Ord n =>
CanonicaliseOptions
-> Maybe GraphID
-> GlobalAttributes
-> ClusterLookup
-> NodeLookup n
-> [DotEdge n]
-> DotGraph n
createCanonical CanonicaliseOptions
opts Maybe GraphID
gid GlobalAttributes
gas ClusterLookup
cl NodeLookup n
nl [DotEdge n]
es = forall n. DotSubGraph n -> DotGraph n
promoteDSG forall a b. (a -> b) -> a -> b
$ forall n. CanonControl n -> NodePaths n -> DotSubGraph n
makeGrouping CanonControl n
cc [([Maybe GraphID], DotNode n)]
ns
where
nUnlook :: (n, (t a, Attributes)) -> ([a], DotNode n)
nUnlook (n
n,(t a
p,Attributes
as)) = (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t a
p, forall n. n -> Attributes -> DotNode n
DotNode n
n Attributes
as)
ns :: [([Maybe GraphID], DotNode n)]
ns = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => [a] -> [a] -> Ordering
compLists forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {t :: * -> *} {n} {a}.
Foldable t =>
(n, (t a, Attributes)) -> ([a], DotNode n)
nUnlook forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList NodeLookup n
nl
es' :: EdgeLocations n
es' = if CanonicaliseOptions -> Bool
edgesInClusters CanonicaliseOptions
opts
then forall n. Ord n => NodeLookup n -> [DotEdge n] -> EdgeLocations n
edgeClusters NodeLookup n
nl [DotEdge n]
es
else (forall k a. Map k a
Map.empty, [DotEdge n]
es)
cc :: CanonControl n
cc = CC { cOpts :: CanonicaliseOptions
cOpts = CanonicaliseOptions
opts
, isGraph :: Bool
isGraph = Bool
True
, clusters :: ClusterLookup
clusters = ClusterLookup
cl
, clustEs :: EdgeLocations n
clustEs = EdgeLocations n
es'
, topID :: Maybe GraphID
topID = Maybe GraphID
gid
, topAttrs :: Attributes
topAttrs = GlobalAttributes -> Attributes
attrs GlobalAttributes
gas
}
thisLevel :: NodePaths n -> (NodePaths n, [DotNode n])
thisLevel :: forall n. NodePaths n -> (NodePaths n, [DotNode n])
thisLevel = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
makeGrouping :: CanonControl n -> NodePaths n -> DotSubGraph n
makeGrouping :: forall n. CanonControl n -> NodePaths n -> DotSubGraph n
makeGrouping CanonControl n
cc NodePaths n
cns = DotSG { isCluster :: Bool
isCluster = Bool
True
, subGraphID :: Maybe GraphID
subGraphID = Maybe GraphID
cID
, subGraphStmts :: DotStatements n
subGraphStmts = DotStatements n
stmts
}
where
cID :: Maybe GraphID
cID | forall n. CanonControl n -> Bool
isGraph CanonControl n
cc = forall n. CanonControl n -> Maybe GraphID
topID CanonControl n
cc
| Bool
otherwise = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ NodePaths n
cns
(NodePaths n
nestedNs, [DotNode n]
ns) = forall n. NodePaths n -> (NodePaths n, [DotNode n])
thisLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a -> Bool -> a
bool (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a. [a] -> [a]
tail) forall a. a -> a
id (forall n. CanonControl n -> Bool
isGraph CanonControl n
cc)
forall a b. (a -> b) -> a -> b
$ NodePaths n
cns
es :: [DotEdge n]
es = forall a. a -> a -> Bool -> a
bool (forall a. a -> Maybe a -> a
fromMaybe [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Maybe GraphID
cID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a, b) -> b
snd (forall n. CanonControl n -> Bool
isGraph CanonControl n
cc)
forall a b. (a -> b) -> a -> b
$ forall n. CanonControl n -> EdgeLocations n
clustEs CanonControl n
cc
gas :: Attributes
gas | forall n. CanonControl n -> Bool
isGraph CanonControl n
cc = forall n. CanonControl n -> Attributes
topAttrs CanonControl n
cc
| Bool
otherwise = GlobalAttributes -> Attributes
attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall n. CanonControl n -> ClusterLookup
clusters CanonControl n
cc forall k a. Ord k => Map k a -> k -> a
Map.! Maybe GraphID
cID
subGs :: [DotSubGraph n]
subGs = forall a b. (a -> b) -> [a] -> [b]
map (forall n. CanonControl n -> NodePaths n -> DotSubGraph n
makeGrouping forall a b. (a -> b) -> a -> b
$ CanonControl n
cc { isGraph :: Bool
isGraph = Bool
False })
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst))
forall a b. (a -> b) -> a -> b
$ NodePaths n
nestedNs
stmts :: DotStatements n
stmts = forall n.
CanonicaliseOptions
-> Attributes -> DotStatements n -> DotStatements n
setGlobal (forall n. CanonControl n -> CanonicaliseOptions
cOpts CanonControl n
cc) Attributes
gas
forall a b. (a -> b) -> a -> b
$ DotStmts { attrStmts :: [GlobalAttributes]
attrStmts = []
, subGraphs :: [DotSubGraph n]
subGraphs = [DotSubGraph n]
subGs
, nodeStmts :: [DotNode n]
nodeStmts = [DotNode n]
ns
, edgeStmts :: [DotEdge n]
edgeStmts = [DotEdge n]
es
}
setGlobal :: CanonicaliseOptions
-> Attributes
-> DotStatements n
-> DotStatements n
setGlobal :: forall n.
CanonicaliseOptions
-> Attributes -> DotStatements n -> DotStatements n
setGlobal CanonicaliseOptions
opts Attributes
as DotStatements n
stmts = DotStatements n
stmts { attrStmts :: [GlobalAttributes]
attrStmts = [GlobalAttributes]
globs'
, subGraphs :: [DotSubGraph n]
subGraphs = [DotSubGraph n]
sgs'
, nodeStmts :: [DotNode n]
nodeStmts = [DotNode n]
ns'
, edgeStmts :: [DotEdge n]
edgeStmts = [DotEdge n]
es'
}
where
sgs :: [DotSubGraph n]
sgs = forall n. DotStatements n -> [DotSubGraph n]
subGraphs DotStatements n
stmts
sStmts :: [DotStatements n]
sStmts = forall a b. (a -> b) -> [a] -> [b]
map forall n. DotSubGraph n -> DotStatements n
subGraphStmts [DotSubGraph n]
sgs
ns :: [DotNode n]
ns = forall n. DotStatements n -> [DotNode n]
nodeStmts DotStatements n
stmts
es :: [DotEdge n]
es = forall n. DotStatements n -> [DotEdge n]
edgeStmts DotStatements n
stmts
sGlobs :: [(Attributes, Attributes, Attributes)]
sGlobs = forall a b. (a -> b) -> [a] -> [b]
map ([GlobalAttributes] -> (Attributes, Attributes, Attributes)
partitionGlobal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. DotStatements n -> [GlobalAttributes]
attrStmts) [DotStatements n]
sStmts
([Attributes]
sgas,[Attributes]
snas,[Attributes]
seas) = forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(Attributes, Attributes, Attributes)]
sGlobs
gas' :: Attributes
gas' = Attributes
as
nas' :: Attributes
nas' = forall n a.
CanonicaliseOptions
-> (DotStatements n -> [a])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
getCommonGlobs CanonicaliseOptions
opts forall n. DotStatements n -> [DotNode n]
nodeStmts [Attributes]
snas [DotStatements n]
sStmts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall n. DotNode n -> Attributes
nodeAttributes [DotNode n]
ns
eas' :: Attributes
eas' = forall n a.
CanonicaliseOptions
-> (DotStatements n -> [a])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
getCommonGlobs CanonicaliseOptions
opts forall n. DotStatements n -> [DotEdge n]
edgeStmts [Attributes]
seas [DotStatements n]
sStmts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall n. DotEdge n -> Attributes
edgeAttributes [DotEdge n]
es
globs' :: [GlobalAttributes]
globs' = [GlobalAttributes] -> [GlobalAttributes]
nonEmptyGAs [ Attributes -> GlobalAttributes
GraphAttrs Attributes
gas'
, Attributes -> GlobalAttributes
NodeAttrs Attributes
nas'
, Attributes -> GlobalAttributes
EdgeAttrs Attributes
eas'
]
ns' :: [DotNode n]
ns' = forall a b. (a -> b) -> [a] -> [b]
map (\DotNode n
dn -> DotNode n
dn { nodeAttributes :: Attributes
nodeAttributes = forall n. DotNode n -> Attributes
nodeAttributes DotNode n
dn forall a. Eq a => [a] -> [a] -> [a]
\\ Attributes
nas' }) [DotNode n]
ns
es' :: [DotEdge n]
es' = forall a b. (a -> b) -> [a] -> [b]
map (\DotEdge n
de -> DotEdge n
de { edgeAttributes :: Attributes
edgeAttributes = forall n. DotEdge n -> Attributes
edgeAttributes DotEdge n
de forall a. Eq a => [a] -> [a] -> [a]
\\ Attributes
eas' }) [DotEdge n]
es
sgas' :: [Attributes]
sgas' = Attributes -> [Attributes] -> [Attributes]
updateGraphGlobs Attributes
gas' [Attributes]
sgas
snas' :: [Attributes]
snas' = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Eq a => [a] -> [a] -> [a]
\\ Attributes
nas') [Attributes]
snas
seas' :: [Attributes]
seas' = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Eq a => [a] -> [a] -> [a]
\\ Attributes
eas') [Attributes]
seas
sGlobs' :: [(Attributes, Attributes, Attributes)]
sGlobs' = forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Attributes]
sgas' [Attributes]
snas' [Attributes]
seas'
sStmts' :: [DotStatements n]
sStmts' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ DotStatements n
sSt (Attributes, Attributes, Attributes)
sGl -> DotStatements n
sSt { attrStmts :: [GlobalAttributes]
attrStmts = [GlobalAttributes] -> [GlobalAttributes]
nonEmptyGAs forall a b. (a -> b) -> a -> b
$ (Attributes, Attributes, Attributes) -> [GlobalAttributes]
unPartitionGlobal (Attributes, Attributes, Attributes)
sGl })
[DotStatements n]
sStmts
[(Attributes, Attributes, Attributes)]
sGlobs'
sgs' :: [DotSubGraph n]
sgs' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ DotSubGraph n
sg DotStatements n
sSt -> DotSubGraph n
sg { subGraphStmts :: DotStatements n
subGraphStmts = DotStatements n
sSt }) [DotSubGraph n]
sgs [DotStatements n]
sStmts'
updateGraphGlobs :: Attributes -> [Attributes] -> [Attributes]
updateGraphGlobs :: Attributes -> [Attributes] -> [Attributes]
updateGraphGlobs Attributes
gas = forall a b. (a -> b) -> [a] -> [b]
map Attributes -> Attributes
go
where
gasS :: Set Attribute
gasS = forall a. Ord a => [a] -> Set a
Set.fromList Attributes
gas
override :: SAttrs
override = Attributes -> SAttrs
toSAttr forall a b. (a -> b) -> a -> b
$ Attributes -> Attributes
nonSameDefaults Attributes
gas
go :: Attributes -> Attributes
go = forall a. Set a -> [a]
Set.toList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Attribute
gasS)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SAttrs -> Set Attribute
unSameSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => Set a -> Set a -> Set a
`Set.union` SAttrs
override)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> SAttrs
toSAttr
nonSameDefaults :: Attributes -> Attributes
nonSameDefaults :: Attributes -> Attributes
nonSameDefaults = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ Attribute
a -> [ Attribute
a' | Attribute
a' <- Attribute -> Maybe Attribute
defaultAttributeValue Attribute
a, Attribute
a' forall a. Eq a => a -> a -> Bool
/= Attribute
a] )
getCommonGlobs :: CanonicaliseOptions
-> (DotStatements n -> [a])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
getCommonGlobs :: forall n a.
CanonicaliseOptions
-> (DotStatements n -> [a])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
getCommonGlobs CanonicaliseOptions
opts DotStatements n -> [a]
f [Attributes]
sas [DotStatements n]
stmts [Attributes]
as
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ CanonicaliseOptions -> Bool
groupAttributes CanonicaliseOptions
opts = []
| Bool
otherwise = case [Attributes]
sas' forall a. [a] -> [a] -> [a]
++ [Attributes]
as of
[] -> []
[Attributes
_] -> []
[Attributes]
as' -> forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a. Ord a => Set a -> Set a -> Set a
Set.intersection
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Ord a => [a] -> Set a
Set.fromList [Attributes]
as'
where
sas' :: [Attributes]
sas' = forall n a.
(DotStatements n -> [a])
-> [Attributes] -> [DotStatements n] -> [Attributes]
keepIfAny DotStatements n -> [a]
f [Attributes]
sas [DotStatements n]
stmts
keepIfAny :: (DotStatements n -> [a]) -> [Attributes] -> [DotStatements n]
-> [Attributes]
keepIfAny :: forall n a.
(DotStatements n -> [a])
-> [Attributes] -> [DotStatements n] -> [Attributes]
keepIfAny DotStatements n -> [a]
f [Attributes]
sas = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Attributes]
sas forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall n a. (DotStatements n -> [a]) -> DotStatements n -> Bool
hasAny DotStatements n -> [a]
f)
hasAny :: (DotStatements n -> [a]) -> DotStatements n -> Bool
hasAny :: forall n a. (DotStatements n -> [a]) -> DotStatements n -> Bool
hasAny DotStatements n -> [a]
f DotStatements n
ds = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ DotStatements n -> [a]
f DotStatements n
ds) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall n a. (DotStatements n -> [a]) -> DotStatements n -> Bool
hasAny DotStatements n -> [a]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. DotSubGraph n -> DotStatements n
subGraphStmts) (forall n. DotStatements n -> [DotSubGraph n]
subGraphs DotStatements n
ds)
promoteDSG :: DotSubGraph n -> DotGraph n
promoteDSG :: forall n. DotSubGraph n -> DotGraph n
promoteDSG DotSubGraph n
dsg = DotGraph { strictGraph :: Bool
strictGraph = forall a. HasCallStack => a
undefined
, directedGraph :: Bool
directedGraph = forall a. HasCallStack => a
undefined
, graphID :: Maybe GraphID
graphID = forall n. DotSubGraph n -> Maybe GraphID
subGraphID DotSubGraph n
dsg
, graphStatements :: DotStatements n
graphStatements = forall n. DotSubGraph n -> DotStatements n
subGraphStmts DotSubGraph n
dsg
}
compLists :: (Ord a) => [a] -> [a] -> Ordering
compLists :: forall a. Ord a => [a] -> [a] -> Ordering
compLists [] [] = Ordering
EQ
compLists [] [a]
_ = Ordering
GT
compLists [a]
_ [] = Ordering
LT
compLists (a
x:[a]
xs) (a
y:[a]
ys) = case forall a. Ord a => a -> a -> Ordering
compare a
x a
y of
Ordering
EQ -> forall a. Ord a => [a] -> [a] -> Ordering
compLists [a]
xs [a]
ys
Ordering
oth -> Ordering
oth
nonEmptyGAs :: [GlobalAttributes] -> [GlobalAttributes]
nonEmptyGAs :: [GlobalAttributes] -> [GlobalAttributes]
nonEmptyGAs = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalAttributes -> Attributes
attrs)
edgeClusters :: (Ord n) => NodeLookup n -> [DotEdge n]
-> EdgeLocations n
edgeClusters :: forall n. Ord n => NodeLookup n -> [DotEdge n] -> EdgeLocations n
edgeClusters NodeLookup n
nl = (forall {b'}. [([Maybe GraphID], b')] -> Map (Maybe GraphID) [b']
toM forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map DotEdge n -> ([Maybe GraphID], DotEdge n)
inClust
where
nl' :: Map n [Maybe GraphID]
nl' = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) NodeLookup n
nl
inClust :: DotEdge n -> ([Maybe GraphID], DotEdge n)
inClust de :: DotEdge n
de@(DotEdge n
n1 n
n2 Attributes
_) = (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) DotEdge n
de)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==))
forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (Map n [Maybe GraphID]
nl' forall k a. Ord k => Map k a -> k -> a
Map.! n
n1) (Map n [Maybe GraphID]
nl' forall k a. Ord k => Map k a -> k -> a
Map.! n
n2)
toM :: [([Maybe GraphID], b')] -> Map (Maybe GraphID) [b']
toM = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. DList a -> [a]
DList.toList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. DList a -> DList a -> DList a
DList.append)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> a
last forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. a -> DList a
DList.singleton)
transitiveReduction :: (DotRepr dg n) => dg n -> DotGraph n
transitiveReduction :: forall (dg :: * -> *) n. DotRepr dg n => dg n -> DotGraph n
transitiveReduction = forall (dg :: * -> *) n.
DotRepr dg n =>
CanonicaliseOptions -> dg n -> DotGraph n
transitiveReductionOptions CanonicaliseOptions
defaultCanonOptions
transitiveReductionOptions :: (DotRepr dg n) => CanonicaliseOptions
-> dg n -> DotGraph n
transitiveReductionOptions :: forall (dg :: * -> *) n.
DotRepr dg n =>
CanonicaliseOptions -> dg n -> DotGraph n
transitiveReductionOptions CanonicaliseOptions
opts dg n
dg = DotGraph n
cdg { strictGraph :: Bool
strictGraph = forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsStrict dg n
dg
, directedGraph :: Bool
directedGraph = forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsDirected dg n
dg
}
where
cdg :: DotGraph n
cdg = forall n.
Ord n =>
CanonicaliseOptions
-> Maybe GraphID
-> GlobalAttributes
-> ClusterLookup
-> NodeLookup n
-> [DotEdge n]
-> DotGraph n
createCanonical CanonicaliseOptions
opts (forall (dg :: * -> *) n. DotRepr dg n => dg n -> Maybe GraphID
getID dg n
dg) GlobalAttributes
gas ClusterLookup
cl NodeLookup n
nl [DotEdge n]
es'
(GlobalAttributes
gas, ClusterLookup
cl) = forall (dg :: * -> *) n.
DotRepr dg n =>
dg n -> (GlobalAttributes, ClusterLookup)
graphStructureInformationClean dg n
dg
nl :: NodeLookup n
nl = forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> NodeLookup n
nodeInformationClean Bool
True dg n
dg
es :: [DotEdge n]
es = forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> [DotEdge n]
edgeInformationClean Bool
True dg n
dg
es' :: [DotEdge n]
es' | forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsDirected dg n
dg = forall n. Ord n => [DotEdge n] -> [DotEdge n]
rmTransEdges [DotEdge n]
es
| Bool
otherwise = [DotEdge n]
es
rmTransEdges :: (Ord n) => [DotEdge n] -> [DotEdge n]
rmTransEdges :: forall n. Ord n => [DotEdge n] -> [DotEdge n]
rmTransEdges [] = []
rmTransEdges [DotEdge n]
es = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. TaggedValues n -> [TaggedEdge n]
outgoing) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems TagMap n
esM
where
tes :: [TaggedEdge n]
tes = forall n. [DotEdge n] -> [TaggedEdge n]
tagEdges [DotEdge n]
es
esMS :: StateT (TagMap n, TagSet) Identity ()
esMS = do forall n. Ord n => [TaggedEdge n] -> TagState n ()
edgeGraph [TaggedEdge n]
tes
[n]
ns <- forall n a. (TagMap n -> a) -> TagState n a
getsMap forall k a. Map k a -> [k]
Map.keys
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall n. Ord n => Int -> n -> TagState n ()
traverseTag Int
zeroTag) [n]
ns
esM :: TagMap n
esM = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState StateT (TagMap n, TagSet) Identity ()
esMS (forall k a. Map k a
Map.empty, forall a. Set a
Set.empty)
type Tag = Int
type TagSet = Set Int
type TaggedEdge n = (Tag, DotEdge n)
zeroTag :: Tag
zeroTag :: Int
zeroTag = Int
0
tagEdges :: [DotEdge n] -> [TaggedEdge n]
tagEdges :: forall n. [DotEdge n] -> [TaggedEdge n]
tagEdges = forall a b. [a] -> [b] -> [(a, b)]
zip [(forall a. Enum a => a -> a
succ Int
zeroTag)..]
data TaggedValues n = TV { forall n. TaggedValues n -> Bool
marked :: Bool
, forall n. TaggedValues n -> [TaggedEdge n]
incoming :: [TaggedEdge n]
, forall n. TaggedValues n -> [TaggedEdge n]
outgoing :: [TaggedEdge n]
}
deriving (TaggedValues n -> TaggedValues n -> Bool
forall n. Eq n => TaggedValues n -> TaggedValues n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TaggedValues n -> TaggedValues n -> Bool
$c/= :: forall n. Eq n => TaggedValues n -> TaggedValues n -> Bool
== :: TaggedValues n -> TaggedValues n -> Bool
$c== :: forall n. Eq n => TaggedValues n -> TaggedValues n -> Bool
Eq, TaggedValues n -> TaggedValues n -> Bool
TaggedValues n -> TaggedValues n -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {n}. Ord n => Eq (TaggedValues n)
forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
forall n. Ord n => TaggedValues n -> TaggedValues n -> Ordering
forall n.
Ord n =>
TaggedValues n -> TaggedValues n -> TaggedValues n
min :: TaggedValues n -> TaggedValues n -> TaggedValues n
$cmin :: forall n.
Ord n =>
TaggedValues n -> TaggedValues n -> TaggedValues n
max :: TaggedValues n -> TaggedValues n -> TaggedValues n
$cmax :: forall n.
Ord n =>
TaggedValues n -> TaggedValues n -> TaggedValues n
>= :: TaggedValues n -> TaggedValues n -> Bool
$c>= :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
> :: TaggedValues n -> TaggedValues n -> Bool
$c> :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
<= :: TaggedValues n -> TaggedValues n -> Bool
$c<= :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
< :: TaggedValues n -> TaggedValues n -> Bool
$c< :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
compare :: TaggedValues n -> TaggedValues n -> Ordering
$ccompare :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Ordering
Ord, Int -> TaggedValues n -> ShowS
forall n. Show n => Int -> TaggedValues n -> ShowS
forall n. Show n => [TaggedValues n] -> ShowS
forall n. Show n => TaggedValues n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TaggedValues n] -> ShowS
$cshowList :: forall n. Show n => [TaggedValues n] -> ShowS
show :: TaggedValues n -> String
$cshow :: forall n. Show n => TaggedValues n -> String
showsPrec :: Int -> TaggedValues n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> TaggedValues n -> ShowS
Show, ReadPrec [TaggedValues n]
ReadPrec (TaggedValues n)
ReadS [TaggedValues n]
forall n. Read n => ReadPrec [TaggedValues n]
forall n. Read n => ReadPrec (TaggedValues n)
forall n. Read n => Int -> ReadS (TaggedValues n)
forall n. Read n => ReadS [TaggedValues n]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TaggedValues n]
$creadListPrec :: forall n. Read n => ReadPrec [TaggedValues n]
readPrec :: ReadPrec (TaggedValues n)
$creadPrec :: forall n. Read n => ReadPrec (TaggedValues n)
readList :: ReadS [TaggedValues n]
$creadList :: forall n. Read n => ReadS [TaggedValues n]
readsPrec :: Int -> ReadS (TaggedValues n)
$creadsPrec :: forall n. Read n => Int -> ReadS (TaggedValues n)
Read)
defTV :: TaggedValues n
defTV :: forall n. TaggedValues n
defTV = forall n.
Bool -> [TaggedEdge n] -> [TaggedEdge n] -> TaggedValues n
TV Bool
False [] []
type TagMap n = Map n (TaggedValues n)
type TagState n a = State (TagMap n, TagSet) a
getMap :: TagState n (TagMap n)
getMap :: forall n. TagState n (TagMap n)
getMap = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> a
fst
getsMap :: (TagMap n -> a) -> TagState n a
getsMap :: forall n a. (TagMap n -> a) -> TagState n a
getsMap TagMap n -> a
f = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (TagMap n -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
modifyMap :: (TagMap n -> TagMap n) -> TagState n ()
modifyMap :: forall n. (TagMap n -> TagMap n) -> TagState n ()
modifyMap TagMap n -> TagMap n
f = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first TagMap n -> TagMap n
f)
getSet :: TagState n TagSet
getSet :: forall n. TagState n TagSet
getSet = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> b
snd
modifySet :: (TagSet -> TagSet) -> TagState n ()
modifySet :: forall n. (TagSet -> TagSet) -> TagState n ()
modifySet TagSet -> TagSet
f = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second TagSet -> TagSet
f)
edgeGraph :: (Ord n) => [TaggedEdge n] -> TagState n ()
edgeGraph :: forall n. Ord n => [TaggedEdge n] -> TagState n ()
edgeGraph = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {n}.
Ord n =>
TaggedEdge n -> StateT (TagMap n, TagSet) Identity ()
addEdge forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
where
addEdge :: TaggedEdge n -> StateT (TagMap n, TagSet) Identity ()
addEdge TaggedEdge n
te = forall {n}. Ord n => n -> TaggedValues n -> TagState n ()
addVal n
f TaggedValues n
tvOut forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {n}. Ord n => n -> TaggedValues n -> TagState n ()
addVal n
t TaggedValues n
tvIn
where
e :: DotEdge n
e = forall a b. (a, b) -> b
snd TaggedEdge n
te
f :: n
f = forall n. DotEdge n -> n
fromNode DotEdge n
e
t :: n
t = forall n. DotEdge n -> n
toNode DotEdge n
e
addVal :: n -> TaggedValues n -> TagState n ()
addVal n
n TaggedValues n
tv = forall n. (TagMap n -> TagMap n) -> TagState n ()
modifyMap (forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall {n}. TaggedValues n -> TaggedValues n -> TaggedValues n
mergeTV n
n TaggedValues n
tv)
tvIn :: TaggedValues n
tvIn = forall n. TaggedValues n
defTV { incoming :: [TaggedEdge n]
incoming = [TaggedEdge n
te] }
tvOut :: TaggedValues n
tvOut = forall n. TaggedValues n
defTV { outgoing :: [TaggedEdge n]
outgoing = [TaggedEdge n
te] }
mergeTV :: TaggedValues n -> TaggedValues n -> TaggedValues n
mergeTV TaggedValues n
tvNew TaggedValues n
tv = TaggedValues n
tv { incoming :: [TaggedEdge n]
incoming = forall n. TaggedValues n -> [TaggedEdge n]
incoming TaggedValues n
tvNew forall a. [a] -> [a] -> [a]
++ forall n. TaggedValues n -> [TaggedEdge n]
incoming TaggedValues n
tv
, outgoing :: [TaggedEdge n]
outgoing = forall n. TaggedValues n -> [TaggedEdge n]
outgoing TaggedValues n
tvNew forall a. [a] -> [a] -> [a]
++ forall n. TaggedValues n -> [TaggedEdge n]
outgoing TaggedValues n
tv
}
traverseTag :: (Ord n) => Tag -> n -> TagState n ()
traverseTag :: forall n. Ord n => Int -> n -> TagState n ()
traverseTag Int
t n
n = do Bool -> TagState n ()
setMark Bool
True
TagState n ()
checkIncoming
[TaggedEdge n]
outEs <- forall n a. (TagMap n -> a) -> TagState n a
getsMap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall n. TaggedValues n -> [TaggedEdge n]
outgoing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
n)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {n}.
Ord n =>
TaggedEdge n -> StateT (TagMap n, TagSet) Identity ()
maybeRecurse [TaggedEdge n]
outEs
Bool -> TagState n ()
setMark Bool
False
where
setMark :: Bool -> TagState n ()
setMark Bool
mrk = forall n. (TagMap n -> TagMap n) -> TagState n ()
modifyMap (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\TaggedValues n
tv -> TaggedValues n
tv { marked :: Bool
marked = Bool
mrk }) n
n)
isMarked :: Map k (TaggedValues n) -> k -> Bool
isMarked Map k (TaggedValues n)
m k
n' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False forall n. TaggedValues n -> Bool
marked forall a b. (a -> b) -> a -> b
$ k
n' forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map k (TaggedValues n)
m
checkIncoming :: TagState n ()
checkIncoming = do TagMap n
m <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> a
fst
let es :: [TaggedEdge n]
es = forall n. TaggedValues n -> [TaggedEdge n]
incoming forall a b. (a -> b) -> a -> b
$ TagMap n
m forall k a. Ord k => Map k a -> k -> a
Map.! n
n
([TaggedEdge n]
keepEs, [TaggedEdge n]
delEs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall {k} {n}.
Ord k =>
Map k (TaggedValues n) -> (Int, DotEdge k) -> Bool
keepEdge TagMap n
m) [TaggedEdge n]
es
forall n. (TagMap n -> TagMap n) -> TagState n ()
modifyMap (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\TaggedValues n
tv -> TaggedValues n
tv {incoming :: [TaggedEdge n]
incoming = [TaggedEdge n]
keepEs}) n
n)
forall n. (TagSet -> TagSet) -> TagState n ()
modifySet (forall a. Ord a => Set a -> Set a -> Set a
Set.union forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [TaggedEdge n]
delEs))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {n}.
Ord n =>
TaggedEdge n -> StateT (TagMap n, TagSet) Identity ()
delOtherEdge [TaggedEdge n]
delEs
where
keepEdge :: Map k (TaggedValues n) -> (Int, DotEdge k) -> Bool
keepEdge Map k (TaggedValues n)
m (Int
t',DotEdge k
e) = Int
t forall a. Eq a => a -> a -> Bool
== Int
t' Bool -> Bool -> Bool
|| Bool -> Bool
not (forall {k} {n}. Ord k => Map k (TaggedValues n) -> k -> Bool
isMarked Map k (TaggedValues n)
m forall a b. (a -> b) -> a -> b
$ forall n. DotEdge n -> n
fromNode DotEdge k
e)
delOtherEdge :: TaggedEdge n -> TagState n ()
delOtherEdge TaggedEdge n
te = forall n. (TagMap n -> TagMap n) -> TagState n ()
modifyMap (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust TaggedValues n -> TaggedValues n
delE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. DotEdge n -> n
fromNode forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd TaggedEdge n
te)
where
delE :: TaggedValues n -> TaggedValues n
delE TaggedValues n
tv = TaggedValues n
tv {outgoing :: [TaggedEdge n]
outgoing = forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) TaggedEdge n
te forall a b. (a -> b) -> a -> b
$ forall n. TaggedValues n -> [TaggedEdge n]
outgoing TaggedValues n
tv}
maybeRecurse :: (Int, DotEdge n) -> StateT (TagMap n, TagSet) Identity ()
maybeRecurse (Int
t',DotEdge n
e) = do TagMap n
m <- forall n. TagState n (TagMap n)
getMap
TagSet
delSet <- forall n. TagState n TagSet
getSet
let n' :: n
n' = forall n. DotEdge n -> n
toNode DotEdge n
e
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall {k} {n}. Ord k => Map k (TaggedValues n) -> k -> Bool
isMarked TagMap n
m n
n' Bool -> Bool -> Bool
|| Int
t' forall a. Ord a => a -> Set a -> Bool
`Set.member` TagSet
delSet)
forall a b. (a -> b) -> a -> b
$ forall n. Ord n => Int -> n -> TagState n ()
traverseTag Int
t' n
n'