module HGraph.Directed.Generator
       ( bidirectedCycle
       , randomAcyclicDigraph
       , randomDigraph
       , oneWayGrid
       )
where

import Control.Monad.State
import Data.List
import HGraph.Directed
import HGraph.Utils
import qualified Data.Set as S
import qualified HGraph.Undirected.AdjacencyMap as U
import qualified HGraph.Undirected              as U
import qualified HGraph.Undirected.Generator    as U
import System.Random

-- | A cycle where vertices are connected in both directions
bidirectedCycle :: t a -> a -> t a
bidirectedCycle t a
d0 a
n =
  ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex t a
d0 [a
0..a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1]) ([(a, a)] -> t a) -> [(a, a)] -> t a
forall a b. (a -> b) -> a -> b
$ 
    ([a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a
0..a
na -> a -> a
forall a. Num a => a -> a -> a
-a
2]) (a
0 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a
1..a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1]))
    [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ ([a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (a
0a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1,a
na -> a -> a
forall a. Num a => a -> a -> a
-a
2..a
1]) ((a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a
na -> a -> a
forall a. Num a => a -> a -> a
-a
2,a
na -> a -> a
forall a. Num a => a -> a -> a
-a
3..a
0]))

-- |Generate a random weakly-connected acyclic digraph with `n` vertices and `m` + `n` - 1 arcs.
randomAcyclicDigraph :: t t -> t -> t -> StateT g Identity (t t)
randomAcyclicDigraph t t
d0 t
n t
m' = do
  Graph t
utree <- Graph t -> t -> StateT g Identity (Graph t)
forall {g} {t :: * -> *} {a}.
(RandomGen g, Mutable t, Ord a, UndirectedGraph t, Num a,
 Enum a) =>
t a -> a -> StateT g Identity (t a)
U.randomTree Graph t
forall a. Ord a => Graph a
U.emptyGraph t
n
  let m :: t
m = t -> t -> t
forall a. Ord a => a -> a -> a
max (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) (t -> t -> t
forall a. Ord a => a -> a -> a
min t
m' (t
n t -> t -> t
forall a. Num a => a -> a -> a
* (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
2))
      dtree :: t t
dtree = t t -> Graph t -> t t
forall {t :: * -> *} {t :: * -> *} {a}.
(Mutable t, DirectedGraph t, UndirectedGraph t, Ord a) =>
t a -> t a -> t a
acyclicOrientation t t
d0 Graph t
utree
  if (t
m t -> t -> t
forall a. Num a => a -> a -> a
+ t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> (t
n t -> t -> t
forall a. Num a => a -> a -> a
* (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)) t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
4 then do
    t t
d' <- t t -> t -> StateT g Identity (t t)
forall {t :: * -> *} {a} {g} {t}.
(DirectedGraph t, Random a, RandomGen g, Integral t, Integral a,
 Adjacency t, Mutable t) =>
t a -> t -> StateT g Identity (t a)
removeRandomArcs (((t, t) -> t t -> t t) -> t t -> [(t, t)] -> t t
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (t, t) -> t t -> t t
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((t -> t t -> t t) -> t t -> [t] -> t t
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr t -> t t -> t t
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t t -> t t
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t t
d0) ([t] -> t t) -> [t] -> t t
forall a b. (a -> b) -> a -> b
$ t t -> [t]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t t
dtree)
                            [ (t
v,t
u)
                            | t
v <- t t -> [t]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t t
dtree
                            , t
u <- t t -> [t]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t t
dtree
                            , t
v t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
u Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ t t -> (t, t) -> Bool
forall a. t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t t
dtree (t
v,t
u))
                            ]
                     )
                     (t
m t -> t -> t
forall a. Num a => a -> a -> a
- t
n t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)
    t t -> StateT g Identity (t t)
forall a. a -> StateT g Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (t t -> StateT g Identity (t t)) -> t t -> StateT g Identity (t t)
forall a b. (a -> b) -> a -> b
$ ((t, t) -> t t -> t t) -> t t -> [(t, t)] -> t t
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (t, t) -> t t -> t t
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc t t
d' ([(t, t)] -> t t) -> [(t, t)] -> t t
forall a b. (a -> b) -> a -> b
$ t t -> [(t, t)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t t
dtree
  else
    t t -> t -> StateT g Identity (t t)
forall {t :: * -> *} {a} {g} {t}.
(DirectedGraph t, Random a, RandomGen g, Integral t, Integral a,
 Mutable t) =>
t a -> t -> StateT g Identity (t a)
addRandomArcsAcyclic t t
dtree t
m

-- An acyclic grid where columns only go down and rows only go left.
oneWayGrid :: t a -> a -> a -> t a
oneWayGrid t a
d0 a
w a
h = 
      ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t a -> t a
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t a
d0) ([a
0..a
w a -> a -> a
forall a. Num a => a -> a -> a
* a
h a -> a -> a
forall a. Num a => a -> a -> a
- a
1])) ([(a, a)] -> t a) -> [(a, a)] -> t a
forall a b. (a -> b) -> a -> b
$
                      [ (a
v, a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
                      | a
r <- [a
0..a
ha -> a -> a
forall a. Num a => a -> a -> a
-a
1]
                      , a
c <- [a
0..a
wa -> a -> a
forall a. Num a => a -> a -> a
-a
2]
                      , let v :: a
v = a
ra -> a -> a
forall a. Num a => a -> a -> a
*a
w a -> a -> a
forall a. Num a => a -> a -> a
+ a
c
                      ]
                      [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++
                      [ (a
v, a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
w)
                      | a
r <- [a
0..a
ha -> a -> a
forall a. Num a => a -> a -> a
-a
2]
                      , a
c <- [a
0..a
wa -> a -> a
forall a. Num a => a -> a -> a
-a
1]
                      , let v :: a
v = a
ra -> a -> a
forall a. Num a => a -> a -> a
*a
w a -> a -> a
forall a. Num a => a -> a -> a
+ a
c
                      ]

acyclicOrientation :: t a -> t a -> t a
acyclicOrientation t a
d0 t a
g = ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t a -> t a
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t a
d0) ([a] -> t a) -> [a] -> t a
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. UndirectedGraph t => t a -> [a]
U.vertices t a
g) ([(a, a)] -> t a) -> [(a, a)] -> t a
forall a b. (a -> b) -> a -> b
$
  [ if a
u a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
v then (a
u,a
v) else (a
v,a
u)
  | (a
u,a
v) <- t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. UndirectedGraph t => t a -> [(a, a)]
U.edges t a
g
  ]

