module Music.Theory.Graph.Dot where
import Data.Char
import Data.List
import qualified Data.Graph.Inductive.Graph as G
import qualified Data.Graph.Inductive.PatriciaTree as G
import qualified Music.Theory.List as T
sep1 :: Eq t => t -> [t] -> ([t],[t])
sep1 e l =
case break (== e) l of
(p,_:q) -> (p,q)
_ -> error "sep1"
maybe_quote :: String -> String
maybe_quote s = if any isSpace s then concat ["\"",s,"\""] else s
assoc_union :: Eq k => [(k,v)] -> [(k,v)] -> [(k,v)]
assoc_union p q =
let p_k = map fst p
q' = filter ((`notElem` p_k) . fst) q
in p ++ q'
type DOT_KEY = String
type DOT_OPT = String
type DOT_VALUE = String
type DOT_ATTR = (DOT_OPT,DOT_VALUE)
type DOT_ATTR_SET = (String,[DOT_ATTR])
dot_key_sep :: String -> (String,String)
dot_key_sep = sep1 ':'
dot_attr_pp :: DOT_ATTR -> String
dot_attr_pp (lhs,rhs) = concat [lhs,"=",maybe_quote rhs]
dot_attr_set_pp :: DOT_ATTR_SET -> String
dot_attr_set_pp (ty,opt) = concat [ty," [",intercalate "," (map dot_attr_pp opt),"];"]
dot_attr_collate :: [DOT_ATTR] -> [DOT_ATTR_SET]
dot_attr_collate opt =
let f (k,v) = let (ty,nm) = dot_key_sep k in (ty,(nm,v))
c = map f opt
in T.collate c
dot_attr_ext :: [DOT_ATTR] -> [DOT_ATTR] -> [DOT_ATTR]
dot_attr_ext = assoc_union
dot_attr_def :: [DOT_ATTR]
dot_attr_def =
[("graph:layout","neato")
,("graph:epsilon","0.000001")
,("node:shape","plaintext")
,("node:fontsize","10")
,("node:fontname","century schoolbook")]
type GR_PP v e = (v -> Maybe String,v -> Maybe String,e -> Maybe String)
gr_pp_lift_node_f :: (v -> String) -> GR_PP v e
gr_pp_lift_node_f f = (const Nothing, Just . f, const Nothing)
gr_pp_id_show :: Show e => GR_PP String e
gr_pp_id_show = (const Nothing,Just . id,Just . show)
br_csl_pp :: Show t => [t] -> String
br_csl_pp l =
case l of
[e] -> show e
_ -> T.bracket ('{','}') (intercalate "," (map show l))
gr_pp_id_br_csl :: Show e => GR_PP String [e]
gr_pp_id_br_csl = (const Nothing,Just . id,Just . br_csl_pp)
data G_TYPE = G_DIGRAPH | G_UGRAPH
g_type_to_string :: G_TYPE -> String
g_type_to_string ty =
case ty of
G_DIGRAPH -> "digraph"
G_UGRAPH -> "graph"
g_type_to_edge_symbol :: G_TYPE -> String
g_type_to_edge_symbol ty =
case ty of
G_DIGRAPH -> " -> "
G_UGRAPH -> " -- "
type POS_FN v = (v -> (Int,Int))
g_to_dot :: G_TYPE -> [DOT_ATTR] -> GR_PP v e -> Maybe (POS_FN v) -> G.Gr v e -> [String]
g_to_dot g_typ opt (n_sh,n_pp,e_pp) pos_f gr =
let p_f (c,r) = concat [",pos=\"",show (c * 100),",",show (r * 100),"\""]
l_f p x = concat [" [label=\"",x,"\"",p,"]"]
n_f (k,n) = let p = maybe "" (\f -> p_f (f n)) pos_f
p' = maybe p (\z -> p ++ ",shape=\"" ++ z ++ "\"") (n_sh n)
a = maybe "" (l_f p') (n_pp n)
in concat [show k,a,";"]
e_f (lhs,rhs,e) = let l = maybe "" (l_f "") (e_pp e)
in concat [show lhs,g_type_to_edge_symbol g_typ,show rhs,l,";"]
in concat [[g_type_to_string g_typ," g {"]
,map dot_attr_set_pp (dot_attr_collate (assoc_union opt dot_attr_def))
,map n_f (G.labNodes gr)
,map e_f (G.labEdges gr)
,["}"]]
g_to_udot :: [DOT_ATTR] -> GR_PP v e -> G.Gr v e -> [String]
g_to_udot o pp = g_to_dot G_UGRAPH o pp Nothing