-- | Graph (fgl) functions.
module Music.Theory.Graph.Fgl where

import Control.Monad {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}

import qualified Data.Map as M {- containers -}

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

import qualified Control.Monad.Logic as L {- logict -}

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

-- | 'T.Lbl' to FGL graph
lbl_to_fgl :: G.Graph gr => T.Lbl v e -> gr v e
lbl_to_fgl :: forall (gr :: * -> * -> *) v e. Graph gr => Lbl v e -> gr v e
lbl_to_fgl ([(Int, v)]
v,[((Int, Int), e)]
e) = let f :: ((a, b), c) -> (a, b, c)
f ((a
i,b
j),c
k) = (a
i,b
j,c
k) in forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
G.mkGraph [(Int, v)]
v (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. ((a, b), c) -> (a, b, c)
f [((Int, Int), e)]
e)

-- | Type-specialised.
lbl_to_fgl_gr :: T.Lbl v e -> G.Gr v e
lbl_to_fgl_gr :: forall v e. Lbl v e -> Gr v e
lbl_to_fgl_gr = forall (gr :: * -> * -> *) v e. Graph gr => Lbl v e -> gr v e
lbl_to_fgl

-- | FGL graph to 'T.Lbl'
fgl_to_lbl :: G.Graph gr => gr v e -> T.Lbl v e
fgl_to_lbl :: forall (gr :: * -> * -> *) v e. Graph gr => gr v e -> Lbl v e
fgl_to_lbl gr v e
gr = (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
G.labNodes gr v e
gr,forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i,Int
j,e
k) -> ((Int
i,Int
j),e
k)) (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
G.labEdges gr v e
gr))

-- | Synonym for 'G.noNodes'.
g_degree :: G.Gr v e -> Int
g_degree :: forall v e. Gr v e -> Int
g_degree = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int
G.noNodes

-- | 'G.subgraph' of each of 'G.components'.
g_partition :: G.Gr v e -> [G.Gr v e]
g_partition :: forall v e. Gr v e -> [Gr v e]
g_partition Gr v e
gr = forall a b. (a -> b) -> [a] -> [b]
map (forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[Int] -> gr a b -> gr a b
`G.subgraph` Gr v e
gr) (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [[Int]]
G.components Gr v e
gr)

-- | Find first 'G.Node' with given label.
g_node_lookup :: (Eq v,G.Graph gr) => gr v e -> v -> Maybe G.Node
g_node_lookup :: forall v (gr :: * -> * -> *) e.
(Eq v, Graph gr) =>
gr v e -> v -> Maybe Int
g_node_lookup gr v e
gr v
l = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== v
l) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
G.labNodes gr v e
gr))

-- | Erroring variant.
g_node_lookup_err :: (Eq v,G.Graph gr) => gr v e -> v -> G.Node
g_node_lookup_err :: forall v (gr :: * -> * -> *) e.
(Eq v, Graph gr) =>
gr v e -> v -> Int
g_node_lookup_err gr v e
gr = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"g_node_lookup") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v (gr :: * -> * -> *) e.
(Eq v, Graph gr) =>
gr v e -> v -> Maybe Int
g_node_lookup gr v e
gr

-- | Set of nodes with given labels, plus all neighbours of these nodes.
-- (impl = implications)
ug_node_set_impl :: (Eq v,G.DynGraph gr) => gr v e -> [v] -> [G.Node]
ug_node_set_impl :: forall v (gr :: * -> * -> *) e.
(Eq v, DynGraph gr) =>
gr v e -> [v] -> [Int]
ug_node_set_impl gr v e
gr [v]
nl =
    let n :: [Int]
n = forall a b. (a -> b) -> [a] -> [b]
map (forall v (gr :: * -> * -> *) e.
(Eq v, Graph gr) =>
gr v e -> v -> Int
g_node_lookup_err gr v e
gr) [v]
nl
    in forall a. Eq a => [a] -> [a]
nub (forall a. Ord a => [a] -> [a]
sort ([Int]
n forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
G.neighbors gr v e
gr) [Int]
n))