randomDigraph :: t t -> t -> t -> StateT g Identity (t t)
randomDigraph t t
g0 t
n t
m
  | t
m t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> (t
n t -> t -> t
forall a. Num a => a -> a -> a
* (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)) = t t -> t -> t -> StateT g Identity (t t)
randomDigraph t t
g0 t
n (t
n t -> t -> t
forall a. Num a => a -> a -> a
* (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1))
  | t
m t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> (t
n t -> t -> t
forall a. Num a => a -> a -> a
* (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)) t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
2 = do -- dense graph
    let g1 :: t t
g1 = ((t, t) -> t t -> t t) -> t t -> [(t, t)] -> t t
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (t, t) -> t t -> t t
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((t -> t t -> t t) -> t t -> [t] -> t t
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr t -> t t -> t t
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t t -> t t
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t t
g0) [t
1..t
n]) [(t
v,t
u) | t
v <- [t
1..t
n], t
u <- [t
1..t
n], t
v t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/= t
u]
    t t -> t -> StateT g Identity (t t)
forall {t :: * -> *} {a} {g} {t}.
(DirectedGraph t, Random a, RandomGen g, Integral t, Integral a,
 Adjacency t, Mutable t) =>
t a -> t -> StateT g Identity (t a)
removeRandomArcs t t
g1 t
m
  | Bool
otherwise = do -- sparse graph
    let g1 :: t t
g1 = (t -> t t -> t t) -> t t -> [t] -> t t
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr t -> t t -> t t
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t t -> t t
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t t
g0) [t
0..t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1]
    t t -> t -> StateT g Identity (t t)
forall {t :: * -> *} {a} {g} {t}.
(DirectedGraph t, Random a, RandomGen g, Integral t, Integral a,
 Mutable t) =>
t a -> t -> StateT g Identity (t a)
addRandomArcs t t
g1 t
m

addRandomArcs :: t a -> t -> StateT g Identity (t a)
addRandomArcs t a
g t
m
  | t a -> t
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numArcs t a
g t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
m = t a -> StateT g Identity (t a)
forall a. a -> StateT g Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return t a
g
  | Bool
otherwise = do
    a
v <- a -> a -> State g a
forall a g. (Random a, RandomGen g) => a -> a -> State g a
randomN a
0 (t a -> a
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t a
g a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
    a
u <- a -> a -> State g a
forall a g. (Random a, RandomGen g) => a -> a -> State g a
randomN a
0 (t a -> a
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t a
g a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
    if a
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
v then
      t a -> t -> StateT g Identity (t a)
addRandomArcs ((a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc (a
v,a
u) t a
g) t
m
    else
      t a -> t -> StateT g Identity (t a)
addRandomArcs t a
g t
m

addRandomArcsAcyclic :: t a -> t -> StateT g Identity (t a)
addRandomArcsAcyclic t a
g t
m
  | t a -> t
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numArcs t a
g t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
m = t a -> StateT g Identity (t a)
forall a. a -> StateT g Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return t a
g
  | Bool
otherwise = do
    a
v <- a -> a -> State g a
forall a g. (Random a, RandomGen g) => a -> a -> State g a
randomN a
0 (t a -> a
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t a
g a -> a -> a
forall a. Num a => a -> a -> a
- a
2)
    a
u <- a -> a -> State g a
forall a g. (Random a, RandomGen g) => a -> a -> State g a
randomN (a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) (t a -> a
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t a
g a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
    if a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
u then
      t a -> t -> StateT g Identity (t a)
addRandomArcsAcyclic ((a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc (a
v,a
u) t a
g) t
m
    else
      t a -> t -> StateT g Identity (t a)
addRandomArcsAcyclic t a
g t
m

removeRandomArcs :: t a -> t -> StateT g Identity (t a)
removeRandomArcs t a
g t
m
  | t a -> t
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numArcs t a
g t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
m = t a -> StateT g Identity (t a)
forall a. a -> StateT g Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return t a
g
  | Bool
otherwise = do
    a
v <- a -> a -> State g a
forall a g. (Random a, RandomGen g) => a -> a -> State g a
randomN a
0 (t a -> a
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t a
g a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
    a
u <- a -> a -> State g a
forall a g. (Random a, RandomGen g) => a -> a -> State g a
randomN a
0 (t a -> a
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t a
g a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
    if a
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
v Bool -> Bool -> Bool
&& t a -> (a, a) -> Bool
forall a. t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t a
g (a
v,a
u) then
      t a -> t -> StateT g Identity (t a)
removeRandomArcs ((a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
removeArc (a
v,a
u) t a
g) t
m
    else
      t a -> t -> StateT g Identity (t a)
removeRandomArcs t a
g t
m