-- | This module contains functions for generating random point schedules.
--
-- A point schedule is a set of tables, having one table per simulated peer.
-- Each row of a table correspond to a point in time, also called a tick.
--
-- Each tick has a timestamp and a state to set for the corresponding peer at
-- that time. The state of each peer is described by three blocks points
-- related to the peer's hypothetical chain selection:
--
-- * Tip Point: the tip of the hypothetical chain selection. This tip is
--       advertised to the node under test in ChainSync client exchanges.
-- * Header Point: the most recent header that the peer should send to the
--       node under test. Any newer headers should wait until the Header
--       Point is updated to newer headers.
-- * Block Point: the most recent block that the peer should send to the
--       node under test. Any newer blocks should wait until the Block Point
--       is updated to newer headers.
--
-- Given a chain selection like this:
--
-- > Genesis -> A -> B -> C -> D
--
-- The point schedule of a peer might look like this:
--
-- > +--------+----------------+----------------+----------------+
-- > | Tick   | Tip Point      | Header Point   | Block Point    |
-- > +--------+----------------+----------------+----------------+
-- > |   0.0s | Genesis        | Genesis        | Genesis        |
-- > +--------+----------------+----------------+----------------+
-- > |   1.2s | D              | Genesis        | Genesis        |
-- > +--------+----------------+----------------+----------------+
-- > |   1.3s | D              | C              | Genesis        |
-- > +--------+----------------+----------------+----------------+
-- > |   1.6s | D              | C              | B              |
-- > +--------+----------------+----------------+----------------+
-- > |   2.0s | D              | C              | C              |
-- > +--------+----------------+----------------+----------------+
-- > |   2.2s | D              | D              | D              |
-- > +--------+----------------+----------------+----------------+
--
-- Some rules apply to how the point schedule progresses, although
-- exceptions might be tested occasionally. In general,
--
-- * The Tip Point is set first
-- * Header points are not allowed to point to newer blocks than the tip point
-- * Block points are not allowed to point to newer blocks than the header point
--
-- The following is an example with rollbacks:
--
-- > Genesis -> A -> B -> C -> D
-- >                   \-> C' -> D' -> E
--
-- > +--------+----------------+----------------+----------------+
-- > | Tick   | Tip Point      | Header Point   | Block Point    |
-- > +--------+----------------+----------------+----------------+
-- > |   0.0s | Genesis        | Genesis        | Genesis        |
-- > +--------+----------------+----------------+----------------+
-- > |   1.2s | D              | Genesis        | Genesis        |
-- > +--------+----------------+----------------+----------------+
-- > |   1.3s | D              | C              | Genesis        |
-- > +--------+----------------+----------------+----------------+
-- > |   1.6s | D              | C              | B              |
-- > +--------+----------------+----------------+----------------+
-- > |   2.0s | D              | C              | C              |
-- > +--------+----------------+----------------+----------------+
-- > |   2.1s | D              | D              | C              |
-- > +--------+----------------+----------------+----------------+
-- > |   2.3s | D              | D              | D              |
-- > +--------+----------------+----------------+----------------+
-- > |   2.4s | E              | D              | D              |
-- > +--------+----------------+----------------+----------------+
-- > |   2.6s | E              | D'             | D              |
-- > +--------+----------------+----------------+----------------+
-- > |   2.7s | E              | D'             | C'             |
-- > +--------+----------------+----------------+----------------+
-- > |   2.9s | E              | D'             | D'             |
-- > +--------+----------------+----------------+----------------+
-- > |   3.0s | E              | E              | D'             |
-- > +--------+----------------+----------------+----------------+
-- > |   3.1s | E              | E              | E              |
-- > +--------+----------------+----------------+----------------+
module Test.Consensus.PointSchedule.SinglePeer
  ( IsTrunk (..)
  , PeerScheduleParams (..)
  , SchedulePoint (..)
  , defaultPeerScheduleParams
  , peerScheduleFromTipPoints
  , schedulePointToBlock
  , singleJumpPeerSchedule

    -- * Exposed for testing
  , mergeOn
  , scheduleBlockPoint
  , scheduleHeaderPoint
  , scheduleTipPoint
  , zipMany
  ) where

import Cardano.Slotting.Slot (WithOrigin (At, Origin), withOrigin)
import Control.Arrow (second)
import Control.Monad.Class.MonadTime.SI (Time)
import Data.List (mapAccumL)
import Data.Time.Clock (DiffTime)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block (BlockNo (unBlockNo), blockSlot)
import qualified System.Random.Stateful as R (StatefulGen)
import Test.Consensus.PointSchedule.SinglePeer.Indices
  ( HeaderPointSchedule (hpsBranch, hpsTrunk)
  , headerPointSchedule
  , singleJumpTipPoints
  , tipPointSchedule
  )