-- * Hamiltonian

-- | Node select function, ie. given a graph /g/ and a node /n/ select a set of related nodes from /g/
type G_Node_Sel_f v e = G.Gr v e -> G.Node -> [G.Node]

-- | 'msum' '.' 'map' 'return'.
ml_from_list :: MonadPlus m => [t] -> m t
ml_from_list :: forall (m :: * -> *) t. MonadPlus m => [t] -> m t
ml_from_list = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Use /sel_f/ of 'G.pre' for directed graphs and 'G.neighbors' for undirected.
g_hamiltonian_path_ml :: (MonadPlus m, L.MonadLogic m) => G_Node_Sel_f v e -> G.Gr v e -> G.Node -> m [G.Node]
g_hamiltonian_path_ml :: forall (m :: * -> *) v e.
(MonadPlus m, MonadLogic m) =>
G_Node_Sel_f v e -> Gr v e -> Int -> m [Int]
g_hamiltonian_path_ml G_Node_Sel_f v e
sel_f Gr v e
gr =
    let n_deg :: Int
n_deg = forall v e. Gr v e -> Int
g_degree Gr v e
gr
        recur :: [Int] -> Int -> m [Int]
recur [Int]
r Int
c =
            if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
r forall a. Eq a => a -> a -> Bool
== Int
n_deg forall a. Num a => a -> a -> a
- Int
1
            then forall (m :: * -> *) a. Monad m => a -> m a
return (Int
cforall a. a -> [a] -> [a]
:[Int]
r)
            else do Int
i <- forall (m :: * -> *) t. MonadPlus m => [t] -> m t
ml_from_list (G_Node_Sel_f v e
sel_f Gr v e
gr Int
c)
                    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
r)
                    [Int] -> Int -> m [Int]
recur (Int
cforall a. a -> [a] -> [a]
:[Int]
r) Int
i
    in forall {m :: * -> *}. MonadPlus m => [Int] -> Int -> m [Int]
recur []

-- | 'g_hamiltonian_path_ml' of 'G.neighbors' starting at first node.
--
-- > map (L.observeAll . ug_hamiltonian_path_ml_0) (g_partition gr)
ug_hamiltonian_path_ml_0 :: (MonadPlus m, L.MonadLogic m) => G.Gr v e -> m [G.Node]
ug_hamiltonian_path_ml_0 :: forall (m :: * -> *) v e.
(MonadPlus m, MonadLogic m) =>
Gr v e -> m [Int]
ug_hamiltonian_path_ml_0 Gr v e
gr = forall (m :: * -> *) v e.
(MonadPlus m, MonadLogic m) =>
G_Node_Sel_f v e -> Gr v e -> Int -> m [Int]
g_hamiltonian_path_ml forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
G.neighbors Gr v e
gr (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Int]
G.nodes Gr v e
gr forall a. [a] -> Int -> a
!! Int
0)

-- * G (from edges)

-- | Edge, no label.
type Edge v = (v,v)

-- | Edge, with label.
type Edge_Lbl v l = (Edge v,l)

-- | Generate a graph given a set of labelled edges.
g_from_edges_l :: (Eq v,Ord v) => [Edge_Lbl v e] -> G.Gr v e
g_from_edges_l :: forall v e. (Eq v, Ord v) => [Edge_Lbl v e] -> Gr v e
g_from_edges_l [Edge_Lbl v e]
e =
    let n :: [v]
n = forall a. Eq a => [a] -> [a]
nub (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\((v
lhs,v
rhs),e
_) -> [v
lhs,v
rhs]) [Edge_Lbl v e]
e)
        n_deg :: Int
n_deg = forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
n
        n_id :: [Int]
n_id = [Int
0 .. Int
n_deg forall a. Num a => a -> a -> a
- Int
1]
        m :: Map v Int
m = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [v]
n [Int]
n_id)
        m_get :: v -> Int
m_get v
k = forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (forall a. HasCallStack => [Char] -> a
error [Char]
"g_from_edges: m_get") v
k Map v Int
m
        e' :: [(Int, Int, e)]
