module Graphviz(Tree(..),LabeledTree(..),Color(..),toPng,Graph(..),pnG,pdfG) where
import System(system)

data Color = None | Black | Red | Blue | Green deriving Show

showColor None = ""
showColor c = "["++colorAttr c++"]"

colorAttr Black = "color=black"
colorAttr Red = "color=red"
colorAttr Blue = "color=blue"
colorAttr Green = "color=darkgreen"

-----------------------------------------
-- Class definitions

class Tree t where
  subtrees :: t -> [(t,Color)]
  
class Tree t => LabeledTree t where
  label :: t -> String

---------------------------------------------
-- Overloaded functions

depth  :: Tree t => t -> Int
depth   = (1+) . foldl max 0 . map depth . (map fst) . subtrees

size   :: Tree t => t -> Int
size    = (1+) . sum . map size . (map fst) . subtrees

paths               :: Tree t => t -> [[t]]
paths t | null br    = [ [t] ]
        | otherwise  = [ t:p | b <- br, p <- paths b ]
          where br = map fst (subtrees t)

dfs    :: Tree t => t -> [t]
dfs t   = t : concat (map dfs (map fst(subtrees t))) 


-----------------------------------------------------
-- An example with instances

data BinTree a   = Leaf a
                 | BinTree a :^: BinTree a
                   deriving Show

example :: BinTree Int
example  = l :^: r
 where l = p :^: q
       r = s :^: t
       p = Leaf 1 :^: t
       q = s :^: Leaf 2
       s = Leaf 3 :^: Leaf 4
       t = Leaf 5 :^: Leaf 6

instance Tree (BinTree a) where
  subtrees (Leaf x)   = []
  subtrees (l :^: r)  = [(l,Red),(r,Green)]
  
instance Show a => LabeledTree (BinTree a) where
  label (Leaf x)   = show x
  label (l :^: r)  = ""

instance Functor BinTree where
  fmap f (Leaf x)   = Leaf (f x)
  fmap f (l :^: r)  = fmap f l :^: fmap f r


-----------------------------------------------------------
-- Code for using Graphviz to draw trees

toDot :: LabeledTree t => t -> IO ()
toDot t = writeFile "tree.dot"
           ("digraph tree {\n"
            ++ semi (nodeTree [] t)
            ++ "}\n")
 where semi = foldr (\l ls -> l ++ ";\n" ++ ls) ""

toPng t =
  do { toDot t
     ; system "dot -Tpdf tree.dot > /u/hook/public_html/tree.pdf"
--      ; system "explorer tree.png "
     }

type Path    = [Int]
type NodeId  = String

showPath      :: Path -> String
showPath p     = "\"" ++ show p ++ "\""

nodeTree    :: LabeledTree t => Path -> t -> [String]
nodeTree p t = [ showPath p ++ " [label=\"" ++ label t ++ "\"]" ]
            ++ concat (zipWith (edgeTree p) [1..] (subtrees t))

edgeTree      :: LabeledTree t => Path -> Int -> (t,Color) -> [String]
edgeTree p n (t,color) = [ showPath p ++ " ->" ++ showPath p' ++ showColor color ] ++ nodeTree p' t
                 where p' = n : p
                 
--------------------------------------------------------
-- Pictures of Graph like things

class Graph t where
  nodes:: t -> [(Int,String,Color)]
  edges:: t -> [(Int,Int,String,Color)]
  
showNode (n,str,col) = show n++showAttr (str,col)++";"
showEdge (n,m,str,col) = show n++" -> "++show m++showAttr(str,col)++";"
showAttr (str,None)  = " [label="++show str++"]"
showAttr (str,c) = " [label="++show str++", "++colorAttr c++"]"


dotG:: Graph t => t -> String
dotG t = (unlines lines)
   where ns = nodes t
         es = edges t
         lines = ["digraph tree {"]++map showNode ns++map showEdge es++["}"]


pnG t =
  do { writeFile "graph.dot" (dotG t)
     ; system "dot -Tpng graph.dot > graph.png "      -- for Windows, Mac
--     ; system "dot -Tpdf graph.dot > /u/hook/public_html/graph.pdf "  -- for Unix
     ; system "explorer graph.png "  -- Windows
--     ; system "open graph.png "     -- Mac
     }

pdfG f t = 
    do { writeFile (f++".dot") (dotG t)
       ; system $ "dot -Tpdf "++f++".dot > "++f++".pdf "
       }