-- | A point in the schedule of a single peer.
data SchedulePoint blk
  = ScheduleTipPoint (WithOrigin blk)
  | ScheduleHeaderPoint (WithOrigin blk)
  | ScheduleBlockPoint (WithOrigin blk)
  deriving (SchedulePoint blk -> SchedulePoint blk -> Bool
(SchedulePoint blk -> SchedulePoint blk -> Bool)
-> (SchedulePoint blk -> SchedulePoint blk -> Bool)
-> Eq (SchedulePoint blk)
forall blk.
Eq blk =>
SchedulePoint blk -> SchedulePoint blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
Eq blk =>
SchedulePoint blk -> SchedulePoint blk -> Bool
== :: SchedulePoint blk -> SchedulePoint blk -> Bool
$c/= :: forall blk.
Eq blk =>
SchedulePoint blk -> SchedulePoint blk -> Bool
/= :: SchedulePoint blk -> SchedulePoint blk -> Bool
Eq, Int -> SchedulePoint blk -> ShowS
[SchedulePoint blk] -> ShowS
SchedulePoint blk -> String
(Int -> SchedulePoint blk -> ShowS)
-> (SchedulePoint blk -> String)
-> ([SchedulePoint blk] -> ShowS)
-> Show (SchedulePoint blk)
forall blk. Show blk => Int -> SchedulePoint blk -> ShowS
forall blk. Show blk => [SchedulePoint blk] -> ShowS
forall blk. Show blk => SchedulePoint blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. Show blk => Int -> SchedulePoint blk -> ShowS
showsPrec :: Int -> SchedulePoint blk -> ShowS
$cshow :: forall blk. Show blk => SchedulePoint blk -> String
show :: SchedulePoint blk -> String
$cshowList :: forall blk. Show blk => [SchedulePoint blk] -> ShowS
showList :: [SchedulePoint blk] -> ShowS
Show)

scheduleTipPoint :: blk -> SchedulePoint blk
scheduleTipPoint :: forall blk. blk -> SchedulePoint blk
scheduleTipPoint = WithOrigin blk -> SchedulePoint blk
forall blk. WithOrigin blk -> SchedulePoint blk
ScheduleTipPoint (WithOrigin blk -> SchedulePoint blk)
-> (blk -> WithOrigin blk) -> blk -> SchedulePoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> WithOrigin blk
forall t. t -> WithOrigin t
At

scheduleHeaderPoint :: blk -> SchedulePoint blk
scheduleHeaderPoint :: forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint = WithOrigin blk -> SchedulePoint blk
forall blk. WithOrigin blk -> SchedulePoint blk
ScheduleHeaderPoint (WithOrigin blk -> SchedulePoint blk)
-> (blk -> WithOrigin blk) -> blk -> SchedulePoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> WithOrigin blk
forall t. t -> WithOrigin t
At

scheduleBlockPoint :: blk -> SchedulePoint blk
scheduleBlockPoint :: forall blk. blk -> SchedulePoint blk
scheduleBlockPoint = WithOrigin blk -> SchedulePoint blk
forall blk. WithOrigin blk -> SchedulePoint blk
ScheduleBlockPoint (WithOrigin blk -> SchedulePoint blk)
-> (blk -> WithOrigin blk) -> blk -> SchedulePoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> WithOrigin blk
forall t. t -> WithOrigin t
At

schedulePointToBlock :: SchedulePoint blk -> WithOrigin blk
schedulePointToBlock :: forall blk. SchedulePoint blk -> WithOrigin blk
schedulePointToBlock (ScheduleTipPoint WithOrigin blk
b) = WithOrigin blk
b
schedulePointToBlock (ScheduleHeaderPoint WithOrigin blk
b) = WithOrigin blk
b
schedulePointToBlock (ScheduleBlockPoint WithOrigin blk
b) = WithOrigin blk
b

