{-|
originally from Autotool (https://gitlab.imn.htwk-leipzig.de/autotool/all0)
based on revision: ad25a990816a162fdd13941ff889653f22d6ea0a
based on file: collection/src/Petri/Roll.hs
-}
module Modelling.PetriNet.Reach.Roll (net, netLimits) where

import qualified Data.Map                         as M (fromList)
import qualified Data.Set                         as S (fromList)

import Modelling.PetriNet.Reach.Type (
  Net (..),
  Capacity,
  State (State),
  Connection,
  )

import Control.Monad                    (forM)
import Control.Monad.Random.Class       (MonadRandom (getRandomR))
import System.Random.Shuffle            (shuffleM)

net :: (MonadRandom m, Ord s, Ord t) => [s] -> [t] -> Capacity s -> m (Net s t)
net :: forall (m :: * -> *) s t.
(MonadRandom m, Ord s, Ord t) =>
[s] -> [t] -> Capacity s -> m (Net s t)
net = ([s] -> [t] -> m [Connection s t])
-> [s] -> [t] -> Capacity s -> m (Net s t)
forall (m :: * -> *) s t.
(MonadRandom m, Ord s, Ord t) =>
([s] -> [t] -> m [Connection s t])
-> [s] -> [t] -> Capacity s -> m (Net s t)
netConns [s] -> [t] -> m [Connection s t]
forall (m :: * -> *) s t.
MonadRandom m =>
[s] -> [t] -> m [Connection s t]
conn

netConns
  :: (MonadRandom m, Ord s, Ord t)
  => ([s] -> [t] -> m [Connection s t])
  -> [s]
  -> [t]
  -> Capacity s
  -> m (Net s t)
netConns :: forall (m :: * -> *) s t.
(MonadRandom m, Ord s, Ord t) =>
([s] -> [t] -> m [Connection s t])
-> [s] -> [t] -> Capacity s -> m (Net s t)
netConns [s] -> [t] -> m [Connection s t]
conns [s]
ps [t]
ts Capacity s
cap = do
  State s
s <- [s] -> m (State s)
forall (m :: * -> *) s.
(MonadRandom m, Ord s) =>
[s] -> m (State s)
state [s]
ps
  [Connection s t]
cs <- [s] -> [t] -> m [Connection s t]
conns [s]
ps [t]
ts
  Net s t -> m (Net s t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Net s t -> m (Net s t)) -> Net s t -> m (Net s t)
forall a b. (a -> b) -> a -> b
$ Net {
    places :: Set s
places      = [s] -> Set s
forall a. Ord a => [a] -> Set a
S.fromList [s]
ps,
    transitions :: Set t
transitions = [t] -> Set t
forall a. Ord a => [a] -> Set a
S.fromList [t]
ts,
    connections :: [Connection s t]
connections = [Connection s t]
cs,
    capacity :: Capacity s
capacity    = Capacity s
cap,
    start :: State s
start       = State s
s
    }

state :: (MonadRandom m, Ord s) => [s] -> m (State s)
state :: forall (m :: * -> *) s.
(MonadRandom m, Ord s) =>
[s] -> m (State s)
state [s]
ps = do
  [s]
qs <- [s] -> m [s]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
selection [s]
ps
  State s -> m (State s)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (State s -> m (State s)) -> State s -> m (State s)
forall a b. (a -> b) -> a -> b
$ Map s Int -> State s
forall s. Map s Int -> State s
State (Map s Int -> State s) -> Map s Int -> State s
forall a b. (a -> b) -> a -> b
$ [(s, Int)] -> Map s Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(s, Int)] -> Map s Int) -> [(s, Int)] -> Map s Int
forall a b. (a -> b) -> a -> b
$ do
    s
