module Data.GraphViz.Algorithms
(
CanonicaliseOptions(..)
, defaultCanonOptions
, dotLikeOptions
, canonicalise
, canonicaliseOptions
, transitiveReduction
, transitiveReductionOptions
) where
import Data.GraphViz.Attributes.Complete( Attributes, usedByClusters
, defaultAttributeValue)
import Data.GraphViz.Attributes.Same
import Data.GraphViz.Types
import Data.GraphViz.Types.Canonical
import Data.Function(on)
import Data.List(groupBy, sortBy, partition, (\\), sort, deleteBy)
import Data.Maybe(listToMaybe, mapMaybe, fromMaybe)
import qualified Data.DList as DList
import qualified Data.Map as Map
import Data.Map(Map)
import qualified Data.Set as Set
import Data.Set(Set)
import qualified Data.Foldable as F
import Control.Arrow(first, second, (***))
import Control.Monad(unless)
import Control.Monad.Trans.State
data CanonicaliseOptions = COpts {
edgesInClusters :: Bool
, groupAttributes :: Bool
}
deriving (Eq, Ord, Show, Read)
defaultCanonOptions :: CanonicaliseOptions
defaultCanonOptions = COpts { edgesInClusters = True
, groupAttributes = True
}
dotLikeOptions :: CanonicaliseOptions
dotLikeOptions = COpts { edgesInClusters = True
, groupAttributes = False
}
canonicalise :: (DotRepr dg n) => dg n -> DotGraph n
canonicalise = canonicaliseOptions defaultCanonOptions
canonicaliseOptions :: (DotRepr dg n) => CanonicaliseOptions
-> dg n -> DotGraph n
canonicaliseOptions opts dg = cdg { strictGraph = graphIsStrict dg
, directedGraph = graphIsDirected dg
, graphID = getID dg
}
where
cdg = createCanonical opts gas cl nl es
(gas, cl) = graphStructureInformation dg
nl = nodeInformation True dg
es = edgeInformation True dg
createCanonical :: (Ord n) => CanonicaliseOptions -> GlobalAttributes
-> ClusterLookup -> NodeLookup n -> [DotEdge n] -> DotGraph n
createCanonical opts gas cl nl es
= DotGraph { strictGraph = undefined
, directedGraph = undefined
, graphID = undefined
, graphStatements = gStmts
}
where
gStmts = DotStmts { attrStmts = gas'
, subGraphs = sgs
, nodeStmts = topNs'
, edgeStmts = topEs'
}
gas' = nonEmptyGAs [ gas
, NodeAttrs topNAs
, EdgeAttrs topEAs
]
nUnlook (n,(p,as)) = (F.toList p, DotNode n as)
ns = sortBy (compLists `on` fst) . map nUnlook $ Map.toList nl
(clustNs, topNs) = thisLevel ns
(clustEL, topEs) = if edgesInClusters opts
then edgeClusters nl es
else (Map.empty, es)
topClustAs = filter usedByClusters $ attrs gas
topClustAs' = toSAttr topClustAs
topNAs = mCommon nodeAttributes topNs
topNAs' = toSAttr topNAs
topNs' = map (\dn -> dn {nodeAttributes = nodeAttributes dn \\ topNAs}) topNs
topEAs = mCommon edgeAttributes topEs
topEAs' = toSAttr topEAs
topEs' = map (\de -> de {edgeAttributes = edgeAttributes de \\ topEAs}) topEs
sgs = clusts topClustAs topClustAs' topNAs topNAs' topEAs topEAs' clustNs
clusts oAs oAsS nAs nAsS eAs eAsS = map (toClust oAs oAsS nAs nAsS eAs eAsS)
. groupBy ((==) `on` (listToMaybe . fst))
toClust oAs oAsS nAs nAsS eAs eAsS cns
= DotSG { isCluster = True
, subGraphID = cID
, subGraphStmts = stmts
}
where
cID = head . fst $ head cns
(nested, here) = thisLevel $ map (first tail) cns
stmts = DotStmts { attrStmts = sgAs
, subGraphs = subSGs
, nodeStmts = here'
, edgeStmts = edges'
}
sgAs = nonEmptyGAs [ GraphAttrs as'
, NodeAttrs nas'
, EdgeAttrs eas'
]
subSGs = clusts as asS nas nasS eas easS nested
as = attrs . snd $ cl Map.! cID
asS = toSAttr as
as' = fst $ innerAttributes oAs oAsS as
nas = mCommon nodeAttributes here
nasS = toSAttr nas
(nas',nOv) = innerAttributes nAs nAsS nas
here' = map (\dn -> dn {nodeAttributes = nodeAttributes dn \\ (nas ++ nOv)}) here
eas = mCommon edgeAttributes edges
easS = toSAttr eas
(eas',eOv) = innerAttributes eAs eAsS eas
edges' = map (\de -> de {edgeAttributes = edgeAttributes de \\ (eas ++ eOv)}) edges
edges = fromMaybe [] $ cID `Map.lookup` clustEL
thisLevel = second (map snd) . span (not . null . fst)
mCommon f = if groupAttributes opts
then commonAttrs f
else const []
compLists :: (Ord a) => [a] -> [a] -> Ordering
compLists [] [] = EQ
compLists [] _ = GT
compLists _ [] = LT
compLists (x:xs) (y:ys) = case compare x y of
EQ -> compLists xs ys
oth -> oth
nonEmptyGAs :: [GlobalAttributes] -> [GlobalAttributes]
nonEmptyGAs = filter (not . null . attrs)
commonAttrs :: (a -> Attributes) -> [a] -> Attributes
commonAttrs _ [] = []
commonAttrs f [a] = f a
commonAttrs f xs = Set.toList . foldr1 Set.intersection
$ map (Set.fromList . f) xs
edgeClusters :: (Ord n) => NodeLookup n -> [DotEdge n]
-> (Map (Maybe GraphID) [DotEdge n], [DotEdge n])
edgeClusters nl = (toM *** map snd) . partition (not . null . fst)
. map inClust
where
nl' = Map.map (F.toList . fst) nl
inClust de@(DotEdge n1 n2 _) = (flip (,) de)
. map fst . takeWhile (uncurry (==))
$ zip (nl' Map.! n1) (nl' Map.! n2)
toM = Map.map DList.toList
. Map.fromListWith (flip DList.append)
. map (last *** DList.singleton)
innerAttributes :: Attributes -> SAttrs
-> Attributes -> (Attributes, Attributes)
innerAttributes outer outerS inner = (sort $ inner' ++ override, override)
where
inner' = inner \\ outer
override = mapMaybe defAttr . unSame
$ outerS `Set.difference` toSAttr inner
defAttr a = case defaultAttributeValue a of
Just a' | a == a' -> Nothing
ma' -> ma'
transitiveReduction :: (DotRepr dg n) => dg n -> DotGraph n
transitiveReduction = transitiveReductionOptions defaultCanonOptions
transitiveReductionOptions :: (DotRepr dg n) => CanonicaliseOptions
-> dg n -> DotGraph n
transitiveReductionOptions opts dg = cdg { strictGraph = graphIsStrict dg
, directedGraph = graphIsDirected dg
, graphID = getID dg
}
where
cdg = createCanonical opts gas cl nl es'
(gas, cl) = graphStructureInformation dg
nl = nodeInformation True dg
es = edgeInformation True dg
es' | graphIsDirected dg = rmTransEdges es
| otherwise = es
rmTransEdges :: (Ord n) => [DotEdge n] -> [DotEdge n]
rmTransEdges [] = []
rmTransEdges es = concatMap (map snd . outgoing) $ Map.elems esM
where
tes = tagEdges es
esMS = do edgeGraph tes
ns <- getsMap Map.keys
mapM_ (traverse zeroTag) ns
esM = fst $ execState esMS (Map.empty, Set.empty)
type Tag = Int
type TagSet = Set Int
type TaggedEdge n = (Tag, DotEdge n)
zeroTag :: Tag
zeroTag = 0
tagEdges :: [DotEdge n] -> [TaggedEdge n]
tagEdges = zip [(succ zeroTag)..]
data TaggedValues n = TV { marked :: Bool
, incoming :: [TaggedEdge n]
, outgoing :: [TaggedEdge n]
}
deriving (Eq, Ord, Show, Read)
defTV :: TaggedValues n
defTV = TV False [] []
type TagMap n = Map n (TaggedValues n)
type TagState n a = State (TagMap n, TagSet) a
getMap :: TagState n (TagMap n)
getMap = gets fst
getsMap :: (TagMap n -> a) -> TagState n a
getsMap f = gets (f . fst)
modifyMap :: (TagMap n -> TagMap n) -> TagState n ()
modifyMap f = modify (first f)
getSet :: TagState n TagSet
getSet = gets snd
modifySet :: (TagSet -> TagSet) -> TagState n ()
modifySet f = modify (second f)
edgeGraph :: (Ord n) => [TaggedEdge n] -> TagState n ()
edgeGraph = mapM_ addEdge . reverse
where
addEdge te = addVal f tvOut >> addVal t tvIn
where
e = snd te
f = fromNode e
t = toNode e
addVal n tv = modifyMap (Map.insertWith mergeTV n tv)
tvIn = defTV { incoming = [te] }
tvOut = defTV { outgoing = [te] }
mergeTV tvNew tv = tv { incoming = incoming tvNew ++ incoming tv
, outgoing = outgoing tvNew ++ outgoing tv
}
traverse :: (Ord n) => Tag -> n -> TagState n ()
traverse t n = do setMark True
checkIncoming
outEs <- getsMap (maybe [] outgoing . Map.lookup n)
mapM_ maybeRecurse outEs
setMark False
where
setMark mrk = modifyMap (Map.adjust (\tv -> tv { marked = mrk }) n)
isMarked m n' = maybe False marked $ n' `Map.lookup` m
checkIncoming = do m <- gets fst
let es = incoming $ m Map.! n
(keepEs, delEs) = partition (keepEdge m) es
modifyMap (Map.adjust (\tv -> tv {incoming = keepEs}) n)
modifySet (Set.union $ Set.fromList (map fst delEs))
mapM_ delOtherEdge delEs
where
keepEdge m (t',e) = t == t' || not (isMarked m $ fromNode e)
delOtherEdge te = modifyMap (Map.adjust delE . fromNode $ snd te)
where
delE tv = tv {outgoing = deleteBy ((==) `on` fst) te $ outgoing tv}
maybeRecurse (t',e) = do m <- getMap
delSet <- getSet
let n' = toNode e
unless (isMarked m n' || t' `Set.member` delSet)
$ traverse t' n'