-- | Graph types.
module Music.Theory.Graph.Type where

import Data.Bifunctor {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}

import qualified Data.Graph as Graph {- containers -}

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

-- * Vertices

v_is_normal :: [Int] -> Maybe Int
v_is_normal :: [Int] -> Maybe Int
v_is_normal [Int]
v = let k :: Int
k = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
v in if [Int]
v forall a. Eq a => a -> a -> Bool
== [Int
0 .. Int
k forall a. Num a => a -> a -> a
- Int
1] then forall a. a -> Maybe a
Just Int
k else forall a. Maybe a
Nothing

v_is_normal_err :: [Int] -> Int
v_is_normal_err :: [Int] -> Int
v_is_normal_err = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"v_is_normal?") forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Maybe Int
v_is_normal

-- * Edge

-- | Un-directed edge equality.
--
-- > e_eq_undir (0,1) (1,0) == True
e_eq_undir :: Eq t => (t,t) -> (t,t) -> Bool
e_eq_undir :: forall t. Eq t => (t, t) -> (t, t) -> Bool
e_eq_undir (t, t)
e0 (t, t)
e1 =
  let swap :: (b, a) -> (a, b)
swap (b
i,a
j) = (a
j,b
i)
  in (t, t)
e0 forall a. Eq a => a -> a -> Bool
== (t, t)
e1 Bool -> Bool -> Bool
|| (t, t)
e0 forall a. Eq a => a -> a -> Bool
== forall {b} {a}. (b, a) -> (a, b)
swap (t, t)
e1

-- | Sort edge.
--
-- > map e_sort [(0,1),(1,0)] == [(0,1),(0,1)]
e_sort :: Ord t => (t, t) -> (t, t)
e_sort :: forall t. Ord t => (t, t) -> (t, t)
e_sort (t
i,t
j) = (forall a. Ord a => a -> a -> a
min t
i t
j,forall a. Ord a => a -> a -> a
max t
i t
j)

-- * (vertices,edges) graph

-- | (vertices,edges)
type Gr t = ([t],[(t,t)])

-- | 'Gr' is a functor.
gr_map :: (t -> u) -> Gr t -> Gr u
gr_map :: forall t u. (t -> u) -> Gr t -> Gr u
gr_map t -> u
f ([t]
v,[(t, t)]
e) = (forall a b. (a -> b) -> [a] -> [b]
map t -> u
f [t]
v,forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap t -> u
f t -> u
f) [(t, t)]
e)

-- | (|V|,|E|)
gr_degree :: Gr t -> (Int,Int)
gr_degree :: forall t. Gr t -> (Int, Int)
gr_degree ([t]
v,[(t, t)]
e) = (forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
v,forall (t :: * -> *) a. Foldable t => t a -> Int
length [(t, t)]
e)

-- | Re-label graph given table.
gr_relabel :: Eq t => [(t,u)] -> Gr t -> Gr u
gr_relabel :: forall t u. Eq t => [(t, u)] -> Gr t -> Gr u
gr_relabel [(t, u)]
tbl ([t]
v,[(t, t)]
e) =
  let get :: t -> u
get t
z = forall k v. Eq k => k -> [(k, v)] -> v
T.lookup_err t
z [(t, u)]
tbl
  in (forall a b. (a -> b) -> [a] -> [b]
map t -> u
get [t]
v,forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap t -> u
get t -> u
get) [(t, t)]
e)

-- | If (i,j) and (j,i) are both in E delete (j,i) where i < j.
gr_mk_undir :: Ord t => Gr t -> Gr t
gr_mk_undir :: forall t. Ord t => Gr t -> Gr t
gr_mk_undir ([t]
v,[(t, t)]
e) = ([t]
v,forall a. Eq a => [a] -> [a]
nub (forall a. Ord a => [a] -> [a]
sort (forall a b. (a -> b) -> [a] -> [b]
map forall t. Ord t => (t, t) -> (t, t)
e_sort [(t, t)]
e)))

-- | List of E to G, derives V from E.
eset_to_gr :: Ord t => [(t,t)] -> Gr t
eset_to_gr :: forall t. Ord t => [(t, t)] -> Gr t
eset_to_gr [(t, t)]
e =
  let v :: [t]
