-- | 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 " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" {\n" forall a. [a] -> [a] -> [a]
++ 
  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
xs -> String
"  "forall a. [a] -> [a] -> [a]
++String
xsforall a. [a] -> [a] -> [a]
++String
"\n") [String]
lines    
  forall a. [a] -> [a] -> [a]
++ String
"}\n"
  
--------------------------------------------------------------------------------

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

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

binTree'Dot' :: (Show a, Show b) => BinTree' a b -> [String]
binTree'Dot' :: forall a b. (Show a, Show b) => BinTree' a b -> [String]
binTree'Dot' BinTree' a b
tree = [String]
lines where
  lines :: [String]
lines = forall {a} {t} {b}.
(Show a, Num t, Show b) =>
t -> String -> BinTree' a b -> [String]
worker (Int
0::Int) String
"r" BinTree' a b
tree 
  name :: String -> String
name String
path = String
"node_"forall a. [a] -> [a] -> [a]
++String
path
  worker :: t -> String -> BinTree' a b -> [String]
worker t
depth String
path (Leaf' a
x) = 
    [ String -> String
name String
path forall a. [a] -> [a] -> [a]
++ String
"[shape=box,label=\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x forall a. [a] -> [a] -> [a]
++ String
"\"" forall a. [a] -> [a] -> [a]
++ String
"];" ]
  worker t
depth String
path (Branch' BinTree' a b
left b
y BinTree' a b
right) 
    = [String
vertex,String
leftedge,String
rightedge] forall a. [a] -> [a] -> [a]
++ 
      t -> String -> BinTree' a b -> [String]
worker (t
depthforall a. Num a => a -> a -> a
+t
1) (Char
'l'forall a. a -> [a] -> [a]
:String
path) BinTree' a b
left forall a. [a] -> [a] -> [a]
++ 
      t -> String -> BinTree' a b -> [String]
worker (t
depthforall a. Num a => a -> a -> a
+t
1) (Char
'r'forall a. a -> [a] -> [a]
:String
path) BinTree' a b
right
    where 
      vertex :: String
vertex = String -> String
name String
path forall a. [a] -> [a] -> [a]
++ String
"[shape=ellipse,label=\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show b
y forall a. [a] -> [a] -> [a]
++ String
"\"];"
      leftedge :: String
leftedge  = String -> String
name String
path forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ String -> String
name (Char
'l'forall a. a -> [a] -> [a]
:String
path) forall a. [a] -> [a] -> [a]
++ String
"[tailport=sw];"
      rightedge :: String
rightedge = String -> String
name String
path forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ String -> String
name (Char
'r'forall a. a -> [a] -> [a]
:String
path) 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 :: forall a. Show a => 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a} {b} {a}.
(Show a, Show b, Show a) =>
a -> Tree (a, b) -> [String]
cluster [(Int
1::Int)..] (forall a. Forest a -> Forest (a, Int)
addUniqueLabelsForest Forest a
forest) 
  name :: a -> String
name a
unique = String
"node_"forall a. [a] -> [a] -> [a]
++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 = 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_"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show a
jforall a. [a] -> [a] -> [a]
++String
" {") forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (String
"  "forall a. [a] -> [a] -> [a]
++) [String]
treelines forall a. [a] -> [a] -> [a]
++ [String
"}"] 
  worker :: t -> Tree (a, b) -> [String]
worker t
depth (Node (a
label,b
unique) [Tree (a, b)]
subtrees) = String
vertex forall a. a -> [a] -> [a]
: [String]
edges forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (t -> Tree (a, b) -> [String]
worker (t
depthforall a. Num a => a -> a -> a
+t
1)) [Tree (a, b)]
subtrees where
    vertex :: String
vertex = forall a. Show a => a -> String
name b
unique forall a. [a] -> [a] -> [a]
++ String
"[label=\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
label forall a. [a] -> [a] -> [a]
++ String
"\"" forall a. [a] -> [a] -> [a]
++ String
"];"
    edges :: [String]
edges = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. Show a => Tree (a, a) -> String
edge [Tree (a, b)]
subtrees
    edge :: Tree (a, a) -> String
edge (Node (a
_,a
unique') [Tree (a, a)]
_) = if Bool -> Bool
not Bool
revarrows 
      then forall a. Show a => a -> String
name b
unique  forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
name a
unique'   
      else forall a. Show a => a -> String
name a
unique' forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ 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 :: forall a. Show a => 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 = forall {t} {b} {a}.
(Num t, Show b, Show a) =>
t -> Tree (a, b) -> [String]
worker (Int
0::Int) (forall a. Tree a -> Tree (a, Int)
addUniqueLabelsTree Tree a
tree) 
  name :: a -> String
name a
unique = String
"node_"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show a
unique
  worker :: t -> Tree (a, b) -> [String]
worker t
depth (Node (a
label,b
unique) [Tree (a, b)]
subtrees) = String
vertex forall a. a -> [a] -> [a]
: [String]
edges forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (t -> Tree (a, b) -> [String]
worker (t
depthforall a. Num a => a -> a -> a
+t
1)) [Tree (a, b)]
subtrees where
    vertex :: String
vertex = forall a. Show a => a -> String
name b
unique forall a. [a] -> [a] -> [a]
++ String
"[label=\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
label forall a. [a] -> [a] -> [a]
++ String
"\"" forall a. [a] -> [a] -> [a]
++ String
"];"
    edges :: [String]
edges = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. Show a => Tree (a, a) -> String
edge [Tree (a, b)]
subtrees
    edge :: Tree (a, a) -> String
edge (Node (a
_,a
unique') [Tree (a, a)]
_) = if Bool -> Bool
not Bool
revarrows 
      then forall a. Show a => a -> String
name b
unique  forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
name a
unique'   
      else forall a. Show a => a -> String
name a
unique' forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
name b
unique

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