{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

module Test.ThreadNet.Util (
    -- * Chain properties
    chainCommonPrefix
  , prop_all_common_prefix
  , shortestLength
    -- * LeaderSchedule
  , consensusExpected
  , emptyLeaderSchedule
  , roundRobinLeaderSchedule
    -- * GraphViz Dot
  , tracesToDot
    -- * Re-exports
  , module Test.ThreadNet.Util.Expectations
  ) where

import           Data.Graph.Inductive.Graph
import           Data.Graph.Inductive.PatriciaTree
import           Data.GraphViz
import           Data.GraphViz.Attributes.Complete
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (catMaybes)
import           Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text.Lazy as Text
import           Data.Word (Word64)
import           Numeric.Natural (Natural)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config.SecurityParam
import           Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..))
import           Ouroboros.Consensus.NodeId
import           Ouroboros.Consensus.Protocol.LeaderSchedule
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Network.Mock.Chain (Chain (..))
import qualified Ouroboros.Network.Mock.Chain as Chain
import           Test.QuickCheck
import           Test.ThreadNet.Network (NodeOutput (..))
import           Test.ThreadNet.Util.Expectations (NumBlocks (..),
                     determineForkLength)
import           Test.ThreadNet.Util.HasCreator
import           Test.ThreadNet.Util.NodeJoinPlan (NodeJoinPlan)
import qualified Test.Util.MockChain as Chain
import           Test.Util.Slots (NumSlots (..))

{-------------------------------------------------------------------------------
  Chain properties
-------------------------------------------------------------------------------}

shortestLength :: Map NodeId (Chain b) -> Natural
shortestLength :: forall b. Map NodeId (Chain b) -> Natural
shortestLength = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural)
-> (Map NodeId (Chain b) -> Int) -> Map NodeId (Chain b) -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int)
-> (Map NodeId (Chain b) -> [Int]) -> Map NodeId (Chain b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chain b -> Int) -> [Chain b] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Chain b -> Int
forall block. Chain block -> Int
Chain.length ([Chain b] -> [Int])
-> (Map NodeId (Chain b) -> [Chain b])
-> Map NodeId (Chain b)
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map NodeId (Chain b) -> [Chain b]
forall k a. Map k a -> [a]
Map.elems

prop_all_common_prefix :: (HasHeader b, Condense (HeaderHash b), Eq b)
                       => Word64 -> [Chain b] -> Property