v = forall a. Ord a => [a] -> [a]
sort (forall a. Eq a => [a] -> [a]
nub (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(t
i,t
j) -> [t
i,t
j]) [(t, t)]
e))
  in ([t]
v,[(t, t)]
e)

-- | Sort v and e.
gr_sort :: Ord t => Gr t -> Gr t
gr_sort :: forall t. Ord t => Gr t -> Gr t
gr_sort ([t]
v,[(t, t)]
e) = (forall a. Ord a => [a] -> [a]
sort [t]
v,forall a. Ord a => [a] -> [a]
sort [(t, t)]
e)

-- | Complete k-graph (un-directed) given list of vertices
--
-- > gr_complete_graph "xyz" == ("xyz",[('x','y'),('x','z'),('y','z')])
gr_complete_graph :: Ord t => [t] -> Gr t
gr_complete_graph :: forall t. Ord t => [t] -> Gr t
gr_complete_graph [t]
v = let e :: [(t, t)]
e = [(t
i,t
j) | t
i <- [t]
v,t
j <- [t]
v,t
i forall a. Ord a => a -> a -> Bool
< t
j] in ([t]
v,[(t, t)]
e)

-- * Int graph

-- | 'Gr' of 'Int'
type G = Gr Int

-- | Simple text representation of 'G'.  Requires (and checks) that vertices are (0 .. |v|-1).
--   The first line is the number of vertices, following lines are edges.
g_to_text :: G -> String
g_to_text :: G -> String
g_to_text ([Int]
v,[(Int, Int)]
e) =
  let k :: Int
k = [Int] -> Int
v_is_normal_err [Int]
v
      f :: (a, a) -> String
f (a
i,a
j) = [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [a
i,a
j])
  in [String] -> String
unlines (forall a. Show a => a -> String
show Int
k forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, a) -> String
f [(Int, Int)]
e)

-- | 'Graph.Graph' to 'G'.
graph_to_g :: Graph.Graph -> G
graph_to_g :: Graph -> G
graph_to_g Graph
gr = (Graph -> [Int]
Graph.vertices Graph
gr,Graph -> [(Int, Int)]
Graph.edges Graph
gr)

-- | 'G' to 'Graph.Graph'
--
-- > g = ([0,1,2],[(0,1),(0,2),(1,2)])
-- > g == gr_sort (graph_to_g (g_to_graph g))
g_to_graph :: G -> Graph.Graph
g_to_graph :: G -> Graph
g_to_graph ([Int]
v,[(Int, Int)]
e) = (Int, Int) -> [(Int, Int)] -> Graph
Graph.buildG (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
v,forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
v) [(Int, Int)]
e

-- | Unlabel graph, make table.
--
-- > gr_unlabel ("xyz",[('x','y'),('x','z')]) == (([0,1,2],[(0,1),(0,2)]),[(0,'x'),(1,'y'),(2,'z')])
gr_unlabel :: Eq t => Gr t -> (G,[(Int,t)])
gr_unlabel :: forall t. Eq t => Gr t -> (G, [(Int, t)])
gr_unlabel ([t]
v1,[(t, t)]
e1) =
  let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
v1
      v2 :: [Int]
v2 = [Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1]
      tbl :: [(Int, t)]
tbl = forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
v2 [t]
v1
      get :: t -> Int
get t
k = forall v k. Eq v => v -> [(k, v)] -> k
T.reverse_lookup_err t
k [(Int, t)]
tbl
      e2 :: [(Int, Int)]
e2 = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap t -> Int
get t -> Int
get) [(t, t)]
e1
  in (([Int]
v2,[(Int, Int)]
e2),[(Int, t)]
tbl)

-- | 'fst' of 'gr_unlabel'
gr_to_g :: Eq t => Gr t -> G
gr_to_g :: forall t. Eq t => Gr t -> G
gr_to_g = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Eq t => Gr t -> (G, [(Int, t)])
gr_unlabel

