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

-- | Schedule generators for a single peer
--
-- These functions generate schedules for the tip points, the header points and
-- the block points of a single peer. All of them are expressed in terms of
-- block indices rather than actual block points.
--
-- The tip points are to be generated first with either of 'singleJumpTipPoints'
-- or 'rollbacksTipPoints'. Then the tip points can be assigned times at which
-- to announce them with 'tipPointSchedule'. Then, the header points can be
-- generated with 'headerPointSchedule'. Finally, the block points can be
-- generated with 'headerPointSchedule' as well. See the implementation of
-- 'Test.Consensus.PointSchedule.Random.singleJumpPeerSchedule' for an example.
--
module Test.Consensus.PointSchedule.SinglePeer.Indices (
    HeaderPointSchedule (..)
  , headerPointSchedule
  , rollbacksTipPoints
  , singleJumpTipPoints
  , tipPointSchedule
  , uniformRMDiffTime
  ) where

import           Control.Monad (forM, replicateM)
import           Control.Monad.Class.MonadTime.SI (Time (Time), addTime)
import           Data.List (sort)
import           Data.Time.Clock (DiffTime, diffTimeToPicoseconds,
                     picosecondsToDiffTime)
import           GHC.Stack (HasCallStack)
import           Ouroboros.Network.Block (SlotNo (SlotNo))
import qualified System.Random.Stateful as R


-- | @singleJumpTipPoints g m n@ generates a list of tip points for a single peer
-- serving a single branch between block indices @m@ and @n@. The schedule is a
-- list of block indices for the tip point of the peer state.
--
-- The first tip jumps to a block in the middle of the index range, and
-- then updates the tip one block at a time.
--
-- > singleJumpTipPoints
-- >   :: g
-- >   -> {m:Int | m >= 0}
-- >   -> {n:Int | n >= 0}
-- >   -> m {v:[Int]
-- >        | isSorted v &&
-- >          all (m<=) v &&
-- >          all (<=n) v &&
-- >          not (hasDuplicates v)
-- >        }
--
singleJumpTipPoints :: R.StatefulGen g m => g -> Int -> Int -> m [Int]
singleJumpTipPoints :: forall g (m :: * -> *).
StatefulGen g m =>
g -> Int -> Int -> m [Int]
singleJumpTipPoints g
_g Int
m Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
m = [Int] -> m [Int]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
singleJumpTipPoints g
g Int
m Int
n = do
    Int
jump <- (Int, Int) -> g -> m Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
R.uniformRM (Int
m, Int
n) g
g
    [Int] -> m [Int]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int
jump..Int
n]

-- | @rollbacksTipPoints k bs g@ generates a schedule for a single peer
-- serving from multiple alternative branches. The schedule is a list of block
-- indices for the tip point of the peer state. Here the block indices are
-- separated per branch in the result. Each index is relative to the branch it
-- belongs to.
--
-- @k@ is the security parameter.
--
-- @bs@ are the length in blocks of the alternative branches of the block tree.
-- The lengths need to be provided in the order in which the branches intersect
-- with the trunk.
--
-- > rollbacksTipPoints
-- >   :: g
-- >   -> {k:Int | k > 0}
-- >   -> {bs:[Int] | all (0<=) bs}
-- >   -> m {v:[Int]
-- >        | isSorted v &&
-- >          all (all (0<=)) v &&
-- >          all (all (<k)) v &&
-- >          all isSorted v &&
-- >          all (not . hasDuplicates) v &&
-- >          and [all (<bn) bbs | (bn, bbs) <- zip bs v] &&
-- >          length v == length bs bracketChainSyncClient
-- >        }
--
rollbacksTipPoints
  :: R.StatefulGen g m => g -> Int -> [Int] -> m [[Int]]
rollbacksTipPoints :: forall g (m :: * -> *).
StatefulGen g m =>
g -> Int -> [Int] -> m [[Int]]
rollbacksTipPoints g
g Int
k = (Int -> m [Int]) -> [Int] -> m [[Int]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Int -> m [Int]
forall {m :: * -> *}. StatefulGen g m => Int -> m [Int]
walkBranch
  where
    walkBranch :: Int -> m [Int]
walkBranch Int
bn = g -> Int -> Int -> m [Int]
forall g (m :: * -> *).
StatefulGen g m =>
g -> Int -> Int -> m [Int]
singleJumpTipPoints g
g Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
bn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))


