{-# LANGUAGE RecordWildCards #-}
{-|
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 (netLimitsFiltered, simpleConnectionGenerator, generateValidConnection, generateFusableConnections) where

import qualified Data.Bimap                       as BM (
  fromList,
  lookup,
  member,
  memberR,
  null,
  Bimap,
  )
import qualified Data.Map                         as M (
  fromList,
  fromListWith,
  fromSet,
  elems,
  union,
  )
import qualified Data.Set                         as S (fromList)

import Modelling.PetriNet.Reach.Type (
  Net (..),
  Capacity,
  State (State),
  Connection,
  TransitionBehaviorConstraints,
  ArrowDensityConstraints (..),
  hasIsolatedNodes,
  satisfiesTransitionBehaviorConstraints,
  )

import Control.Monad                    (forM, guard)
import Control.Monad.Random.Class       (MonadRandom (getRandomR))
import Data.Maybe                       (fromMaybe)
import System.Random.Shuffle            (shuffleM)

-- | Generate a valid connection for a transition with retry logic
generateValidConnection
  :: (MonadRandom m, Ord s, Ord t)
  => BM.Bimap t s  -- ^ Bimap from fusable consuming-transitions to their input places
  -> BM.Bimap t s  -- ^ Bimap from fusable consuming-transitions to their output places
  -> m [s]         -- ^ Action to get input places
  -> m [s]         -- ^ Action to get output places
  -> t             -- ^ Transition
  -> m ([s], [s])  -- ^ (vor, nach)
generateValidConnection :: forall (m :: * -> *) s t.
(MonadRandom m, Ord s, Ord t) =>
Bimap t s -> Bimap t s -> m [s] -> m [s] -> t -> m ([s], [s])
generateValidConnection Bimap t s
transitionConsumingBimap Bimap t s
transitionProducingBimap =
  \m [s]
inputPlacesAction m [s]
outputPlacesAction t
t ->
  let
    go :: m ([s], [s])
go = do
      [s]
vor <- if t -> Bimap t s -> Bool
forall a b. (Ord a, Ord b) => a -> Bimap a b -> Bool
BM.member t
t Bimap t s
transitionConsumingBimap
             then [s] -> m [s]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
             else m [s]
inputPlacesAction
      [s]
nach <- if t -> Bimap t s -> Bool
forall a b. (Ord a, Ord b) => a -> Bimap a b -> Bool
BM.member t
t Bimap t s
transitionProducingBimap
              then [s] -> m [s]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
              else m [s]
outputPlacesAction
      -- Check both input and output place usage
      if t -> [s] -> [s] -> Bool
isValidInputPlaceUsage t
t [s]
vor [s]
nach Bool -> Bool -> Bool
&& t -> [s] -> [s] -> Bool
isValidOutputPlaceUsage t
t [s]
vor [s]
nach
        then ([s], [s]) -> m ([s], [s])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([s]
vor, [s]
nach)
        else m ([s], [s])
go  -- Retry if invalid
  in m ([s], [s])
go
  where
    -- | Check if input place usage is valid for a transition
    isValidInputPlaceUsage :: t -> [s] -> [s] -> Bool
isValidInputPlaceUsage =
      if Bimap t s -> Bool
forall a b. Bimap a b -> Bool
BM.null Bimap t s
transitionConsumingBimap
      then \t
_ [s]
_ [s]
_ -> Bool
True
      else \t
t [s]
vor [s]
nach ->
         -- For each place in vor: if it's a forbidden input place, only allow if vor == nach == [that place]
         (s -> Bool) -> [s] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\s
place -> Bool -> Bool
not (s -> Bimap t s -> Bool
forall a b. (Ord a, Ord b) => b -> Bimap a b -> Bool
BM.memberR s
place Bimap t s
transitionConsumingBimap) Bool -> Bool -> Bool
|| ([s]
vor [s] -> [s] -> Bool
forall a. Eq a => a -> a -> Bool
== [s
place] Bool -> Bool -> Bool
&& [s]
nach [s] -> [s] -> Bool
forall a. Eq a => a -> a -> Bool
== [s
place])) [s]
vor
         -- If t has a pregenerated input place, prevent that place from appearing in nach
         Bool -> Bool -> Bool
&& Bool -> (s -> Bool) -> Maybe s -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (s -> [s] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [s]
nach) (t -> Bimap t s -> Maybe s
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
a -> Bimap a b -> m b
BM.lookup t
t Bimap t s
transitionConsumingBimap)

    -- | Check if output place usage is valid for a transition
    isValidOutputPlaceUsage :: t -> [s] -> [s] -> Bool
isValidOutputPlaceUsage =
      if Bimap t s -> Bool
forall a b. Bimap a b -> Bool
BM.null Bimap t s
transitionProducingBimap
      then \t
_ [s]
_ [s]
_ -> Bool
True
      else \t
t [s]
vor [s]
nach ->
         -- For each place in nach: if it's a forbidden output place, only allow if vor == nach == [that place]
         (s -> Bool) -> [s] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\s
place -> Bool -> Bool
not (s -> Bimap t s -> Bool
forall a b. (Ord a, Ord b) => b -> Bimap a b -> Bool
BM.memberR s
place Bimap t s
transitionProducingBimap) Bool -> Bool -> Bool
|| ([s]
vor [s] -> [s] -> Bool
forall a. Eq a => a -> a -> Bool
== [s
place] Bool -> Bool -> Bool
&& [s]
nach [s] -> [s] -> Bool
forall a. Eq a => a -> a -> Bool
== [s
place])) [s]
nach
         -- If t has a pregenerated output place, prevent that place from appearing in vor
         Bool -> Bool -> Bool