-- | 'g_to_graph' of 'gr_unlabel'.
--
-- > gr = ("abc",[('a','b'),('a','c'),('b','c')])
-- > (g,tbl) = gr_to_graph gr
gr_to_graph :: Eq t => Gr t -> (Graph.Graph,[(Int,t)])
gr_to_graph :: forall t. Eq t => Gr t -> (Graph, [(Int, t)])
gr_to_graph Gr t
gr =
  let (([Int]
v,[(Int, Int)]
e),[(Int, t)]
tbl) = forall t. Eq t => Gr t -> (G, [(Int, t)])
gr_unlabel Gr t
gr
  in ((Int, Int) -> [(Int, Int)] -> Graph
Graph.buildG (Int
0,forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
v forall a. Num a => a -> a -> a
- Int
1) [(Int, Int)]
e,[(Int, t)]
tbl)

-- | Complete k-graph (un-directed).
--
-- > g_complete_graph 3 == ([0,1,2],[(0,1),(0,2),(1,2)])
g_complete_graph :: Int -> G
g_complete_graph :: Int -> G
g_complete_graph Int
k = forall t. Ord t => [t] -> Gr t
gr_complete_graph [Int
0 .. Int
k forall a. Num a => a -> a -> a
- Int
1]

-- * Edg = edge list (zero-indexed)

-- | ((|V|,|E|),[E])
type Edg = ((Int,Int), [(Int,Int)])

-- | Requires (and checks) that vertices are (0 .. |v| - 1).
g_to_edg :: G -> Edg
g_to_edg :: G -> Edg
g_to_edg ([Int]
v,[(Int, Int)]
e) = (([Int] -> Int
v_is_normal_err [Int]
v,forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int)]
e),[(Int, Int)]
e)

-- | Requires (but does not check) that vertices of 'Edg' are all in (0,|v| - 1).
edg_to_g :: Edg -> G
edg_to_g :: Edg -> G
edg_to_g ((Int
nv,Int
ne),[(Int, Int)]
e) =
  let v :: [Int]
v = [Int
0 .. Int
nv forall a. Num a => a -> a -> a
- Int
1]
  in if Int
ne forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int)]
e
     then forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show (String
"edg_to_g",Int
nv,Int
ne,forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int)]
e))
     else ([Int]
v,[(Int, Int)]
e)

-- | Parse Edg as printed by nauty-listg.
edg_parse :: [String] -> Edg
edg_parse :: [String] -> Edg
edg_parse [String]
ln =
  let parse_int_list :: String -> [Int]
parse_int_list = forall a b. (a -> b) -> [a] -> [b]
map forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words
      parse_int_pairs :: String -> [(Int, Int)]
parse_int_pairs = forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Int]
parse_int_list
      parse_int_pair :: String -> (Int, Int)
parse_int_pair = forall t. [t] -> t
T.unlist1_err forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(Int, Int)]
parse_int_pairs
  in case [String]
ln of
       [String
m,String
e] -> (String -> (Int, Int)
parse_int_pair String
m,String -> [(Int, Int)]
parse_int_pairs String
e)
       [String]
_ -> forall a. HasCallStack => String -> a
error String
"edg_parse"

-- * Adjacencies

-- | Adjacency list [(left-hand-side,[right-hand-side])]
type Adj t = [(t,[t])]

-- | 'Adj' to edge set.
adj_to_eset :: Ord t => Adj t -> [(t,t)]
adj_to_eset :: forall t. Ord t => Adj t -> [(t, t)]
adj_to_eset = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(t
i,[t]
j) -> forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. a -> [a]
repeat t
i) [t]
j)

-- | 'Adj' to 'Gr'
adj_to_gr :: Ord t => Adj t -> Gr t
adj_to_gr :: forall t. Ord t => Adj t -> Gr t
adj_to_gr = forall t. Ord t => [(t, t)] -> Gr t
eset_to_gr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Ord t => Adj t -> [(t, t)]
adj_to_eset

-- | 'Gr' to 'Adj' (selection-function)
gr_to_adj :: Ord t => (t -> (t,t) -> Maybe t) -> Gr t -> Adj t
gr_to_adj :: forall t. Ord t => (t -> (t, t) -> Maybe t) -> Gr t -> Adj t
gr_to_adj t -> (t, t) -> Maybe t
sel_f ([t]
v,[(t, t)]
e) =
  let f :: t -> (t, [t])
f t
k = (t
k,forall a. Ord a => [a] -> [a]
sort (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (t -> (t, t) -> Maybe t
sel_f t
k) [(t, t)]
e))
  in forall a. (a -> Bool) -> [a] -> [a]