-- | @tipPointSchedule g slotLengh msgDelayInterval slots@ attaches times to a
-- sequence of tip points. These times are the times at which the tip points
-- should be offered to the node under test. Times are expressed as an offset
-- from the time of slot 0.
--
-- @slotLength@ is the length of a slot in seconds.
--
-- @msgDelayInterval@ is the interval from which to sample the delay of
-- each tip point after the slot in which it was minted.
--
-- @slots@ are the slot numbers of the blocks in the tip point schedule.
-- Because the slots might belong to different branches, they might be
-- duplicated or not monotonically increasing. e.g.
--
-- If 0s and 1s signal the tip points that we want to announce
--
-- > slot number: 0123456
-- > trunk  :     011001
-- > alternative:   01101
--
-- The slots of the tip points to serve could be @[1, 2, 5, 3, 4, 6]@
-- Then the generated times could be close to
--
-- > [1*20, 2*20, 5*20, t3, t4, 6*20]
--
-- where @t3@ and @t4@ are chosen randomly in the interval between the
-- branch tips, that is between 5*20 and 6*20.
--
-- > tipPointSchedule
-- >   :: g
-- >   -> {slotLength:DiffTime | slotLength >= 0}
-- >   -> {msgDelayInterval:(DiffTime, DiffTime)
-- >      | fst msgDelayInterval <= snd msgDelayInterval
-- >      }
-- >   -> {slots:[SlotNo] | all (0<=) slots}
-- >   -> m {v:[DiffTime] | isSorted v && length v == length slots}
--
tipPointSchedule
  :: forall g m. R.StatefulGen g m => g -> DiffTime -> (DiffTime, DiffTime) -> [SlotNo] -> m [Time]
tipPointSchedule :: forall g (m :: * -> *).
StatefulGen g m =>
g -> DiffTime -> (DiffTime, DiffTime) -> [SlotNo] -> m [Time]
tipPointSchedule g
_g DiffTime
slotLength (DiffTime
a, DiffTime
b) [SlotNo]
_slots
    | DiffTime
slotLength DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= DiffTime
b = [Char] -> m [Time]
forall a. HasCallStack => [Char] -> a
error [Char]
"tipPointSchedule: slotLength <= maximum delay"
    | DiffTime
b DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
a = [Char] -> m [Time]
forall a. HasCallStack => [Char] -> a
error [Char]
"tipPointSchedule: empty delay interval"
tipPointSchedule g
g DiffTime
slotLength (DiffTime, DiffTime)
msgDelayInterval [SlotNo]
slots = do
    let -- pairs of times corresponding to the start and end of each interval
        -- between tip points
        slotTimes :: [Time]
slotTimes = (SlotNo -> Time) -> [SlotNo] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map SlotNo -> Time
slotTime [SlotNo]
slots
        timePairs :: [(Time, Time)]
timePairs = [Time] -> [Time] -> [(Time, Time)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Time]
slotTimes ([Time] -> [(Time, Time)]) -> [Time] -> [(Time, Time)]
forall a b. (a -> b) -> a -> b
$ (Int -> [Time] -> [Time]
forall a. Int -> [a] -> [a]
drop Int
1 [Time]
slotTimes) [Time] -> [Time] -> [Time]
forall a. [a] -> [a] -> [a]
++ [DiffTime -> Time -> Time
addTime DiffTime
1 ([Time] -> Time
forall a. HasCallStack => [a] -> a
last [Time]
slotTimes)]
    [(Time, Time)] -> m [Time]
go [(Time, Time)]
timePairs
  where
    go :: [(Time, Time)] -> m [Time]
    go :: [(Time, Time)] -> m [Time]
go [] = [Time] -> m [Time]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    go [(Time, Time)]
xs = do
      -- While the slots are increasing, assign a time to each point
      -- by choosing a random time in the delay interval after the
      -- slot start
      let ([(Time, Time)]
pointSeq, [(Time, Time)]
newBranch) = ((Time, Time) -> Bool)
-> [(Time, Time)] -> ([(Time, Time)], [(Time, Time)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(Time
a, Time
b) -> Time
a Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
b) [(Time, Time)]
xs
      [Time]
times <- [(Time, Time)] -> ((Time, Time) -> m Time) -> m [Time]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Time, Time)]
pointSeq (((Time, Time) -> m Time) -> m [Time])
-> ((Time, Time) -> m Time) -> m [Time]
forall a b. (a -> b) -> a -> b
$ \(Time
s, Time
_) -> do
                 DiffTime