p <- [s]
ps
    (s, Int) -> [(s, Int)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (s
p, if s
p s -> [s] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [s]
qs then Int
1 else Int
0)

conn :: MonadRandom m => [s] -> [t] -> m [Connection s t]
conn :: forall (m :: * -> *) s t.
MonadRandom m =>
[s] -> [t] -> m [Connection s t]
conn [s]
ps [t]
ts = [t] -> (t -> m (Connection s t)) -> m [Connection s t]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [t]
ts ((t -> m (Connection s t)) -> m [Connection s t])
-> (t -> m (Connection s t)) -> m [Connection s t]
forall a b. (a -> b) -> a -> b
$ \t
t -> do
  [s]
vor <- [s] -> m [s]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
selection [s]
ps
  [s]
nach <- [s] -> m [s]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
selection [s]
ps
  Connection s t -> m (Connection s t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([s]
vor, t
t, [s]
nach)

{- | pick a non-empty subset,
 size s with probability 2^-s
-}
selection :: MonadRandom m => [a] -> m [a]
selection :: forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
selection [] = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
selection [a]
xs = do
  Int
i <- (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  let ([a]
pre,a
x:[a]
post) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
xs
  Bool
f <- (Bool, Bool) -> m Bool
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Bool
False, Bool
True)
  [a]
xs' <- if Bool
f then [a] -> m [a]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
selection ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ [a]
pre [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
post else [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs'

netLimits
  :: (MonadRandom m, Ord s, Ord t)
  => Int
  -> Int
  -> Int
  -> Int
  -> [s]
  -> [t]
  -> Capacity s
  -> m (Net s t)
netLimits :: forall (m :: * -> *) s t.
(MonadRandom m, Ord s, Ord t) =>
Int -> Int -> Int -> Int -> [s] -> [t] -> Capacity s -> m (Net s t)
netLimits Int
vLow Int
vHigh Int
nLow Int
nHigh = ([s] -> [t] -> m [Connection s t])
-> [s] -> [t] -> Capacity s -> m (Net s t)
forall (m :: * -> *) s t.
(MonadRandom m, Ord s, Ord t) =>
([s] -> [t] -> m [Connection s t])
-> [s] -> [t] -> Capacity s -> m (Net s t)
netConns (([s] -> [t] -> m [Connection s t])
 -> [s] -> [t] -> Capacity s -> m (Net s t))
-> ([s] -> [t] -> m [Connection s t])
-> [s]
-> [t]
-> Capacity s
-> m (Net s t)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> [s] -> [t] -> m [Connection s t]
forall (m :: * -> *) s t.
MonadRandom m =>
Int -> Int -> Int -> Int -> [s] -> [t] -> m [Connection s t]
connLimits Int
vLow Int
vHigh Int
nLow Int
nHigh

connLimits
  :: MonadRandom m
  => Int
  -> Int
  -> Int
  -> Int
  -> [s]
  -> [t]
  -> m [Connection s t]
connLimits :: forall (m :: * -> *) s t.
MonadRandom m =>
Int -> Int -> Int -> Int -> [s] -> [t] -> m [Connection s t]
connLimits Int
vLow Int
vHigh Int
nLow Int
nHigh [s]
ps [t]
ts = [t] -> (t -> m (Connection s t)) -> m [Connection s t]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [t]
ts ((t -> m (Connection s t)) -> m [Connection s t])
-> (t -> m (Connection s t)) -> m [Connection s t]
forall a b. (a -> b) -> a -> b
$ \t
t -> do
  [s]
vor <- Int -> Int -> [s] -> m [s]
forall (m :: * -> *) a. MonadRandom m => Int -> Int -> [a] -> m [a]
takeRandom Int
vLow Int
vHigh [s]
ps
  [s]
nach <- Int -> Int -> [s] -> m [s]
forall (m :: * -> *) a. MonadRandom m => Int -> Int -> [a] -> m [a]
takeRandom Int
nLow Int
nHigh [s]
ps
  Connection s t -> m (Connection s t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([s]
vor, t
t, [s]
nach)

takeRandom :: MonadRandom m => Int -> Int -> [a] -> m [a]
takeRandom :: forall (m :: * -> *) a. MonadRandom m => Int -> Int -> [a] -> m [a]
takeRandom Int
low Int
high [a]
xs  = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take
  (Int -> [a] -> [a]) -> m Int -> m ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
low, Int
high)
  m ([a] -> [a]) -> m [a] -> m [a]
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [a] -> m [a]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
shuffleM [a]
xs