filter (\(t
_,[t]
a) -> [t]
a forall a. Eq a => a -> a -> Bool
/= []) (forall a b. (a -> b) -> [a] -> [b]
map t -> (t, [t])
f [t]
v)

-- | 'Gr' to 'Adj' (directed)
--
-- > g = ([0,1,2,3],[(0,1),(2,1),(0,3),(3,0)])
-- > r = [(0,[1,3]),(2,[1]),(3,[0])]
-- > gr_to_adj_dir g == r
gr_to_adj_dir :: Ord t => Gr t -> Adj t
gr_to_adj_dir :: forall t. Ord t => Gr t -> Adj t
gr_to_adj_dir =
  let sel_f :: a -> (a, a) -> Maybe a
sel_f a
k (a
i,a
j) = if a
i forall a. Eq a => a -> a -> Bool
== a
k then forall a. a -> Maybe a
Just a
j else forall a. Maybe a
Nothing
  in forall t. Ord t => (t -> (t, t) -> Maybe t) -> Gr t -> Adj t
gr_to_adj forall {a} {a}. Eq a => a -> (a, a) -> Maybe a
sel_f

-- | 'Gr' to 'Adj' (un-directed)
--
-- > g = ([0,1,2,3],[(0,1),(2,1),(0,3),(3,0)])
-- > gr_to_adj_undir g == [(0,[1,3,3]),(1,[2])]
gr_to_adj_undir :: Ord t => Gr t -> Adj t
gr_to_adj_undir :: forall t. Ord t => Gr t -> Adj t
gr_to_adj_undir =
  let sel_f :: a -> (a, a) -> Maybe a
sel_f a
k (a
i,a
j) =
        if a
i forall a. Eq a => a -> a -> Bool
== a
k Bool -> Bool -> Bool
&& a
j forall a. Ord a => a -> a -> Bool
>= a
k
        then forall a. a -> Maybe a
Just a
j
        else if a
j forall a. Eq a => a -> a -> Bool
== a
k Bool -> Bool -> Bool
&& a
i forall a. Ord a => a -> a -> Bool
>= a
k
             then forall a. a -> Maybe a
Just a
i
             else forall a. Maybe a
Nothing
  in forall t. Ord t => (t -> (t, t) -> Maybe t) -> Gr t -> Adj t
gr_to_adj forall {a}. Ord a => a -> (a, a) -> Maybe a
sel_f

-- | Adjacency matrix, (|v|,mtx)
type Adj_Mtx t = (Int,[[t]])

{- | Edg to Adj_Mtx for un-directed graph.

> e = ((4,3),[(0,3),(1,3),(2,3)])
> edg_to_adj_mtx_undir (0,1) e == (4,[[0,0,0,1],[0,0,0,1],[0,0,0,1],[1,1,1,0]])

> e = ((4,4),[(0,1),(0,3),(1,2),(2,3)])
> edg_to_adj_mtx_undir (0,1) e == (4,[[0,1,0,1],[1,0,1,0],[0,1,0,1],[1,0,1,0]])

-}
edg_to_adj_mtx_undir :: (t,t) -> Edg -> Adj_Mtx t
edg_to_adj_mtx_undir :: forall t. (t, t) -> Edg -> Adj_Mtx t
edg_to_adj_mtx_undir (t
false,t
true) ((Int
nv,Int
_ne),[(Int, Int)]
e) =
  let v :: [Int]
v = [Int
0 .. Int
nv forall a. Num a => a -> a -> a
- Int
1]
      f :: Int -> Int -> t
f Int
i Int
j = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall t. Eq t => (t, t) -> (t, t) -> Bool
e_eq_undir (Int
i,Int
j)) [(Int, Int)]
e of
                Maybe (Int, Int)
Nothing -> t
false
                Maybe (Int, Int)
_ -> t
true
  in (Int
nv,forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> t
f Int
i) [Int]
v) [Int]
v)