-- | Parameters for generating a schedule for a single peer.
--
-- In the most general form, the caller provides a list of tip points and the
-- schedule is generated by following the given tip points. All headers points
-- and block points are sent eventually, but the points are delayed according
-- to these parameters.
data PeerScheduleParams = PeerScheduleParams
  { PeerScheduleParams -> DiffTime
pspSlotLength :: DiffTime
  , PeerScheduleParams -> (DiffTime, DiffTime)
pspTipDelayInterval :: (DiffTime, DiffTime)
  -- ^ Each of these pairs specifies a range of delays for a point. The
  -- actual delay is chosen uniformly at random from the range.
  --
  -- For tip points, the delay is relative to the slot of the tip point.
  , PeerScheduleParams -> (DiffTime, DiffTime)
pspHeaderDelayInterval :: (DiffTime, DiffTime)
  -- ^ For header points, the delay is relative to the previous header point
  -- or the tip point that advertises the existence of the header (whichever
  -- happened most recently).
  , PeerScheduleParams -> (DiffTime, DiffTime)
pspBlockDelayInterval :: (DiffTime, DiffTime)
  -- ^ For block points, the delay is relative to the previous block point or
  -- the header point that advertises the existence of the block (whichever
  -- happened most recently).
  }
  deriving Int -> PeerScheduleParams -> ShowS
[PeerScheduleParams] -> ShowS
PeerScheduleParams -> String
(Int -> PeerScheduleParams -> ShowS)
-> (PeerScheduleParams -> String)
-> ([PeerScheduleParams] -> ShowS)
-> Show PeerScheduleParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PeerScheduleParams -> ShowS
showsPrec :: Int -> PeerScheduleParams -> ShowS
$cshow :: PeerScheduleParams -> String
show :: PeerScheduleParams -> String
$cshowList :: [PeerScheduleParams] -> ShowS
showList :: [PeerScheduleParams] -> ShowS
Show

defaultPeerScheduleParams :: PeerScheduleParams
defaultPeerScheduleParams :: PeerScheduleParams
defaultPeerScheduleParams =
  PeerScheduleParams
    { pspSlotLength :: DiffTime
pspSlotLength = DiffTime
20
    , pspTipDelayInterval :: (DiffTime, DiffTime)
pspTipDelayInterval = (DiffTime
0, DiffTime
1)
    , pspHeaderDelayInterval :: (DiffTime, DiffTime)
pspHeaderDelayInterval = (DiffTime
0.018, DiffTime
0.021)
    , pspBlockDelayInterval :: (DiffTime, DiffTime)
pspBlockDelayInterval = (DiffTime
0.050, DiffTime
0.055)
    }

-- | Generate a schedule for a single peer that jumps once to the middle of a
-- sequence of blocks.
--
--  See 'peerScheduleFromTipPoints' for generation of schedules with rollbacks
singleJumpPeerSchedule ::
  (R.StatefulGen g m, AF.HasHeader blk) =>
  g ->
  PeerScheduleParams ->
  AF.AnchoredFragment blk ->
  m [(Time, SchedulePoint blk)]
singleJumpPeerSchedule :: forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
g
-> PeerScheduleParams
-> AnchoredFragment blk
-> m [(Time, SchedulePoint blk)]
singleJumpPeerSchedule g
g PeerScheduleParams
psp AnchoredFragment blk
chain = do
  let chainv :: Vector blk
chainv = [blk] -> Vector blk
forall a. [a] -> Vector a
Vector.fromList ([blk] -> Vector blk) -> [blk] -> Vector blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment blk
chain
  (tps, hps, bps) <- g
-> PeerScheduleParams
-> Vector blk
-> m ([(Time, blk)], [(Time, blk)], [(Time, blk)])
forall g (m :: * -> *) b.
(StatefulGen g m, HasHeader b) =>
g
-> PeerScheduleParams
-> Vector b
-> m ([(Time, b)], [(Time, b)], [(Time, b)])
singleJumpRawPeerSchedule g
g PeerScheduleParams
psp Vector blk
chainv
  let tipPoints = ((Time, blk) -> (Time, SchedulePoint blk))
-> [(Time, blk)] -> [(Time, SchedulePoint blk)]
forall a b. (a -> b) -> [a] -> [b]
map ((blk -> SchedulePoint blk)
-> (Time, blk) -> (Time, SchedulePoint blk)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint) [(Time, blk)]
tps
      headerPoints = ((Time, blk) -> (Time, SchedulePoint blk))
-> [(Time, blk)] -> [(Time, SchedulePoint blk)]
forall a b. (a -> b) -> [a] -> [b]
map ((blk -> SchedulePoint blk)
-> (Time, blk) -> (Time, SchedulePoint blk)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint) [(Time, blk)]
hps
      blockPoints = ((Time, blk) -> (Time, SchedulePoint blk))
