-- | Graph (dot) functions.
module Music.Theory.Graph.Dot where

import Control.Monad {- base -}
import Data.Char {- base -}
import Data.List {- base -}
import System.FilePath {- filepath -}
import System.Process {- process -}

import qualified Data.Graph.Inductive.Graph as G {- fgl -}

import qualified Music.Theory.Graph.Type as T {- hmt-base -}
import qualified Music.Theory.List as List {- hmt-base -}
import qualified Music.Theory.Show as Show {- hmt-base -}

import qualified Music.Theory.Graph.Fgl as T {- hmt -}

-- * Util

-- | Classify /s/ using a first element predicate, a remainder predicate and a unit predicate.
s_classify :: (t -> Bool) -> (t -> Bool) -> ([t] -> Bool) -> [t] -> Bool
s_classify :: forall t.
(t -> Bool) -> (t -> Bool) -> ([t] -> Bool) -> [t] -> Bool
s_classify t -> Bool
p t -> Bool
q [t] -> Bool
r [t]
s =
  case [t]
s of
    t
c0:[t]
s' -> t -> Bool
p t
c0 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all t -> Bool
q [t]
s' Bool -> Bool -> Bool
&& [t] -> Bool
r [t]
s
    [] -> Bool
False

-- | Symbol rule.
--
-- > map is_symbol ["sym","Sym2","3sym","1",""] == [True,True,False,False,False]
is_symbol :: String -> Bool
is_symbol :: Dot_Type -> Bool
is_symbol = forall t.
(t -> Bool) -> (t -> Bool) -> ([t] -> Bool) -> [t] -> Bool
s_classify Char -> Bool
isAlpha Char -> Bool
isAlphaNum (forall a b. a -> b -> a
const Bool
True)

-- | Number rule.
--
-- > map is_number ["123","123.45",".25","1.","1.2.3",""] == [True,True,False,True,False,False]
is_number :: String -> Bool
is_number :: Dot_Type -> Bool
is_number = forall t.
(t -> Bool) -> (t -> Bool) -> ([t] -> Bool) -> [t] -> Bool
s_classify Char -> Bool
isDigit (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'.') ((forall a. Ord a => a -> a -> Bool
< Int
2) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Char
'.' forall a. Eq a => a -> a -> Bool
==))

-- | Quote /s/ if 'is_symbol' or 'is_number'.
--
-- > map maybe_quote ["abc","a b c","12","12.3"] == ["abc","\"a b c\"","12","12.3"]
maybe_quote :: String -> String
maybe_quote :: Dot_Type -> Dot_Type
maybe_quote Dot_Type
s = if Dot_Type -> Bool
is_symbol Dot_Type
s Bool -> Bool -> Bool
|| Dot_Type -> Bool
is_number Dot_Type
s then Dot_Type
s else forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Dot_Type
"\"",Dot_Type
s,Dot_Type
"\""]

-- * Attr/Key

type Dot_Key = String
type Dot_Value = String
type Dot_Attr = (Dot_Key,Dot_Value)

-- | Format 'Dot_Attr'.
dot_attr_pp :: Dot_Attr -> String
dot_attr_pp :: Dot_Attr -> Dot_Type
dot_attr_pp (Dot_Type
lhs,Dot_Type
rhs) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Dot_Type
lhs,Dot_Type
"=",Dot_Type -> Dot_Type
maybe_quote Dot_Type
rhs]

-- | Format sequence of Dot_Attr.
--
-- > dot_attr_seq_pp [("layout","neato"),("epsilon","0.0001")]
dot_attr_seq_pp :: [Dot_Attr] -> String
dot_attr_seq_pp :: [Dot_Attr] -> Dot_Type
dot_attr_seq_pp [Dot_Attr]
opt =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Dot_Attr]
opt
  then Dot_Type
""
  else forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Dot_Type
"[",forall a. [a] -> [[a]] -> [a]
intercalate Dot_Type
"," (forall a b. (a -> b) -> [a] -> [b]
map Dot_Attr -> Dot_Type
dot_attr_pp [Dot_Attr]
opt),Dot_Type
"]"]

