{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

#if __GLASGOW_HASKELL__ >= 910
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif

-- | Test that 'PerasWeightSnapshot' can correctly compute the weight of points
-- and fragments.
module Test.Consensus.Peras.WeightSnapshot (tests) where

import Cardano.Ledger.BaseTypes (unNonZero)
import Data.Containers.ListUtils (nubOrd)
import Data.List (find)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromJust)
import Data.Traversable (for)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config.SecurityParam
import Ouroboros.Consensus.Peras.Weight
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Mock.Chain (Chain)
import qualified Ouroboros.Network.Mock.Chain as Chain
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.Orphans.Arbitrary ()
import Test.Util.QuickCheck
import Test.Util.TestBlock

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"PerasWeightSnapshot"
    [ [Char] -> (TestSetup -> Property) -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"correctness" TestSetup -> Property
prop_perasWeightSnapshot
    ]

prop_perasWeightSnapshot :: TestSetup -> Property
prop_perasWeightSnapshot :: TestSetup -> Property
prop_perasWeightSnapshot TestSetup
testSetup =
  [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate [Char]
"log₂ # of points" [Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round @Double @Int (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Point TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Point TestBlock]
tsPoints))]
    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"PerasWeightSnapshot: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> PerasWeightSnapshot TestBlock -> [Char]
forall a. Show a => a -> [Char]
show PerasWeightSnapshot TestBlock
snap)
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
          [ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Incorrect weight for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Point TestBlock -> [Char]
forall a. Condense a => a -> [Char]
condense Point TestBlock
pt) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
              Point TestBlock -> PerasWeight
weightBoostOfPointReference Point TestBlock
pt PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Condense a) => a -> a -> Property
=:= PerasWeightSnapshot TestBlock -> Point TestBlock -> PerasWeight
forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> Point blk -> PerasWeight
weightBoostOfPoint PerasWeightSnapshot TestBlock
snap Point TestBlock
pt
          | Point TestBlock
