{-# 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 :: a -> b
int = a -> b
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 (Gen RealWorld)
IO GenIO
MWC.createSystemRandom
    UniformRng IO -> Natural -> Natural -> IO (Maybe (DiGraph Int))
forall (m :: * -> *).
Monad m =>
UniformRng m -> Natural -> Natural -> m (Maybe (DiGraph Int))
rrg @IO ((Int, Int) -> GenIO -> IO Int
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
`MWC.uniformR` Gen RealWorld
GenIO
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 :: UniformRng m -> Natural -> Natural -> m (Maybe (DiGraph Int))
rrg UniformRng m
gen Natural
n Natural
d = Natural -> Set (Int, Int) -> DiGraph Int -> m (Maybe (DiGraph Int))
forall a b.
(Eq a, Hashable a) =>
Natural -> Set (a, b) -> DiGraph a -> m (Maybe (DiGraph a))
go Natural
0 ([(Int, Int)] -> Set (Int, Int)
forall a. Ord a => [a] -> Set a
S.fromList [(Int, Int)]
c) (Natural -> DiGraph Int
emptyGraph Natural
n)
  where
    v :: [Int]
v = [Int
0 .. Natural -> Int
forall a b. (Integral a, Num b) => a -> b
int Natural
n Int -> Int -> Int
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 .. Natural -> Int
forall a b. (Integral a, Num b) => a -> b
int Natural
d Int -> Int -> Int
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
        | Set (a, b) -> Bool
forall a. Set a -> Bool
S.null Set (a, b)
s = Maybe (DiGraph a) -> m (Maybe (DiGraph a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (DiGraph a) -> m (Maybe (DiGraph a)))
-> Maybe (DiGraph a) -> m (Maybe (DiGraph a))
forall a b. (a -> b) -> a -> b
$ DiGraph a -> Maybe (DiGraph a)
forall a. a -> Maybe a
Just DiGraph a
g
        | ((a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a)
-> (((a, b), Set (a, b)) -> (a, b)) -> ((a, b), Set (a, b)) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b), Set (a, b)) -> (a, b)
forall a b. (a, b) -> a
fst (((a, b), Set (a, b)) -> a)
-> Maybe ((a, b), Set (a, b)) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (a, b) -> Maybe ((a, b), Set (a, b))
forall a. Set a -> Maybe (a, Set a)
S.minView Set (a, b)
s) Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== ((a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a)
-> (((a, b), Set (a, b)) -> (a, b)) -> ((a, b), Set (a, b)) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b), Set (a, b)) -> (a, b)
forall a b. (a, b) -> a
fst (((a, b), Set (a, b)) -> a)
-> Maybe ((a, b), Set (a, b)) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (a, b) -> Maybe ((a, b), Set (a, b))
forall a. Set a -> Maybe (a, Set a)
S.maxView Set (a, b)
s) = Maybe (DiGraph a) -> m (Maybe (DiGraph a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DiGraph a)
forall a. Maybe a
Nothing
        | Bool
otherwise = Set (a, b) -> DiGraph a -> m (Maybe (Set (a, b), DiGraph a))
forall a b.
(Eq a, Hashable a) =>
Set (a, b) -> DiGraph a -> m (Maybe (Set (a, b), DiGraph a))
sampleEdge Set (a, b)
s DiGraph a
g m (Maybe (Set (a, b), DiGraph a))
-> (Maybe (Set (a, b), DiGraph a) -> m (Maybe (DiGraph a)))
-> m (Maybe (DiGraph a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (Set (a, b), DiGraph a)
Nothing -> if Natural
i Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Natural
n then Natural -> Set (a, b) -> DiGraph a -> m (Maybe (DiGraph a))
go (Natural
i Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1) Set (a, b)
s DiGraph a
g else Maybe (DiGraph a) -> m (Maybe (DiGraph a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DiGraph a)
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 = MaybeT m (Set (a, b), DiGraph a)
-> m (Maybe (Set (a, b), DiGraph a))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m (Set (a, b), DiGraph a)
 -> m (Maybe (Set (a, b), DiGraph a)))
-> MaybeT m (Set (a, b), DiGraph a)
-> m (Maybe (Set (a, b), DiGraph a))
forall a b. (a -> b) -> a -> b
$ do
        (Set (a, b)
s', (a, b)
v₁) <- m (Set (a, b), (a, b)) -> MaybeT m (Set (a, b), (a, b))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Set (a, b), (a, b)) -> MaybeT m (Set (a, b), (a, b)))
-> m (Set (a, b), (a, b)) -> MaybeT m (Set (a, b), (a, b))
forall a b. (a -> b) -> a -> b
$ UniformRng m -> Set (a, b) -> m (Set (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₂) <- m (Set (a, b), (a, b)) -> MaybeT m (Set (a, b), (a, b))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Set (a, b), (a, b)) -> MaybeT m (Set (a, b), (a, b)))
-> m (Set (a, b), (a, b)) -> MaybeT m (Set (a, b), (a, b))
forall a b. (a -> b) -> a -> b
$ UniformRng m -> Set (a, b) -> m (Set (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₁ = ((a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
v₁, (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
v₂)
        let e₂ :: (a, a)
e₂ = ((a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
v₂, (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
v₁)
        Bool -> MaybeT m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT m ()) -> Bool -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
v₁ a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
v₂ Bool -> Bool -> Bool
&& Bool -> Bool
not ((a, a) -> DiGraph a -> Bool
forall a. (Eq a, Hashable a) => DiEdge a -> DiGraph a -> Bool
isEdge (a, a)
e₁ DiGraph a
graph)
        (Set (a, b), DiGraph a) -> MaybeT m (Set (a, b), DiGraph a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set (a, b)
s'', (a, a) -> DiGraph a -> DiGraph a
forall a. (Eq a, Hashable a) => DiEdge a -> DiGraph a -> DiGraph a
insertEdge (a, a)
e₁ (DiGraph a -> DiGraph a) -> DiGraph a -> DiGraph a
forall a b. (a -> b) -> a -> b
$ (a, a) -> DiGraph a -> DiGraph a
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 :: UniformRng m -> Set a -> m (Set a, a)
uniformSample UniformRng m
gen Set a
s = do
    Int
p <- UniformRng m
gen (Int
0, Set a -> Int
forall a. Set a -> Int
S.size Set a
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    (Set a, a) -> m (Set a, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Set a -> Set a
forall a. Int -> Set a -> Set a
S.deleteAt Int
p Set a
s, Int -> Set a -> a
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 :: UniformRng m -> Natural -> Double -> m (DiGraph Int)
gnp UniformRng m
gen Natural
n Double
p = (DiGraph Int -> (Int, Int) -> DiGraph Int)
-> DiGraph Int
-> (DiGraph Int -> DiGraph Int)
-> Stream (Of (Int, Int)) m ()
-> m (DiGraph Int)
forall (m :: * -> *) x a b r.
Monad m =>
(x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r -> m b
S.fold_ (((Int, Int) -> DiGraph Int -> DiGraph Int)
-> DiGraph Int -> (Int, Int) -> DiGraph Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int, Int) -> DiGraph Int -> DiGraph Int
forall a. (Eq a, Hashable a) => DiEdge a -> DiGraph a -> DiGraph a
insertEdge) (Natural -> DiGraph Int
emptyGraph Natural
n) DiGraph Int -> DiGraph Int
forall a. a -> a
id
    (Stream (Of (Int, Int)) m () -> m (DiGraph Int))
-> Stream (Of (Int, Int)) m () -> m (DiGraph Int)
forall a b. (a -> b) -> a -> b
$ Stream (Of [(Int, Int)]) m () -> Stream (Of (Int, Int)) m ()
forall (m :: * -> *) (f :: * -> *) a r.
(Monad m, Foldable f) =>
Stream (Of (f a)) m r -> Stream (Of a) m r
S.concat
    (Stream (Of [(Int, Int)]) m () -> Stream (Of (Int, Int)) m ())
-> Stream (Of [(Int, Int)]) m () -> Stream (Of (Int, Int)) m ()
forall a b. (a -> b) -> a -> b
$ ([(Int, Int)] -> m Bool)
-> Stream (Of [(Int, Int)]) m () -> Stream (Of [(Int, Int)]) m ()
forall (m :: * -> *) a r.
Monad m =>
(a -> m Bool) -> Stream (Of a) m r -> Stream (Of a) m r
S.filterM (m Bool -> [(Int, Int)] -> m Bool
forall a b. a -> b -> a
const m Bool
choice)
    (Stream (Of [(Int, Int)]) m () -> Stream (Of [(Int, Int)]) m ())
-> Stream (Of [(Int, Int)]) m () -> Stream (Of [(Int, Int)]) m ()
forall a b. (a -> b) -> a -> b
$ [[(Int, Int)]] -> Stream (Of [(Int, Int)]) m ()
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..Natural -> Int
forall a b. (Integral a, Num b) => a -> b
int Natural
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
        , Int
b <- [Int
0..Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
        ]
  where
    choice :: m Bool
choice = do
        Int
v <- UniformRng m
gen (Int
0, Int
forall a. Bounded a => a
maxBound)
        Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
int Int
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
p Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
int (Int
forall a. Bounded a => a
maxBound :: Int)