-- | Merge attributes, left-biased.
dot_attr_ext :: [Dot_Attr] -> [Dot_Attr] -> [Dot_Attr]
dot_attr_ext :: [Dot_Attr] -> [Dot_Attr] -> [Dot_Attr]
dot_attr_ext = forall k v. Eq k => [(k, v)] -> [(k, v)] -> [(k, v)]
List.assoc_merge

-- | graph|node|edge
type Dot_Type = String

-- | (type,[attr])
type Dot_Attr_Set = (Dot_Type,[Dot_Attr])

-- | Format Dot_Attr_Set.
--
-- > a = ("graph",[("layout","neato"),("epsilon","0.0001")])
-- > dot_attr_set_pp a == "graph [layout=neato,epsilon=0.0001]"
dot_attr_set_pp :: Dot_Attr_Set -> String
dot_attr_set_pp :: Dot_Attr_Set -> Dot_Type
dot_attr_set_pp (Dot_Type
ty,[Dot_Attr]
opt) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Dot_Type
ty,Dot_Type
" ",[Dot_Attr] -> Dot_Type
dot_attr_seq_pp [Dot_Attr]
opt]

-- | type:attr (type = graph|node|edge)
type Dot_Meta_Key = String

type Dot_Meta_Attr = (Dot_Meta_Key,Dot_Value)

-- | Keys are given as "type:attr".
--
-- > dot_key_sep "graph:layout" == ("graph","layout")
dot_key_sep :: Dot_Meta_Key -> (Dot_Type,Dot_Key)
dot_key_sep :: Dot_Type -> Dot_Attr
dot_key_sep = forall t. Eq t => [t] -> [t] -> ([t], [t])
List.split_on_1_err Dot_Type
":"

-- | Collate Dot_Key attribute set to Dot_Attr_Set.
dot_attr_collate :: [Dot_Meta_Attr] -> [Dot_Attr_Set]
dot_attr_collate :: [Dot_Attr] -> [Dot_Attr_Set]
dot_attr_collate [Dot_Attr]
opt =
    let f :: (Dot_Type, b) -> (Dot_Type, (Dot_Type, b))
f (Dot_Type
k,b
v) = let (Dot_Type
ty,Dot_Type
nm) = Dot_Type -> Dot_Attr
dot_key_sep Dot_Type
k in (Dot_Type
ty,(Dot_Type
nm,b
v))
        c :: [(Dot_Type, Dot_Attr)]
c = forall a b. (a -> b) -> [a] -> [b]
map forall {b}. (Dot_Type, b) -> (Dot_Type, (Dot_Type, b))
f [Dot_Attr]
opt
    in forall a b. Ord a => [(a, b)] -> [(a, [b])]
List.collate [(Dot_Type, Dot_Attr)]
c

-- | Default values for default meta-keys.
--
-- > k = dot_attr_def ("neato","century schoolbook",10,"plaintext")
-- > map dot_attr_set_pp (dot_attr_collate k)
dot_attr_def :: (String,String,Double,String) -> [Dot_Meta_Attr]
dot_attr_def :: (Dot_Type, Dot_Type, Double, Dot_Type) -> [Dot_Attr]
dot_attr_def (Dot_Type
ly,Dot_Type
fn,Double
fs,Dot_Type
sh) =
    [(Dot_Type
"graph:layout",Dot_Type
ly)
    ,(Dot_Type
"node:fontname",Dot_Type
fn)
    ,(Dot_Type
"node:fontsize",forall a. Show a => a -> Dot_Type
show Double
fs)
    ,(Dot_Type
"node:shape",Dot_Type
sh)]

-- * Graph

-- | Graph pretty-printer, (v -> [attr],e -> [attr])
type Graph_Pp v e = ((Int,v) -> [Dot_Attr],((Int,Int),e) -> [Dot_Attr])

-- | Make Graph_Pp value given label functions for vertices and edges.
gr_pp_label_m :: Maybe (v -> Dot_Value) -> Maybe (e -> Dot_Value) -> Graph_Pp v e
gr_pp_label_m :: forall v e.
Maybe (v -> Dot_Type) -> Maybe (e -> Dot_Type) -> Graph_Pp v e
gr_pp_label_m Maybe (v -> Dot_Type)
f_v Maybe (e -> Dot_Type)
f_e =
  let lift :: Maybe (t -> b) -> (a, t) -> [(Dot_Type, b)]