delay <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime, DiffTime)
msgDelayInterval g
g
                 Time -> m Time
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> m Time) -> Time -> m Time
forall a b. (a -> b) -> a -> b
$ DiffTime -> Time -> Time
addTime DiffTime
delay Time
s
      ([Time]
times', [(Time, Time)]
xss) <- case [(Time, Time)]
newBranch of
        [] -> ([Time], [(Time, Time)]) -> m ([Time], [(Time, Time)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
        ((Time
seqLast, Time
_) : [(Time, Time)]
branches) -> do
          DiffTime
delay <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime, DiffTime)
msgDelayInterval g
g
          let lastTime :: Time
lastTime = DiffTime -> Time -> Time
addTime DiffTime
delay Time
seqLast
          ([Time]
times', [(Time, Time)]
xss) <- Time -> [(Time, Time)] -> m ([Time], [(Time, Time)])
handleDelayedTipPoints Time
lastTime [(Time, Time)]
branches
          ([Time], [(Time, Time)]) -> m ([Time], [(Time, Time)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time
lastTime Time -> [Time] -> [Time]
forall a. a -> [a] -> [a]
: [Time]
times', [(Time, Time)]
xss)
      -- When the slots are not increasing, we must be doing a rollback.
      -- We might have tip points in past slots.
      [Time]
times'' <- [(Time, Time)] -> m [Time]
go [(Time, Time)]
xss
      [Time] -> m [Time]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Time] -> m [Time]) -> [Time] -> m [Time]
forall a b. (a -> b) -> a -> b
$ [Time]
times [Time] -> [Time] -> [Time]
forall a. [a] -> [a] -> [a]
++ [Time]
times' [Time] -> [Time] -> [Time]
forall a. [a] -> [a] -> [a]
++ [Time]
times''

    -- | The amount of time taken by the given number of slots.
    slotsDiffTime :: Int -> DiffTime
    slotsDiffTime :: Int -> DiffTime
slotsDiffTime Int
s = Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
slotLength

    -- | The time at the start of the slot.
    slotTime :: SlotNo -> Time
    slotTime :: SlotNo -> Time
slotTime (SlotNo Word64
s) = DiffTime -> Time
Time (Int -> DiffTime
slotsDiffTime (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s))

    -- | Assign times to tip points in past slots. A past slot is
    -- any earlier slot than the first parameter.
    --
    -- Yields the assigned times and the remaining tip points which
    -- aren't in the past.
    handleDelayedTipPoints :: Time -> [(Time, Time)] -> m ([Time], [(Time, Time)])
    handleDelayedTipPoints :: Time -> [(Time, Time)] -> m ([Time], [(Time, Time)])
handleDelayedTipPoints Time
lastTime [(Time, Time)]
xss = do
      let ([(Time, Time)]
pointSeq, [(Time, Time)]
newBranch) = ((Time, Time) -> Bool)
-> [(Time, Time)] -> ([(Time, Time)], [(Time, Time)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(Time
a, Time
_) -> DiffTime -> Time -> Time
addTime ((DiffTime, DiffTime) -> DiffTime
forall a b. (a, b) -> a
fst (DiffTime, DiffTime)
msgDelayInterval) Time
a Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
lastTime) [(Time, Time)]
xss
          nseq :: Int
nseq = [(Time, Time)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Time, Time)]
pointSeq
          -- The first point in xss that is not in the past
          firstLater :: Time
firstLater = case [(Time, Time)]
newBranch of
            -- If there is no later point, pick an arbitrary later time interval
            -- to sample from
            []           -> DiffTime -> Time -> Time
addTime (Int -> DiffTime
slotsDiffTime (Int -> Int
forall a. Enum a => Int -> a
toEnum Int
nseq)) Time
lastTime
            ((Time
a, Time
_) : [(Time, Time)]
_) -> DiffTime -> Time -> Time
addTime ((DiffTime, DiffTime) -> DiffTime
forall a b. (a, b) -> a
fst (DiffTime, DiffTime)
msgDelayInterval) Time
a
      [Time]
