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 qualified Sound.SC3.UGen.Dot.Common as C
import qualified Sound.SC3.UGen.Dot.Type as D
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 = C.bracket1 ('[',']') . intercalate "," . mapMaybe attr_pp_maybe
attr_set_pp :: String -> [Attr] -> String
attr_set_pp nm attr = concat [nm," ",attr_list_pp attr,";"]
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 :: D.Dot_Options -> [String]
std_style o =
[attr_set_pp "graph" [("splines",bool_pp (D.use_splines o))
,("size",maybe "" size_pp (D.graph_size o))]
,attr_set_pp "node" [("fontsize",C.int_pp (D.font_size o))
,("fontname",C.string_pp (D.font_name o))]
,attr_set_pp "edge" [("arrowhead","box")
,("arrowsize","0.25")]]
dotGraph :: D.Dot_Options -> S.Graph -> String
dotGraph o g =
let (S.Graph _ _ ks us) = g
ls = concat [["digraph Anonymous {"]
,std_style o
,if D.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 :: D.Dot_Options -> String -> IO ()
view_with o x = do
v <- get_viewer o
let d = D.output_directory o
f = d </> D.output_file_name o
f_dot = f <.> "dot"
f_svg = f <.> "svg"
f_svg_gz = f_svg <.> "gz"
f_view = case D.output_format o of
D.DOT -> f_dot
D.SVG -> f_svg
D.SVG_GZ -> f_svg_gz
gen_svg = rawSystem "dot" ["-T","svg",f_dot,"-o",f_svg]
writeFile f_dot x
when (D.output_format o `elem` [D.SVG,D.SVG_GZ]) (void gen_svg)
when (D.output_format o == D.SVG_GZ) (void (rawSystem "gzip" ["-f",f_svg]))
when (False && D.output_format o /= D.DOT) (removeFile f_dot)
void (rawSystem v [f_view])
data IP = IP_Label String
| IP_Port String Char Int
| IP_Const (Maybe String,String,Int) S.Sample
limit_precision_o :: D.Dot_Options -> S.Sample -> String
limit_precision_o o = C.limit_precision (D.indicate_precision o) (D.numeric_precision o)
ip_record :: D.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 :: D.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
a = if D.use_attr_id o then printf " ID=\"%s:%s\"" u p else ""
in printf "<TD PORT=\"%s\"%s></TD>" p a
IP_Const (k,u,p) n ->
let p' = "K_" ++ show p
n' = limit_precision_o o n
l = maybe "" (++":") k ++ n'
a = if D.use_attr_id o then printf " ID=\"%s:%s\"" u p' else ""
in printf "<TD%s>%s</TD>" a l
record :: D.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",C.string_pp "record")
,("color",C.string_pp clr)
,("label",C.label_pp lbl)]
table :: D.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",C.string_pp "plaintext")
,("color",C.string_pp clr)
,("label",concat ["<<TABLE BORDER=\"0\" CELLBORDER=\"1\">"
,f [] upr ++ f e lwr
,"</TABLE>>"])]
dot_edge :: D.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 D.fix_edge_location o then ":s" else ""
clr = if D.colour_edges o then S.rate_color (S.node_rate ln) else "black"
in if S.is_node_c ln || S.is_node_k ln && D.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
," [color=",clr,"]"
,";"]
input :: D.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 D.inline_controls o
then let Just n = S.find_node g i
l = if D.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 :: D.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_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 D.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",C.string_pp c)
dot_node_k_rec :: D.Dot_Options -> S.Node -> String
dot_node_k_rec o u =
attr_set_pp
(S.node_label u)
[("shape",C.string_pp "rect")
,dot_node_k_color u
,("label",C.string_pp (S.node_k_name u ++ ":" ++ limit_precision_o o (S.node_k_default u)))]
dot_node_k_html :: D.Dot_Options -> S.Node -> String
dot_node_k_html o u =
attr_set_pp
(S.node_label u)
[("shape",C.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 :: D.Dot_Options -> S.Node -> String
dot_node_k o =
if D.use_tables o
then dot_node_k_html o
else dot_node_k_rec o
get_viewer :: D.Dot_Options -> IO String
get_viewer o =
if D.output_format o == D.DOT
then S.get_env_default "DOTVIEWER" (D.dot_viewer o)
else S.get_env_default "SVGVIEWER" (D.svg_viewer o)