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