module Data.GraphViz.Types.Clustering
( NodeCluster(..)
, clustersToNodes
) where
import Data.GraphViz.Types
import Data.GraphViz.Attributes
import Data.Either(partitionEithers)
import Data.List(groupBy, sortBy)
import Data.Graph.Inductive.Graph(Graph, Node, LNode, labNodes)
data NodeCluster c a = N (LNode a)
| C c (NodeCluster c a)
deriving (Show)
clustersToNodes :: (Ord c, Graph gr) => (LNode a -> NodeCluster c l)
-> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
-> (LNode l -> Attributes) -> gr a b
-> ([DotSubGraph Node], [DotNode Node])
clustersToNodes clusterBy cID fmtCluster fmtNode
= treesToDot cID fmtCluster fmtNode
. collapseNClusts
. map (clustToTree . clusterBy)
. labNodes
data ClusterTree c a = NT (LNode a)
| CT c [ClusterTree c a]
deriving (Show)
clustToTree :: NodeCluster c a -> ClusterTree c a
clustToTree (N ln) = NT ln
clustToTree (C c nc) = CT c [clustToTree nc]
sameClust :: (Eq c) => ClusterTree c a -> ClusterTree c a -> Bool
sameClust (NT _) (NT _) = True
sameClust (CT c1 _) (CT c2 _) = c1 == c2
sameClust _ _ = False
clustOrder :: (Ord c) => ClusterTree c a -> ClusterTree c a -> Ordering
clustOrder (NT _) (NT _) = EQ
clustOrder (NT _) (CT _ _) = LT
clustOrder (CT _ _) (NT _) = GT
clustOrder (CT c1 _) (CT c2 _) = compare c1 c2
getNodes :: ClusterTree c a -> [ClusterTree c a]
getNodes n@(NT _) = [n]
getNodes (CT _ ns) = ns
collapseNClusts :: (Ord c) => [ClusterTree c a] -> [ClusterTree c a]
collapseNClusts = concatMap grpCls
. groupBy sameClust
. sortBy clustOrder
where
grpCls [] = []
grpCls ns@((NT _):_) = ns
grpCls cs@((CT c _):_) = [CT c (collapseNClusts $ concatMap getNodes cs)]
treesToDot :: (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
-> (LNode a -> Attributes) -> [ClusterTree c a]
-> ([DotSubGraph Node], [DotNode Node])
treesToDot cID fmtCluster fmtNode
= partitionEithers
. map (treeToDot cID fmtCluster fmtNode)
treeToDot :: (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
-> (LNode a -> Attributes) -> ClusterTree c a
-> Either (DotSubGraph Node) (DotNode Node)
treeToDot _ _ fmtNode (NT ln)
= Right DotNode { nodeID = fst ln
, nodeAttributes = fmtNode ln
}
treeToDot cID fmtCluster fmtNode (CT c nts)
= Left DotSG { isCluster = True
, subGraphID = cID c
, subGraphStmts = stmts
}
where
stmts = DotStmts { attrStmts = fmtCluster c
, subGraphs = cs
, nodeStmts = ns
, edgeStmts = []
}
(cs, ns) = treesToDot cID fmtCluster fmtNode nts