module Data.Graph.Analysis.Visualisation
(
graphviz,
graphvizClusters,
graphvizClusters',
assignCluster,
noAttributes,
showPath,
showPath',
showCycle,
showCycle',
showNodes,
showNodes',
blockPrint,
blockPrint',
blockPrintList,
blockPrintList',
blockPrintWith,
blockPrintWith',
) where
import Data.Graph.Analysis.Types
import Data.Graph.Analysis.Utils
import Data.Graph.Inductive.Graph
import Data.GraphViz
import Data.List(intersperse, unfoldr)
graphviz :: GraphData n e -> [GlobalAttributes]
-> (LNode n -> Attributes)
-> (LEdge e -> Attributes) -> DotGraph Node
graphviz = applyDirAlg graphToDot
graphvizClusters :: (ClusterLabel cl) => GraphData cl e -> [GlobalAttributes]
-> (Cluster cl -> [GlobalAttributes])
-> (LNode (NodeLabel cl) -> Attributes)
-> (LEdge e -> Attributes) -> DotGraph Node
graphvizClusters g gas = graphvizClusters' g gas assignCluster clusterID
graphvizClusters' :: (Ord c) => GraphData n e -> [GlobalAttributes]
-> (LNode n -> NodeCluster c l)
-> (c -> Maybe GraphID)
-> (c -> [GlobalAttributes]) -> (LNode l -> Attributes)
-> (LEdge e -> Attributes) -> DotGraph Node
graphvizClusters' = applyDirAlg clusterGraphToDot
assignCluster :: (ClusterLabel cl) => LNode cl
-> NodeCluster (Cluster cl) (NodeLabel cl)
assignCluster (n,a) = C (cluster a) $ N (n, nodeLabel a)
noAttributes :: a -> Attributes
noAttributes = const []
showPath :: (Show a) => [a] -> String
showPath = showPath' show
showPath' :: (a -> String) -> [a] -> String
showPath' _ [] = ""
showPath' f ls = blockPrint' (l:ls'')
where
(l:ls') = map f ls
ls'' = map ("-> "++) ls'
showCycle :: (Show a) => [a] -> String
showCycle = showCycle' show
showCycle' :: (a -> String) -> [a] -> String
showCycle' _ [] = ""
showCycle' f ls@(l:_) = showPath' f (ls ++ [l])
showNodes :: (Show a) => [a] -> String
showNodes = showNodes' show
showNodes' :: (a -> String) -> [a] -> String
showNodes' _ [] = ""
showNodes' f ls = blockPrint' . addCommas
$ map f ls
where
addCommas [] = []
addCommas [l] = [l]
addCommas (l:ls') = (l ++ ", ") : addCommas ls'
blockPrint :: (Show a) => [a] -> String
blockPrint = blockPrintWith " "
blockPrint' :: [String] -> String
blockPrint' = blockPrintWith' " "
blockPrintList :: (Show a) => [a] -> String
blockPrintList = blockPrintWith ", "
blockPrintList' :: [String] -> String
blockPrintList' = blockPrintWith' ", "
blockPrintWith :: (Show a) => String -> [a] -> String
blockPrintWith str = blockPrintWith' str . map show
blockPrintWith' :: String -> [String] -> String
blockPrintWith' sep as = init
. unlines $ map unwords' lns
where
lsep = length sep
las = addLengths as
sidelen :: Double
sidelen = (1.75*) . sqrt . fromIntegral . sum $ map fst las
slen = round sidelen
serr = round $ sidelen/10
lns = unfoldr (takeLen slen serr lsep) las
unwords' = concat . intersperse sep
takeLen :: Int -> Int -> Int -> [(Int,String)]
-> Maybe ([String],[(Int,String)])
takeLen _ _ _ [] = Nothing
takeLen len err lsep ((l,a):als) = Just lr
where
lmax = len + err
lr = if l > len
then ([a],als)
else (a:as,als')
(as,als') = takeLine (lmax l lsep) lsep als
takeLine :: Int -> Int -> [(Int,String)] -> ([String],[(Int,String)])
takeLine len lsep als
| null als = ([],als)
| len <= 0 = ([],als)
| l > len = ([],als)
| otherwise = (a:as,als'')
where
((l,a):als') = als
len' = len l lsep
(as,als'') = takeLine len' lsep als'