-- | 'edg_to_adj_mtx_undir' of 'g_to_edg'
g_to_adj_mtx_undir :: (t,t) -> G -> Adj_Mtx t
g_to_adj_mtx_undir :: forall t. (t, t) -> G -> Adj_Mtx t
g_to_adj_mtx_undir (t, t)
o = forall t. (t, t) -> Edg -> Adj_Mtx t
edg_to_adj_mtx_undir (t, t)
o forall b c a. (b -> c) -> (a -> b) -> a -> c
. G -> Edg
g_to_edg

-- | Lookup 'Adj_Mtx' to find connected vertices.
adj_mtx_con :: Eq t => (t,t) -> Adj_Mtx t -> Int -> [Int]
adj_mtx_con :: forall t. Eq t => (t, t) -> Adj_Mtx t -> Int -> [Int]
adj_mtx_con (t
false,t
true) (Int
_,[[t]]
mx) Int
e =
  let f :: t -> a -> Maybe a
f t
i a
j = if t
i forall a. Eq a => a -> a -> Bool
== t
true then forall a. a -> Maybe a
Just a
j else if t
i forall a. Eq a => a -> a -> Bool
== t
false then forall a. Maybe a
Nothing else forall a. HasCallStack => String -> a
error String
"adj_mtx_con?"
  in forall a. [Maybe a] -> [a]
catMaybes (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. t -> a -> Maybe a
f ([[t]]
mx forall a. [a] -> Int -> a
!! Int
e) [Int
0..])

-- * Labels

-- | Labelled graph, distinct vertex and edge labels.
type Lbl_Gr v v_lbl e_lbl = ([(v,v_lbl)],[((v,v),e_lbl)])

-- | 'Lbl_Gr' of 'Int'
type Lbl v e = Lbl_Gr Int v e

-- | 'Lbl' with () edge labels.
type Lbl_ v = Lbl v ()

-- | Number of vertices and edges.
lbl_degree :: Lbl v e -> (Int,Int)
lbl_degree :: forall v e. Lbl v e -> (Int, Int)
lbl_degree ([(Int, v)]
v,[((Int, Int), e)]
e) = (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, v)]
v,forall (t :: * -> *) a. Foldable t => t a -> Int
length [((Int, Int), e)]
e)

-- | Apply /v/ at vertex labels and /e/ at edge labels.
lbl_bimap :: (v -> v') -> (e -> e') -> Lbl v e -> Lbl v' e'
lbl_bimap :: forall v v' e e'. (v -> v') -> (e -> e') -> Lbl v e -> Lbl v' e'
lbl_bimap v -> v'
v_f e -> e'
e_f ([(Int, v)]
v,[((Int, Int), e)]
e) = (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> v'
v_f) [(Int, v)]
v,forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e'
e_f) [((Int, Int), e)]
e)

-- | Merge two 'Lbl' graphs, do not share vertices, vertex indices at /g1/ are stable.
lbl_merge :: Lbl v e -> Lbl v e -> Lbl v e
lbl_merge :: forall v e. Lbl v e -> Lbl v e -> Lbl v e
lbl_merge ([(Int, v)]
v1,[((Int, Int), e)]
e1) ([(Int, v)]
v2,[((Int, Int), e)]
e2) =
  let m :: Int
m = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Int, v)]
v1) forall a. Num a => a -> a -> a
+ Int
1
      v3 :: [(Int, v)]
v3 = forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i,v
j) -> (Int
i forall a. Num a => a -> a -> a
+ Int
m,v
j)) [(Int, v)]
v2
      e3 :: [((Int, Int), e)]
e3 = forall a b. (a -> b) -> [a] -> [b]
map (\((Int
i,Int
j),e
k) -> ((Int
i forall a. Num a => a -> a -> a
+ Int
m,Int
j forall a. Num a => a -> a -> a
+ Int
m),e
k)) [((Int, Int), e)]
e2
  in ([(Int, v)]
v1 forall a. [a] -> [a] -> [a]
++ [(Int, v)]
v3,[((Int, Int), e)]
e1 forall a. [a] -> [a] -> [a]
++ [((Int, Int), e)]
e3)

-- | 'foldl1' of 'lbl_merge'
lbl_merge_seq :: [Lbl v e] -> Lbl v e
lbl_merge_seq :: forall v e. [Lbl v e] -> Lbl v e
lbl_merge_seq = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall v e. Lbl v e -> Lbl v e -> Lbl v e
lbl_merge

