module Test.Consensus.PointSchedule.SinglePeer (
IsTrunk (..)
, PeerScheduleParams (..)
, SchedulePoint (..)
, defaultPeerScheduleParams
, peerScheduleFromTipPoints
, schedulePointToBlock
, singleJumpPeerSchedule
, 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)
data SchedulePoint blk
= ScheduleTipPoint (WithOrigin blk)
| (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
= 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
data PeerScheduleParams = PeerScheduleParams
{ PeerScheduleParams -> DiffTime
pspSlotLength :: DiffTime
, PeerScheduleParams -> (DiffTime, DiffTime)
pspTipDelayInterval :: (DiffTime, DiffTime)
, :: (DiffTime, DiffTime)
, PeerScheduleParams -> (DiffTime, DiffTime)
pspBlockDelayInterval :: (DiffTime, DiffTime)
}
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)
}
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
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
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
ts <- tipPointSchedule g (pspSlotLength psp) (pspTipDelayInterval psp) tipPointSlots
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
bpss <- headerPointSchedule g (pspBlockDelayInterval psp) [(Nothing, hps)]
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
:: (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
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
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
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
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
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"
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
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