times <- Int -> m Time -> m [Time]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nseq ((Time, Time) -> g -> m Time
forall g (m :: * -> *).
StatefulGen g m =>
(Time, Time) -> g -> m Time
uniformRMTime (Time
lastTime, Time
firstLater) g
g)
      ([Time], [(Time, Time)]) -> m ([Time], [(Time, Time)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Time] -> [Time]
forall a. Ord a => [a] -> [a]
sort [Time]
times, [(Time, Time)]
newBranch)

-- | Uniformely choose a relative 'DiffTime' in the given range.
uniformRMDiffTime :: R.StatefulGen g m => (DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime :: forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime
a, DiffTime
b) g
g =
    Integer -> DiffTime
picosecondsToDiffTime (Integer -> DiffTime) -> m Integer -> m DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (Integer, Integer) -> g -> m Integer
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Integer, Integer) -> g -> m Integer
R.uniformRM (DiffTime -> Integer
diffTimeToPicoseconds DiffTime
a, DiffTime -> Integer
diffTimeToPicoseconds DiffTime
b) g
g

-- | Uniformely choose an absolute 'Time' in the given range.
uniformRMTime :: R.StatefulGen g m => (Time, Time) -> g -> m Time
uniformRMTime :: forall g (m :: * -> *).
StatefulGen g m =>
(Time, Time) -> g -> m Time
uniformRMTime (Time DiffTime
a, Time DiffTime
b) g
g = DiffTime -> Time
Time (DiffTime -> Time) -> m DiffTime -> m Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime
a, DiffTime
b) g
g

data HeaderPointSchedule = HeaderPointSchedule {
    HeaderPointSchedule -> [(Time, Int)]
hpsTrunk  :: [(Time, Int)] -- ^ header points up to the intersection
  , HeaderPointSchedule -> [(Time, Int)]
hpsBranch :: [(Time, Int)] -- ^ header points after the intersection
                               -- indices are relative to the branch
  }
  deriving (Int -> HeaderPointSchedule -> ShowS
[HeaderPointSchedule] -> ShowS
HeaderPointSchedule -> [Char]
(Int -> HeaderPointSchedule -> ShowS)
-> (HeaderPointSchedule -> [Char])
-> ([HeaderPointSchedule] -> ShowS)
-> Show HeaderPointSchedule
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeaderPointSchedule -> ShowS
showsPrec :: Int -> HeaderPointSchedule -> ShowS
$cshow :: HeaderPointSchedule -> [Char]
show :: HeaderPointSchedule -> [Char]
$cshowList :: [HeaderPointSchedule] -> ShowS
showList :: [HeaderPointSchedule] -> ShowS
Show)

