{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module: Data.DiGraph.Random
-- Copyright: Copyright © 2019 - 2020 Kadena LLC.
-- License: MIT
-- Maintainer: Lars Kuhtz <lars@kadena.io>
-- Stability: experimental
--
-- Throughout the module an undirected graph is a directed graph that is
-- symmetric and irreflexive.
--
--
module Data.DiGraph.Random
(
-- * Random Regular Graph
  UniformRng
, rrgIO
, rrg

-- * Random Graphs in the \(G_{n,p}\) model
, gnp
) where

import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe

import qualified Data.Set as S

import Numeric.Natural

import qualified Streaming.Prelude as S

import qualified System.Random.MWC as MWC

-- internal modules

import Data.DiGraph

-- -------------------------------------------------------------------------- --
-- Utils

-- | Type of a random number generator that uniformily chooses an element from a
-- range.
--
type UniformRng m = (Int, Int) -> m Int

int :: Integral a => Num b => a -> b
int :: forall a b. (Integral a, Num b) => a -> b
int = forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE int #-}

-- -------------------------------------------------------------------------- --
-- Random Regular Graph

-- | Undirected, irreflexive random regular graph.
--
-- The algorithm here is incomplete. For a complete approach see for instance
-- https://users.cecs.anu.edu.au/~bdm/papers/RandRegGen.pdf
--
rrgIO
    :: Natural
    -> Natural
    -> IO (Maybe (DiGraph Int))
rrgIO :: Natural -> Natural -> IO (Maybe (DiGraph Int))
rrgIO Natural
n Natural
d = do
    Gen RealWorld
gen <- IO GenIO
MWC.createSystemRandom
    forall (m :: * -> *).
Monad m =>
UniformRng m -> Natural -> Natural -> m (Maybe (DiGraph Int))
rrg @IO (forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
`MWC.uniformR` Gen RealWorld
gen) Natural
n Natural
d

-- | Undirected, irreflexive random regular graph.
--
-- The algorithm here is incomplete. For a complete approach see for instance
-- https://users.cecs.anu.edu.au/~bdm/papers/RandRegGen.pdf
--
rrg
    :: Monad m
    => UniformRng m
        -- ^ a uniform random number generator
    -> Natural
    -> Natural
    -> m (Maybe (DiGraph Int))
rrg :: forall (m :: * -> *).
Monad m =>
UniformRng m -> Natural -> Natural -> m (Maybe (DiGraph Int))
rrg UniformRng m
gen Natural
n Natural
d = forall {a} {b}.
Hashable a =>
Natural -> Set (a, b) -> DiGraph a -> m (Maybe (DiGraph a))
go Natural
0 (forall a. Ord a => [a] -> Set a
S.fromList [(Int, Int)]
c) (Natural -> DiGraph Int
emptyGraph Natural
n)
  where
    v :: [Int]
v = [Int
0 .. forall a b. (Integral a, Num b) => a -> b
int Natural
n forall a. Num a => a -> a -> a
- Int
1]
    c :: [(Int, Int)]
c = [(Int
x, Int
y) | Int
x <- [Int]
v, Int
y <- [Int
0 :: Int .. forall a b. (Integral a, Num b) => a -> b
int Natural
d forall a. Num a => a -> a -> a
- Int
1]]

    go :: Natural -> Set (a, b) -> DiGraph a -> m (Maybe (DiGraph a))
go Natural
i Set (a, b)
s DiGraph a
g
        | forall a. Set a -> Bool
S.null Set (a, b)
s = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just DiGraph a
g
        | (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> Maybe (a, Set a)
S.minView Set (a, b)
s) forall a. Eq a => a -> a -> Bool
== (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> Maybe (a, Set a)
S.maxView Set (a, b)
s) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        | Bool
otherwise = forall {a} {b}.
Hashable a =>
Set (a, b) -> DiGraph a -> m (Maybe (Set (a, b), DiGraph a))
sampleEdge Set (a, b)
s DiGraph a
g forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (Set (a, b), DiGraph a)
Nothing -> if Natural
i forall a. Ord a => a -> a -> Bool
< Natural
n then Natural -> Set (a, b) -> DiGraph a -> m (Maybe (DiGraph a))
go (Natural
i forall a. Num a => a -> a -> a
+ Natural
1) Set (a, b)
s DiGraph a
g else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just (Set (a, b)
s', DiGraph a
g') -> Natural -> Set (a, b) -> DiGraph a -> m (Maybe (DiGraph a))
go Natural
0 Set (a, b)
s' DiGraph a
g'

    sampleEdge :: Set (a, b) -> DiGraph a -> m (Maybe (Set (a, b), DiGraph a))
sampleEdge Set (a, b)
s DiGraph a
graph = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
        (Set (a, b)
s', (a, b)
v₁) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
UniformRng m -> Set a -> m (Set a, a)
uniformSample UniformRng m
gen Set (a, b)
s
        (Set (a, b)
s'', (a, b)
v₂) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
UniformRng m -> Set a -> m (Set a, a)
uniformSample UniformRng m
gen Set (a, b)
s'
        let e₁ :: (a, a)
e₁ = (forall a b. (a, b) -> a
fst (a, b)
v₁, forall a b. (a, b) -> a
fst (a, b)
v₂)
        let e₂ :: (a, a)
e₂ = (forall a b. (a, b) -> a
fst (a, b)
v₂, forall a b. (a, b) -> a
fst (a, b)
v₁)
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (a, b)
v₁ forall a. Eq a => a -> a -> Bool
/= forall a b. (a, b) -> a
fst (a, b)
v₂ Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. (Eq a, Hashable a) => DiEdge a -> DiGraph a -> Bool
isEdge (a, a)
e₁ DiGraph a
graph)
        forall (m :: * -> *) a. Monad m => a -> m a
return (Set (a, b)
s'', forall a. (Eq a, Hashable a) => DiEdge a -> DiGraph a -> DiGraph a
insertEdge (a, a)
e₁ forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => DiEdge a -> DiGraph a -> DiGraph a
insertEdge (a, a)
e₂ DiGraph a
graph)

-- | Uniformily sample an element from the input set. Returns the set with the
-- sampled element removed and the sampled element.
--
uniformSample :: Monad m => UniformRng m -> S.Set a -> m (S.Set a, a)
uniformSample :: forall (m :: * -> *) a.
Monad m =>
UniformRng m -> Set a -> m (Set a, a)
uniformSample UniformRng m
gen Set a
s = do
    Int
p <- UniformRng m
gen (Int
0, forall a. Set a -> Int
S.size Set a
s forall a. Num a => a -> a -> a
- Int
1)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Int -> Set a -> Set a
S.deleteAt Int
p Set a
s, forall a. Int -> Set a -> a
S.elemAt Int
p Set a
s)