lift Maybe (t -> b)
m (a
_,t
x) = case Maybe (t -> b)
m of
                       Maybe (t -> b)
Nothing -> []
                       Just t -> b
f -> [(Dot_Type
"label",t -> b
f t
x)]
  in (forall {t} {b} {a}. Maybe (t -> b) -> (a, t) -> [(Dot_Type, b)]
lift Maybe (v -> Dot_Type)
f_v,forall {t} {b} {a}. Maybe (t -> b) -> (a, t) -> [(Dot_Type, b)]
lift Maybe (e -> Dot_Type)
f_e)

-- | Label V & E.
gr_pp_label :: (v -> Dot_Value) -> (e -> Dot_Value) -> Graph_Pp v e
gr_pp_label :: forall v e. (v -> Dot_Type) -> (e -> Dot_Type) -> Graph_Pp v e
gr_pp_label v -> Dot_Type
f_v e -> Dot_Type
f_e = forall v e.
Maybe (v -> Dot_Type) -> Maybe (e -> Dot_Type) -> Graph_Pp v e
gr_pp_label_m (forall a. a -> Maybe a
Just v -> Dot_Type
f_v) (forall a. a -> Maybe a
Just e -> Dot_Type
f_e)

-- | Label V only.
gr_pp_label_v :: (v -> Dot_Value) -> Graph_Pp v e
gr_pp_label_v :: forall v e. (v -> Dot_Type) -> Graph_Pp v e
gr_pp_label_v v -> Dot_Type
f = forall v e.
Maybe (v -> Dot_Type) -> Maybe (e -> Dot_Type) -> Graph_Pp v e
gr_pp_label_m (forall a. a -> Maybe a
Just v -> Dot_Type
f) forall a. Maybe a
Nothing

-- | br = brace, csl = comma separated list
br_csl_pp :: Show t => [t] -> String
br_csl_pp :: forall t. Show t => [t] -> Dot_Type
br_csl_pp [t]
l =
    case [t]
l of
      [t
e] -> forall a. Show a => a -> Dot_Type
show t
e
      [t]
_ -> forall a. (a, a) -> [a] -> [a]
List.bracket (Char
'{',Char
'}') (forall a. [a] -> [[a]] -> [a]
intercalate Dot_Type
"," (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Dot_Type
show [t]
l))

-- | Graph type, directed or un-directed.
data Graph_Type = Graph_Digraph | Graph_Ugraph

g_type_to_string :: Graph_Type -> String
g_type_to_string :: Graph_Type -> Dot_Type
g_type_to_string Graph_Type
ty =
    case Graph_Type
ty of
      Graph_Type
Graph_Digraph -> Dot_Type
"digraph"
      Graph_Type
Graph_Ugraph -> Dot_Type
"graph"

g_type_to_edge_symbol :: Graph_Type -> String
g_type_to_edge_symbol :: Graph_Type -> Dot_Type
g_type_to_edge_symbol Graph_Type
ty =
    case Graph_Type
ty of
      Graph_Type
Graph_Digraph -> Dot_Type
" -> "
      Graph_Type
Graph_Ugraph -> Dot_Type
" -- "

-- | Generate node position attribute given (x,y) coordinate.
node_pos_attr :: (Show n, Real n) => (n,n) -> Dot_Attr
node_pos_attr :: forall n. (Show n, Real n) => (n, n) -> Dot_Attr
node_pos_attr (n
x,n
y) = let pp :: n -> Dot_Type
pp = forall t. Real t => Int -> t -> Dot_Type
Show.real_pp_trunc Int
2 in (Dot_Type
"pos",forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [n -> Dot_Type
pp n
x,Dot_Type
",",n -> Dot_Type
pp n
y])

-- | Edge POS attributes are sets of cubic bezier control points.
edge_pos_attr :: Real t => [(t,t)] -> Dot_Attr
edge_pos_attr :: forall t. Real t => [(t, t)] -> Dot_Attr
edge_pos_attr [(t, t)]
pt =
  let r_pp :: t -> Dot_Type
r_pp = forall t. Real t => Int -> t -> Dot_Type
Show.real_pp_trunc Int
2
      pt_pp :: (t, t) -> Dot_Type