-> [(Time, blk)] -> [(Time, SchedulePoint blk)]
forall a b. (a -> b) -> [a] -> [b]
map ((blk -> SchedulePoint blk)
-> (Time, blk) -> (Time, SchedulePoint blk)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint) [(Time, blk)]
bps
  -- merge the schedules
  pure $
    mergeOn fst tipPoints $
      mergeOn fst headerPoints blockPoints

singleJumpRawPeerSchedule ::
  (R.StatefulGen g m, AF.HasHeader b) =>
  g ->
  PeerScheduleParams ->
  Vector b ->
  m ([(Time, b)], [(Time, b)], [(Time, b)])
singleJumpRawPeerSchedule :: forall g (m :: * -> *) b.
(StatefulGen g m, HasHeader b) =>
g
-> PeerScheduleParams
-> Vector b
-> m ([(Time, b)], [(Time, b)], [(Time, b)])
singleJumpRawPeerSchedule g
g PeerScheduleParams
psp Vector b
chainv = do
  -- generate the tip points
  ixs <- g -> Int -> Int -> m [Int]
forall g (m :: * -> *).
StatefulGen g m =>
g -> Int -> Int -> m [Int]
singleJumpTipPoints g
g Int
0 (Vector b -> Int
forall a. Vector a -> Int
Vector.length Vector b
chainv Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  let tipPointBlks = (Int -> b) -> [Int] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Vector b
chainv Vector b -> Int -> b
forall a. Vector a -> Int -> a
Vector.!) [Int]
ixs
      tipPointSlots = (b -> SlotNo) -> [b] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map b -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot [b]
tipPointBlks
  -- generate the tip point schedule
  ts <- tipPointSchedule g (pspSlotLength psp) (pspTipDelayInterval psp) tipPointSlots
  -- generate the header point schedule
  hpss <- headerPointSchedule g (pspHeaderDelayInterval psp) [(Nothing, zip ts ixs)]
  let hps = (HeaderPointSchedule -> [(Time, Int)])