-- | Re-write graph so vertex indices are (0 .. n-1) and vertex labels are unique.
lbl_canonical :: (Eq v,Ord v) => Lbl v e -> Lbl v e
lbl_canonical :: forall v e. (Eq v, Ord v) => Lbl v e -> Lbl v e
lbl_canonical ([(Int, v)]
v1,[((Int, Int), e)]
e1) =
  let v2 :: [(Int, v)]
v2 = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (forall a. Eq a => [a] -> [a]
nub (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Int, v)]
v1))
      reix :: Int -> Int
reix Int
i = forall v k. Eq v => v -> [(k, v)] -> k
T.reverse_lookup_err (forall k v. Eq k => k -> [(k, v)] -> v
T.lookup_err Int
i [(Int, v)]
v1) [(Int, v)]
v2
      e2 :: [((Int, Int), e)]
e2 = forall a b. (a -> b) -> [a] -> [b]
map (\((Int
i,Int
j),e
k) -> ((Int -> Int
reix Int
i,Int -> Int
reix Int
j),e
k)) [((Int, Int), e)]
e1
  in ([(Int, v)]
v2,[((Int, Int), e)]
e2)

-- | Re-write edges so that vertex indices are ascending.
lbl_undir :: Lbl v e -> Lbl v e
lbl_undir :: forall v e. Lbl v e -> Lbl v e
lbl_undir ([(Int, v)]
v,[((Int, Int), e)]
e) = ([(Int, v)]
v,forall a b. (a -> b) -> [a] -> [b]
map (\((Int
i,Int
j),e
k) -> ((forall a. Ord a => a -> a -> a
min Int
i Int
j,forall a. Ord a => a -> a -> a
max Int
i Int
j),e
k)) [((Int, Int), e)]
e)

-- | 'Lbl' path graph.
lbl_path_graph :: [x] -> Lbl_ x
lbl_path_graph :: forall x. [x] -> Lbl_ x
lbl_path_graph [x]
v =
  let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [x]
v forall a. Num a => a -> a -> a
- Int
1
  in (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 .. Int
n] [x]
v
     ,forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1] [Int
1 .. Int
n]) (forall a. a -> [a]
repeat ()))

-- | 'Lbl' complete graph (undirected, no self-edges)
lbl_complete_graph :: [x] -> Lbl_ x
lbl_complete_graph :: forall x. [x] -> Lbl_ x
lbl_complete_graph [x]
v =
  let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [x]
v forall a. Num a => a -> a -> a
- Int
1
      u :: [Int]
u = [Int
0 .. Int
n]
  in (forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
u [x]
v
     ,forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
i,Int
j) | Int
i <- [Int]
u, Int
j <- [Int]
u, Int
i forall a. Ord a => a -> a -> Bool
< Int
j] (forall a. a -> [a]
repeat ()))

-- | Lookup vertex label with default value.
v_label :: v -> Lbl v e -> Int -> v
v_label :: forall v e. v -> Lbl v e -> Int -> v
v_label v
def ([(Int, v)]
tbl,[((Int, Int), e)]
_) Int
v = forall a. a -> Maybe a -> a
fromMaybe v
def (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
v [(Int, v)]
tbl)

-- | 'v_label' with 'error' as default.
v_label_err :: Lbl v e -> Int -> v
v_label_err :: forall v e. Lbl v e -> Int -> v
v_label_err = forall v e. v -> Lbl v e -> Int -> v
v_label (forall a. HasCallStack => String -> a
error String
"v_label")

-- | Lookup edge label with default value.
e_label :: e -> Lbl v e -> (Int,Int) -> e
e_label :: forall e v. e -> Lbl v e -> (Int, Int) -> e
e_label e
def ([(Int, v)]
_,[((Int, Int), e)]
tbl) (Int, Int)
e = forall a. a -> Maybe a -> a
fromMaybe e
def (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Int, Int)
e [((Int, Int), e)]
tbl)

-- | 'e_label' with 'error' as default.
e_label_err :: Lbl v e -> (Int,Int) -> e
e_label_err :: forall v e. Lbl v e -> (Int, Int) -> e
e_label_err = forall e v. e -> Lbl v e -> (Int, Int) -> e
e_label (forall a. HasCallStack => String -> a
error String
"e_label")

