-- | Module to provide graph drawing of unit generator graphs.  The
--   output is in the form of a dot graph, which can be layed out
--   using the @graphviz@ tools, see <http://graphviz.org>.
--
-- > import Sound.SC3.ID
-- > import Sound.SC3.UGen.Dot
--
-- Simple a-rate only graph.
--
-- > draw (out 0 (sinOsc AR 440 0 * 0.1))
--
-- With k-rate subgraph.
--
-- > let f = lfSaw KR 1 0 * 220 + 440
-- > in draw (out 0 (sinOsc AR f 0 * 0.1))
--
-- With i-rate subgraph
--
-- > let {l = rand 'a' 200 400
-- >     ;m = rand 'b' l 600
-- >     ;a = rand 'c' 500 900
-- >     ;f = lfSaw KR 1 0 * m + a}
-- > in draw (out 0 (sinOsc AR f 0 * 0.1))
--
-- With control input
--
-- > let f = control KR "freq" 440
-- > in draw (out 0 (sinOsc AR f 0 * 0.1))
--
-- With multiple channel expansion.
--
-- > let f = mce2 440 220
-- > in draw (out 0 (sinOsc AR f 0 * 0.1))
--
-- With multiple root graph.
--
-- > let {f = mce2 440 220 + in' 2 KR 0
-- >     ;o1 = sinOsc AR f 0 * 0.1
-- >     ;o2 = sinOsc KR (mce2 0.25 0.35) 0 * mce2 10 15 }
-- > in draw (mrg [out 0 o1,out 0 o2])
module Sound.SC3.UGen.Dot (Drawable(..)) where

import Control.Exception
import Control.Monad
import Data.List
import Data.Maybe
import Sound.SC3
import System.IO
import System.IO.Error
import System.Cmd {- process -}
import System.Directory {- directory -}
import System.Environment
import System.FilePath {- filepath -}

-- | Draw the unit generator graph provided using the viewer at the
--   environment variable @DOTVIEWER@, or @dotty@ if that variable is
--   not defined.
class Drawable a where
    dot :: a -> String
    draw :: a -> IO ()
    draw x = get_dot_viewer >>= view_with (dot x)

instance Drawable UGen where
    dot = dotGraph . synth

instance Drawable Synthdef where
    dot = dotGraph . synthdefGraph

-- * Implemetation

-- Generate dot representation of the provided unit generator graph.
dotGraph :: Graph -> String
dotGraph g =
    let (Graph _ _ ks us) = g
        ls = concat [["digraph Anonymous {"]
                    ,map dot_node_k ks
                    ,map (dot_node_u g) us
                    ,map (dot_edge g) (edges us)
                    ,["}"]]
    in unlines ls

view_with :: String -> String -> IO ()
view_with x v = do
  d <- getTemporaryDirectory
  let f = d </> "hsc3.dot"
  withFile f WriteMode (`hPutStr` x)
  _ <- system (v ++ " " ++ f)
  return ()

data ToPort = ToPort Int Int
              deriving (Eq,Show)

type Edge = (FromPort,ToPort)
type Edges = [Edge]

find_node :: Graph -> Int -> Node
find_node (Graph _ cs ks us) n =
    fromJust (find (\x -> node_id x == n) (cs ++ ks ++ us))

edges :: [Node] -> Edges
edges =
    let f (NodeU x _ _ i _ _ _) = zip i (map (ToPort x) [0..])
        f _ = error "edges"
    in concatMap f

record :: String -> String -> [[String]] -> String
record lbl clr slt =
    let f l = concat ["{",g l,"}"]
        g = intercalate "|"
    in concat [lbl
              ,"[shape=\"record\","
              ,"color=\"",clr,"\","
              ,"label=\"{",g (map f slt),"}\"];"]

label :: Node -> String
label nd =
    case nd of
      NodeC n _ -> "N_" ++ show n
      NodeK n _ _ _ _ -> "C_" ++ show n
      NodeU n _ _ _ _ _ _ -> "U_" ++ show n
      NodeP n _ _ -> "U_" ++ show n

port_indx :: FromPort -> Int
port_indx (FromPort_U _ x) = x
port_indx _ = 0

is_node_c :: Node -> Bool
is_node_c (NodeC _ _) = True
is_node_c _ = False

is_node_u :: Node -> Bool
is_node_u (NodeU _ _ _ _ _ _ _) = True
is_node_u _ = False

dot_edge :: Graph -> Edge -> String
dot_edge g (l,ToPort ri rn) =
    let ln = find_node g (port_nid l)
    in if is_node_c ln
       then ""
       else concat [label ln
                   ,if is_node_u ln
                    then ":O_" ++ show (port_indx l)
                    else ""
                   ," -> "
                   ,label (find_node g ri)
                   ,":I_"
                   ,show rn
                   ,";"]

rate_color :: Rate -> String
rate_color AR = "black"
rate_color KR = "blue"
rate_color IR = "yellow"
rate_color DR = "red"

input :: Graph -> FromPort -> Int -> String
input g (FromPort_C n) _ = show (node_c_value (find_node g n))
input _ _ i = "<I_" ++ show i ++ ">"

name :: String -> Int -> String
name "UnaryOpUGen" n = unaryName n
name "BinaryOpUGen" n = binaryName n
name n _ = n

is_implicit_control :: Node -> Bool
is_implicit_control (NodeU x _ s _ _ _ _) =
    let cs = ["AudioControl","Control","TrigControl"]
    in x == -1 && s `elem` cs
is_implicit_control _ = False

dot_node_u :: Graph -> Node -> String
dot_node_u g u =
    let lbl = label u
        clr = rate_color (node_u_rate u)
        i = node_u_inputs u
        i' = length i - 1
        (Special s) = node_u_special u
        upr = name (node_u_name u) s : zipWith (input g) i [0..i']
        o = length (node_u_outputs u) - 1
        lwr = map (\j -> "<O_" ++ show j ++ ">") [0..o]
    in if is_implicit_control u
       then ""
       else record lbl clr [upr,lwr]

dot_node_k :: Node -> String
dot_node_k u =
    concat [label u
           ,"[shape=\"trapezium\",color=\""
           ,rate_color (node_k_rate u)
           ,"\",label=\""
           ,node_k_name u,":",show (node_k_default u)
           ,"\"];"]

-- Read the environment variable @DOTVIEWER@, the default value is
-- @"dotty"@.
get_dot_viewer :: IO String
get_dot_viewer = do
  r <- tryJust (guard . isDoesNotExistError) (getEnv "DOTVIEWER")
  case r of
    Right v -> return v
    _ -> return "dotty"