-- | @headerPointSchedule g msgDelayInterval tpSchedule@ generates a
-- schedule of header points for a single peer.
--
-- @msgDelayInterval@ is the interval from which to sample the delay of
-- each header after offering the previous header.
--
-- @tpSchedule@ is the tip point schedule for the peer.
-- Tip points are grouped by the branch they point to. Each group has
-- the index of the intersection block with the trunk. Then each group
-- has a list of tip point block indices relative to the branch. Groups
-- corresponding to tip points in trunk use 'Nothing' as the intersection.
--
-- For each group of tip points, the schedule generates a HeaderPointSchedule,
-- which provides the time at which each header should be offered.
--
-- If scheduled, header points are guaranteed to be scheduled after the tip
-- point that enables them. They might not be generated if they cannot be
-- delivered before a tip point of a different branch is announced.  The
-- header points on a same chain are never announced out of order.
--
-- > headerPointSchedule
-- >   :: g
-- >   -> {msgDelayInterval:(DiffTime, DiffTime)
-- >      | fst msgDelayInterval <= snd msgDelayInterval
-- >      }
-- >   -> {tpSchedule:[(Maybe Int, [(DiffTime, Int)]]
-- >      | isSorted (catMaybes (map fst tpSchedule)) &&
-- >        all (\(_, xs) -> isSorted xs) tpSchedule &&
-- >        all (\(_, xs) -> all (0<=) (map snd xs)) tpSchedule &&
-- >        all (\(_, xs) -> not (hasDuplicates (map snd xs))) tpSchedule &&
-- >        all (\(_, xs) -> not (null xs)) tpSchedule &&
-- >        all (\(_, xs) -> all (0<=) (map snd xs)) tpSchedule
-- >      }
-- >   -> m {v:[HeaderPointSchedule]
-- >        | length v == length tpSchedule &&
-- >          isSorted [ map fst (hpsTrunk hps) ++ map fst (hpsBranch hps) | hps <- v ] &&
-- >          isSorted [ map snd (hpsTrunk hps) | hps <- v ] &&
-- >          all (\hps -> isSorted (map snd $ hpsBranch hps)) v &&
-- >          all (\hps -> all (0<=) (map snd (hpsTrunk hps))) v &&
-- >          all (\hps -> all (0<=) (map snd (hpsBranch hps))) v &&
-- >          all (\hps -> not (hasDuplicates (map snd (hpsTrunk hps)))) v &&
-- >          all (\hps -> not (hasDuplicates (map snd (hpsBranch hps)))) v
-- >        }
headerPointSchedule
  :: forall g m. (HasCallStack, R.StatefulGen g m)
  => g
  -> (DiffTime, DiffTime)
  -> [(Maybe Int, [(Time, Int)])]
  -> m [HeaderPointSchedule]
headerPointSchedule :: forall g (m :: * -> *).
(HasCallStack, StatefulGen g m) =>
g
-> (DiffTime, DiffTime)
-> [(Maybe Int, [(Time, Int)])]
-> m [HeaderPointSchedule]
headerPointSchedule g
g (DiffTime, DiffTime)
msgDelayInterval [(Maybe Int, [(Time, Int)])]
xs =
   let -- Pair each  branch with the maximum time at which its header points
       -- should be offered
       xs' :: [((Maybe Int, [(Time, Int)]), Maybe Time)]
xs' = [(Maybe Int, [(Time, Int)])]
-> [Maybe Time] -> [((Maybe Int, [(Time, Int)]), Maybe Time)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Maybe Int, [(Time, Int)])]
xs ([Maybe Time] -> [((Maybe Int, [(Time, Int)]), Maybe Time)])
-> [Maybe Time] -> [((Maybe Int, [(Time, Int)]), Maybe Time)]
forall a b. (a -> b) -> a -> b
$ ((Maybe Int, [(Time, Int)]) -> Maybe Time)
-> [(Maybe Int, [(Time, Int)])] -> [Maybe Time]
forall a b. (a -> b) -> [a] -> [b]
map (Time -> Maybe Time
forall a. a -> Maybe a
Just (Time -> Maybe Time)
-> ((Maybe Int, [(Time, Int)]) -> Time)
-> (Maybe Int, [(Time, Int)])
-> Maybe Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, Int) -> Time
forall a b. (a, b) -> a
fst ((Time, Int) -> Time)
-> ((Maybe Int, [(Time, Int)]) -> (Time, Int))
-> (Maybe Int, [(Time, Int)])
-> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Time, Int)] -> (Time, Int)
forall a. HasCallStack => [a] -> a
headCallStack ([(Time, Int)] -> (Time, Int))
-> ((Maybe Int, [(Time, Int)]) -> [(Time, Int)])
-> (Maybe Int, [(Time, Int)])
-> (Time, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Int, [(Time, Int)]) -> [(Time, Int)]
forall a b. (a, b) -> b
snd) (Int -> [(Maybe Int, [(Time, Int)])] -> [(Maybe Int, [(Time, Int)])]
forall a. Int -> [a] -> [a]
drop Int
1 [(Maybe Int, [(Time, Int)])]
xs) [Maybe Time] -> [Maybe Time] -> [Maybe Time]
forall a. [a] -> [a] -> [a]
++ [Maybe Time
forall a. Maybe a
Nothing]
    in ((Time, Int), [HeaderPointSchedule]) -> [HeaderPointSchedule]
forall a b. (a, b) -> b
snd (((Time, Int), [HeaderPointSchedule]) -> [HeaderPointSchedule])
-> m ((Time, Int), [HeaderPointSchedule])
-> m [HeaderPointSchedule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Time, Int)
 -> ((Maybe Int, [(Time, Int)]), Maybe Time)
 -> m ((Time, Int), HeaderPointSchedule))