&& Bool -> (s -> Bool) -> Maybe s -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (s -> [s] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [s]
vor) (t -> Bimap t s -> Maybe s
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
a -> Bimap a b -> m b
BM.lookup t
t Bimap t s
transitionProducingBimap)

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)

{- | 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'

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

-- | Helper to check if a value satisfies the given bounds
inBounds :: (Int, Maybe Int) -> Int -> Bool
inBounds :: (Int, Maybe Int) -> Int -> Bool
inBounds (Int
low, Maybe Int
maybeHigh) Int
value =
  Int
value Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
low Bool -> Bool -> Bool
&& Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int
value Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=) Maybe Int
maybeHigh

-- | Generate pre-determined fusable node connections
generateFusableConnections
  :: (MonadRandom m, Ord t, Ord s)
  => [s]  -- ^ All places
  -> [t]  -- ^ All transitions
  -> Int  -- ^ Number of fusable consuming-transitions to create
  -> Int  -- ^ Number of fusable producing-transitions to create
  -> m (BM.Bimap t s, BM.Bimap t s)
generateFusableConnections :: forall (m :: * -> *) t s.
(MonadRandom m, Ord t, Ord s) =>
[s] -> [t] -> Int -> Int -> m (Bimap t s, Bimap t s)
generateFusableConnections [s]
allPlaces [t]
allTransitions Int
numConsumingFusable Int
numProducingFusable = do
  -- Randomly select transitions and places for fusable nodes
  [t]
shuffledTransitions <- [t] -> m [t]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
shuffleM [t]
allTransitions
  [s]
shuffledPlaces <- [s] -> m [s]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
shuffleM [s]
allPlaces
  let ([t]
inputFusableTransitions, [t]
remainingTransitions) = Int -> [t] -> ([t], [t])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
numConsumingFusable [t]
shuffledTransitions
      outputFusableTransitions :: [t]
outputFusableTransitions = Int -> [t] -> [t]
forall a. Int -> [a] -> [a]
take Int
numProducingFusable [t]
remainingTransitions
      ([s]
placesForInputFusableTransitions, [s]
remainingPlaces) = Int -> [s] -> ([s], [s])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
numConsumingFusable [s]
shuffledPlaces
      placesForOutputFusableTransitions :: [s]
placesForOutputFusableTransitions = Int -> [s] -> [s]
forall a. Int -> [a] -> [a]
take Int
numProducingFusable [s]
remainingPlaces
  -- Create bimaps from transitions to their pregenerated places
  let transitionConsumingBimap :: Bimap t s
transitionConsumingBimap = [(t, s)] -> Bimap t s
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
BM.fromList ([(t, s)] -> Bimap t s) -> [(t, s)] -> Bimap t s
forall a b. (a -> b) -> a -> b
$ [t] -> [s] -> [(t, s)]
forall a b. [a] -> [b] -> [(a, b)]
zip [t]
inputFusableTransitions [s]
placesForInputFusableTransitions
      transitionProducingBimap :: Bimap t s
transitionProducingBimap = [(t, s)] -> Bimap t s
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
BM.fromList ([(t, s)] -> Bimap t s) -> [(t, s)] -> Bimap t s
forall a b. (a -> b) -> a -> b
$ [t] -> [s] -> [(t, s)]
forall a b. [a] -> [b] -> [(a, b)]
zip [t]
outputFusableTransitions [s]
placesForOutputFusableTransitions
  -- Return transition-place bimaps
  (Bimap t s, Bimap t s) -> m (Bimap t s, Bimap t s)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bimap t s
