-- | Creates graphviz @.dot@ files from trees.

module Math.Combinat.Trees.Graphviz 
  ( Dot
  , graphvizDotBinTree
  , graphvizDotBinTree'
  , graphvizDotForest
  , graphvizDotTree
  )
  where

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

import Data.Tree

import Control.Applicative

import {-# SOURCE #-} Math.Combinat.Trees.Binary ( BinTree(..)         , BinTree'(..)          )
import {-# SOURCE #-} Math.Combinat.Trees.Nary   ( addUniqueLabelsTree , addUniqueLabelsForest )

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

type Dot = String

digraphBracket :: String -> [String] -> String   
digraphBracket :: String -> [String] -> String
digraphBracket String
name [String]
lines = 
  String
"digraph " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" {\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
  (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
xs -> String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xsString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n") [String]
lines    
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}\n"
  
--------------------------------------------------------------------------------

graphvizDotBinTree :: Show a => String -> BinTree a -> Dot
graphvizDotBinTree :: String -> BinTree a -> String
graphvizDotBinTree String
graphname BinTree a
tree = 
  String -> [String] -> String
digraphBracket String
graphname ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ BinTree a -> [String]
forall a. Show a => BinTree a -> [String]
binTreeDot' BinTree a
tree

graphvizDotBinTree' :: (Show a, Show b) => String -> BinTree' a b -> Dot
graphvizDotBinTree' :: String -> BinTree' a b -> String
graphvizDotBinTree' String
graphname BinTree' a b
tree = 
  String -> [String] -> String
digraphBracket String
graphname ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ BinTree' a b -> [String]
forall a b. (Show a, Show b) => BinTree' a b -> [String]
binTree'Dot' BinTree' a b
tree
  
binTreeDot' :: Show a => BinTree a -> [String]
binTreeDot' :: BinTree a -> [String]
binTreeDot' BinTree a
tree = [String]
lines where
  lines :: [String]
lines = Int -> String -> BinTree a -> [String]
forall a a. (Show a, Num a) => a -> String -> BinTree a -> [String]
worker (Int
0::Int) String
"r" BinTree a
tree 
  name :: String -> String
name String
path = String
"node_"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
path
  worker :: a -> String -> BinTree a -> [String]
worker a
depth String
path (Leaf a
x) = 
    [ String -> String
name String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[shape=box,label=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"];" ]
  worker a
depth String
path (Branch BinTree a
left BinTree a
right) 
    = [String
vertex,String
leftedge,String
rightedge] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ 
      a -> String -> BinTree a -> [String]
worker (a
deptha -> a -> a
forall a. Num a => a -> a -> a
+a
1) (Char
'l'Char -> String -> String
forall a. a -> [a] -> [a]
:String
path) BinTree a
left [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ 
      a -> String -> BinTree a -> [String]
worker (a
deptha -> a -> a
forall a. Num a => a -> a -> a
+a
1) (Char
'r'Char -> String -> String
forall a. a -> [a] -> [a]
:String
path) BinTree a
right
    where 
      vertex :: String
vertex = String -> String
name String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[shape=circle,style=filled,height=0.25,label=\"\"];"
      leftedge :: String
leftedge  = String -> String
name String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
name (Char
'l'Char -> String -> String
forall a. a -> [a] -> [a]
:String
path) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[tailport=sw];"
      rightedge :: String
rightedge = String -> String
name String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
name (Char
'r'Char -> String -> String
forall a. a -> [a] -> [a]
:String
path) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[tailport=se];"

binTree'Dot' :: (Show a, Show b) => BinTree' a b -> [String]
binTree'Dot' :: BinTree' a b -> [String]
binTree'Dot' BinTree' a b
tree = [String]
lines where
  lines :: [String]
lines = Int -> String -> BinTree' a b -> [String]
forall a a b.
(Show a, Num a, Show b) =>
a -> String -> BinTree' a b -> [String]
worker (Int
0::Int) String
"r" BinTree' a b
tree 
  name :: String -> String
name String
path = String
"node_"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
path
  worker :: a -> String -> BinTree' a b -> [String]
worker a
depth String
path (Leaf' a
x) = 
    [ String -> String
name String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[shape=box,label=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"];" ]
  worker a
depth String
path (Branch' BinTree' a b
left b
y BinTree' a b
right) 
    = [String
vertex,String
leftedge,String
rightedge] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ 
      a -> String -> BinTree' a b -> [String]
worker (a
deptha -> a -> a
forall a. Num a => a -> a -> a
+a
1) (Char
'l'Char -> String -> String
forall a. a -> [a] -> [a]
:String
path) BinTree' a b
left [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ 
      a -> String -> BinTree' a b -> [String]
worker (a
deptha -> a -> a
forall a. Num a => a -> a -> a
+a
1) (Char
'r'Char -> String -> String
forall a. a -> [a] -> [a]
:String
path) BinTree' a b
right
    where 
      vertex :: String
vertex = String -> String
name String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[shape=ellipse,label=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Show a => a -> String
show b
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"];"
      leftedge :: String
leftedge  = String -> String
name String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
name (Char
'l'Char -> String -> String
forall a. a -> [a] -> [a]
:String
path) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[tailport=sw];"
      rightedge :: String
rightedge = String -> String
name String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
name (Char
'r'Char -> String -> String
forall a. a -> [a] -> [a]
:String
path) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[tailport=se];"

--------------------------------------------------------------------------------
    
-- | Generates graphviz @.dot@ file from a forest. The first argument tells whether
-- to make the individual trees clustered subgraphs; the second is the name of the
-- graph.
graphvizDotForest
  :: Show a 
  => Bool        -- ^ make the individual trees clustered subgraphs
  -> Bool        -- ^ reverse the direction of the arrows
  -> String      -- ^ name of the graph
  -> Forest a 
  -> Dot
graphvizDotForest :: Bool -> Bool -> String -> Forest a -> String
graphvizDotForest Bool
clustered Bool
revarrows String
graphname Forest a
forest = String -> [String] -> String
digraphBracket String
graphname [String]
lines where
  lines :: [String]
lines = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (Int -> Tree (a, Int) -> [String])
-> [Int] -> [Tree (a, Int)] -> [[String]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Tree (a, Int) -> [String]
forall a b a.
(Show a, Show b, Show a) =>
a -> Tree (a, b) -> [String]
cluster [(Int
1::Int)..] (Forest a -> [Tree (a, Int)]
forall a. Forest a -> Forest (a, Int)
addUniqueLabelsForest Forest a
forest) 
  name :: a -> String
name a
unique = String
"node_"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
unique
  cluster :: a -> Tree (a, b) -> [String]
cluster a
j Tree (a, b)
tree = let treelines :: [String]
treelines = Int -> Tree (a, b) -> [String]
forall t b a.
(Num t, Show b, Show a) =>
t -> Tree (a, b) -> [String]
worker (Int
0::Int) Tree (a, b)
tree in case Bool
clustered of
    Bool
False -> [String]
treelines
    Bool
True  -> (String
"subgraph cluster_"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
jString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" {") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
treelines [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"}"] 
  worker :: t -> Tree (a, b) -> [String]
worker t
depth (Node (a
label,b
unique) Forest (a, b)
subtrees) = String
vertex String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
edges [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Tree (a, b) -> [String]) -> Forest (a, b) -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (t -> Tree (a, b) -> [String]
worker (t
deptht -> t -> t
forall a. Num a => a -> a -> a
+t
1)) Forest (a, b)
subtrees where
    vertex :: String
vertex = b -> String
forall a. Show a => a -> String
name b
unique String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[label=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
label String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"];"
    edges :: [String]
edges = (Tree (a, b) -> String) -> Forest (a, b) -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Tree (a, b) -> String
forall a a. Show a => Tree (a, a) -> String
edge Forest (a, b)
subtrees
    edge :: Tree (a, a) -> String
edge (Node (a
_,a
unique') Forest (a, a)
_) = if Bool -> Bool
not Bool
revarrows 
      then b -> String
forall a. Show a => a -> String
name b
unique  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
name a
unique'   
      else a -> String
forall a. Show a => a -> String
name a
unique' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Show a => a -> String
name b
unique
      
-- | Generates graphviz @.dot@ file from a tree. The first argument is
-- the name of the graph.
graphvizDotTree
  :: Show a 
  => Bool     -- ^ reverse the direction of the arrow
  -> String   -- ^ name of the graph
  -> Tree a 
  -> Dot
graphvizDotTree :: Bool -> String -> Tree a -> String
graphvizDotTree Bool
revarrows String
graphname Tree a
tree = String -> [String] -> String
digraphBracket String
graphname [String]
lines where
  lines :: [String]
lines = Int -> Tree (a, Int) -> [String]
forall t b a.
(Num t, Show b, Show a) =>
t -> Tree (a, b) -> [String]
worker (Int
0::Int) (Tree a -> Tree (a, Int)
forall a. Tree a -> Tree (a, Int)
addUniqueLabelsTree Tree a
tree) 
  name :: a -> String
name a
unique = String
"node_"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
unique
  worker :: t -> Tree (a, b) -> [String]
worker t
depth (Node (a
label,b
unique) Forest (a, b)
subtrees) = String
vertex String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
edges [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Tree (a, b) -> [String]) -> Forest (a, b) -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (t -> Tree (a, b) -> [String]
worker (t
deptht -> t -> t
forall a. Num a => a -> a -> a
+t
1)) Forest (a, b)
subtrees where
    vertex :: String
vertex = b -> String
forall a. Show a => a -> String
name b
unique String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[label=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
label String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"];"
    edges :: [String]
edges = (Tree (a, b) -> String) -> Forest (a, b) -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Tree (a, b) -> String
forall a a. Show a => Tree (a, a) -> String
edge Forest (a, b)
subtrees
    edge :: Tree (a, a) -> String
edge (Node (a
_,a
unique') Forest (a, a)
_) = if Bool -> Bool
not Bool
revarrows 
      then b -> String
forall a. Show a => a -> String
name b
unique  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
name a
unique'   
      else a -> String
forall a. Show a => a -> String
name a
unique' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Show a => a -> String
name b
unique

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