prop_all_common_prefix :: forall b.
(HasHeader b, Condense (HeaderHash b), Eq b) =>
Word64 -> [Chain b] -> Property
prop_all_common_prefix Word64
_ []     = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
prop_all_common_prefix Word64
l (Chain b
c:[Chain b]
cs) = [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin [Word64 -> Chain b -> Chain b -> Property
forall b.
(HasHeader b, Condense (HeaderHash b), Eq b) =>
Word64 -> Chain b -> Chain b -> Property
prop_common_prefix Word64
l Chain b
c Chain b
d | Chain b
d <- [Chain b]
cs]

prop_common_prefix :: forall b. (HasHeader b, Condense (HeaderHash b), Eq b)
                   => Word64 -> Chain b -> Chain b -> Property
prop_common_prefix :: forall b.
(HasHeader b, Condense (HeaderHash b), Eq b) =>
Word64 -> Chain b -> Chain b -> Property
prop_common_prefix Word64
l Chain b
x Chain b
y = Chain b -> Chain b -> Property
go Chain b
x Chain b
y Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Chain b -> Chain b -> Property
go Chain b
y Chain b
x
  where
    go :: Chain b -> Chain b -> Property
go Chain b
c Chain b
d =
        let (Word64
l', Chain b
c') = Chain b -> Chain b -> (Word64, Chain b)
forall {b} {a}. (Eq b, Num a) => Chain b -> Chain b -> (a, Chain b)
findPrefix Chain b
c Chain b
d
            e :: String
e        = String
"after dropping "
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
l'
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" blocks from "
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Chain b -> String
showChain Chain b
c
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
",\n\nthe resulting "
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Chain b -> String
showChain Chain b
c'
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\nis a prefix of "
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Chain b -> String
showChain Chain b
d
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
",\n\nbut only "
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
l
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" block(s) should have been necessary"
        in  String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
e (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Word64
l' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
l

    findPrefix :: Chain b -> Chain b -> (a, Chain b)
findPrefix Chain b
c' Chain b
d
        | Chain b
c' Chain b -> Chain b -> Bool
forall block. Eq block => Chain block -> Chain block -> Bool
`Chain.isPrefixOf` Chain b
d = (a
0, Chain b
c')
        | Bool
otherwise         = let (a
l', Chain b
c'') = Chain b -> Chain b -> (a, Chain b)
findPrefix (Int -> Chain b -> Chain b
forall b. Int -> Chain b -> Chain b
Chain.dropLastBlocks Int
1 Chain b
c') Chain b
d
                              in  (a
l' a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, Chain b
c'')

    showChain :: Chain b -> String
    showChain :: Chain b -> String
showChain Chain b
c = Tip b -> String
forall a. Condense a => a -> String
condense (Chain b -> Tip b
forall block. HasHeader block => Chain block -> Tip block
Chain.headTip Chain b
c)
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n(length "
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Chain b -> Int
forall block. Chain block -> Int
Chain.length Chain b
c)
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"

-- | Find the common prefix of two chains
chainCommonPrefix :: HasHeader b => Chain b -> Chain b -> Chain b
chainCommonPrefix :: forall b. HasHeader b => Chain b -> Chain b -> Chain b
chainCommonPrefix Chain b
Genesis        Chain b
_              = Chain b
forall block. Chain block
Genesis
chainCommonPrefix Chain b
_              Chain b
Genesis        = Chain b
forall block. Chain block
Genesis
chainCommonPrefix cl :: Chain b
cl@(Chain b
cl' :> b
bl) cr :: Chain b
cr@(Chain b
cr' :> b
br) =
    case b -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo b
bl BlockNo -> BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` b -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo b
br of
      Ordering
LT -> Chain b -> Chain b -> Chain b
forall b. HasHeader b => Chain b -> Chain b -> Chain b
chainCommonPrefix Chain b
cl  Chain b
cr'
      Ordering
GT -> Chain b -> Chain b -> Chain b
forall b. HasHeader b => Chain b -> Chain b -> Chain b
chainCommonPrefix Chain b
cl' Chain b
cr
      Ordering
EQ ->
          if b -> HeaderHash b
forall b. HasHeader b => b -> HeaderHash b
blockHash b
bl HeaderHash b -> HeaderHash b -> Bool
forall a. Eq a => a -> a -> Bool
/= b -> HeaderHash b
forall b. HasHeader b => b -> HeaderHash b
blockHash b
br
          then Chain b -> Chain b -> Chain b
forall b. HasHeader b => Chain b -> Chain b -> Chain b
chainCommonPrefix Chain b
cl' Chain b
cr'
          else Chain b
cl

{-------------------------------------------------------------------------------
  Generation of a dot-file to represent the trace as a graph
-------------------------------------------------------------------------------}

data BlockInfo b = BlockInfo
    { forall b. BlockInfo b -> SlotNo
biSlot     :: !SlotNo
    , forall b. BlockInfo b -> Maybe CoreNodeId
biCreator  :: !(Maybe CoreNodeId)
    , forall b. BlockInfo b -> ChainHash b
biHash     :: !(ChainHash b)
    , forall b. BlockInfo b -> Maybe (ChainHash b)
biPrevious :: !(Maybe (ChainHash b))
    }

genesisBlockInfo :: BlockInfo b
genesisBlockInfo :: forall b. BlockInfo b
genesisBlockInfo = BlockInfo
    { biSlot :: SlotNo
biSlot     = SlotNo
0
    , biCreator :: Maybe CoreNodeId
biCreator  = Maybe CoreNodeId
forall a. Maybe a
Nothing
    , biHash :: ChainHash b
biHash     = ChainHash b
forall {k} (b :: k). ChainHash b
GenesisHash
    , biPrevious :: Maybe (ChainHash b)
biPrevious = Maybe (ChainHash b)
forall a. Maybe a
Nothing
    }


blockInfo :: (GetPrevHash b, HasCreator b)
          => b -> BlockInfo b
blockInfo :: forall b. (GetPrevHash b, HasCreator b) => b -> BlockInfo b
blockInfo b
b = BlockInfo
    { biSlot :: SlotNo
biSlot     = b -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot b
b
    , biCreator :: Maybe CoreNodeId
biCreator  = CoreNodeId -> Maybe CoreNodeId
forall a. a -> Maybe a
Just (CoreNodeId -> Maybe CoreNodeId) -> CoreNodeId -> Maybe CoreNodeId
forall a b. (a -> b) -> a -> b
$ b -> CoreNodeId
forall b. HasCreator b => b -> CoreNodeId
getCreator b
b
    , biHash :: ChainHash b
biHash     = HeaderHash b -> ChainHash b
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (HeaderHash b -> ChainHash b) -> HeaderHash b -> ChainHash b
forall a b. (a -> b) -> a -> b
$ b -> HeaderHash b
forall b. HasHeader b => b -> HeaderHash b
blockHash b
b
    , biPrevious :: Maybe (ChainHash b)
biPrevious = ChainHash b -> Maybe (ChainHash b)
forall a. a -> Maybe a
Just (ChainHash b -> Maybe (ChainHash b))
-> ChainHash b -> Maybe (ChainHash b)
forall a b. (a -> b) -> a -> b
$ b -> ChainHash b
forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash b
b
    }

data NodeLabel = NodeLabel
    { NodeLabel -> SlotNo
nlSlot      :: SlotNo
    , NodeLabel -> Maybe CoreNodeId
nlCreator   :: Maybe CoreNodeId
    , NodeLabel -> Set NodeId
nlBelievers :: Set NodeId
    }

instance Labellable NodeLabel where
    toLabelValue :: NodeLabel -> Label
toLabelValue NodeLabel{Maybe CoreNodeId
Set NodeId
SlotNo
nlSlot :: NodeLabel -> SlotNo
nlCreator :: NodeLabel -> Maybe CoreNodeId
nlBelievers :: NodeLabel -> Set NodeId
nlSlot :: SlotNo
nlCreator :: Maybe CoreNodeId
nlBelievers :: Set NodeId
..} = EscString -> Label
StrLabel (EscString -> Label) -> EscString -> Label
forall a b. (a -> b) -> a -> b
$ String -> EscString
Text.pack (String -> EscString) -> String -> EscString
forall a b. (a -> b) -> a -> b
$
           Word64 -> String
forall a. Show a => a -> String
show (SlotNo -> Word64
unSlotNo SlotNo
nlSlot)
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> (CoreNodeId -> String) -> Maybe CoreNodeId -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (NodeId -> String
showNodeId (NodeId -> String)
-> (CoreNodeId -> NodeId) -> CoreNodeId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreNodeId -> NodeId
fromCoreNodeId) Maybe CoreNodeId
nlCreator
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Set NodeId -> String
showNodeIds Set NodeId
nlBelievers
      where
        fromNodeId :: NodeId -> Maybe Word64
        fromNodeId :: NodeId -> Maybe Word64
fromNodeId (CoreId (CoreNodeId Word64
nid)) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
nid
        fromNodeId (RelayId Word64
_)               = Maybe Word64
forall a. Maybe a
Nothing

        showNodeId :: NodeId -> String
        showNodeId :: NodeId -> String
showNodeId = String -> (Word64 -> String) -> Maybe Word64 -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Word64 -> String
forall a. Show a => a -> String
show (Maybe Word64 -> String)
-> (NodeId -> Maybe Word64) -> NodeId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeId -> Maybe Word64
fromNodeId

        showNodeIds :: Set NodeId -> String
        showNodeIds :: Set NodeId -> String
showNodeIds Set NodeId
nids = case [Maybe Word64] -> [Word64]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Word64] -> [Word64]) -> [Maybe Word64] -> [Word64]
forall a b. (a -> b) -> a -> b
$ (NodeId -> Maybe Word64) -> [NodeId] -> [Maybe Word64]
forall a b. (a -> b) -> [a] -> [b]
map NodeId -> Maybe Word64
fromNodeId ([NodeId] -> [Maybe Word64]) -> [NodeId] -> [Maybe Word64]
forall a b. (a -> b) -> a -> b
$ Set NodeId -> [NodeId]
forall a. Set a -> [a]
Set.toList Set NodeId
nids of
            [] -> String
""
            [Word64]
xs -> String
" [" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords ((Word64 -> String) -> [Word64] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> String
forall a. Show a => a -> String
show [Word64]
xs) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]"

data EdgeLabel = EdgeLabel

instance Labellable EdgeLabel where
    toLabelValue :: EdgeLabel -> Label
toLabelValue = Label -> EdgeLabel -> Label
forall a b. a -> b -> a
const (Label -> EdgeLabel -> Label) -> Label -> EdgeLabel -> Label
forall a b. (a -> b) -> a -> b
$ EscString -> Label
StrLabel EscString
Text.empty

tracesToDot :: forall b. (GetPrevHash b, HasCreator b)
            => Map NodeId (NodeOutput b)
            -> String
tracesToDot :: forall b.
(GetPrevHash b, HasCreator b) =>
Map NodeId (NodeOutput b) -> String
tracesToDot Map NodeId (NodeOutput b)
traces = EscString -> String
Text.unpack (EscString -> String) -> EscString -> String
forall a b. (a -> b) -> a -> b
$ DotGraph Int -> EscString
forall (dg :: * -> *) n. PrintDotRepr dg n => dg n -> EscString
printDotGraph (DotGraph Int -> EscString) -> DotGraph Int -> EscString
forall a b. (a -> b) -> a -> b
$ GraphvizParams Int NodeLabel EdgeLabel () NodeLabel
-> Gr NodeLabel EdgeLabel -> DotGraph Int
forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Int nl el cl l -> gr nl el -> DotGraph Int
graphToDot GraphvizParams Int NodeLabel EdgeLabel () NodeLabel
forall nl el n.
(Labellable nl, Labellable el) =>
GraphvizParams n nl el () nl
quickParams Gr NodeLabel EdgeLabel
graph
  where
    chainBlockInfos :: Chain b
                    -> Map (ChainHash b) (BlockInfo b)
    chainBlockInfos :: Chain b -> Map (ChainHash b) (BlockInfo b)
chainBlockInfos = (Map (ChainHash b) (BlockInfo b)
 -> b -> Map (ChainHash b) (BlockInfo b))
-> Map (ChainHash b) (BlockInfo b)
-> Chain b
-> Map (ChainHash b) (BlockInfo b)
forall a b. (a -> b -> a) -> a -> Chain b -> a
Chain.foldChain Map (ChainHash b) (BlockInfo b)
-> b -> Map (ChainHash b) (BlockInfo b)
forall {b}.
(GetPrevHash b, HasCreator b) =>
Map (ChainHash b) (BlockInfo b)
-> b -> Map (ChainHash b) (BlockInfo b)
f (ChainHash b -> BlockInfo b -> Map (ChainHash b) (BlockInfo b)
forall k a. k -> a -> Map k a
Map.singleton ChainHash b
forall {k} (b :: k). ChainHash b
GenesisHash BlockInfo b
forall b. BlockInfo b
genesisBlockInfo)
      where
        f :: Map (ChainHash b) (BlockInfo b)
-> b -> Map (ChainHash b) (BlockInfo b)
f Map (ChainHash b) (BlockInfo b)
m b
b = let info :: BlockInfo b
info = b -> BlockInfo b
forall b. (GetPrevHash b, HasCreator b) => b -> BlockInfo b
blockInfo b
b
                in  ChainHash b
-> BlockInfo b
-> Map (ChainHash b) (BlockInfo b)
-> Map (ChainHash b) (BlockInfo b)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (BlockInfo b -> ChainHash b
forall b. BlockInfo b -> ChainHash b
biHash BlockInfo b
info) BlockInfo b
info Map (ChainHash b) (BlockInfo b)
m

    blockInfos :: Map (ChainHash b) (BlockInfo b)
    blockInfos :: Map (ChainHash b) (BlockInfo b)
blockInfos = [Map (ChainHash b) (BlockInfo b)]
-> Map (ChainHash b) (BlockInfo b)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
      [ Chain b -> Map (ChainHash b) (BlockInfo b)
chainBlockInfos (NodeOutput b -> Chain b
forall blk. NodeOutput blk -> Chain blk
nodeOutputFinalChain NodeOutput b
no)
      | NodeOutput b
no <- Map NodeId (NodeOutput b) -> [NodeOutput b]
forall k a. Map k a -> [a]
Map.elems Map NodeId (NodeOutput b)
traces
      ]

    lastHash :: Chain b -> ChainHash b
    lastHash :: Chain b -> ChainHash b
lastHash Chain b
Genesis  = ChainHash b
forall {k} (b :: k). ChainHash b
GenesisHash
    lastHash (Chain b
_ :> b
b) = HeaderHash b -> ChainHash b
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (HeaderHash b -> ChainHash b) -> HeaderHash b -> ChainHash b
forall a b. (a -> b) -> a -> b
$ b -> HeaderHash b
forall b. HasHeader b => b -> HeaderHash b
blockHash b
b

    blockInfosAndBelievers :: Map (ChainHash b) (BlockInfo b, Set NodeId)
    blockInfosAndBelievers :: Map (ChainHash b) (BlockInfo b, Set NodeId)
blockInfosAndBelievers =
        (Map (ChainHash b) (BlockInfo b, Set NodeId)
 -> NodeId
 -> Chain b
 -> Map (ChainHash b) (BlockInfo b, Set NodeId))
-> Map (ChainHash b) (BlockInfo b, Set NodeId)
-> Map NodeId (Chain b)
-> Map (ChainHash b) (BlockInfo b, Set NodeId)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey Map (ChainHash b) (BlockInfo b, Set NodeId)
-> NodeId -> Chain b -> Map (ChainHash b) (BlockInfo b, Set NodeId)
f Map (ChainHash b) (BlockInfo b, Set NodeId)
i (NodeOutput b -> Chain b
forall blk. NodeOutput blk -> Chain blk
nodeOutputFinalChain (NodeOutput b -> Chain b)
-> Map NodeId (NodeOutput b) -> Map NodeId (Chain b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NodeId (NodeOutput b)
traces)
      where
        i :: Map (ChainHash b) (BlockInfo b, Set NodeId)
i = (\BlockInfo b
info -> (BlockInfo b
info, Set NodeId
forall a. Set a
Set.empty)) (BlockInfo b -> (BlockInfo b, Set NodeId))
-> Map (ChainHash b) (BlockInfo b)
-> Map (ChainHash b) (BlockInfo b, Set NodeId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (ChainHash b) (BlockInfo b)
blockInfos

        f :: Map (ChainHash b) (BlockInfo b, Set NodeId)
-> NodeId -> Chain b -> Map (ChainHash b) (BlockInfo b, Set NodeId)
f Map (ChainHash b) (BlockInfo b, Set NodeId)
m NodeId
nid Chain b
chain = ((BlockInfo b, Set NodeId) -> (BlockInfo b, Set NodeId))
-> ChainHash b
-> Map (ChainHash b) (BlockInfo b, Set NodeId)
-> Map (ChainHash b) (BlockInfo b, Set NodeId)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
            (\(BlockInfo b
info, Set NodeId
believers) ->
              (BlockInfo b
info, NodeId -> Set NodeId -> Set NodeId
forall a. Ord a => a -> Set a -> Set a
Set.insert NodeId
nid Set NodeId
believers))
            (Chain b -> ChainHash b
lastHash Chain b
chain)
            Map (ChainHash b) (BlockInfo b, Set NodeId)
m

    hashToId :: Map (ChainHash b) Node
    hashToId :: Map (ChainHash b) Int
hashToId = [(ChainHash b, Int)] -> Map (ChainHash b) Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ChainHash b, Int)] -> Map (ChainHash b) Int)
-> [(ChainHash b, Int)] -> Map (ChainHash b) Int
forall a b. (a -> b) -> a -> b
$ [ChainHash b] -> [Int] -> [(ChainHash b, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Map (ChainHash b) (BlockInfo b, Set NodeId) -> [ChainHash b]
forall k a. Map k a -> [k]
Map.keys Map (ChainHash b) (BlockInfo b, Set NodeId)
blockInfosAndBelievers) [Int
0..]

    ns :: [LNode NodeLabel]
    ns :: [LNode NodeLabel]
ns = [ ( Map (ChainHash b) Int
hashToId Map (ChainHash b) Int -> ChainHash b -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! ChainHash b
h
           , NodeLabel
                { nlSlot :: SlotNo
nlSlot      = BlockInfo b -> SlotNo
forall b. BlockInfo b -> SlotNo
biSlot BlockInfo b
info
                , nlCreator :: Maybe CoreNodeId
nlCreator   = BlockInfo b -> Maybe CoreNodeId
forall b. BlockInfo b -> Maybe CoreNodeId
biCreator BlockInfo b
info
                , nlBelievers :: Set NodeId
nlBelievers = Set NodeId
believers
                }
           )
         | (ChainHash b
h, (BlockInfo b
info, Set NodeId
believers)) <- Map (ChainHash b) (BlockInfo b, Set NodeId)
-> [(ChainHash b, (BlockInfo b, Set NodeId))]
forall k a. Map k a -> [(k, a)]
Map.toList Map (ChainHash b) (BlockInfo b, Set NodeId)
blockInfosAndBelievers
         ]

    es :: [LEdge EdgeLabel]
    es :: [LEdge EdgeLabel]
es = ((ChainHash b, ChainHash b) -> LEdge EdgeLabel)
-> [(ChainHash b, ChainHash b)] -> [LEdge EdgeLabel]
forall a b. (a -> b) -> [a] -> [b]
map (ChainHash b, ChainHash b) -> LEdge EdgeLabel
g
       ([(ChainHash b, ChainHash b)] -> [LEdge EdgeLabel])
-> [(ChainHash b, ChainHash b)] -> [LEdge EdgeLabel]
forall a b. (a -> b) -> a -> b
$ [Maybe (ChainHash b, ChainHash b)] -> [(ChainHash b, ChainHash b)]
forall a. [Maybe a] -> [a]
catMaybes
       ([Maybe (ChainHash b, ChainHash b)]
 -> [(ChainHash b, ChainHash b)])
-> [Maybe (ChainHash b, ChainHash b)]
-> [(ChainHash b, ChainHash b)]
forall a b. (a -> b) -> a -> b
$ ((ChainHash b, Maybe (ChainHash b))
 -> Maybe (ChainHash b, ChainHash b))
-> [(ChainHash b, Maybe (ChainHash b))]
-> [Maybe (ChainHash b, ChainHash b)]
forall a b. (a -> b) -> [a] -> [b]
map (ChainHash b, Maybe (ChainHash b))
-> Maybe (ChainHash b, ChainHash b)
forall {f :: * -> *} {t} {a}. Functor f => (t, f a) -> f (t, a)
f
       [ (BlockInfo b -> ChainHash b
forall b. BlockInfo b -> ChainHash b
biHash BlockInfo b
info, BlockInfo b -> Maybe (ChainHash b)
forall b. BlockInfo b -> Maybe (ChainHash b)
biPrevious BlockInfo b
info) | BlockInfo b
info <- Map (ChainHash b) (BlockInfo b) -> [BlockInfo b]
forall k a. Map k a -> [a]
Map.elems Map (ChainHash b) (BlockInfo b)
blockInfos]
      where f :: (t, f a) -> f (t, a)
f (t
h, f a
mh) = (t
h,) (a -> (t, a)) -> f a -> f (t, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
mh
            g :: (ChainHash b, ChainHash b) -> LEdge EdgeLabel
g (ChainHash b
h1, ChainHash b
h2) = (Map (ChainHash b) Int
hashToId Map (ChainHash b) Int -> ChainHash b -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! ChainHash b
h1, Map (ChainHash b) Int
hashToId Map (ChainHash b) Int -> ChainHash b -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! ChainHash b
h2, EdgeLabel
EdgeLabel)

    graph :: Gr NodeLabel EdgeLabel
    graph :: Gr NodeLabel EdgeLabel
graph = [LNode NodeLabel] -> [LEdge EdgeLabel] -> Gr NodeLabel EdgeLabel
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode NodeLabel]
ns [LEdge EdgeLabel]
es

{-------------------------------------------------------------------------------
  Leader Schedule
-------------------------------------------------------------------------------}

consensusExpected ::
     SecurityParam
  -> NodeJoinPlan
  -> LeaderSchedule
  -> Bool
consensusExpected :: SecurityParam -> NodeJoinPlan -> LeaderSchedule -> Bool
consensusExpected SecurityParam
k NodeJoinPlan
nodeJoinPlan LeaderSchedule
schedule =
    Word64
maxForkLength Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= SecurityParam -> Word64
maxRollbacks SecurityParam
k
  where
    NumBlocks Word64
maxForkLength = SecurityParam -> NodeJoinPlan -> LeaderSchedule -> NumBlocks
determineForkLength SecurityParam
k NodeJoinPlan
nodeJoinPlan LeaderSchedule
schedule

emptyLeaderSchedule :: NumSlots -> LeaderSchedule
emptyLeaderSchedule :: NumSlots -> LeaderSchedule
emptyLeaderSchedule (NumSlots Word64
t) = Map SlotNo [CoreNodeId] -> LeaderSchedule
LeaderSchedule (Map SlotNo [CoreNodeId] -> LeaderSchedule)
-> Map SlotNo [CoreNodeId] -> LeaderSchedule
forall a b. (a -> b) -> a -> b
$
    [(SlotNo, [CoreNodeId])] -> Map SlotNo [CoreNodeId]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SlotNo, [CoreNodeId])] -> Map SlotNo [CoreNodeId])
-> [(SlotNo, [CoreNodeId])] -> Map SlotNo [CoreNodeId]
forall a b. (a -> b) -> a -> b
$
    [ (Word64 -> SlotNo
SlotNo Word64
i, [])
    | Word64
i <- [ Word64
0 .. Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1 ]
    ]

roundRobinLeaderSchedule :: NumCoreNodes -> NumSlots -> LeaderSchedule
roundRobinLeaderSchedule :: NumCoreNodes -> NumSlots -> LeaderSchedule
roundRobinLeaderSchedule (NumCoreNodes Word64
n) (NumSlots Word64
t) = Map SlotNo [CoreNodeId] -> LeaderSchedule
LeaderSchedule (Map SlotNo [CoreNodeId] -> LeaderSchedule)
-> Map SlotNo [CoreNodeId] -> LeaderSchedule
forall a b. (a -> b) -> a -> b
$
    [(SlotNo, [CoreNodeId])] -> Map SlotNo [CoreNodeId]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SlotNo, [CoreNodeId])] -> Map SlotNo [CoreNodeId])
-> [(SlotNo, [CoreNodeId])] -> Map SlotNo [CoreNodeId]
forall a b. (a -> b) -> a -> b
$
    [ (Word64 -> SlotNo
SlotNo Word64
i, [Word64 -> CoreNodeId
CoreNodeId (Word64
i Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
n)])
    | Word64
i <- [ Word64
0 .. Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1 ]
    ]