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
import System.Directory
import System.Environment
import System.FilePath
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
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)
,"\"];"]
get_dot_viewer :: IO String
get_dot_viewer = do
r <- tryJust (guard . isDoesNotExistError) (getEnv "DOTVIEWER")
case r of
Right v -> return v
_ -> return "dotty"