module Sound.SC3.UGen.Dot.Internal where
import Control.Monad
import Data.List
import Data.Maybe
import Sound.SC3 as S
import Sound.SC3.Server.Synthdef.Internal as S
import Sound.SC3.UGen.Dot.Type
import System.IO
import System.Cmd
import System.Directory
import System.FilePath
import Text.Printf
std_style :: Dot_Options -> [String]
std_style o =
let s = if use_splines o then "true" else "false"
sz = font_size o
nm = font_name o
in [printf "graph [splines=%s];" s
,printf "node [fontsize=%d,fontname=\"%s\"];" sz nm
,"edge [arrowhead=box,arrowsize=0.25];"]
dotGraph :: Dot_Options -> S.Graph -> String
dotGraph o g =
let (S.Graph _ _ ks us) = g
ls = concat [["digraph Anonymous {"]
,std_style o
,if inline_controls o
then []
else map (dot_node_k o) ks
,map (dot_node_u o g) us
,map (dot_edge o g) (S.edges us)
,["}"]]
in unlines (filter (not.null) ls)
view_with :: Dot_Options -> String -> IO ()
view_with o x = do
v <- get_viewer o
let d = output_directory o
f = d </> output_file_name o
f_dot = f <.> "dot"
f_svg = f <.> "svg"
f_svg_gz = f_svg <.> "gz"
f_view = case output_format o of
DOT -> f_dot
SVG -> f_svg
SVG_GZ -> f_svg_gz
gen_svg = rawSystem "dot" ["-T","svg",f_dot,"-o",f_svg]
withFile f_dot WriteMode (`hPutStr` x)
when (output_format o `elem` [SVG,SVG_GZ]) (void gen_svg)
when (output_format o == SVG_GZ) (void (rawSystem "gzip" ["-f",f_svg]))
when (output_format o /= DOT) (removeFile f_dot)
_ <- rawSystem v [f_view]
return ()
data IP = IP_Label String
| IP_Port String Char Int
| IP_Const (Maybe String,String,Int) Double
right_variant :: ([a] -> [b]) -> [a] -> [b]
right_variant f = reverse . f . reverse
limit_precision_p :: Int -> Double -> String
limit_precision_p n c =
let i = printf "%.*f" n c
in right_variant (dropWhile (== '.') . dropWhile (== '0')) i
limit_precision_e :: Int -> Double -> String
limit_precision_e n c =
let (i,_:j) = break (== '.') (show c)
(k,l) = break (== 'e') j
f :: String -> Int
f m = round ((read (take (n + 1) m) :: Double) / 10)
k' = if length k > n
then show (f k)
else k
in i ++ if k == "0"
then l
else "." ++ k' ++ l
limit_precision :: Int -> Double -> String
limit_precision n c =
if c < 0.001 || c > 1e6
then limit_precision_e n c
else limit_precision_p n c
limit_precision_o :: Dot_Options -> Double -> String
limit_precision_o o = limit_precision (numeric_precision o)
ip_record :: Dot_Options -> IP -> String
ip_record o i =
case i of
IP_Label l -> l
IP_Port _ d n -> '<' : d : '_' : show n ++ ">"
IP_Const _ n -> limit_precision_o o n
escape_html :: String -> String
escape_html =
let t = [('<',"<"),('>',">"),('&',"&")]
f c = fromMaybe [c] (lookup c t)
in concatMap f
ip_html :: Dot_Options -> IP -> String
ip_html o i =
case i of
IP_Label l -> printf "<TD>%s</TD>" (escape_html l)
IP_Port u c n ->
let p = c : '_' : show n
in printf "<TD PORT=\"%s\" ID=\"%s:%s\"></TD>" p u p
IP_Const (k,u,p) n ->
let p' = "K_" ++ show p
n' = limit_precision_o o n
l = maybe "" (++":") k ++ n'
in printf "<TD ID=\"%s:%s\">%s</TD>" u p' l
record :: Dot_Options -> String -> String -> ([IP],[IP]) -> String
record o nm clr (upr,lwr) =
let f l = concat ["{",g (map (ip_record o) l),"}"]
g = intercalate "|"
lbl = g [f upr,f lwr]
in printf "%s [shape=\"record\",color=\"%s\",label=\"{%s}\"];" nm clr lbl
table :: Dot_Options -> String -> String -> ([IP],[IP]) -> String
table o lbl clr (upr,lwr) =
let k = length upr length lwr
e = concat (replicate k "<TD BORDER=\"0\"></TD>")
f p l = if null l
then ""
else concat ["<TR>",p ++ concatMap (ip_html o) l,"</TR>"]
in concat [lbl
,"[shape=\"plaintext\","
,"color=\"",clr,"\","
,"label=<<TABLE BORDER=\"0\" CELLBORDER=\"1\">"
,f [] upr ++ f e lwr
,"</TABLE>>];"]
dot_edge :: Dot_Options -> S.Graph -> S.Edge -> String
dot_edge o g (l,S.ToPort ri rn) =
let Just ln = S.find_node g (S.port_nid l)
s = if fix_edge_location o then ":s" else ""
in if S.is_node_c ln || S.is_node_k ln && inline_controls o
then ""
else concat [S.node_label ln
,if S.is_node_u ln
then ":o_" ++ show (S.port_idx_or_zero l) ++ s
else if S.is_node_k ln
then ":o_0"
else ""
," -> "
,let Just ri_n = S.find_node g ri in S.node_label ri_n
,":i_"
,show rn
,";"]
input :: Dot_Options -> S.Graph -> S.Node -> S.FromPort -> Int -> IP
input o g u fp k =
case fp of
S.FromPort_C i -> let Just n = S.find_node g i
in IP_Const (Nothing,S.node_label u,k) (S.node_c_value n)
S.FromPort_K i _ -> if inline_controls o
then let Just n = S.find_node g i
l = if display_control_names o
then Just (S.node_k_name n)
else Nothing
in IP_Const (l,S.node_label u,k) (S.node_k_default n)
else IP_Port (S.node_label u) 'i' k
_ -> IP_Port (S.node_label u) 'i' k
dot_node_u :: Dot_Options -> S.Graph -> S.Node -> String
dot_node_u o g u =
let lbl = S.node_label u
clr = S.rate_color (S.node_u_rate u)
i = S.node_u_inputs u
i' = length i 1
s = S.node_u_special u
upr = IP_Label (S.ugen_user_name (S.node_u_name u) s) :
zipWith (input o g u) i [0..i']
lwr = map (IP_Port (S.node_label u) 'o') [0 .. length (S.node_u_outputs u) 1]
f = if use_tables o then table o else record o
in if S.is_implicit_control u
then ""
else f lbl clr (upr,lwr)
dot_node_k_rec :: Dot_Options -> S.Node -> String
dot_node_k_rec o u =
concat [S.node_label u
,"[shape=\"rect\",color=\""
,S.rate_color (S.node_k_rate u)
,"\",label=\""
,S.node_k_name u
,":"
,limit_precision_o o (S.node_k_default u)
,"\"];"]
dot_node_k_html :: Dot_Options -> S.Node -> String
dot_node_k_html o u =
concat [S.node_label u
,"[shape=\"plaintext\",color=\""
,S.rate_color (S.node_k_rate u)
,"\",label=<<TABLE BORDER=\"0\" CELLBORDER=\"1\"><TR><TD PORT=\"o_0\">"
,S.node_k_name u
,":"
,limit_precision_o o (S.node_k_default u)
,"</TD></TR></TABLE>>];"]
dot_node_k :: Dot_Options -> S.Node -> String
dot_node_k o =
if use_tables o
then dot_node_k_html o
else dot_node_k_rec o
get_viewer :: Dot_Options -> IO String
get_viewer o =
if output_format o == DOT
then get_env_default "DOTVIEWER" (dot_viewer o)
else get_env_default "SVGVIEWER" (svg_viewer o)