e' = forall a b. (a -> b) -> [a] -> [b]
map (\((v
lhs,v
rhs),e
label) -> (v -> Int
m_get v
lhs,v -> Int
m_get v
rhs,e
label)) [Edge_Lbl v e]
e
    in forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
G.mkGraph (forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
n_id [v]
n) [(Int, Int, e)]
e'

-- | Variant that supplies '()' as the (constant) edge label.
--
-- > let g = G.mkGraph [(0,'a'),(1,'b'),(2,'c')] [(0,1,()),(1,2,())]
-- > in g_from_edges_ul [('a','b'),('b','c')] == g
g_from_edges :: Ord v => [Edge v] -> G.Gr v ()
g_from_edges :: forall v. Ord v => [Edge v] -> Gr v ()
g_from_edges = let f :: a -> (a, ())
f a
e = (a
e,()) in forall v e. (Eq v, Ord v) => [Edge_Lbl v e] -> Gr v e
g_from_edges_l forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. a -> (a, ())
f

-- * Edges

-- | Label sequence of edges starting at one.
e_label_seq :: [Edge v] -> [Edge_Lbl v Int]
e_label_seq :: forall v. [Edge v] -> [Edge_Lbl v Int]
e_label_seq = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
k Edge v
e -> (Edge v
e,Int
k)) [Int
1..]

-- | Normalised undirected labeled edge (ie. order nodes).
e_normalise_l :: Ord v => Edge_Lbl v l -> Edge_Lbl v l
e_normalise_l :: forall v l. Ord v => Edge_Lbl v l -> Edge_Lbl v l
e_normalise_l ((v
p,v
q),l
r) = ((forall a. Ord a => a -> a -> a
min v
p v
q,forall a. Ord a => a -> a -> a
max v
p v
q),l
r)

-- | Collate labels for edges that are otherwise equal.
e_collate_l :: Ord v => [Edge_Lbl v l] -> [Edge_Lbl v [l]]
e_collate_l :: forall v l. Ord v => [Edge_Lbl v l] -> [Edge_Lbl v [l]]
e_collate_l = forall a b. Ord a => [(a, b)] -> [(a, [b])]
T.collate

-- | 'e_collate_l' of 'e_normalise_l'.
e_collate_normalised_l :: Ord v => [Edge_Lbl v l] -> [Edge_Lbl v [l]]
e_collate_normalised_l :: forall v l. Ord v => [Edge_Lbl v l] -> [Edge_Lbl v [l]]
e_collate_normalised_l = forall v l. Ord v => [Edge_Lbl v l] -> [Edge_Lbl v [l]]
e_collate_l forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall v l. Ord v => Edge_Lbl v l -> Edge_Lbl v l
e_normalise_l

-- | Apply predicate to universe of possible edges.
e_univ_select_edges :: (t -> t -> Bool) -> [t] -> [Edge t]
e_univ_select_edges :: forall t. (t -> t -> Bool) -> [t] -> [Edge t]
e_univ_select_edges t -> t -> Bool
f [t]
l = [(t
p,t
q) | t
p <- [t]
l, t
q <- [t]
l, t -> t -> Bool
f t
p t
q]

-- | Consider only edges (p,q) where p < q.
e_univ_select_u_edges :: Ord t => (t -> t -> Bool) -> [t] -> [Edge t]
e_univ_select_u_edges :: forall t. Ord t => (t -> t -> Bool) -> [t] -> [Edge t]
e_univ_select_u_edges t -> t -> Bool
f = let g :: t -> t -> Bool
g t
p t
q = t
p forall a. Ord a => a -> a -> Bool
< t
q Bool -> Bool -> Bool
&& t -> t -> Bool
f t
p t
q in forall t. (t -> t -> Bool) -> [t] -> [Edge t]
e_univ_select_edges t -> t -> Bool
g

