module Music.Theory.Graph.FGL where
import Data.List
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Graph.Inductive.Graph as G
import qualified Data.Graph.Inductive.Query as G
import qualified Data.Graph.Inductive.PatriciaTree as G
import qualified Control.Monad.Logic as L
import qualified Music.Theory.List as T
g_degree :: G.Gr v e -> Int
g_degree = G.noNodes
g_partition :: G.Gr v e -> [G.Gr v e]
g_partition gr = map (\n -> G.subgraph n gr) (G.components gr)
g_node_lookup :: (Eq v,G.Graph gr) => gr v e -> v -> Maybe G.Node
g_node_lookup gr l = fmap fst (find ((== l) . snd) (G.labNodes gr))
g_node_lookup_err :: (Eq v,G.Graph gr) => gr v e -> v -> G.Node
g_node_lookup_err gr = fromMaybe (error "g_node_lookup") . g_node_lookup gr
ug_node_set_impl :: (Eq v,G.DynGraph gr) => gr v e -> [v] -> [G.Node]
ug_node_set_impl gr nl =
let n = map (g_node_lookup_err gr) nl
in nub (sort (n ++ concatMap (G.neighbors gr) n))
type G_NODE_SEL_F v e = G.Gr v e -> G.Node -> [G.Node]
ml_from_list :: L.MonadLogic m => [t] -> m t
ml_from_list = L.msum . map return
g_hamiltonian_path_ml :: L.MonadLogic m => G_NODE_SEL_F v e -> G.Gr v e -> G.Node -> m [G.Node]
g_hamiltonian_path_ml sel_f gr =
let n_deg = g_degree gr
recur r c =
if length r == n_deg 1
then return (c:r)
else do i <- ml_from_list (sel_f gr c)
L.guard (i `notElem` r)
recur (c:r) i
in recur []
ug_hamiltonian_path_ml_0 :: L.MonadLogic m => G.Gr v e -> m [G.Node]
ug_hamiltonian_path_ml_0 gr = g_hamiltonian_path_ml G.neighbors gr (G.nodes gr !! 0)
type EDGE v = (v,v)
type GRAPH v = [EDGE v]
type EDGE_L v l = (EDGE v,l)
type GRAPH_L v l = [EDGE_L v l]
g_from_edges_l :: (Eq v,Ord v) => GRAPH_L v e -> G.Gr v e
g_from_edges_l e =
let n = nub (concatMap (\((lhs,rhs),_) -> [lhs,rhs]) e)
n_deg = length n
n_id = [0 .. n_deg 1]
m = M.fromList (zip n n_id)
m_get k = M.findWithDefault (error "g_from_edges: m_get") k m
e' = map (\((lhs,rhs),label) -> (m_get lhs,m_get rhs,label)) e
in G.mkGraph (zip n_id n) e'
g_from_edges :: Ord v => GRAPH v -> G.Gr v ()
g_from_edges = let f e = (e,()) in g_from_edges_l . map f
e_label_seq :: [EDGE v] -> [EDGE_L v Int]
e_label_seq = map (\(k,e) -> (e,k)) . zip [1..]
e_normalise_l :: Ord v => EDGE_L v l -> EDGE_L v l
e_normalise_l ((p,q),r) = ((min p q,max p q),r)
e_collate_l :: Ord v => [EDGE_L v l] -> [EDGE_L v [l]]
e_collate_l = T.collate
e_collate_normalised_l :: Ord v => [EDGE_L v l] -> [EDGE_L v [l]]
e_collate_normalised_l = e_collate_l . map e_normalise_l
e_univ_select_edges :: (t -> t -> Bool) -> [t] -> [EDGE t]
e_univ_select_edges f l = [(p,q) | p <- l, q <- l, f p q]
e_univ_select_u_edges :: Ord t => (t -> t -> Bool) -> [t] -> [EDGE t]
e_univ_select_u_edges f = let g p q = p < q && f p q in e_univ_select_edges g
e_path_to_edges :: [t] -> [EDGE t]
e_path_to_edges = T.adj2 1
e_undirected_eq :: Eq t => EDGE t -> EDGE t -> Bool
e_undirected_eq (a,b) (c,d) = (a == c && b == d) || (a == d && b == c)
elem_by :: (p -> q -> Bool) -> p -> [q] -> Bool
elem_by f = any . f
e_is_path :: Eq t => GRAPH t -> [t] -> Bool
e_is_path e sq =
case sq of
p:q:sq' -> elem_by e_undirected_eq (p,q) e && e_is_path e (q:sq')
_ -> True