module Data.GraphViz.Types.Clustering
( NodeCluster(..)
, clustersToNodes
) where
import Prelude hiding (LT)
import qualified Prelude as P
import Data.GraphViz.Types
import Data.GraphViz.Attributes
import Data.List(groupBy, sortBy, mapAccumL)
import Data.Graph.Inductive.Graph(Graph, 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 a)
-> (c -> [Attribute]) -> (LNode a -> [Attribute])
-> gr a b -> [DotNode]
clustersToNodes clusterBy fmtCluster fmtNode
= treesToNodes 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 _ _) = P.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)]
treesToNodes :: (c -> [Attribute]) -> (LNode a -> [Attribute])
-> [ClusterTree c a] -> [DotNode]
treesToNodes fmtCluster fmtNode = snd . treesToNodesFrom fmtCluster fmtNode 0
treesToNodesFrom :: (c -> [Attribute]) -> (LNode a -> [Attribute])
-> Int -> [ClusterTree c a] -> (Int,[DotNode])
treesToNodesFrom fmtCluster fmtNode n = mapAccumL mkNodes n
where
mkNodes = treeToNode fmtCluster fmtNode
treeToNode :: (c -> [Attribute]) -> (LNode a -> [Attribute])
-> Int -> ClusterTree c a -> (Int, DotNode)
treeToNode _ fmtNode n (NT ln) = ( n
, DotNode { nodeID = fst ln
, nodeAttributes = fmtNode ln
}
)
treeToNode fmtCluster fmtNode n (CT c nts) = (n',clust)
where
(n', nts') = treesToNodesFrom fmtCluster fmtNode (n+1) nts
clust = DotCluster { clusterID = show n
, clusterAttributes = fmtCluster c
, clusterElems = nts'
}