-- | Sequence of connected vertices to edges.
--
-- > e_path_to_edges "abcd" == [('a','b'),('b','c'),('c','d')]
e_path_to_edges :: [t] -> [Edge t]
e_path_to_edges :: forall t. [t] -> [Edge t]
e_path_to_edges = forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1

-- | Undirected edge equality.
e_undirected_eq :: Eq t => Edge t -> Edge t -> Bool
e_undirected_eq :: forall t. Eq t => Edge t -> Edge t -> Bool
e_undirected_eq (t
a,t
b) (t
c,t
d) = (t
a forall a. Eq a => a -> a -> Bool
== t
c Bool -> Bool -> Bool
&& t
b forall a. Eq a => a -> a -> Bool
== t
d) Bool -> Bool -> Bool
|| (t
a forall a. Eq a => a -> a -> Bool
== t
d Bool -> Bool -> Bool
&& t
b forall a. Eq a => a -> a -> Bool
== t
c)

-- | /any/ of /f/.
elem_by :: (p -> q -> Bool) -> p -> [q] -> Bool
elem_by :: forall p q. (p -> q -> Bool) -> p -> [q] -> Bool
elem_by p -> q -> Bool
f = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> q -> Bool
f

-- | Is the sequence of vertices a path at the graph, ie. are all
-- adjacencies in the sequence edges.
e_is_path :: Eq t => [Edge t] -> [t] -> Bool
e_is_path :: forall t. Eq t => [Edge t] -> [t] -> Bool
e_is_path [Edge t]
e [t]
sq =
    case [t]
sq of
      t
p:t
q:[t]
sq' -> forall p q. (p -> q -> Bool) -> p -> [q] -> Bool
elem_by forall t. Eq t => Edge t -> Edge t -> Bool
e_undirected_eq (t
p,t
q) [Edge t]
e Bool -> Bool -> Bool
&& forall t. Eq t => [Edge t] -> [t] -> Bool
e_is_path [Edge t]
e (t
qforall a. a -> [a] -> [a]
:[t]
sq')
      [t]
_ -> Bool
True

-- * Analysis

-- | <https://github.com/ivan-m/Graphalyze/blob/master/Data/Graph/Analysis/Algorithms/Common.hs>
--   Graphalyze has pandoc as a dependency...
pathTree             :: (G.DynGraph g) => G.Decomp g a b -> [[G.Node]]
pathTree :: forall (g :: * -> * -> *) a b.
DynGraph g =>
Decomp g a b -> [[Int]]
pathTree (MContext a b
Nothing,g a b
_) = []
pathTree (Just Context a b
ct,g a b
g)
    | forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
G.isEmpty g a b
g = []
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
sucs = [[Int
n]]
    | Bool
otherwise = (:) [Int
n] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Int
nforall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {g :: * -> * -> *} {a} {b}.
DynGraph g =>
g a b -> Int -> [[Int]]
subPathTree g a b
g') forall a b. (a -> b) -> a -> b
$ [Int]
sucs
    where
      n :: Int
n = forall a b. Context a b -> Int
G.node' Context a b
ct
      sucs :: [Int]
sucs = forall a b. Context a b -> [Int]
G.suc' Context a b
ct
      ct' :: Context a b
ct' = forall a b. Context a b -> Context a b
makeLeaf Context a b
ct
      g' :: g a b
g' = Context a b
ct' forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
G.& g a b
g
      subPathTree :: g a b -> Int -> [[Int]]
subPathTree g a b
gr Int
n' = forall (g :: * -> * -> *) a b.
DynGraph g =>
Decomp g a b -> [[Int]]
pathTree forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b.
Graph gr =>
Int -> gr a b -> Decomp gr a b
G.match Int
n' g a b
gr

-- | Remove all outgoing edges
makeLeaf           :: G.Context a b -> G.Context a b
makeLeaf :: forall a b. Context a b -> Context a b
makeLeaf (Adj b
p,Int
n,a
a,Adj b
_) = (Adj b
p', Int
n, a
a, [])
    where p' :: Adj b
p' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(b
_,Int
n') -> Int
n' forall a. Eq a => a -> a -> Bool
/= Int
n) Adj b
p