-- -------------------------------------------------------------------------- --
-- Gnp

-- | Undirected irreflexive random graph in the \(G_{n,p}\) model.
--
gnp
    :: forall m
    . Monad m
    => UniformRng m
    -> Natural
    -> Double
    -> m (DiGraph Int)
gnp :: forall (m :: * -> *).
Monad m =>
UniformRng m -> Natural -> Double -> m (DiGraph Int)
gnp UniformRng m
gen Natural
n Double
p = forall (m :: * -> *) x a b r.
Monad m =>
(x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r -> m b
S.fold_ (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (Eq a, Hashable a) => DiEdge a -> DiGraph a -> DiGraph a
insertEdge) (Natural -> DiGraph Int
emptyGraph Natural
n) forall a. a -> a
id
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (f :: * -> *) a r.
(Monad m, Foldable f) =>
Stream (Of (f a)) m r -> Stream (Of a) m r
S.concat
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
Monad m =>
(a -> m Bool) -> Stream (Of a) m r -> Stream (Of a) m r
S.filterM (forall a b. a -> b -> a
const m Bool
choice)
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
f a -> Stream (Of a) m ()
S.each
        [ [(Int
a,Int
b), (Int
b,Int
a)]
        | Int
a <- [Int
0..forall a b. (Integral a, Num b) => a -> b
int Natural
n forall a. Num a => a -> a -> a
- Int
1]
        , Int
b <- [Int
0..Int
aforall a. Num a => a -> a -> a
-Int
1]
        ]
  where
    choice :: m Bool
choice = do
        Int
v <- UniformRng m
gen (Int
0, forall a. Bounded a => a
maxBound)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
int Int
v forall a. Ord a => a -> a -> Bool
<= Double
p forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
int (forall a. Bounded a => a
maxBound :: Int)