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 = [('<',"&lt;"),('>',"&gt;"),('&',"&amp;")]
        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

-- | 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)