pt <- [Point TestBlock]
tsPoints
          ]
      , [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
          [ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
              [ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Incorrect weight for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> [Char]
forall a. Condense a => a -> [Char]
condense AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                  AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
weightBoostOfFragmentReference AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Condense a) => a -> a -> Property
=:= PerasWeightSnapshot TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag
              , [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Weight not inductively consistent for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> [Char]
forall a. Condense a => a -> [Char]
condense AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                  PerasWeightSnapshot TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Property
prop_fragmentInduction PerasWeightSnapshot TestBlock
snap AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag
              ]
          | AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag <- [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments
          ]
      , [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
          [ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
              [ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Incorrect volatile suffix for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> [Char]
forall a. Condense a => a -> [Char]
condense AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                  AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
takeVolatileSuffixReference AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Property
forall a. (Eq a, Condense a) => a -> a -> Property
=:= AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
volSuffix
              , [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Volatile suffix must be a suffix of" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> [Char]
forall a. Condense a => a -> [Char]
condense AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                  AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Point TestBlock
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag Point TestBlock -> Point TestBlock -> Property
forall a. (Eq a, Condense a) => a -> a -> Property
=:= AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Point TestBlock
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
volSuffix
                    Property -> Bool -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Point TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Point TestBlock
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
volSuffix) AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag
              , [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"A longer volatile suffix still has total weight at most k") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                  let isImproperSuffix :: Bool
isImproperSuffix = AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
volSuffix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag
                      fragSuffixOneLonger :: AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
fragSuffixOneLonger =
                        Word64
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.anchorNewest (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
volSuffix) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag
                      weightOneLonger :: PerasWeight
weightOneLonger = PerasWeightSnapshot TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
totalWeightOfFragment PerasWeightSnapshot TestBlock
snap AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
fragSuffixOneLonger
                   in Bool
isImproperSuffix Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.||. PerasWeight
weightOneLonger PerasWeight -> PerasWeight -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`gt` SecurityParam -> PerasWeight
maxRollbackWeight SecurityParam
tsSecParam
              , [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Volatile suffix of " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> [Char]
forall a. Condense a => a -> [Char]
condense AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" must contain at most k blocks") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                  AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
volSuffix Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`le` Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
tsSecParam))
              ]
          | AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag <- [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments
          , let volSuffix :: AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
volSuffix = PerasWeightSnapshot TestBlock
-> SecurityParam
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk
-> SecurityParam -> AnchoredFragment h -> AnchoredFragment h
takeVolatileSuffix PerasWeightSnapshot TestBlock
snap SecurityParam
tsSecParam AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag
          ]
      ]
 where
  TestSetup
    { Map (Point TestBlock) PerasWeight
tsWeights :: Map (Point TestBlock) PerasWeight
tsWeights :: TestSetup -> Map (Point TestBlock) PerasWeight
tsWeights
    , [Point TestBlock]
tsPoints :: [Point TestBlock]
tsPoints :: TestSetup -> [Point TestBlock]
tsPoints
    , [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments :: [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments :: TestSetup
-> [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments
    , SecurityParam
tsSecParam :: SecurityParam
tsSecParam :: TestSetup -> SecurityParam
tsSecParam
    } = TestSetup
testSetup

  snap :: PerasWeightSnapshot TestBlock
snap = [(Point TestBlock, PerasWeight)] -> PerasWeightSnapshot TestBlock
forall blk.
StandardHash blk =>
[(Point blk, PerasWeight)] -> PerasWeightSnapshot blk
mkPerasWeightSnapshot ([(Point TestBlock, PerasWeight)] -> PerasWeightSnapshot TestBlock)
-> [(Point TestBlock, PerasWeight)]
-> PerasWeightSnapshot TestBlock
forall a b. (a -> b) -> a -> b
$ Map (Point TestBlock) PerasWeight
-> [(Point TestBlock, PerasWeight)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Point TestBlock) PerasWeight
tsWeights

  weightBoostOfPointReference :: Point TestBlock -> PerasWeight
  weightBoostOfPointReference :: Point TestBlock -> PerasWeight
weightBoostOfPointReference Point TestBlock
pt = PerasWeight
-> Point TestBlock
-> Map (Point TestBlock) PerasWeight
-> PerasWeight
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault PerasWeight
forall a. Monoid a => a
mempty Point TestBlock
pt Map (Point TestBlock) PerasWeight
tsWeights

  weightBoostOfFragmentReference :: AnchoredFragment TestBlock -> PerasWeight
  weightBoostOfFragmentReference :: AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
weightBoostOfFragmentReference AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag =
    (TestBlock -> PerasWeight) -> [TestBlock] -> PerasWeight
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
      (Point TestBlock -> PerasWeight
weightBoostOfPointReference (Point TestBlock -> PerasWeight)
-> (TestBlock -> Point TestBlock) -> TestBlock -> PerasWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint)
      (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag)

  takeVolatileSuffixReference ::
    AnchoredFragment TestBlock -> AnchoredFragment TestBlock
  takeVolatileSuffixReference :: AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
takeVolatileSuffixReference =
    Maybe
  (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe
   (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
 -> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
-> (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
    -> Maybe
         (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock))
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
 -> Bool)
-> [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
-> Maybe
     (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Bool
hasWeightAtMostK ([AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
 -> Maybe
      (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock))
-> (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
    -> [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock])
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Maybe
     (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
forall {v} {a} {b}.
Anchorable v a b =>
AnchoredSeq v a b -> [AnchoredSeq v a b]
suffixes
   where
    -- Consider suffixes of @frag@, longest first
    suffixes :: AnchoredSeq v a b -> [AnchoredSeq v a b]
suffixes AnchoredSeq v a b
frag =
      [ Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.anchorNewest (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) AnchoredSeq v a b
frag
      | Int
len <- [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0 .. AnchoredSeq v a b -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq v a b
frag]
      ]

    hasWeightAtMostK :: AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Bool
hasWeightAtMostK AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag =
      PerasWeight
totalWeight PerasWeight -> PerasWeight -> Bool
forall a. Ord a => a -> a -> Bool
<= SecurityParam -> PerasWeight
maxRollbackWeight SecurityParam
tsSecParam
     where
      weightBoost :: PerasWeight
weightBoost = AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
weightBoostOfFragmentReference AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag
      lengthWeight :: PerasWeight
lengthWeight = Word64 -> PerasWeight
PerasWeight (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag))
      totalWeight :: PerasWeight
totalWeight = PerasWeight
lengthWeight PerasWeight -> PerasWeight -> PerasWeight
forall a. Semigroup a => a -> a -> a
<> PerasWeight
weightBoost

-- | Test that the weight of a fragment is equal to the weight of its
-- first\/last point plus the weight of the remaining suffix\/infix.
prop_fragmentInduction ::
  PerasWeightSnapshot TestBlock ->
  AnchoredFragment TestBlock ->
  Property
prop_fragmentInduction :: PerasWeightSnapshot TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Property
prop_fragmentInduction PerasWeightSnapshot TestBlock
snap =
  \AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag -> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Property
fromLeft AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Property
fromRight AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag
 where
  fromLeft :: AnchoredFragment TestBlock -> Property
  fromLeft :: AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Property
fromLeft AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag = case AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag of
    AF.Empty Anchor TestBlock
_ ->
      PerasWeightSnapshot TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PerasWeight
forall a. Monoid a => a
mempty
    TestBlock
b AF.:< AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag' ->
      PerasWeightSnapshot TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag
        PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PerasWeightSnapshot TestBlock -> Point TestBlock -> PerasWeight
forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> Point blk -> PerasWeight
weightBoostOfPoint PerasWeightSnapshot TestBlock
snap (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
b) PerasWeight -> PerasWeight -> PerasWeight
forall a. Semigroup a => a -> a -> a
<> PerasWeightSnapshot TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag'

  fromRight :: AnchoredFragment TestBlock -> Property
  fromRight :: AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Property
fromRight AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag = case AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag of
    AF.Empty Anchor TestBlock
_ ->
      PerasWeightSnapshot TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PerasWeight
forall a. Monoid a => a
mempty
    AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag' AF.:> TestBlock
b ->
      PerasWeightSnapshot TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag
        PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PerasWeightSnapshot TestBlock -> Point TestBlock -> PerasWeight
forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> Point blk -> PerasWeight
weightBoostOfPoint PerasWeightSnapshot TestBlock
snap (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
b) PerasWeight -> PerasWeight -> PerasWeight
forall a. Semigroup a => a -> a -> a
<> PerasWeightSnapshot TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
frag'

data TestSetup = TestSetup
  { TestSetup -> Map (Point TestBlock) PerasWeight
tsWeights :: Map (Point TestBlock) PerasWeight
  , TestSetup -> [Point TestBlock]
tsPoints :: [Point TestBlock]
  -- ^ Check the weight of these points.
  , TestSetup
-> [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments :: [AnchoredFragment TestBlock]
  -- ^ Check the weight of these fragments.
  , TestSetup -> SecurityParam
tsSecParam :: SecurityParam
  }
  deriving stock Int -> TestSetup -> [Char] -> [Char]
[TestSetup] -> [Char] -> [Char]
TestSetup -> [Char]
(Int -> TestSetup -> [Char] -> [Char])
-> (TestSetup -> [Char])
-> ([TestSetup] -> [Char] -> [Char])
-> Show TestSetup
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> TestSetup -> [Char] -> [Char]
showsPrec :: Int -> TestSetup -> [Char] -> [Char]
$cshow :: TestSetup -> [Char]
show :: TestSetup -> [Char]
$cshowList :: [TestSetup] -> [Char] -> [Char]
showList :: [TestSetup] -> [Char] -> [Char]
Show

instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = do
    -- Generate a block tree rooted at Genesis.
    tree :: BlockTree <- Gen BlockTree
forall a. Arbitrary a => Gen a
arbitrary

    let
      -- Points for all blocks in the block tree.
      tsPoints :: [Point TestBlock]
      tsPoints = [Point TestBlock] -> [Point TestBlock]
forall a. Ord a => [a] -> [a]
nubOrd ([Point TestBlock] -> [Point TestBlock])
-> [Point TestBlock] -> [Point TestBlock]
forall a b. (a -> b) -> a -> b
$ Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint Point TestBlock -> [Point TestBlock] -> [Point TestBlock]
forall a. a -> [a] -> [a]
: (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint (TestBlock -> Point TestBlock) -> [TestBlock] -> [Point TestBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockTree -> [TestBlock]
treeToBlocks BlockTree
tree)

      -- Chains from Genesis to all leaves of the block tree.
      treeChains :: [Chain TestBlock]
      treeChains = BlockTree -> [Chain TestBlock]
treeToChains BlockTree
tree

    -- Randomly boost some points. This might need to be refined in the future
    -- (as per https://github.com/tweag/cardano-peras/issues/124).
    tsWeights :: Map (Point TestBlock) PerasWeight <-
      Map.fromList . catMaybes <$> for tsPoints \Point TestBlock
pt ->
        (PerasWeight -> (Point TestBlock, PerasWeight))
-> Maybe PerasWeight -> Maybe (Point TestBlock, PerasWeight)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Point TestBlock
pt,) (Maybe PerasWeight -> Maybe (Point TestBlock, PerasWeight))
-> Gen (Maybe PerasWeight)
-> Gen (Maybe (Point TestBlock, PerasWeight))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Maybe PerasWeight)
genWeightBoost

    -- Generate a list of fragments as random infixes of the @treeChains@.
    tsFragments <-
      for treeChains genInfixFragment

    tsSecParam <- arbitrary
    pure
      TestSetup
        { tsWeights
        , tsPoints
        , tsFragments
        , tsSecParam
        }
   where
    -- Generate a weight boost (for some point).
    genWeightBoost :: Gen (Maybe PerasWeight)
    genWeightBoost :: Gen (Maybe PerasWeight)
genWeightBoost =
      [(Int, Gen (Maybe PerasWeight))] -> Gen (Maybe PerasWeight)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
3, Maybe PerasWeight -> Gen (Maybe PerasWeight)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PerasWeight
forall a. Maybe a
Nothing)
        , (Int
1, PerasWeight -> Maybe PerasWeight
forall a. a -> Maybe a
Just (PerasWeight -> Maybe PerasWeight)
-> (Word64 -> PerasWeight) -> Word64 -> Maybe PerasWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> PerasWeight
PerasWeight (Word64 -> Maybe PerasWeight)
-> Gen Word64 -> Gen (Maybe PerasWeight)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
10))
        ]

    -- Given a chain, generate an infix fragment of that chain.
    genInfixFragment :: Chain TestBlock -> Gen (AnchoredFragment TestBlock)
    genInfixFragment :: Chain TestBlock
-> Gen
     (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
genInfixFragment Chain TestBlock
chain = do
      let lenChain :: Int
lenChain = Chain TestBlock -> Int
forall block. Chain block -> Int
Chain.length Chain TestBlock
chain
          fullFrag :: AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
fullFrag = Chain TestBlock
-> AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
Chain.toAnchoredFragment Chain TestBlock
chain
      nTakeNewest <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
lenChain)
      nDropNewest <- choose (0, nTakeNewest)
      pure $
        AF.dropNewest nDropNewest $
          AF.anchorNewest (fromIntegral nTakeNewest) fullFrag

  shrink :: TestSetup -> [TestSetup]
shrink TestSetup
ts =
    [[TestSetup]] -> [TestSetup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ TestSetup
ts{tsWeights = Map.fromList tsWeights'}
        | [(Point TestBlock, PerasWeight)]
tsWeights' <-
            ((Point TestBlock, PerasWeight)
 -> [(Point TestBlock, PerasWeight)])
-> [(Point TestBlock, PerasWeight)]
-> [[(Point TestBlock, PerasWeight)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList
              (\(Point TestBlock
pt, PerasWeight
w) -> (Point TestBlock
pt,) (PerasWeight -> (Point TestBlock, PerasWeight))
-> [PerasWeight] -> [(Point TestBlock, PerasWeight)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PerasWeight -> [PerasWeight]
shrinkWeight PerasWeight
w)
              ([(Point TestBlock, PerasWeight)]
 -> [[(Point TestBlock, PerasWeight)]])
-> [(Point TestBlock, PerasWeight)]
-> [[(Point TestBlock, PerasWeight)]]
forall a b. (a -> b) -> a -> b
$ Map (Point TestBlock) PerasWeight
-> [(Point TestBlock, PerasWeight)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Point TestBlock) PerasWeight
tsWeights
        ]
      , [ TestSetup
ts{tsPoints = tsPoints'}
        | [Point TestBlock]
tsPoints' <- (Point TestBlock -> [Point TestBlock])
-> [Point TestBlock] -> [[Point TestBlock]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (\Point TestBlock
_pt -> []) [Point TestBlock]
tsPoints
        ]
      , [ TestSetup
ts{tsFragments = tsFragments'}
        | [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments' <- (AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
 -> [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock])
-> [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
-> [[AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (\AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
_frag -> []) [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments
        ]
      , [ TestSetup
ts{tsSecParam = tsSecParam'}
        | SecurityParam
tsSecParam' <- SecurityParam -> [SecurityParam]
forall a. Arbitrary a => a -> [a]
shrink SecurityParam
tsSecParam
        ]
      ]
   where
    -- Decrease by @1@, unless this would mean that it is non-positive.
    shrinkWeight :: PerasWeight -> [PerasWeight]
    shrinkWeight :: PerasWeight -> [PerasWeight]
shrinkWeight (PerasWeight Word64
w)
      | Word64
w Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
1 = [Word64 -> PerasWeight
PerasWeight (Word64
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)]
      | Bool
otherwise = []

    TestSetup
      { Map (Point TestBlock) PerasWeight
tsWeights :: TestSetup -> Map (Point TestBlock) PerasWeight
tsWeights :: Map (Point TestBlock) PerasWeight
tsWeights
      , [Point TestBlock]
tsPoints :: TestSetup -> [Point TestBlock]
tsPoints :: [Point TestBlock]
tsPoints
      , [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments :: TestSetup
-> [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments :: [AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock]
tsFragments
      , SecurityParam
tsSecParam :: TestSetup -> SecurityParam
tsSecParam :: SecurityParam
tsSecParam
      } = TestSetup
ts