module Sound.SC3.UGen.Dot.Internal where
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import System.Directory
import System.FilePath
import System.Process
import Text.Printf
import qualified Sound.SC3 as S
import qualified Sound.SC3.UGen.Graph as S
import Sound.SC3.UGen.Dot.Type
bracket1 :: (a,a) -> [a] -> [a]
bracket1 (l,r) x = [l] ++ x ++ [r]
bracket :: ([a],[a]) -> [a] -> [a]
bracket (l,r) x = l ++ x ++ r
string_pp :: String -> String
string_pp = bracket1 ('"','"')
label_pp :: String -> String
label_pp = bracket ("\"{","}\"")
type Attr = (String,String)
attr_pp :: Attr -> String
attr_pp (k,v) = k ++ "=" ++ v
attr_pp_maybe :: Attr -> Maybe String
attr_pp_maybe (k,v) = if null v then Nothing else Just (attr_pp (k,v))
attr_list_pp :: [Attr] -> String
attr_list_pp = bracket1 ('[',']') . intercalate "," . mapMaybe attr_pp_maybe
attr_set_pp :: String -> [Attr] -> String
attr_set_pp nm attr = concat [nm," ",attr_list_pp attr,";"]
int_pp :: Int -> String
int_pp = show
size_pp :: (Double,Double) -> String
size_pp (x,y) = printf "\"%f,%f\"" x y
bool_pp :: Bool -> String
bool_pp = map toLower . show
std_style :: Dot_Options -> [String]
std_style o =
[attr_set_pp "graph" [("splines",bool_pp (use_splines o))
,("size",maybe "" size_pp (graph_size o))]
,attr_set_pp "node" [("fontsize",int_pp (font_size o))
,("fontname",string_pp (font_name o))]
,attr_set_pp "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]
writeFile f_dot 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 (False && 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) S.Sample
right_variant :: ([a] -> [b]) -> [a] -> [b]
right_variant f = reverse . f . reverse
limit_precision_p :: Bool -> Int -> S.Sample -> String
limit_precision_p r n c =
let i = printf "%.*f" n c
in if r
then i
else right_variant (dropWhile (== '.') . dropWhile (== '0')) i
limit_precision_e :: Int -> S.Sample -> 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) :: S.Sample) / 10)
k' = if length k > n
then show (f k)
else k
in i ++ if k == "0"
then l
else "." ++ k' ++ l
limit_precision :: Bool -> Int -> S.Sample -> String
limit_precision r n c =
if c /= 0 && (c < (10 ** fromIntegral ( n)) || c > 1e6)
then limit_precision_e n c
else limit_precision_p r n c
limit_precision_o :: Dot_Options -> S.Sample -> String
limit_precision_o o = limit_precision (indicate_precision o) (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 attr_set_pp nm [("shape",string_pp "record")
,("color",string_pp clr)
,("label",label_pp 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 attr_set_pp
lbl
[("shape",string_pp "plaintext")
,("color",string_pp clr)
,("label",concat ["<<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 = let n = length (S.node_u_outputs u) 1
in map (IP_Port (S.node_label u) 'o') [0 .. n]
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_color :: S.Node -> Attr
dot_node_k_color k =
let c = if S.node_k_type k == S.K_TR
then "cyan"
else S.rate_color (S.node_k_rate k)
in ("color",string_pp c)
dot_node_k_rec :: Dot_Options -> S.Node -> String
dot_node_k_rec o u =
attr_set_pp
(S.node_label u)
[("shape",string_pp "rect")
,dot_node_k_color u
,("label",string_pp (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 =
attr_set_pp
(S.node_label u)
[("shape",string_pp "plaintext")
,dot_node_k_color u
,("label",concat ["<<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 S.get_env_default "DOTVIEWER" (dot_viewer o)
else S.get_env_default "SVGVIEWER" (svg_viewer o)