diff --git a/README b/README --- a/README +++ b/README @@ -1,13 +1,27 @@ hsc3-dot - haskell supercollider dot +------------------------------------ -hsc3-dot provides dot graph drawing for SuperCollider unit generator -graphs. The graph rendering is delegated to graphviz, which must be -installed. +[hsc3-dot][hsc3-dot] provides [dot][dot] graph drawing for +[SuperCollider][sc3] unit generator graphs generated by the +[hsc3][hsc3] [haskell][hs] library. - http://slavepianos.org/rd/?t=hsc3-dot - http://haskell.org/ - http://audiosynth.com/ - http://graphviz.org/ +The graph rendering is delegated to [graphviz][graphviz], which must +be installed. -(c) rohan drape, 2006-2011 - gpl, http://gnu.org/copyleft/ +There is an +[entry](?t=hsc3-texts&l=lhs/hsc3-tutorial.lhs#ugen-graph-drawings) +at the [hsc3-texts](?t=hsc3-texts) +[tutorial](?t=hsc3-texts&l=lhs/hsc3-tutorial.lhs). + +[hs]: http://haskell.org/ +[sc3]: http://audiosynth.com/ +[graphviz]: http://graphviz.org/ +[dot]: http://www.graphviz.org/doc/info/lang.html +[hsc3-dot]: http://rd.slavepianos.org/?t=hsc3-dot +[hsc3-texts]: http://rd.slavepianos.org/?t=hsc3-texts +[hsc3]: http://rd.slavepianos.org/?t=hsc3 + +© [rohan drape][rd], 2006-2012, [gpl] + +[rd]: http://rd.slavepianos.org/ +[gpl]: http://gnu.org/copyleft/ diff --git a/Sound/SC3/UGen/Dot.hs b/Sound/SC3/UGen/Dot.hs --- a/Sound/SC3/UGen/Dot.hs +++ b/Sound/SC3/UGen/Dot.hs @@ -9,12 +9,19 @@ -- -- > draw (out 0 (sinOsc AR 440 0 * 0.1)) -- +-- As above, but using the /record/ interface. +-- +-- > import Sound.SC3.UGen.Dot.Type +-- +-- > let o = dot_options {use_tables = False} +-- > in draw_with_opt o (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 +-- With k-rate & i-rate subgraphs -- -- > let {l = rand 'a' 200 400 -- > ;m = rand 'b' l 600 @@ -27,6 +34,19 @@ -- > let f = control KR "freq" 440 -- > in draw (out 0 (sinOsc AR f 0 * 0.1)) -- +-- As above but with inlined controls. +-- +-- > let {f = control KR "freq" 440 +-- > ;o = dot_options {inline_controls = True}} +-- > in draw_with_opt o (out 0 (sinOsc AR f 0 * 0.1)) +-- +-- As above but without control name label. +-- +-- > let {o = dot_options {inline_controls = True +-- > ,display_control_names = False} +-- > ;f = control KR "freq" 440} +-- > in draw_with_opt o (out 0 (sinOsc AR f 0 * 0.1)) +-- -- With multiple channel expansion. -- -- > let f = mce2 440 220 @@ -38,164 +58,54 @@ -- > ;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 +-- +-- With multiple channel UGen. +-- +-- > draw (out 0 (pan2 (sinOsc AR 440 0 * 0.1) 0 1)) +-- +-- With reserved labels (ie. <,>,&). +-- +-- > draw_svg (out 0 (sinOsc AR 440 0 >* 0)) +module Sound.SC3.UGen.Dot where -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 - ,";"] +import Sound.SC3.UGen.Dot.Class +import Sound.SC3.UGen.Dot.Internal +import Sound.SC3.UGen.Dot.Type -rate_color :: Rate -> String -rate_color AR = "black" -rate_color KR = "blue" -rate_color IR = "yellow" -rate_color DR = "red" +dot :: Drawable a => a -> String +dot = dot_with_opt dot_options -input :: Graph -> FromPort -> Int -> String -input g (FromPort_C n) _ = show (node_c_value (find_node g n)) -input _ _ i = "" +dot_svg :: Drawable a => a -> String +dot_svg = dot_with_opt svg_options -name :: String -> Int -> String -name "UnaryOpUGen" n = unaryName n -name "BinaryOpUGen" n = binaryName n -name n _ = n +draw_with_opt :: Drawable a => Dot_Options -> a -> IO () +draw_with_opt o x = view_with o (dot_with_opt o x) -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 +draw :: Drawable a => a -> IO () +draw = draw_with_opt dot_options -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 -> "") [0..o] - in if is_implicit_control u - then "" - else record lbl clr [upr,lwr] +draw_svg :: Drawable a => a -> IO () +draw_svg = draw_with_opt svg_options -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) - ,"\"];"] +-- | Default @dot@ format 'Dot_Options'. +dot_options :: Dot_Options +dot_options = Dot_Options + {use_tables = True + ,use_splines = False + ,output_format = DOT + ,output_directory = "/tmp" + ,output_file_name = "hsc3" + ,fix_edge_location = False + ,numeric_precision = 3 + ,inline_controls = False + ,display_control_names = True + ,dot_viewer = "dotty" + ,svg_viewer = "rsvg-view" + ,font_name = "Courier" + ,font_size = 12 + } --- 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" +-- | Default @svg@ format 'Dot_Options'. +svg_options :: Dot_Options +svg_options = dot_options {output_format = SVG + ,fix_edge_location = True} diff --git a/Sound/SC3/UGen/Dot/Class.hs b/Sound/SC3/UGen/Dot/Class.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/UGen/Dot/Class.hs @@ -0,0 +1,20 @@ +module Sound.SC3.UGen.Dot.Class where + +import Sound.SC3 as S +import Sound.SC3.UGen.Dot.Internal +import Sound.SC3.UGen.Dot.Type + +-- | 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_with_opt :: Dot_Options -> a -> String + +instance Drawable S.Graph where + dot_with_opt = dotGraph + +instance Drawable S.UGen where + dot_with_opt o = dotGraph o . S.synth + +instance Drawable S.Synthdef where + dot_with_opt o = dotGraph o . S.synthdefGraph diff --git a/Sound/SC3/UGen/Dot/Internal.hs b/Sound/SC3/UGen/Dot/Internal.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/UGen/Dot/Internal.hs @@ -0,0 +1,225 @@ +module Sound.SC3.UGen.Dot.Internal where + +import Control.Monad +import Data.List +import Data.Maybe +import Sound.SC3 as S {- hsc3 -} +import Sound.SC3.Server.Synthdef.Internal as S +import Sound.SC3.UGen.Dot.Type +import System.IO +import System.Cmd {- process -} +import System.Directory {- directory -} +import System.FilePath {- 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];"] + +-- Generate dot representation of the provided unit generator graph. +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 + +-- > drop_while_right f = right_variant (dropWhile f) +right_variant :: ([a] -> [b]) -> [a] -> [b] +right_variant f = reverse . f . reverse + +-- > map (limit_precision_p 3) [1,1.25,0.05,pi*1e8,1e9] +limit_precision_p :: Int -> Double -> String +limit_precision_p n c = + let i = printf "%.*f" n c + in right_variant (dropWhile (== '.') . dropWhile (== '0')) i + +-- > map (limit_precision_e 3) [1,1.25,0.05,pi*1e8,1e9] +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 + +-- > map (limit_precision 3) [1,1.25,0.05,pi*1e8,1e9] +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 "%s" (escape_html l) + IP_Port u c n -> + let p = c : '_' : show n + in printf "" 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 "%s" 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 "") + f p l = if null l + then "" + else concat ["",p ++ concatMap (ip_html o) l,""] + in concat [lbl + ,"[shape=\"plaintext\"," + ,"color=\"",clr,"\"," + ,"label=<" + ,f [] upr ++ f e lwr + ,"
>];"] + +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=<
" + ,S.node_k_name u + ,":" + ,limit_precision_o o (S.node_k_default u) + ,"
>];"] + +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 + +-- | Considering 'output_format' read either the environment variable +-- @DOTVIEWER@ or @SVGVIEWER@, the default values are 'dot_viewer' and +-- 'svg_viewer'. +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) diff --git a/Sound/SC3/UGen/Dot/Type.hs b/Sound/SC3/UGen/Dot/Type.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/UGen/Dot/Type.hs @@ -0,0 +1,21 @@ +module Sound.SC3.UGen.Dot.Type where + +-- | Dot output formats. +data Dot_Format = DOT | SVG | SVG_GZ deriving (Eq) + +-- | Dot options record. +data Dot_Options = Dot_Options + {use_tables :: Bool -- ^ Select @record@ or @html/table@ rendering. + ,use_splines :: Bool -- ^ Select edge rendering + ,output_format :: Dot_Format -- ^ Select viewer format. + ,fix_edge_location :: Bool -- ^ Select output port edge location. + ,numeric_precision :: Int -- ^ Printing precision for constants. + ,inline_controls :: Bool + ,display_control_names :: Bool + ,output_directory :: FilePath -- ^ File name (without suffix). + ,output_file_name :: String -- ^ File name (without suffix). + ,dot_viewer :: String -- ^ @dot@ file viewer (ie. "dotty") + ,svg_viewer :: String -- ^ @svg@ file viewer (ie. "rsvg-view","inkview") + ,font_name :: String -- ^ Name of font to use + ,font_size :: Int -- ^ Font size + } diff --git a/hsc3-dot.cabal b/hsc3-dot.cabal --- a/hsc3-dot.cabal +++ b/hsc3-dot.cabal @@ -1,16 +1,16 @@ Name: hsc3-dot -Version: 0.11 +Version: 0.12 Synopsis: haskell supercollider graph drawing Description: dot format graph generator for SuperCollider unit generator graphs constructed using hsc3. License: GPL Category: Sound -Copyright: (c) Rohan Drape, 2006-2011 +Copyright: (c) Rohan Drape, 2006-2012 Author: Rohan Drape Maintainer: rd@slavepianos.org Stability: Experimental -Homepage: http://slavepianos.org/rd/?t=hsc3-dot -Tested-With: GHC == 7.2.2 +Homepage: http://rd.slavepianos.org/?t=hsc3-dot +Tested-With: GHC == 7.6.1 Build-Type: Simple Cabal-Version: >= 1.8 @@ -20,11 +20,14 @@ Build-Depends: base == 4.*, directory, filepath, - hsc3 == 0.11.*, + hsc3 == 0.12.*, process GHC-Options: -Wall -fwarn-tabs Exposed-modules: Sound.SC3.UGen.Dot + Sound.SC3.UGen.Dot.Class + Sound.SC3.UGen.Dot.Internal + Sound.SC3.UGen.Dot.Type Source-Repository head Type: darcs - Location: http://slavepianos.org/rd/sw/hsc3-dot/ + Location: http://rd.slavepianos.org/sw/hsc3-dot/