transitionConsumingBimap  -- bimap from fusable consuming-transitions to their places
         , Bimap t s
transitionProducingBimap  -- bimap from fusable producing-transitions to their places
         )

-- | Generate a net with limits and filtering for isolated nodes and transition behavior constraints,
-- potentially with pregenerated fusable connections (of which the makeUpdateConnection argument takes care)
netLimitsFiltered
  :: (MonadRandom m, Ord s, Ord t)
  => (m [s] -> m [s] -> t -> m (Connection s t))  -- ^ Function to make/update a connection for a transition
  -> ArrowDensityConstraints           -- ^ arrow density constraints
  -> Int                               -- ^ numPlaces
  -> [s]                               -- ^ places
  -> [t]                               -- ^ transitions
  -> Capacity s                        -- ^ capacityConstraint
  -> TransitionBehaviorConstraints     -- ^ transition behavior constraints
  -> m (Maybe (Net s t))
netLimitsFiltered :: forall (m :: * -> *) s t.
(MonadRandom m, Ord s, Ord t) =>
(m [s] -> m [s] -> t -> m (Connection s t))
-> ArrowDensityConstraints
-> Int
-> [s]
-> [t]
-> Capacity s
-> TransitionBehaviorConstraints
-> m (Maybe (Net s t))
netLimitsFiltered
  m [s] -> m [s] -> t -> m (Connection s t)
makeUpdateConnection
  ArrowDensityConstraints{(Int, Maybe Int)
incomingArrowsPerTransition :: (Int, Maybe Int)
outgoingArrowsPerTransition :: (Int, Maybe Int)
incomingArrowsPerPlace :: (Int, Maybe Int)
outgoingArrowsPerPlace :: (Int, Maybe Int)
totalArrowsFromPlacesToTransitions :: (Int, Maybe Int)
totalArrowsFromTransitionsToPlaces :: (Int, Maybe Int)
totalArrowsFromTransitionsToPlaces :: ArrowDensityConstraints -> (Int, Maybe Int)
totalArrowsFromPlacesToTransitions :: ArrowDensityConstraints -> (Int, Maybe Int)
outgoingArrowsPerPlace :: ArrowDensityConstraints -> (Int, Maybe Int)
incomingArrowsPerPlace :: ArrowDensityConstraints -> (Int, Maybe Int)
outgoingArrowsPerTransition :: ArrowDensityConstraints -> (Int, Maybe Int)
incomingArrowsPerTransition :: ArrowDensityConstraints -> (Int, Maybe Int)
..}
  Int
numPlaces
  [s]
ps
  [t]
ts
  Capacity s
capacityConstraint
  TransitionBehaviorConstraints
transitionBehaviorConstraints = do
  State s
s <- [s] -> m (State s)
forall (m :: * -> *) s.
(MonadRandom m, Ord s) =>
[s] -> m (State s)
state [s]
ps
  -- Generate connections for ALL transitions, respecting forbid sets
  [Connection s t]
theConnections <- [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 (m [s] -> m [s] -> t -> m (Connection s t)
makeUpdateConnection (Int -> Int -> [s] -> m [s]
forall (m :: * -> *) a. MonadRandom m => Int -> Int -> [a] -> m [a]
takeRandom Int
vLow Int
vHigh [s]
ps) (Int -> Int -> [s] -> m [s]
forall (m :: * -> *) a. MonadRandom m => Int -> Int -> [a] -> m [a]
takeRandom Int
nLow Int
nHigh [s]
ps))
  let n :: Net s t
n = 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]
theConnections,
    capacity :: Capacity s
capacity    = Capacity s
capacityConstraint,
    start :: State s
start       = State s
s
    }
  Maybe (Net s t) -> m (Maybe (Net s t))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Net s t) -> m (Maybe (Net s t)))
-> Maybe (Net s t) -> m (Maybe (Net s t))
forall a b. (a -> b) -> a -> b
$ do
    -- Filter out nets with isolated nodes
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Net s t -> Bool
forall s t. (Ord s, Ord t) => Net s t -> Bool
hasIsolatedNodes Net s t
n
    -- Filter out nets that don't satisfy transition behavior constraints
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Net s t -> TransitionBehaviorConstraints -> Bool
forall s t. Net s t -> TransitionBehaviorConstraints -> Bool
satisfiesTransitionBehaviorConstraints Net s t
n TransitionBehaviorConstraints
transitionBehaviorConstraints
    -- Filter out nets that don't satisfy arrow density constraints beyond incomingArrowsPerTransition and outgoingArrowsPerTransition
    let allTransToPlaces :: [s]