-> (Time, Int)
-> [((Maybe Int, [(Time, Int)]), Maybe Time)]
-> m ((Time, Int), [HeaderPointSchedule])
forall (m :: * -> *) s x y.
Monad m =>
(s -> x -> m (s, y)) -> s -> [x] -> m (s, [y])
mapAccumM (Time, Int)
-> ((Maybe Int, [(Time, Int)]), Maybe Time)
-> m ((Time, Int), HeaderPointSchedule)
genHPBranchSchedule (DiffTime -> Time
Time DiffTime
0, Int
0) [((Maybe Int, [(Time, Int)]), Maybe Time)]
xs'

  where
    -- | @genHPBranchSchedule (tNext, trunkNextHp) ((mi, tps), mtMax)@ generates
    -- a schedule for a single branch.
    --
    -- @tNext@ is the time at which the next header point should be offered.
    --
    -- @trunkNextHp@ is the index of the next header point that was offered
    -- from the trunk.
    --
    -- @mi@ is the index of the intersection block with the trunk. Nothing
    -- means this group has tip points from the trunk.
    --
    -- @tps@ is the list of tip point indices relative to the branch.
    --
    -- @mtMax@ is the maximum time at which the last header point can be
    -- offered. 'Nothing' stands for infinity.
    --
    -- Returns the time at which the last header point was offered, the next
    -- header point to offer and the schedule for the branch.
    genHPBranchSchedule
      :: (Time, Int)
      -> ((Maybe Int, [(Time, Int)]), Maybe Time)
      -> m ((Time, Int), HeaderPointSchedule)
    genHPBranchSchedule :: (Time, Int)
-> ((Maybe Int, [(Time, Int)]), Maybe Time)
-> m ((Time, Int), HeaderPointSchedule)
genHPBranchSchedule (Time
tNext, Int
trunkNextHp) ((Maybe Int
_mi, []), Maybe Time
_mtMax) =
      ((Time, Int), HeaderPointSchedule)
-> m ((Time, Int), HeaderPointSchedule)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Time
tNext, Int
trunkNextHp), [(Time, Int)] -> [(Time, Int)] -> HeaderPointSchedule
HeaderPointSchedule [] [])
    genHPBranchSchedule (Time
tNext, Int
trunkNextHp) ((Maybe Int
Nothing, [(Time, Int)]
tps), Maybe Time
mtMax) = do
      ((Time, Int)
p, [[(Time, Int)]]
tsTrunk) <- ((Time, Int) -> (Time, Int) -> m ((Time, Int), [(Time, Int)]))
-> (Time, Int) -> [(Time, Int)] -> m ((Time, Int), [[(Time, Int)]])
forall (m :: * -> *) s x y.
Monad m =>
(s -> x -> m (s, y)) -> s -> [x] -> m (s, [y])
mapAccumM (Maybe Time
-> (Time, Int) -> (Time, Int) -> m ((Time, Int), [(Time, Int)])
generatePerTipPointTimes Maybe Time
mtMax) (Time
tNext, Int
trunkNextHp) [(Time, Int)]
tps
      ((Time, Int), HeaderPointSchedule)
-> m ((Time, Int), HeaderPointSchedule)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Time, Int)
p, [(Time, Int)] -> [(Time, Int)] -> HeaderPointSchedule
HeaderPointSchedule ([[(Time, Int)]] -> [(Time, Int)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Time, Int)]]
tsTrunk) [])
    genHPBranchSchedule (Time
tNext, Int
trunkNextHp) ((Just Int
iLast, tps :: [(Time, Int)]
tps@((Time
firstTipTime, Int
_):[(Time, Int)]
_)), Maybe Time
mtMax) = do
      ((Time
tNext', Int
trunkNextHp'), [(Time, Int)]
tsTrunk) <- Maybe Time
-> (Time, Int) -> (Time, Int) -> m ((Time, Int), [(Time, Int)])
generatePerTipPointTimes Maybe Time
mtMax (Time
tNext, Int
trunkNextHp) (Time
firstTipTime, Int
iLast)
      ((Time
tNext'', Int
_), [[(Time, Int)]]
tsBranch) <- ((Time, Int) -> (Time, Int) -> m ((Time, Int), [(Time, Int)]))
-> (Time, Int) -> [(Time, Int)] -> m ((Time, Int), [[(Time, Int)]])
forall (m :: * -> *) s x y.
Monad m =>
(s -> x -> m (s, y)) -> s -> [x] -> m (s, [y])
mapAccumM (Maybe Time
-> (Time, Int) -> (Time, Int) -> m ((Time, Int), [(Time, Int)])
generatePerTipPointTimes Maybe Time
mtMax) (Time
tNext', Int
0) [(Time, Int)]
tps
      ((Time, Int), HeaderPointSchedule)
-> m ((Time, Int), HeaderPointSchedule)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Time
tNext'', Int
trunkNextHp'), [(Time, Int)] -> [(Time, Int)] -> HeaderPointSchedule
HeaderPointSchedule [(Time, Int)]
tsTrunk ([[(Time, Int)]] -> [(Time, Int)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Time, Int)]]
tsBranch))

    -- | @generatePerTipPointTimes mtMax (tNext, nextHp) (tTip, tp)@ schedules the header
    -- points from @nextHp@ to @tp@ in ascending order starting from the maximum
    -- of @tNext@ and @tTip + t@ where t is sampled from @msgDelayInterval@.
    --
    -- Less header points are scheduled if they would be scheduled after @mtMax@.
    --
    -- The delay of each tipPoint is sampled from @msgDelayInterval@.
    --
    generatePerTipPointTimes
      :: Maybe Time
      -> (Time, Int)
      -> (Time, Int)
      -> m ((Time, Int), [(Time, Int)])
    generatePerTipPointTimes :: Maybe Time