pt_pp (t
x,t
y) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [t -> Dot_Type
r_pp t
x,Dot_Type
",",t -> Dot_Type
r_pp t
y]
  in (Dot_Type
"pos",[Dot_Type] -> Dot_Type
unwords (forall a b. (a -> b) -> [a] -> [b]
map (t, t) -> Dot_Type
pt_pp [(t, t)]
pt))

-- | Variant that accepts single cubic bezier data set.
edge_pos_attr_1 :: Real t => ((t,t),(t,t),(t,t),(t,t)) -> Dot_Attr
edge_pos_attr_1 :: forall t. Real t => ((t, t), (t, t), (t, t), (t, t)) -> Dot_Attr
edge_pos_attr_1 ((t, t)
p1,(t, t)
p2,(t, t)
p3,(t, t)
p4) = forall t. Real t => [(t, t)] -> Dot_Attr
edge_pos_attr [(t, t)
p1,(t, t)
p2,(t, t)
p3,(t, t)
p4]

{-
-- | Vertex position function.
type POS_FN v = (v -> (Int,Int))

g_lift_pos_fn :: (v -> (Int,Int)) -> v -> [Dot_Attr]
g_lift_pos_fn f v = let (c,r) = f v in [node_pos_attr (c * 100,r * 100)]
-}

lbl_to_dot :: Graph_Type -> [Dot_Meta_Attr] -> Graph_Pp v e -> T.Lbl v e -> [String]
lbl_to_dot :: forall v e.
Graph_Type -> [Dot_Attr] -> Graph_Pp v e -> Lbl v e -> [Dot_Type]
lbl_to_dot Graph_Type
g_typ [Dot_Attr]
opt ((Int, v) -> [Dot_Attr]
v_attr,((Int, Int), e) -> [Dot_Attr]
e_attr) ([(Int, v)]
v,[((Int, Int), e)]
e) =
    let ws :: Dot_Type -> Dot_Type
ws Dot_Type
s = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Dot_Type
s then Dot_Type
"" else Dot_Type
" " forall a. [a] -> [a] -> [a]
++ Dot_Type
s
        v_f :: (Int, v) -> Dot_Type
v_f (Int
k,v
lbl) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [forall a. Show a => a -> Dot_Type
show Int
k,Dot_Type -> Dot_Type
ws ([Dot_Attr] -> Dot_Type
dot_attr_seq_pp ((Int, v) -> [Dot_Attr]
v_attr (Int
k,v
lbl))),Dot_Type
";"]
        e_f :: ((Int, Int), e) -> Dot_Type
e_f ((Int
lhs,Int
rhs),e
lbl) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [forall a. Show a => a -> Dot_Type
show Int
lhs,Graph_Type -> Dot_Type
g_type_to_edge_symbol Graph_Type
g_typ,forall a. Show a => a -> Dot_Type
show Int
rhs
                                     ,Dot_Type -> Dot_Type
ws ([Dot_Attr] -> Dot_Type
dot_attr_seq_pp (((Int, Int), e) -> [Dot_Attr]
e_attr ((Int
lhs,Int
rhs),e
lbl))),Dot_Type
";"]
    in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Graph_Type -> Dot_Type
g_type_to_string Graph_Type
g_typ,Dot_Type
" g {"]
              ,forall a b. (a -> b) -> [a] -> [b]
map Dot_Attr_Set -> Dot_Type
dot_attr_set_pp ([Dot_Attr] -> [Dot_Attr_Set]
dot_attr_collate [Dot_Attr]
opt)
              ,forall a b. (a -> b) -> [a] -> [b]
map (Int, v) -> Dot_Type
v_f [(Int, v)]
v
              ,forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int), e) -> Dot_Type
e_f [((Int, Int), e)]
e
              ,[Dot_Type
"}"]]

lbl_to_udot :: [Dot_Meta_Attr] -> Graph_Pp v e -> T.Lbl v e -> [String]
lbl_to_udot :: forall v e. [Dot_Attr] -> Graph_Pp v e -> Lbl v e -> [Dot_Type]
lbl_to_udot = forall v e.
Graph_Type -> [Dot_Attr] -> Graph_Pp v e -> Lbl v e -> [Dot_Type]
lbl_to_dot Graph_Type
Graph_Ugraph