-- | Convert from 'Lbl_Gr' to 'Lbl'
lbl_gr_to_lbl :: Eq v => Lbl_Gr v v_lbl e_lbl -> Lbl v_lbl e_lbl
lbl_gr_to_lbl :: forall v v_lbl e_lbl.
Eq v =>
Lbl_Gr v v_lbl e_lbl -> Lbl v_lbl e_lbl
lbl_gr_to_lbl ([(v, v_lbl)]
v,[((v, v), e_lbl)]
e) =
  let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(v, v_lbl)]
v
      v' :: [Int]
v' = [Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1]
      tbl :: [(Int, v)]
tbl = forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
v' (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(v, v_lbl)]
v)
      get :: v -> Int
get v
k = forall v k. Eq v => v -> [(k, v)] -> k
T.reverse_lookup_err v
k [(Int, v)]
tbl
      e' :: [((Int, Int), e_lbl)]
e' = forall a b. (a -> b) -> [a] -> [b]
map (\((v
p,v
q),e_lbl
r) -> ((v -> Int
get v
p,v -> Int
get v
q),e_lbl
r)) [((v, v), e_lbl)]
e
  in (forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
v' (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(v, v_lbl)]
v),[((Int, Int), e_lbl)]
e')

-- | Convert from 'Gr' to 'Lbl'.
--
-- > gr_to_lbl ("ab",[('a','b')]) == ([(0,'a'),(1,'b')],[((0,1),('a','b'))])
gr_to_lbl :: Eq t => Gr t -> Lbl t (t,t)
gr_to_lbl :: forall t. Eq t => Gr t -> Lbl t (t, t)
gr_to_lbl ([t]
v,[(t, t)]
e) = forall v v_lbl e_lbl.
Eq v =>
Lbl_Gr v v_lbl e_lbl -> Lbl v_lbl e_lbl
lbl_gr_to_lbl (forall a b. [a] -> [b] -> [(a, b)]
zip [t]
v [t]
v,forall a b. [a] -> [b] -> [(a, b)]
zip [(t, t)]
e [(t, t)]
e)

-- | Delete edge labels from 'Lbl', replacing with '()'
lbl_delete_edge_labels :: Lbl v e -> Lbl_ v
lbl_delete_edge_labels :: forall v e. Lbl v e -> Lbl_ v
lbl_delete_edge_labels ([(Int, v)]
v,[((Int, Int), e)]
e) = ([(Int, v)]
v,forall a b. (a -> b) -> [a] -> [b]
map (\((Int, Int)
x,e
_) -> ((Int, Int)
x,())) [((Int, Int), e)]
e)

-- | 'lbl_delete_edge_labels' of 'gr_to_lbl'
gr_to_lbl_ :: Eq t => Gr t -> Lbl_ t
gr_to_lbl_ :: forall t. Eq t => Gr t -> Lbl_ t
gr_to_lbl_ = forall v e. Lbl v e -> Lbl_ v
lbl_delete_edge_labels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Eq t => Gr t -> Lbl t (t, t)
gr_to_lbl

-- | Construct Lbl from set of E, derives V from E.
eset_to_lbl :: Ord t => [(t,t)] -> Lbl_ t
eset_to_lbl :: forall t. Ord t => [(t, t)] -> Lbl_ t
eset_to_lbl [(t, t)]
e =
  let v :: [t]
v = forall a. Eq a => [a] -> [a]
nub (forall a. Ord a => [a] -> [a]
sort (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(t
i,t
j) -> [t
i,t
j]) [(t, t)]
e))
      get_ix :: t -> Int
get_ix t
z = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"eset_to_lbl") (forall a. Eq a => a -> [a] -> Maybe Int
elemIndex t
z [t]
v)
  in (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [t]
v, forall a b. (a -> b) -> [a] -> [b]
map (\(t
i,t
j) -> ((t -> Int
get_ix t
i,t -> Int
get_ix t
j),())) [(t, t)]
e)

-- | Unlabel 'Lbl' graph.
lbl_to_g :: Lbl v e -> G
lbl_to_g :: forall v e. Lbl v e -> G
lbl_to_g ([(Int, v)]
v,[((Int, Int), e)]
e) = (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Int, v)]
v,forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [((Int, Int), e)]
e)