-> [HeaderPointSchedule] -> [(Time, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderPointSchedule -> [(Time, Int)]
hpsTrunk [HeaderPointSchedule]
hpss
  -- generate the block point schedule
  bpss <- headerPointSchedule g (pspBlockDelayInterval psp) [(Nothing, hps)]
  -- collect the blocks for each schedule
  let bps = (HeaderPointSchedule -> [(Time, Int)])
-> [HeaderPointSchedule] -> [(Time, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderPointSchedule -> [(Time, Int)]
hpsTrunk [HeaderPointSchedule]
bpss
      tipPointTips = [Time] -> [b] -> [(Time, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Time]
ts [b]
tipPointBlks
      hpsHeaders = ((Time, Int) -> (Time, b)) -> [(Time, Int)] -> [(Time, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> b) -> (Time, Int) -> (Time, b)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Vector b
chainv Vector b -> Int -> b
forall a. Vector a -> Int -> a
Vector.!)) [(Time, Int)]
hps
      bpsBlks = ((Time, Int) -> (Time, b)) -> [(Time, Int)] -> [(Time, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> b) -> (Time, Int) -> (Time, b)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Vector b
chainv Vector b -> Int -> b
forall a. Vector a -> Int -> a
Vector.!)) [(Time, Int)]
bps
  pure (tipPointTips, hpsHeaders, bpsBlks)

data IsTrunk = IsTrunk | IsBranch
  deriving (IsTrunk -> IsTrunk -> Bool
(IsTrunk -> IsTrunk -> Bool)
-> (IsTrunk -> IsTrunk -> Bool) -> Eq IsTrunk
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IsTrunk -> IsTrunk -> Bool
== :: IsTrunk -> IsTrunk -> Bool
$c/= :: IsTrunk -> IsTrunk -> Bool
/= :: IsTrunk -> IsTrunk -> Bool
Eq, Int -> IsTrunk -> ShowS
[IsTrunk] -> ShowS
IsTrunk -> String
(Int -> IsTrunk -> ShowS)
-> (IsTrunk -> String) -> ([IsTrunk] -> ShowS) -> Show IsTrunk
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IsTrunk -> ShowS
showsPrec :: Int -> IsTrunk -> ShowS
$cshow :: IsTrunk -> String
show :: IsTrunk -> String
$cshowList :: [IsTrunk] -> ShowS
showList :: [IsTrunk] -> ShowS
Show)

-- | @peerScheduleFromTipPoints g params tps trunk branches@ generates a
-- schedule for a single peer that follows the given tip points.
--
-- @tps@ contains the tip points for each fragment. The indices correspond to
-- the fragments in branches and go from @0@ to @length branch - 1@.
--
-- @trunk@ is the fragment for the honest chain
--
-- @branches@ contains the fragments for the alternative chains in ascending
-- order of their intersections with the honest chain. Each fragment is anchored
-- at the intersection, and therefore their first block must be the first block
-- after the intersection.
peerScheduleFromTipPoints ::
  (R.StatefulGen g m, AF.HasHeader blk) =>
  g ->
  PeerScheduleParams ->
  [(IsTrunk, [Int])] ->
  AF.AnchoredFragment blk ->
  [AF.AnchoredFragment blk] ->
  m [(Time, SchedulePoint blk)]
peerScheduleFromTipPoints :: forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
g
-> PeerScheduleParams
-> [(IsTrunk, [Int])]
-> AnchoredFragment blk
-> [AnchoredFragment blk]
-> m [(Time, SchedulePoint blk)]
peerScheduleFromTipPoints g
g PeerScheduleParams
psp [(IsTrunk, [Int])]
tipPoints AnchoredFragment blk
trunk0 [AnchoredFragment blk]
branches0 = do
  let trunk0v :: Vector blk
trunk0v = [blk] -> Vector blk
forall a. [a] -> Vector a
Vector.fromList ([blk] -> Vector blk) -> [blk] -> Vector blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment blk
trunk0
      -- NOTE: Is this still correct? Shouldn't it be `withOrigin 0 (+1)`?
      firstTrunkBlockNo :: BlockNo
firstTrunkBlockNo = BlockNo -> (BlockNo -> BlockNo) -> WithOrigin BlockNo -> BlockNo
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin BlockNo
1 (BlockNo -> BlockNo -> BlockNo
forall a. Num a => a -> a -> a
+ BlockNo
1) (WithOrigin BlockNo -> BlockNo) -> WithOrigin BlockNo -> BlockNo
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> WithOrigin BlockNo
forall block. AnchoredFragment block -> WithOrigin BlockNo
AF.anchorBlockNo AnchoredFragment blk
trunk0
      branches0v :: [Vector blk]
branches0v = (AnchoredFragment blk -> Vector blk)
-> [AnchoredFragment blk] -> [Vector blk]
forall a b. (a -> b) -> [a] -> [b]
map ([blk] -> Vector blk
forall a. [a] -> Vector a
Vector.fromList ([blk] -> Vector blk)
-> (AnchoredFragment blk -> [blk])
-> AnchoredFragment blk
-> Vector blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst) [AnchoredFragment blk]
branches0
      anchorBlockIndices :: [Int]
anchorBlockIndices =
        [ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ BlockNo -> Word64
unBlockNo (BlockNo -> Word64) -> BlockNo -> Word64
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> BlockNo
forall blk. AnchoredFragment blk -> BlockNo
fragmentAnchorBlockNo AnchoredFragment blk
b BlockNo -> BlockNo -> BlockNo
forall a. Num a => a -> a -> a
- BlockNo
firstTrunkBlockNo
        | AnchoredFragment blk
b <- [AnchoredFragment blk]
branches0
        ]
      isTrunks :: [IsTrunk]
isTrunks = ((IsTrunk, [Int]) -> IsTrunk) -> [(IsTrunk, [Int])] -> [IsTrunk]
forall a b. (a -> b) -> [a] -> [b]
map (IsTrunk, [Int]) -> IsTrunk
forall a b. (a, b) -> a
fst [(IsTrunk, [Int])]
tipPoints
      intersections :: [Maybe Int]
intersections = [Int] -> [IsTrunk] -> [Maybe Int]
intersperseTrunkFragments [Int]
anchorBlockIndices [IsTrunk]
isTrunks
  (tps, hps, bps) <- g
-> PeerScheduleParams
-> [(IsTrunk, [Int])]
-> Vector blk
-> [Vector blk]
-> [Maybe Int]
-> m ([(Time, blk)], [(Time, blk)], [(Time, blk)])
forall g (m :: * -> *) b.
(StatefulGen g m, HasHeader b) =>
g
-> PeerScheduleParams
-> [(IsTrunk, [Int])]
-> Vector b
-> [Vector b]
-> [Maybe Int]
-> m ([(Time, b)], [(Time, b)], [(Time, b)])
rawPeerScheduleFromTipPoints g
g PeerScheduleParams
psp [(IsTrunk, [Int])]
tipPoints Vector blk
trunk0v [Vector blk]
branches0v [Maybe Int]
intersections
  let tipPoints' = ((Time, blk) -> (Time, SchedulePoint blk))
-> [(Time, blk)] -> [(Time, SchedulePoint blk)]
forall a b. (a -> b) -> [a] -> [b]
map ((blk -> SchedulePoint blk)
-> (Time, blk) -> (Time, SchedulePoint blk)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint) [(Time, blk)]
tps
      headerPoints = ((Time, blk) -> (Time, SchedulePoint blk))
-> [(Time, blk)] -> [(Time, SchedulePoint blk)]
forall a b. (a -> b) -> [a] -> [b]
map ((blk -> SchedulePoint blk)
-> (Time, blk) -> (Time, SchedulePoint blk)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint) [(Time, blk)]
hps
      blockPoints = ((Time, blk) -> (Time, SchedulePoint blk))
-> [(Time, blk)] -> [(Time, SchedulePoint blk)]
forall a b. (a -> b) -> [a] -> [b]
map ((blk -> SchedulePoint blk)
-> (Time, blk) -> (Time, SchedulePoint blk)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint) [(Time, blk)]
bps
  -- merge the schedules
  pure $
    mergeOn fst tipPoints' $
      mergeOn fst headerPoints blockPoints
 where
  fragmentAnchorBlockNo :: AF.AnchoredFragment blk -> BlockNo
  fragmentAnchorBlockNo :: forall blk. AnchoredFragment blk -> BlockNo
fragmentAnchorBlockNo AnchoredFragment blk
f = case AnchoredFragment blk -> WithOrigin BlockNo
forall block. AnchoredFragment block -> WithOrigin BlockNo
AF.anchorBlockNo AnchoredFragment blk
f of
    At BlockNo
s -> BlockNo
s
    WithOrigin BlockNo
Origin -> BlockNo
0

  intersperseTrunkFragments :: [Int] -> [IsTrunk] -> [Maybe Int]
  intersperseTrunkFragments :: [Int] -> [IsTrunk] -> [Maybe Int]
intersperseTrunkFragments [] [] = []
  intersperseTrunkFragments [Int]
iis (IsTrunk
IsTrunk : [IsTrunk]
isTrunks) = Maybe Int
forall a. Maybe a
Nothing Maybe Int -> [Maybe Int] -> [Maybe Int]
forall a. a -> [a] -> [a]
: [Int] -> [IsTrunk] -> [Maybe Int]
intersperseTrunkFragments [Int]
iis [IsTrunk]
isTrunks
  intersperseTrunkFragments (Int
i : [Int]
is) (IsTrunk
IsBranch : [IsTrunk]
isTrunks) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i Maybe Int -> [Maybe Int] -> [Maybe Int]
forall a. a -> [a] -> [a]
: [Int] -> [IsTrunk] -> [Maybe Int]
intersperseTrunkFragments [Int]
is [IsTrunk]
isTrunks
  intersperseTrunkFragments [Int]
_ [] = String -> [Maybe Int]
forall a. HasCallStack => String -> a
error String
"intersperseTrunkFragments: not enough isTrunk flags"
  intersperseTrunkFragments [] [IsTrunk]
_ = String -> [Maybe Int]
forall a. HasCallStack => String -> a
error String
"intersperseTrunkFragments: not enough intersections"

rawPeerScheduleFromTipPoints ::
  (R.StatefulGen g m, AF.HasHeader b) =>
  g ->
  PeerScheduleParams ->
  [(IsTrunk, [Int])] ->
  Vector b ->
  [Vector b] ->
  [Maybe Int] ->
  m ([(Time, b)], [(Time, b)], [(Time, b)])
rawPeerScheduleFromTipPoints :: forall g (m :: * -> *) b.
(StatefulGen g m, HasHeader b) =>
g
-> PeerScheduleParams
-> [(IsTrunk, [Int])]
-> Vector b
-> [Vector b]
-> [Maybe Int]
-> m ([(Time, b)], [(Time, b)], [(Time, b)])
rawPeerScheduleFromTipPoints g
g PeerScheduleParams
psp [(IsTrunk, [Int])]
tipPoints Vector b
trunk0v [Vector b]
branches0v [Maybe Int]
intersections = do
  let ([IsTrunk]
isTrunks, [[Int]]
tpIxs) = [(IsTrunk, [Int])] -> ([IsTrunk], [[Int]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(IsTrunk, [Int])]
tipPoints
      pairedVectors :: [Vector b]
pairedVectors = Vector b -> [Vector b] -> [IsTrunk] -> [Vector b]
forall b. Vector b -> [Vector b] -> [IsTrunk] -> [Vector b]
pairVectorsWithChunks Vector b
trunk0v [Vector b]
branches0v [IsTrunk]
isTrunks
      tipPointBlks :: [b]
tipPointBlks = [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[b]] -> [b]) -> [[b]] -> [b]
forall a b. (a -> b) -> a -> b
$ (Vector b -> [Int] -> [b]) -> [Vector b] -> [[Int]] -> [[b]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Vector b -> [Int] -> [b]
forall b. Vector b -> [Int] -> [b]
indicesToBlocks [Vector b]
pairedVectors [[Int]]
tpIxs
      tipPointSlots :: [SlotNo]
tipPointSlots = (b -> SlotNo) -> [b] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map b -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot [b]
tipPointBlks
  -- generate the tip point schedule
  ts <- g -> DiffTime -> (DiffTime, DiffTime) -> [SlotNo] -> m [Time]
forall g (m :: * -> *).
StatefulGen g m =>
g -> DiffTime -> (DiffTime, DiffTime) -> [SlotNo] -> m [Time]
tipPointSchedule g
g (PeerScheduleParams -> DiffTime
pspSlotLength PeerScheduleParams
psp) (PeerScheduleParams -> (DiffTime, DiffTime)
pspTipDelayInterval PeerScheduleParams
psp) [SlotNo]
tipPointSlots
  -- generate the header point schedule
  let tpSchedules = [Time] -> [[Int]] -> [[(Time, Int)]]
forall a b. [a] -> [[b]] -> [[(a, b)]]
zipMany [Time]
ts [[Int]]
tpIxs
  hpss <- headerPointSchedule g (pspHeaderDelayInterval psp) $ zip intersections tpSchedules
  -- generate the block point schedule
  let (hpsPerBranch, vs) =
        unzip $
          filter (not . null . snd . fst) $
            concat
              [ [((Nothing, hpsTrunk hps), trunk0v), ((mi, hpsBranch hps), v)]
              | (mi, hps, v) <- zip3 intersections hpss pairedVectors
              ]
  bpss <- headerPointSchedule g (pspBlockDelayInterval psp) hpsPerBranch
  let tipPointTips = [Time] -> [b] -> [(Time, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Time]
ts [b]
tipPointBlks
      hpsHeaders = [[(Time, b)]] -> [(Time, b)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Time, b)]] -> [(Time, b)]) -> [[(Time, b)]] -> [(Time, b)]
forall a b. (a -> b) -> a -> b
$ (Vector b -> HeaderPointSchedule -> [(Time, b)])
-> [Vector b] -> [HeaderPointSchedule] -> [[(Time, b)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Vector b -> Vector b -> HeaderPointSchedule -> [(Time, b)]
forall b.
Vector b -> Vector b -> HeaderPointSchedule -> [(Time, b)]
scheduleIndicesToBlocks Vector b
trunk0v) [Vector b]
pairedVectors [HeaderPointSchedule]
hpss
      bpsBlks = [[(Time, b)]] -> [(Time, b)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Time, b)]] -> [(Time, b)]) -> [[(Time, b)]] -> [(Time, b)]