-> (Time, Int) -> (Time, Int) -> m ((Time, Int), [(Time, Int)])
generatePerTipPointTimes Maybe Time
mtMax (Time
tNext0, Int
nextHp0) (Time
tTip, Int
tp) = do
       DiffTime
t <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime, DiffTime)
msgDelayInterval g
g
       Time -> Int -> [(Time, Int)] -> m ((Time, Int), [(Time, Int)])
go (Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
tNext0 (DiffTime -> Time -> Time
addTime DiffTime
t Time
tTip)) Int
nextHp0 []
      where
        go :: Time -> Int -> [(Time, Int)] -> m ((Time, Int), [(Time, Int)])
        go :: Time -> Int -> [(Time, Int)] -> m ((Time, Int), [(Time, Int)])
go Time
tNext Int
nextHp [(Time, Int)]
acc = do
          if Bool -> (Time -> Bool) -> Maybe Time -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Time
tNext Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>) Maybe Time
mtMax Bool -> Bool -> Bool
|| Int
nextHp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
tp then
            ((Time, Int), [(Time, Int)]) -> m ((Time, Int), [(Time, Int)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Time
tNext, Int
nextHp), [(Time, Int)] -> [(Time, Int)]
forall a. [a] -> [a]
reverse [(Time, Int)]
acc)
          else do
            Time
t <- (DiffTime -> Time -> Time
`addTime` Time
tNext) (DiffTime -> Time) -> m DiffTime -> m Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime, DiffTime)
msgDelayInterval g
g
            Time -> Int -> [(Time, Int)] -> m ((Time, Int), [(Time, Int)])
go Time
t (Int
nextHpInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ((Time
tNext, Int
nextHp) (Time, Int) -> [(Time, Int)] -> [(Time, Int)]
forall a. a -> [a] -> [a]
: [(Time, Int)]
acc)

mapAccumM :: Monad m => (s -> x -> m (s, y)) -> s -> [x] -> m (s, [y])
mapAccumM :: forall (m :: * -> *) s x y.
Monad m =>
(s -> x -> m (s, y)) -> s -> [x] -> m (s, [y])
mapAccumM s -> x -> m (s, y)
_ s
acc [] = (s, [y]) -> m (s, [y])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
acc, [])
mapAccumM s -> x -> m (s, y)
f s
acc (x
x:[x]
xs) = do
    (s
acc', y
y) <- s -> x -> m (s, y)
f s
acc x
x
    (s
acc'', [y]
ys) <- (s -> x -> m (s, y)) -> s -> [x] -> m (s, [y])
forall (m :: * -> *) s x y.
Monad m =>
(s -> x -> m (s, y)) -> s -> [x] -> m (s, [y])
mapAccumM s -> x -> m (s, y)
f s
acc' [x]
xs
    (s, [y]) -> m (s, [y])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
acc'', y
yy -> [y] -> [y]
forall a. a -> [a] -> [a]
:[y]
ys)

headCallStack :: HasCallStack => [a] -> a
headCallStack :: forall a. HasCallStack => [a] -> a
headCallStack = \case
  a
x:[a]
_ -> a
x
  [a]
_   -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"headCallStack: empty list"