-- | 'writeFile' of 'lbl_to_udot'
lbl_to_udot_wr :: FilePath -> [Dot_Meta_Attr] -> Graph_Pp v e -> T.Lbl v e -> IO ()
lbl_to_udot_wr :: forall v e.
Dot_Type -> [Dot_Attr] -> Graph_Pp v e -> Lbl v e -> IO ()
lbl_to_udot_wr Dot_Type
fn [Dot_Attr]
o Graph_Pp v e
pp  = Dot_Type -> Dot_Type -> IO ()
writeFile Dot_Type
fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dot_Type] -> Dot_Type
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v e. [Dot_Attr] -> Graph_Pp v e -> Lbl v e -> [Dot_Type]
lbl_to_udot [Dot_Attr]
o Graph_Pp v e
pp

fgl_to_dot :: G.Graph gr => Graph_Type -> [Dot_Meta_Attr] -> Graph_Pp v e -> gr v e -> [String]
fgl_to_dot :: forall (gr :: * -> * -> *) v e.
Graph gr =>
Graph_Type -> [Dot_Attr] -> Graph_Pp v e -> gr v e -> [Dot_Type]
fgl_to_dot Graph_Type
typ [Dot_Attr]
opt Graph_Pp v e
pp gr v e
gr = forall v e.
Graph_Type -> [Dot_Attr] -> Graph_Pp v e -> Lbl v e -> [Dot_Type]
lbl_to_dot Graph_Type
typ [Dot_Attr]
opt Graph_Pp v e
pp (forall (gr :: * -> * -> *) v e. Graph gr => gr v e -> Lbl v e
T.fgl_to_lbl gr v e
gr)

fgl_to_udot :: G.Graph gr => [Dot_Meta_Attr] -> Graph_Pp v e -> gr v e -> [String]
fgl_to_udot :: forall (gr :: * -> * -> *) v e.
Graph gr =>
[Dot_Attr] -> Graph_Pp v e -> gr v e -> [Dot_Type]
fgl_to_udot [Dot_Attr]
opt Graph_Pp v e
pp gr v e
gr = forall v e. [Dot_Attr] -> Graph_Pp v e -> Lbl v e -> [Dot_Type]
lbl_to_udot [Dot_Attr]
opt Graph_Pp v e
pp (forall (gr :: * -> * -> *) v e. Graph gr => gr v e -> Lbl v e
T.fgl_to_lbl gr v e
gr)

-- * Dot-Process

{- | Run /dot/ to generate a file type based on the output file extension (ie. .svg, .png, .jpeg, .gif)
     /-n/ must be given to not run the layout algorithm and to use position data in the /dot/ file.
-}
dot_to_ext :: [String] -> FilePath -> FilePath -> IO ()
dot_to_ext :: [Dot_Type] -> Dot_Type -> Dot_Type -> IO ()
dot_to_ext [Dot_Type]
opt Dot_Type
dot_fn Dot_Type
ext_fn =
  let arg :: [Dot_Type]
arg = [Dot_Type]
opt forall a. [a] -> [a] -> [a]
++ [Dot_Type
"-T",forall a. [a] -> [a]
tail (Dot_Type -> Dot_Type
takeExtension Dot_Type
ext_fn),Dot_Type
"-o",Dot_Type
ext_fn,Dot_Type
dot_fn]
  in forall (f :: * -> *) a. Functor f => f a -> f ()
void (Dot_Type -> [Dot_Type] -> IO ExitCode
rawSystem Dot_Type
"dot" [Dot_Type]
arg)

-- | 'dot_to_ext' generating .svg filename by replacing .dot extension with .svg
dot_to_svg :: [String] -> FilePath -> IO ()
dot_to_svg :: [Dot_Type] -> Dot_Type -> IO ()
dot_to_svg [Dot_Type]
opt Dot_Type
dot_fn = [Dot_Type] -> Dot_Type -> Dot_Type -> IO ()
dot_to_ext [Dot_Type]
opt Dot_Type
dot_fn (Dot_Type -> Dot_Type -> Dot_Type
replaceExtension Dot_Type
dot_fn Dot_Type
"svg")