forall a b. (a -> b) -> a -> b
$ (Vector b -> HeaderPointSchedule -> [(Time, b)])
-> [Vector b] -> [HeaderPointSchedule] -> [[(Time, b)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Vector b -> Vector b -> HeaderPointSchedule -> [(Time, b)]
forall b.
Vector b -> Vector b -> HeaderPointSchedule -> [(Time, b)]
scheduleIndicesToBlocks Vector b
trunk0v) [Vector b]
vs [HeaderPointSchedule]
bpss
  pure (tipPointTips, hpsHeaders, bpsBlks)
 where
  pairVectorsWithChunks ::
    Vector b ->
    [Vector b] ->
    [IsTrunk] ->
    [Vector b]
  pairVectorsWithChunks :: forall b. Vector b -> [Vector b] -> [IsTrunk] -> [Vector b]
pairVectorsWithChunks Vector b
trunk [Vector b]
branches =
    ([Vector b], [Vector b]) -> [Vector b]
forall a b. (a, b) -> b
snd (([Vector b], [Vector b]) -> [Vector b])
-> ([IsTrunk] -> ([Vector b], [Vector b]))
-> [IsTrunk]
-> [Vector b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Vector b] -> IsTrunk -> ([Vector b], Vector b))
-> [Vector b] -> [IsTrunk] -> ([Vector b], [Vector b])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL [Vector b] -> IsTrunk -> ([Vector b], Vector b)
pairVectors [Vector b]
branches
   where
    pairVectors :: [Vector b] -> IsTrunk -> ([Vector b], Vector b)