allTransToPlaces = (Connection s t -> [s]) -> [Connection s t] -> [s]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([s]
_, t
_, [s]
post) -> [s]
post) (Net s t -> [Connection s t]
forall s t. Net s t -> [Connection s t]
connections Net s t
n)
    let allPlacesToTrans :: [s]
allPlacesToTrans = (Connection s t -> [s]) -> [Connection s t] -> [s]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([s]
pre, t
_, [s]
_) -> [s]
pre) (Net s t -> [Connection s t]
forall s t. Net s t -> [Connection s t]
connections Net s t
n)
    let initialMap :: Map s Int
initialMap = (s -> Int) -> Set s -> Map s Int
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (Int -> s -> Int
forall a b. a -> b -> a
const Int
0) (Net s t -> Set s
forall s t. Net s t -> Set s
places Net s t
n)
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ case (Int, Maybe Int)
incomingArrowsPerPlace of
      (Int
0, Maybe Int
Nothing) -> Bool
True
      (Int, Maybe Int)
_ -> let countMap :: Map s Int
countMap = (Int -> Int -> Int) -> [(s, Int)] -> Map s Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [(s
place, Int
1) | s
place <- [s]
allTransToPlaces]
                          Map s Int -> Map s Int -> Map s Int
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map s Int
initialMap
           in (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int, Maybe Int) -> Int -> Bool
inBounds (Int, Maybe Int)
incomingArrowsPerPlace) ([Int] -> Bool) -> [Int] -> Bool
forall a b. (a -> b) -> a -> b
$ Map s Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map s Int
countMap
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ case (Int, Maybe Int)
outgoingArrowsPerPlace of
      (Int
0, Maybe Int
Nothing) -> Bool
True
      (Int, Maybe Int)
_ -> let countMap :: Map s Int
countMap = (Int -> Int -> Int) -> [(s, Int)] -> Map s Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [(s
place, Int
1) | s
place <- [s]
allPlacesToTrans]
                          Map s Int -> Map s Int -> Map s Int
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map s Int
initialMap
           in (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int, Maybe Int) -> Int -> Bool
inBounds (Int, Maybe Int)
outgoingArrowsPerPlace) ([Int] -> Bool) -> [Int] -> Bool
forall a b. (a -> b) -> a -> b
$ Map s Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map s Int
countMap
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ case (Int, Maybe Int)
totalArrowsFromPlacesToTransitions of
      (Int
0, Maybe Int
Nothing) -> Bool
True
      (Int, Maybe Int)
_ -> (Int, Maybe Int) -> Int -> Bool
inBounds (Int, Maybe Int)
totalArrowsFromPlacesToTransitions ([s] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [s]
allPlacesToTrans)
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ case (Int, Maybe Int)
totalArrowsFromTransitionsToPlaces of
      (Int
0, Maybe Int
Nothing) -> Bool
True
      (Int, Maybe Int)
_ -> (Int, Maybe Int) -> Int -> Bool
inBounds (Int, Maybe Int)
totalArrowsFromTransitionsToPlaces ([s] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [s]
allTransToPlaces)
    Net s t -> Maybe (Net s t)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Net s t
n
  where
    fixMaximum :: (Int, Maybe Int) -> (Int, Int)
    fixMaximum :: (Int, Maybe Int) -> (Int, Int)
fixMaximum (Int
low, Maybe Int
high) = (Int
low, Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
numPlaces Maybe Int
high)
    (Int
vLow, Int
vHigh) = (Int, Maybe Int) -> (Int, Int)
fixMaximum (Int, Maybe Int)
incomingArrowsPerTransition
    (Int
nLow, Int
nHigh) = (Int, Maybe Int) -> (Int, Int)
fixMaximum (Int, Maybe Int)
outgoingArrowsPerTransition

-- | Simple connection generator without fusable connections
simpleConnectionGenerator
  :: Monad m
  => m [s] -> m [s] -> t -> m (Connection s t)
simpleConnectionGenerator :: forall (m :: * -> *) s t.
Monad m =>
m [s] -> m [s] -> t -> m (Connection s t)
simpleConnectionGenerator m [s]
inputPlacesAction m [s]
outputPlacesAction t
t = do
  [s]
vor <- m [s]
inputPlacesAction
  [s]
nach <- m [s]
outputPlacesAction
  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)