Visualisation.hs

{- |
   Module      : Data.Graph.Analysis.Visualisation
   Description : Graphviz wrapper functions
   Copyright   : (c) Ivan Lazar Miljenovic 2009
   License     : 2-Clause BSD
   Maintainer  : Ivan.Miljenovic@gmail.com

   Functions to assist in visualising graphs and components of graphs.
 -}
module Data.Graph.Analysis.Visualisation
    ( -- * Graph visualisation.
      -- $graphviz
      graphviz,
      graphvizClusters,
      graphvizClusters',
      assignCluster,
      noAttributes,
      -- * Showing node groupings.
      -- $other
      showPath,
      showPath',
      showCycle,
      showCycle',
      showNodes,
      showNodes',
      -- * Various printing functions.
      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
   Simple wrappers around the Haskell "Data.GraphViz" library to turn
   'GraphData's into basic 'DotGraph's for processing by the GraphViz
   suite of applications.
-}

-- | Convert the 'GraphData' into 'DotGraph' format with the given
--   'Attribute's.
graphviz :: GraphData n e -> [GlobalAttributes]
            -> (LNode n -> Attributes)
            -> (LEdge e -> Attributes) -> DotGraph Node
graphviz = applyDirAlg graphToDot

-- | Convert the clustered 'GraphData' into 'DotGraph' format with the
--   given 'Attribute's.  Cluster the nodes based upon their
--   'ClusterLabel' clusters.
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

-- | Convert the 'GraphData' into a clustered 'DotGraph' format using
--   the given clustering function and with the given 'Attribute's.
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

-- | A function to convert an 'LNode' to the required 'NodeCluster'
--   for use with the GraphViz library.
assignCluster       :: (ClusterLabel cl) => LNode cl
                       -> NodeCluster (Cluster cl) (NodeLabel cl)
assignCluster (n,a) = C (cluster a) $ N (n, nodeLabel a)

-- | Used to state that GraphViz should use the default 'Attribute's
--   for the given value.
noAttributes :: a -> Attributes
noAttributes = const []

-- -----------------------------------------------------------------------------

{- $other
   Printing different lists of labels.
 -}

-- | Print a path, with \"->\" between each element.
showPath :: (Show a) => [a] -> String
showPath = showPath' show

-- | Print a path, with \"->\" between each element.
showPath'      :: (a -> String) -> [a] -> String
showPath' _ [] = ""
showPath' f ls = blockPrint' (l:ls'')
    where
      -- Can't use blockPrintWith above, as it only takes a per-row spacer.
      (l:ls') = map f ls
      ls'' = map ("-> "++) ls'

-- | Print a cycle: copies the first node to the end of the list,
--   and then calls 'showPath'.
showCycle :: (Show a) => [a] -> String
showCycle = showCycle' show

-- | Print a cycle: copies the first node to the end of the list,
--   and then calls 'showPath''.
showCycle'            :: (a -> String) -> [a] -> String
showCycle' _ []       = ""
showCycle' f ls@(l:_) = showPath' f (ls ++ [l])

-- | Show a group of nodes, with no implicit ordering.
showNodes :: (Show a) => [a] -> String
showNodes = showNodes' show

-- | Show a group of nodes, with no implicit ordering.
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'

-- -----------------------------------------------------------------------------

-- | Attempt to convert the @String@ form of a list into
--   as much of a square shape as possible, using a single
--   space as a separation string.
blockPrint :: (Show a) => [a] -> String
blockPrint = blockPrintWith " "

-- | Attempt to convert a list of @String@s into a single @String@
--   that is roughly a square shape, with a single space as a row
--   separator.
blockPrint' :: [String] -> String
blockPrint' = blockPrintWith' " "

-- | Attempt to convert the @String@ form of a list into
--   as much of a square shape as possible, separating values
--   with commas.
blockPrintList :: (Show a) => [a] -> String
blockPrintList = blockPrintWith ",  "

-- | Attempt to combine a list of @String@s into as much of a
--   square shape as possible, separating values with commas.
blockPrintList' :: [String] -> String
blockPrintList' = blockPrintWith' ",  "

-- | Attempt to convert the @String@ form of a list into
--   as much of a square shape as possible, using the given
--   separation string between elements in the same row.
blockPrintWith     :: (Show a) => String -> [a] -> String
blockPrintWith str = blockPrintWith' str . map show

-- | Attempt to convert the combined form of a list of @String@s
--   into as much of a square shape as possible, using the given
--   separation string between elements in the same row.
blockPrintWith'        :: String -> [String] -> String
blockPrintWith' sep as = init -- Remove the final '\n' on the end.
                         . unlines $ map unwords' lns
    where
      lsep = length sep
      las = addLengths as
      -- Scale this, to take into account the height:width ratio.
      sidelen :: Double -- Suppress defaulting messages
      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

-- | Using the given line length and allowed error, take the elements of
--   the next line.
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) -- Overflow line of single item
           else (a:as,als')
      -- We subtract lsep here to take into account the spacer.
      (as,als') = takeLine (lmax - l - lsep) lsep als

-- | Recursively build the rest of the line with given maximum length.
takeLine :: Int -> Int -> [(Int,String)] -> ([String],[(Int,String)])
takeLine len lsep als
    | null als  = ([],als)
    | len <= 0  = ([],als) -- This should be covered by the next guard,
                           -- but just in case...
    | l > len   = ([],als)
    | otherwise = (a:as,als'')
    where
      ((l,a):als') = als
      -- We subtract lsep here to take into account the spacer.
      len' = len - l - lsep
      (as,als'') = takeLine len' lsep als'