pairVectors [Vector b]
brs IsTrunk
IsTrunk = ([Vector b]
brs, Vector b
trunk)
    pairVectors (Vector b
br : [Vector b]
brs) IsTrunk
IsBranch = ([Vector b]
brs, Vector b
br)
    pairVectors [] IsTrunk
IsBranch = String -> ([Vector b], Vector b)
forall a. HasCallStack => String -> a
error String
"not enough branches"

  -- \| Replaces block indices with the actual blocks
  scheduleIndicesToBlocks :: Vector b -> Vector b -> HeaderPointSchedule -> [(Time, b)]
  scheduleIndicesToBlocks :: forall b.
Vector b -> Vector b -> HeaderPointSchedule -> [(Time, b)]
scheduleIndicesToBlocks Vector b
trunk Vector b
v HeaderPointSchedule
hps =
    ((Time, Int) -> (Time, b)) -> [(Time, Int)] -> [(Time, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> b) -> (Time, Int) -> (Time, b)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Vector b
trunk Vector b -> Int -> b
forall a. Vector a -> Int -> a
Vector.!)) (HeaderPointSchedule -> [(Time, Int)]
hpsTrunk HeaderPointSchedule
hps)
      [(Time, b)] -> [(Time, b)] -> [(Time, b)]
forall a. [a] -> [a] -> [a]
++ ((Time, Int) -> (Time, b)) -> [(Time, Int)] -> [(Time, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> b) -> (Time, Int) -> (Time, b)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Vector b
v Vector b -> Int -> b
forall a. Vector a -> Int -> a
Vector.!)) (HeaderPointSchedule -> [(Time, Int)]
hpsBranch HeaderPointSchedule
hps)

  indicesToBlocks :: Vector b -> [Int] -> [b]
  indicesToBlocks :: forall b. Vector b -> [Int] -> [b]
