-- | Implementation of @Dot@ language writer.
module Sound.SC3.UGen.Dot.Internal where

import Control.Monad {- base -}
import Data.Char {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import System.Directory {- directory -}
import System.FilePath {- filepath -}
import System.Process {- process -}
import Text.Printf {- base -}

import qualified Sound.SC3 as S {- hsc3 -}
import qualified Sound.SC3.UGen.Graph as S {- hsc3 -}
import Sound.SC3.UGen.Dot.Type {- hsc3-dot -}

-- | Bracket with elements.
bracket1 :: (a,a) -> [a] -> [a]
bracket1 (l,r) x = [l] ++ x ++ [r]

-- | Bracket with lists.
bracket :: ([a],[a]) -> [a] -> [a]
bracket (l,r) x = l ++ x ++ r

-- | 'bracket' with double quotes.
string_pp :: String -> String
string_pp = bracket1 ('"','"')

-- | 'bracket' with double quotes and braces.
label_pp :: String -> String
label_pp = bracket ("\"{","}\"")

-- | Key value pair.
type Attr = (String,String)

-- | Dot attributes are written @key=value@.
attr_pp :: Attr -> String
attr_pp (k,v) = k ++ "=" ++ v

-- | If @value@ is 'null' then 'Nothing'.
attr_pp_maybe :: Attr -> Maybe String
attr_pp_maybe (k,v) = if null v then Nothing else Just (attr_pp (k,v))

-- | Attribute lists are in square brackets and comma seperated.
attr_list_pp :: [Attr] -> String
attr_list_pp = bracket1 ('[',']') . intercalate "," . mapMaybe attr_pp_maybe

-- | Attribute sets are named and semi-colon terminated.
attr_set_pp :: String -> [Attr] -> String
attr_set_pp nm attr = concat [nm," ",attr_list_pp attr,";"]

-- | Type specialised 'show'.
int_pp :: Int -> String
int_pp = show

-- | Size is given as @(width,height)@.
size_pp :: (Double,Double) -> String
size_pp (x,y) = printf "\"%f,%f\"" x y

-- | 'toLower' of 'show'.
bool_pp :: Bool -> String
bool_pp = map toLower . show

-- | Basic attribute sets given 'Dot_Options'.
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")]]

-- | 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 @dot@ graph according to 'Dot_Options'.
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 ()

-- | Input port.
data IP = IP_Label String
        | IP_Port String Char Int
        | IP_Const (Maybe String,String,Int) S.Sample

-- | 'reverse' of /f/ of 'reverse'.
--
-- > let drop_while_right f = right_variant (dropWhile f)
-- > in drop_while_right isUpper "abcDEF" == "abc"
right_variant :: ([a] -> [b]) -> [a] -> [b]
right_variant f = reverse . f . reverse

-- | Limited precision PP for 'S.Sample', no scientific notation.
--
-- > map (limit_precision_p True 2) [1,1.25,1.12345,0,0.05,pi*1e8,1e9]
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

-- | Limited precision PP for 'S.Sample', with scientific notation.
--
-- > map (limit_precision_e 3) [1,1.25,0.05,pi*1e8,1e9]
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

-- | Variant selecting scientific notation more cautiously than haskells default PP.
--
-- > map (limit_precision True 3) [1,1.25,0.05,0,pi*1e8,1e9]
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

-- | Variant of 'limit_precision' reading parameters from 'Dot_Options'.
limit_precision_o :: Dot_Options -> S.Sample -> String
limit_precision_o o = limit_precision (indicate_precision o) (numeric_precision o)

-- | IP in record form.
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

-- | Very rudimentary HTML escaping.
escape_html :: String -> String
escape_html =
    let t = [('<',"&lt;"),('>',"&gt;"),('&',"&amp;")]
        f c = fromMaybe [c] (lookup c t)
    in concatMap f

-- | 'IP' as @HTML@ string.
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

-- | 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 S.get_env_default "DOTVIEWER" (dot_viewer o)
    else S.get_env_default "SVGVIEWER" (svg_viewer o)