indicesToBlocks Vector b
v [Int]
ixs = (Int -> b) -> [Int] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Vector b
v Vector b -> Int -> b
forall a. Vector a -> Int -> a
Vector.!) [Int]
ixs

-- | Merge two sorted lists.
--
-- PRECONDITION: The lists are sorted.
mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn :: forall b a. Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn a -> b
_f [] [a]
ys = [a]
ys
mergeOn a -> b
_f [a]
xs [] = [a]
xs
mergeOn a -> b
f xxs :: [a]
xxs@(a
x : [a]
xs) yys :: [a]
yys@(a
y : [a]
ys) =
  if a -> b
f a
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> b
f a
y
    then a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> b) -> [a] -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn a -> b
f [a]
xs [a]
yys
    else a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> b) -> [a] -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn a -> b
f [a]
xxs [a]
ys

zipMany :: [a] -> [[b]] -> [[(a, b)]]
zipMany :: forall a b. [a] -> [[b]] -> [[(a, b)]]
zipMany [a]
xs0 = ([a], [[(a, b)]]) -> [[(a, b)]]
forall a b. (a, b) -> b
snd (([a], [[(a, b)]]) -> [[(a, b)]])
-> ([[b]] -> ([a], [[(a, b)]])) -> [[b]] -> [[(a, b)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [b] -> ([a], [(a, b)]))
-> [a] -> [[b]] -> ([a], [[(a, b)]])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL ([(a, b)] -> [a] -> [b] -> ([a], [(a, b)])
forall {a} {b}. [(a, b)] -> [a] -> [b] -> ([a], [(a, b)])
go []) [a]
xs0
 where
  go :: [(a, b)] -> [a] -> [b] -> ([a], [(a, b)])
go [(a, b)]
acc [a]
xs [] = ([a]
xs, [(a, b)] -> [(a, b)]
forall a. [a] -> [a]
reverse [(a, b)]
acc)
  go [(a, b)]
_acc [] [b]
_ys = String -> ([a], [(a, b)])
forall a. HasCallStack => String -> a
error String
"zipMany: lengths don't match"
  go [(a, b)]
acc (a
x : [a]
xs) (b
y : [b]
ys) = [(a, b)] -> [a] -> [b] -> ([a], [(a, b)])
go ((a
x, b
y) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
acc) [a]
xs [b]
ys