{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | Deterministic portion of the Weighted Fait-Accompli committee selection scheme
module Ouroboros.Consensus.Committee.WFA
  ( -- * Weighted Fait-Accompli committee selection scheme
    PersistentCommitteeSize (..)
  , NonPersistentCommitteeSize (..)
  , TotalPersistentStake (..)
  , TotalNonPersistentStake (..)
  , weightedFaitAccompliSplitSeats
  , isAbovePersistentSeatThreshold

    -- * Cumulative stake distributions
  , SeatIndex (..)
  , NumPoolsWithPositiveStake (..)
  , WFAError (..)
  , WFATiebreaker (..)
  , wFATiebreakerWithEpochNonce
  , ExtWFAStakeDistr (..)
  , mkExtWFAStakeDistr
  , getCandidateIfSeatWithinBounds
  , unsafeGetCandidateInSeat
  ) where

-- NOTE: DSIGN/BLS imports are needed to implement the fair 'WFATiebreaker'
-- using epoch nonces. If we move away from BLS in the future of Peras/Leios, we
-- might want to revisit its implementation to use a different hash function.
import Cardano.Crypto.DSIGN (BLS12381MinSigDSIGN, DSIGNAlgorithm (SigDSIGN))
import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.BaseTypes (Nonce (NeutralNonce, Nonce))
import Cardano.Ledger.Binary (runByteBuilder)
import Cardano.Ledger.Core (HASH, Hash, KeyHash (unKeyHash))
import Control.Exception (assert)
import Data.Array (Array, Ix, listArray)
import qualified Data.Array as Array
import qualified Data.ByteString.Builder.Extra as BS
import Data.Function (on)
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import Ouroboros.Consensus.Committee.Types
  ( Cumulative (..)
  , LedgerStake (..)
  , PoolId
  , TargetCommitteeSize (..)
  , unPoolId
  )

-- * Weighted Fait-Accompli committee selection scheme

-- | Persistent committee size
newtype PersistentCommitteeSize
  = PersistentCommitteeSize
  { PersistentCommitteeSize -> Word64
unPersistentCommitteeSize :: Word64
  }
  deriving (Int -> PersistentCommitteeSize -> ShowS
[PersistentCommitteeSize] -> ShowS
PersistentCommitteeSize -> String
(Int -> PersistentCommitteeSize -> ShowS)
-> (PersistentCommitteeSize -> String)
-> ([PersistentCommitteeSize] -> ShowS)
-> Show PersistentCommitteeSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PersistentCommitteeSize -> ShowS
showsPrec :: Int -> PersistentCommitteeSize -> ShowS
$cshow :: PersistentCommitteeSize -> String
show :: PersistentCommitteeSize -> String
$cshowList :: [PersistentCommitteeSize] -> ShowS
showList :: [PersistentCommitteeSize] -> ShowS
Show, PersistentCommitteeSize -> PersistentCommitteeSize -> Bool
(PersistentCommitteeSize -> PersistentCommitteeSize -> Bool)
-> (PersistentCommitteeSize -> PersistentCommitteeSize -> Bool)
-> Eq PersistentCommitteeSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PersistentCommitteeSize -> PersistentCommitteeSize -> Bool
== :: PersistentCommitteeSize -> PersistentCommitteeSize -> Bool
$c/= :: PersistentCommitteeSize -> PersistentCommitteeSize -> Bool
/= :: PersistentCommitteeSize -> PersistentCommitteeSize -> Bool
Eq)

-- | Non-persistent committee size
newtype NonPersistentCommitteeSize
  = NonPersistentCommitteeSize
  { NonPersistentCommitteeSize -> Word64
unNonPersistentCommitteeSize :: Word64
  }
  deriving (Int -> NonPersistentCommitteeSize -> ShowS
[NonPersistentCommitteeSize] -> ShowS
NonPersistentCommitteeSize -> String
(Int -> NonPersistentCommitteeSize -> ShowS)
-> (NonPersistentCommitteeSize -> String)
-> ([NonPersistentCommitteeSize] -> ShowS)
-> Show NonPersistentCommitteeSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NonPersistentCommitteeSize -> ShowS
showsPrec :: Int -> NonPersistentCommitteeSize -> ShowS
$cshow :: NonPersistentCommitteeSize -> String
show :: NonPersistentCommitteeSize -> String
$cshowList :: [NonPersistentCommitteeSize] -> ShowS
showList :: [NonPersistentCommitteeSize] -> ShowS
Show, NonPersistentCommitteeSize -> NonPersistentCommitteeSize -> Bool
(NonPersistentCommitteeSize -> NonPersistentCommitteeSize -> Bool)
-> (NonPersistentCommitteeSize
    -> NonPersistentCommitteeSize -> Bool)
-> Eq NonPersistentCommitteeSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NonPersistentCommitteeSize -> NonPersistentCommitteeSize -> Bool
== :: NonPersistentCommitteeSize -> NonPersistentCommitteeSize -> Bool
$c/= :: NonPersistentCommitteeSize -> NonPersistentCommitteeSize -> Bool
/= :: NonPersistentCommitteeSize -> NonPersistentCommitteeSize -> Bool
Eq)

-- | Total persistent stake
newtype TotalPersistentStake
  = TotalPersistentStake
  { TotalPersistentStake -> Cumulative LedgerStake
unTotalPersistentStake :: Cumulative LedgerStake
  }
  deriving (Int -> TotalPersistentStake -> ShowS
[TotalPersistentStake] -> ShowS
TotalPersistentStake -> String
(Int -> TotalPersistentStake -> ShowS)
-> (TotalPersistentStake -> String)
-> ([TotalPersistentStake] -> ShowS)
-> Show TotalPersistentStake
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TotalPersistentStake -> ShowS
showsPrec :: Int -> TotalPersistentStake -> ShowS
$cshow :: TotalPersistentStake -> String
show :: TotalPersistentStake -> String
$cshowList :: [TotalPersistentStake] -> ShowS
showList :: [TotalPersistentStake] -> ShowS
Show, TotalPersistentStake -> TotalPersistentStake -> Bool
(TotalPersistentStake -> TotalPersistentStake -> Bool)
-> (TotalPersistentStake -> TotalPersistentStake -> Bool)
-> Eq TotalPersistentStake
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TotalPersistentStake -> TotalPersistentStake -> Bool
== :: TotalPersistentStake -> TotalPersistentStake -> Bool
$c/= :: TotalPersistentStake -> TotalPersistentStake -> Bool
/= :: TotalPersistentStake -> TotalPersistentStake -> Bool
Eq)

-- | Total non-persistent stake
newtype TotalNonPersistentStake
  = TotalNonPersistentStake
  { TotalNonPersistentStake -> Cumulative LedgerStake
unTotalNonPersistentStake :: Cumulative LedgerStake
  }
  deriving (Int -> TotalNonPersistentStake -> ShowS
[TotalNonPersistentStake] -> ShowS
TotalNonPersistentStake -> String
(Int -> TotalNonPersistentStake -> ShowS)
-> (TotalNonPersistentStake -> String)
-> ([TotalNonPersistentStake] -> ShowS)
-> Show TotalNonPersistentStake
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TotalNonPersistentStake -> ShowS
showsPrec :: Int -> TotalNonPersistentStake -> ShowS
$cshow :: TotalNonPersistentStake -> String
show :: TotalNonPersistentStake -> String
$cshowList :: [TotalNonPersistentStake] -> ShowS
showList :: [TotalNonPersistentStake] -> ShowS
Show, TotalNonPersistentStake -> TotalNonPersistentStake -> Bool
(TotalNonPersistentStake -> TotalNonPersistentStake -> Bool)
-> (TotalNonPersistentStake -> TotalNonPersistentStake -> Bool)
-> Eq TotalNonPersistentStake
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TotalNonPersistentStake -> TotalNonPersistentStake -> Bool
== :: TotalNonPersistentStake -> TotalNonPersistentStake -> Bool
$c/= :: TotalNonPersistentStake -> TotalNonPersistentStake -> Bool
/= :: TotalNonPersistentStake -> TotalNonPersistentStake -> Bool
Eq)

-- | Errors that can occur when trying to split the stake distribution into
-- persistent and seats via weighted Fait-Accompli.
data WFAError
  = -- | The underlying stake distribution is empty
    EmptyStakeDistribution
  | -- | The target committee size is larger than the number of pools with positive
    -- stake in the underlying stake distribution, which would lead to incorrect
    -- results (e.g. granting persistent seats to voters with zero stake).
    NotEnoughPoolsWithPositiveStake
      TargetCommitteeSize
      NumPoolsWithPositiveStake
  deriving (Int -> WFAError -> ShowS
[WFAError] -> ShowS
WFAError -> String
(Int -> WFAError -> ShowS)
-> (WFAError -> String) -> ([WFAError] -> ShowS) -> Show WFAError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WFAError -> ShowS
showsPrec :: Int -> WFAError -> ShowS
$cshow :: WFAError -> String
show :: WFAError -> String
$cshowList :: [WFAError] -> ShowS
showList :: [WFAError] -> ShowS
Show, WFAError -> WFAError -> Bool
(WFAError -> WFAError -> Bool)
-> (WFAError -> WFAError -> Bool) -> Eq WFAError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WFAError -> WFAError -> Bool
== :: WFAError -> WFAError -> Bool
$c/= :: WFAError -> WFAError -> Bool
/= :: WFAError -> WFAError -> Bool
Eq)

-- | Split a stake distrubution into persistent and non-persistent committee
-- seats according to the weighted Fait-Accompli scheme.
--
-- This function returns:
--   * number of persistent seats granted via the weighted Fait-Accompli scheme
--   * number of non-persistent seats expected to vote via local sortition
--   * total persistent stake
--   * total non-persistent stake
weightedFaitAccompliSplitSeats ::
  -- | Extended cumulative stake distribution of the potential voters
  ExtWFAStakeDistr c ->
  -- | Expected total committee size (persistent + non-persistent)
  TargetCommitteeSize ->
  Either
    WFAError
    ( PersistentCommitteeSize
    , NonPersistentCommitteeSize
    , TotalPersistentStake
    , TotalNonPersistentStake
    )
weightedFaitAccompliSplitSeats :: forall c.
ExtWFAStakeDistr c
-> TargetCommitteeSize
-> Either
     WFAError
     (PersistentCommitteeSize, NonPersistentCommitteeSize,
      TotalPersistentStake, TotalNonPersistentStake)
weightedFaitAccompliSplitSeats ExtWFAStakeDistr c
extWFAStakeDistr TargetCommitteeSize
totalSeats
  -- The target committee size must not be not larger than the actual number of
  -- pools with positive stake in the underlying stake distribution. Otherwise,
  -- it could lead to incorrect/non-desirable results (e.g., granting persistent
  -- seats to voters with zero stake).
  | Bool
notEnoughPoolsWithPositiveStake =
      WFAError
-> Either
     WFAError
     (PersistentCommitteeSize, NonPersistentCommitteeSize,
      TotalPersistentStake, TotalNonPersistentStake)
forall a b. a -> Either a b
Left
        ( TargetCommitteeSize -> NumPoolsWithPositiveStake -> WFAError
NotEnoughPoolsWithPositiveStake
            TargetCommitteeSize
totalSeats
            (ExtWFAStakeDistr c -> NumPoolsWithPositiveStake
forall a. ExtWFAStakeDistr a -> NumPoolsWithPositiveStake
numPoolsWithPositiveStake ExtWFAStakeDistr c
extWFAStakeDistr)
        )
  | Bool
otherwise =
      -- We should have /at most/ as many persistent voters as the total
      -- committee size, but not more.
      Bool
-> Either
     WFAError
     (PersistentCommitteeSize, NonPersistentCommitteeSize,
      TotalPersistentStake, TotalNonPersistentStake)
-> Either
     WFAError
     (PersistentCommitteeSize, NonPersistentCommitteeSize,
      TotalPersistentStake, TotalNonPersistentStake)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Word64
numPersistentVoters Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= TargetCommitteeSize -> Word64
unTargetCommitteeSize TargetCommitteeSize
totalSeats) (Either
   WFAError
   (PersistentCommitteeSize, NonPersistentCommitteeSize,
    TotalPersistentStake, TotalNonPersistentStake)
 -> Either
      WFAError
      (PersistentCommitteeSize, NonPersistentCommitteeSize,
       TotalPersistentStake, TotalNonPersistentStake))
-> Either
     WFAError
     (PersistentCommitteeSize, NonPersistentCommitteeSize,
      TotalPersistentStake, TotalNonPersistentStake)
-> Either
     WFAError
     (PersistentCommitteeSize, NonPersistentCommitteeSize,
      TotalPersistentStake, TotalNonPersistentStake)
forall a b. (a -> b) -> a -> b
$
        (PersistentCommitteeSize, NonPersistentCommitteeSize,
 TotalPersistentStake, TotalNonPersistentStake)
-> Either
     WFAError
     (PersistentCommitteeSize, NonPersistentCommitteeSize,
      TotalPersistentStake, TotalNonPersistentStake)
forall a b. b -> Either a b
Right
          ( Word64 -> PersistentCommitteeSize
PersistentCommitteeSize Word64
numPersistentVoters
          , Word64 -> NonPersistentCommitteeSize
NonPersistentCommitteeSize Word64
numNonPersistentVoters
          , Cumulative LedgerStake -> TotalPersistentStake
TotalPersistentStake (LedgerStake -> Cumulative LedgerStake
forall a. a -> Cumulative a
Cumulative (Rational -> LedgerStake
LedgerStake Rational
persistentStake))
          , Cumulative LedgerStake -> TotalNonPersistentStake
TotalNonPersistentStake (LedgerStake -> Cumulative LedgerStake
forall a. a -> Cumulative a
Cumulative (Rational -> LedgerStake
LedgerStake Rational
nonPersistentStake))
          )
 where
  notEnoughPoolsWithPositiveStake :: Bool
notEnoughPoolsWithPositiveStake =
    NumPoolsWithPositiveStake -> Word64
unNumPoolsWithPositiveStake (ExtWFAStakeDistr c -> NumPoolsWithPositiveStake
forall a. ExtWFAStakeDistr a -> NumPoolsWithPositiveStake
numPoolsWithPositiveStake ExtWFAStakeDistr c
extWFAStakeDistr)
      Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< TargetCommitteeSize -> Word64
unTargetCommitteeSize TargetCommitteeSize
totalSeats

  stakeDistrArray :: Array SeatIndex (PoolId, c, LedgerStake, Cumulative LedgerStake)
stakeDistrArray =
    ExtWFAStakeDistr c
-> Array SeatIndex (PoolId, c, LedgerStake, Cumulative LedgerStake)
forall a.
ExtWFAStakeDistr a
-> Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
unExtWFAStakeDistr ExtWFAStakeDistr c
extWFAStakeDistr

  ( Word64
numPersistentVoters
    , Rational
persistentStake
    , Rational
nonPersistentStake
    ) =
      (SeatIndex, SeatIndex)
-> Bool
-> Word64
-> Rational
-> Rational
-> (Word64, Rational, Rational)
forall {t}.
Num t =>
(SeatIndex, SeatIndex)
-> Bool -> t -> Rational -> Rational -> (t, Rational, Rational)
traverseSeats (Array SeatIndex (PoolId, c, LedgerStake, Cumulative LedgerStake)
-> (SeatIndex, SeatIndex)
forall i e. Array i e -> (i, i)
Array.bounds Array SeatIndex (PoolId, c, LedgerStake, Cumulative LedgerStake)
stakeDistrArray) Bool
True Word64
0 Rational
0 Rational
0

  numNonPersistentVoters :: Word64
numNonPersistentVoters =
    TargetCommitteeSize -> Word64
unTargetCommitteeSize TargetCommitteeSize
totalSeats
      Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
numPersistentVoters

  traverseSeats :: (SeatIndex, SeatIndex)
-> Bool -> t -> Rational -> Rational -> (t, Rational, Rational)
traverseSeats
    (SeatIndex
currSeatIndex, SeatIndex
lastSeatIndex)
    Bool
checkPersistentSeatThreshold
    t
accNumPersistentVoters
    Rational
accPersistentStake
    Rational
accNonPersistentStake
      -- Reached the end
      | SeatIndex
currSeatIndex SeatIndex -> SeatIndex -> Bool
forall a. Ord a => a -> a -> Bool
> SeatIndex
lastSeatIndex =
          ( t
accNumPersistentVoters
          , Rational
accPersistentStake
          , Rational
accNonPersistentStake
          )
      -- The current voter is persistent
      | Bool
isPersistent =
          (SeatIndex, SeatIndex)
-> Bool -> t -> Rational -> Rational -> (t, Rational, Rational)
traverseSeats
            (SeatIndex -> SeatIndex
forall a. Enum a => a -> a
succ SeatIndex
currSeatIndex, SeatIndex
lastSeatIndex)
            Bool
True
            (t
accNumPersistentVoters t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)
            (Rational
accPersistentStake Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
voterStake)
            Rational
accNonPersistentStake
      -- The current voter is non-persistent
      | Bool
otherwise =
          (SeatIndex, SeatIndex)
-> Bool -> t -> Rational -> Rational -> (t, Rational, Rational)
traverseSeats
            (SeatIndex -> SeatIndex
forall a. Enum a => a -> a
succ SeatIndex
currSeatIndex, SeatIndex
lastSeatIndex)
            Bool
False
            t
accNumPersistentVoters
            Rational
accPersistentStake
            (Rational
accNonPersistentStake Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
voterStake)
     where
      -- Extract the entry in the array corresponding to the current seat index
      (PoolId
_, c
_, LedgerStake Rational
voterStake, Cumulative LedgerStake
cumulativeStake) =
        Array SeatIndex (PoolId, c, LedgerStake, Cumulative LedgerStake)
-> SeatIndex -> (PoolId, c, LedgerStake, Cumulative LedgerStake)
forall i e. Ix i => Array i e -> i -> e
(Array.!) Array SeatIndex (PoolId, c, LedgerStake, Cumulative LedgerStake)
stakeDistrArray SeatIndex
currSeatIndex

      -- Check whether the current voter can be granted a persistent seat
      isPersistent :: Bool
isPersistent =
        -- NOTE: because the check should behave monotonically, we can skip it
        -- entirely after the first non-persistent voter is found.
        Bool
checkPersistentSeatThreshold
          Bool -> Bool -> Bool
&& TargetCommitteeSize
-> SeatIndex -> LedgerStake -> Cumulative LedgerStake -> Bool
isAbovePersistentSeatThreshold
            TargetCommitteeSize
totalSeats
            SeatIndex
currSeatIndex
            (Rational -> LedgerStake
LedgerStake Rational
voterStake)
            Cumulative LedgerStake
cumulativeStake

-- | Evaluate whether a voter with the given stake and relative position in the
-- stake distribution can be granted a persistent seat in the voting committee.
isAbovePersistentSeatThreshold ::
  -- | Total committee size (persistent + non-persistent)
  TargetCommitteeSize ->
  -- | Current voter seat index
  SeatIndex ->
  -- | Current voter stake
  LedgerStake ->
  -- | Cumulated stake of voters with smaller or equal stake (or equal stake but
  -- smaller tiebreaker) than the current one
  Cumulative LedgerStake ->
  -- | Whether the current voter has a persistent seat or not
  Bool
isAbovePersistentSeatThreshold :: TargetCommitteeSize
-> SeatIndex -> LedgerStake -> Cumulative LedgerStake -> Bool
isAbovePersistentSeatThreshold
  (TargetCommitteeSize Word64
totalSeats)
  (SeatIndex Word64
voterSeat)
  (LedgerStake Rational
voterStake)
  (Cumulative (LedgerStake Rational
cumulativeStake))
    | Rational
cumulativeStake Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
0 =
        Bool
False -- Avoid division by zero in the left-hand side of the inequality
    | Word64
voterSeat Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
totalSeats =
        Bool
False -- Avoid underflow in the right-hand side of the inequality
    | Bool
otherwise =
        ( (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- (Rational
voterStake Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
cumulativeStake))
            Rational -> Integer -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
2 :: Integer)
        )
          Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< ( Word64 -> Rational
forall a. Real a => a -> Rational
toRational (Word64
totalSeats Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
voterSeat Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)
                Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Word64 -> Rational
forall a. Real a => a -> Rational
toRational (Word64
totalSeats Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
voterSeat)
            )

-- * Cumulative stake distributions

-- | Seat index in the voting committee
newtype SeatIndex
  = SeatIndex
  { SeatIndex -> Word64
unSeatIndex :: Word64
  }
  deriving (Int -> SeatIndex -> ShowS
[SeatIndex] -> ShowS
SeatIndex -> String
(Int -> SeatIndex -> ShowS)
-> (SeatIndex -> String)
-> ([SeatIndex] -> ShowS)
-> Show SeatIndex
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SeatIndex -> ShowS
showsPrec :: Int -> SeatIndex -> ShowS
$cshow :: SeatIndex -> String
show :: SeatIndex -> String
$cshowList :: [SeatIndex] -> ShowS
showList :: [SeatIndex] -> ShowS
Show, SeatIndex -> SeatIndex -> Bool
(SeatIndex -> SeatIndex -> Bool)
-> (SeatIndex -> SeatIndex -> Bool) -> Eq SeatIndex
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SeatIndex -> SeatIndex -> Bool
== :: SeatIndex -> SeatIndex -> Bool
$c/= :: SeatIndex -> SeatIndex -> Bool
/= :: SeatIndex -> SeatIndex -> Bool
Eq, Eq SeatIndex
Eq SeatIndex =>
(SeatIndex -> SeatIndex -> Ordering)
-> (SeatIndex -> SeatIndex -> Bool)
-> (SeatIndex -> SeatIndex -> Bool)
-> (SeatIndex -> SeatIndex -> Bool)
-> (SeatIndex -> SeatIndex -> Bool)
-> (SeatIndex -> SeatIndex -> SeatIndex)
-> (SeatIndex -> SeatIndex -> SeatIndex)
-> Ord SeatIndex
SeatIndex -> SeatIndex -> Bool
SeatIndex -> SeatIndex -> Ordering
SeatIndex -> SeatIndex -> SeatIndex
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SeatIndex -> SeatIndex -> Ordering
compare :: SeatIndex -> SeatIndex -> Ordering
$c< :: SeatIndex -> SeatIndex -> Bool
< :: SeatIndex -> SeatIndex -> Bool
$c<= :: SeatIndex -> SeatIndex -> Bool
<= :: SeatIndex -> SeatIndex -> Bool
$c> :: SeatIndex -> SeatIndex -> Bool
> :: SeatIndex -> SeatIndex -> Bool
$c>= :: SeatIndex -> SeatIndex -> Bool
>= :: SeatIndex -> SeatIndex -> Bool
$cmax :: SeatIndex -> SeatIndex -> SeatIndex
max :: SeatIndex -> SeatIndex -> SeatIndex
$cmin :: SeatIndex -> SeatIndex -> SeatIndex
min :: SeatIndex -> SeatIndex -> SeatIndex
Ord, Int -> SeatIndex
SeatIndex -> Int
SeatIndex -> [SeatIndex]
SeatIndex -> SeatIndex
SeatIndex -> SeatIndex -> [SeatIndex]
SeatIndex -> SeatIndex -> SeatIndex -> [SeatIndex]
(SeatIndex -> SeatIndex)
-> (SeatIndex -> SeatIndex)
-> (Int -> SeatIndex)
-> (SeatIndex -> Int)
-> (SeatIndex -> [SeatIndex])
-> (SeatIndex -> SeatIndex -> [SeatIndex])
-> (SeatIndex -> SeatIndex -> [SeatIndex])
-> (SeatIndex -> SeatIndex -> SeatIndex -> [SeatIndex])
-> Enum SeatIndex
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SeatIndex -> SeatIndex
succ :: SeatIndex -> SeatIndex
$cpred :: SeatIndex -> SeatIndex
pred :: SeatIndex -> SeatIndex
$ctoEnum :: Int -> SeatIndex
toEnum :: Int -> SeatIndex
$cfromEnum :: SeatIndex -> Int
fromEnum :: SeatIndex -> Int
$cenumFrom :: SeatIndex -> [SeatIndex]
enumFrom :: SeatIndex -> [SeatIndex]
$cenumFromThen :: SeatIndex -> SeatIndex -> [SeatIndex]
enumFromThen :: SeatIndex -> SeatIndex -> [SeatIndex]
$cenumFromTo :: SeatIndex -> SeatIndex -> [SeatIndex]
enumFromTo :: SeatIndex -> SeatIndex -> [SeatIndex]
$cenumFromThenTo :: SeatIndex -> SeatIndex -> SeatIndex -> [SeatIndex]
enumFromThenTo :: SeatIndex -> SeatIndex -> SeatIndex -> [SeatIndex]
Enum, Ord SeatIndex
Ord SeatIndex =>
((SeatIndex, SeatIndex) -> [SeatIndex])
-> ((SeatIndex, SeatIndex) -> SeatIndex -> Int)
-> ((SeatIndex, SeatIndex) -> SeatIndex -> Int)
-> ((SeatIndex, SeatIndex) -> SeatIndex -> Bool)
-> ((SeatIndex, SeatIndex) -> Int)
-> ((SeatIndex, SeatIndex) -> Int)
-> Ix SeatIndex
(SeatIndex, SeatIndex) -> Int
(SeatIndex, SeatIndex) -> [SeatIndex]
(SeatIndex, SeatIndex) -> SeatIndex -> Bool
(SeatIndex, SeatIndex) -> SeatIndex -> Int
forall a.
Ord a =>
((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
$crange :: (SeatIndex, SeatIndex) -> [SeatIndex]
range :: (SeatIndex, SeatIndex) -> [SeatIndex]
$cindex :: (SeatIndex, SeatIndex) -> SeatIndex -> Int
index :: (SeatIndex, SeatIndex) -> SeatIndex -> Int
$cunsafeIndex :: (SeatIndex, SeatIndex) -> SeatIndex -> Int
unsafeIndex :: (SeatIndex, SeatIndex) -> SeatIndex -> Int
$cinRange :: (SeatIndex, SeatIndex) -> SeatIndex -> Bool
inRange :: (SeatIndex, SeatIndex) -> SeatIndex -> Bool
$crangeSize :: (SeatIndex, SeatIndex) -> Int
rangeSize :: (SeatIndex, SeatIndex) -> Int
$cunsafeRangeSize :: (SeatIndex, SeatIndex) -> Int
unsafeRangeSize :: (SeatIndex, SeatIndex) -> Int
Ix)

-- | Number of pools with positive stake in the underlying stake distribution
newtype NumPoolsWithPositiveStake
  = NumPoolsWithPositiveStake
  { NumPoolsWithPositiveStake -> Word64
unNumPoolsWithPositiveStake :: Word64
  }
  deriving (Int -> NumPoolsWithPositiveStake -> ShowS
[NumPoolsWithPositiveStake] -> ShowS
NumPoolsWithPositiveStake -> String
(Int -> NumPoolsWithPositiveStake -> ShowS)
-> (NumPoolsWithPositiveStake -> String)
-> ([NumPoolsWithPositiveStake] -> ShowS)
-> Show NumPoolsWithPositiveStake
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NumPoolsWithPositiveStake -> ShowS
showsPrec :: Int -> NumPoolsWithPositiveStake -> ShowS
$cshow :: NumPoolsWithPositiveStake -> String
show :: NumPoolsWithPositiveStake -> String
$cshowList :: [NumPoolsWithPositiveStake] -> ShowS
showList :: [NumPoolsWithPositiveStake] -> ShowS
Show, NumPoolsWithPositiveStake -> NumPoolsWithPositiveStake -> Bool
(NumPoolsWithPositiveStake -> NumPoolsWithPositiveStake -> Bool)
-> (NumPoolsWithPositiveStake -> NumPoolsWithPositiveStake -> Bool)
-> Eq NumPoolsWithPositiveStake
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NumPoolsWithPositiveStake -> NumPoolsWithPositiveStake -> Bool
== :: NumPoolsWithPositiveStake -> NumPoolsWithPositiveStake -> Bool
$c/= :: NumPoolsWithPositiveStake -> NumPoolsWithPositiveStake -> Bool
/= :: NumPoolsWithPositiveStake -> NumPoolsWithPositiveStake -> Bool
Eq)

-- | Tiebreaker for voters with the same stake in the cumulative stake.
--
-- This is needed to ensure that the cumulative stake distribution is fair with
-- respect to the edge case where there are multiple voters with the same stake
-- around the persistent seat threshold, e.g.:
--
--   | seat index | stake | selection outcome |
--   |------------|-------|-------------------|
--   | 0          | 50    | persistent        |
--   | 1          | 30    | persistent        |
--   | 2          | 20    | persistent        |
--   | 3          | 20    | non-persistent    |
--   | 4          | 20    | non-persistent    |
--   | 5          | 10    | non-persistent    |
--   | ...        | ...   | ...               |
--
-- In the case above, the pools with seat index 2, 3 and 4 have the same stake,
-- but (under some hypothetical parameterization) only the one with seat index 2
-- can be granted a persistent seat according to the weighted Fait-Accompli
-- scheme. Then, the job of this tiebreaker is to ensure that the seat index 2
-- is fairly distributed among the pools with the same stake.
--
-- One possible implementation of this tiebreaker is to sort the pools with the
-- same stake according to the hash of the epoch nonce and the pool ID. This way
-- the tiebreaker would be deterministic and resilient to manipulation since an
-- adversary would not be able to predict the epoch nonce in advance
-- (see 'wFATiebreakerWithEpochNonce' below).
newtype WFATiebreaker
  = WFATiebreaker
  { WFATiebreaker -> PoolId -> PoolId -> Ordering
unWFATiebreaker :: PoolId -> PoolId -> Ordering
  -- ^ Given two pool IDs, returns an ordering between them to be used as a
  -- tiebreaker for voters with the same stake.
  }

-- | Fair weighted Fait-Accompli tiebreaker.
--
-- For this, we throw the current epoch nonce into the mix to avoid giving an
-- adversary an edge to manipulate the tiebreaking in their favor, as they
-- cannot predict the epoch nonce in advance.
--
-- NOTE: this implementation uses BLS-based hashing, but could be replaced by
-- any other cryptographic hash function with similar properties.
wFATiebreakerWithEpochNonce :: Nonce -> WFATiebreaker
wFATiebreakerWithEpochNonce :: Nonce -> WFATiebreaker
wFATiebreakerWithEpochNonce Nonce
epochNonce =
  (PoolId -> PoolId -> Ordering) -> WFATiebreaker
WFATiebreaker (Hash HASH (SigDSIGN BLS12381MinSigDSIGN)
-> Hash HASH (SigDSIGN BLS12381MinSigDSIGN) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Hash HASH (SigDSIGN BLS12381MinSigDSIGN)
 -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN) -> Ordering)
-> (PoolId -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN))
-> PoolId
-> PoolId
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PoolId -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN)
hashWithNonce)
 where
  hashWithNonce :: PoolId -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN)
  hashWithNonce :: PoolId -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN)
hashWithNonce PoolId
poolId =
    Hash HASH ByteString -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN)
forall h a b. Hash h a -> Hash h b
Hash.castHash
      (Hash HASH ByteString -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN))
-> (Builder -> Hash HASH ByteString)
-> Builder
-> Hash HASH (SigDSIGN BLS12381MinSigDSIGN)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> ByteString -> Hash HASH ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Hash.hashWith ByteString -> ByteString
forall a. a -> a
id
      (ByteString -> Hash HASH ByteString)
-> (Builder -> ByteString) -> Builder -> Hash HASH ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder -> ByteString
runByteBuilder (Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32)
      (Builder -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN))
-> Builder -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN)
forall a b. (a -> b) -> a -> b
$ Builder
epochNonceBytes Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
poolIdBytes
   where
    epochNonceBytes :: Builder
epochNonceBytes =
      case Nonce
epochNonce of
        Nonce
NeutralNonce -> Builder
forall a. Monoid a => a
mempty
        Nonce Hash HASH Nonce
h -> ByteString -> Builder
BS.byteStringCopy (Hash HASH Nonce -> ByteString
forall h a. Hash h a -> ByteString
Hash.hashToBytes Hash HASH Nonce
h)
    poolIdBytes :: Builder
poolIdBytes =
      ByteString -> Builder
BS.byteStringCopy
        (ByteString -> Builder)
-> (PoolId -> ByteString) -> PoolId -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash ADDRHASH (VerKeyDSIGN DSIGN) -> ByteString
forall h a. Hash h a -> ByteString
Hash.hashToBytes
        (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> ByteString)
-> (PoolId -> Hash ADDRHASH (VerKeyDSIGN DSIGN))
-> PoolId
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash StakePool -> Hash ADDRHASH (VerKeyDSIGN DSIGN)
forall (r :: KeyRole).
KeyHash r -> Hash ADDRHASH (VerKeyDSIGN DSIGN)
unKeyHash
        (KeyHash StakePool -> Hash ADDRHASH (VerKeyDSIGN DSIGN))
-> (PoolId -> KeyHash StakePool)
-> PoolId
-> Hash ADDRHASH (VerKeyDSIGN DSIGN)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolId -> KeyHash StakePool
unPoolId
        (PoolId -> Builder) -> PoolId -> Builder
forall a b. (a -> b) -> a -> b
$ PoolId
poolId

-- | Extended cumulative stake distribution.
--
-- Stake distribution in descending order with precomputed right-cumulative
-- stake, i.e., the total stake of voters with smaller or equal stake than the
-- current one (including the current one itself). In addition, this wrapper
-- also allows the inclusion of an arbitrary payload of type @a@. This is useful
-- to keep track of anything else we might need to know about the voters in the
-- committee selection scheme (e.g. their public keys) in a single place.
--
-- E.g.: given the following stake distribution:
--
-- @
--   PoolId 1 -> (50, PK#1)
--   PoolId 2 -> (15, PK#2)
--   PoolId 3 -> (10, PK#3)
--   PoolId 4 -> (20, PK#4)
--   PoolId 5 -> (5,  PK#5)
-- @
--
--  We would have the following cumulative stake distribution:
--
-- @
--   Array.listArray
--     (SeatIndex 0, SeatIndex 4)
--     [ (PoolId 1, PK#1, LedgerStake 50, CumulativeStake 100)
--     , (PoolId 4, PK#4, LedgerStake 20, CumulativeStake 50)
--     , (PoolId 2, PK#2, LedgerStake 15, CumulativeStake 30)
--     , (PoolId 3, PK#3, LedgerStake 10, CumulativeStake 15)
--     , (PoolId 5, PK#5, LedgerStake 5,  CumulativeStake 5)
--     ]
-- @
--
-- NOTE: this wrapper exists to allow us to share the same cumulative stake
-- distribution across multiple committee selection instances derived from the
-- same underlying stake distribution (e.g. Leios and Peras voting committees
-- for the same epoch).
data ExtWFAStakeDistr a
  = ExtWFAStakeDistr
  { forall a.
ExtWFAStakeDistr a
-> Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
unExtWFAStakeDistr ::
      Array
        SeatIndex
        ( PoolId -- Voter ID of this voter
        , a -- Extra payload associated to this voter
        , LedgerStake -- Ledger stake of this voter
        , Cumulative LedgerStake -- Right-cumulative ledger stake of this voter
        )
  , forall a. ExtWFAStakeDistr a -> NumPoolsWithPositiveStake
numPoolsWithPositiveStake :: NumPoolsWithPositiveStake
  -- ^ Number of pools with positive stake in the underlying stake distribution.
  -- This is also precomputed at the beginning of the epoch to prevent invalid
  -- weighted Fait-Accompli instantiations with a target committee size larger
  -- than the number of pools with positive stake, which would lead to incorrect
  -- results (e.g. granting persistent seats to voters with zero stake).
  }
  deriving Int -> ExtWFAStakeDistr a -> ShowS
[ExtWFAStakeDistr a] -> ShowS
ExtWFAStakeDistr a -> String
(Int -> ExtWFAStakeDistr a -> ShowS)
-> (ExtWFAStakeDistr a -> String)
-> ([ExtWFAStakeDistr a] -> ShowS)
-> Show (ExtWFAStakeDistr a)
forall a. Show a => Int -> ExtWFAStakeDistr a -> ShowS
forall a. Show a => [ExtWFAStakeDistr a] -> ShowS
forall a. Show a => ExtWFAStakeDistr a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ExtWFAStakeDistr a -> ShowS
showsPrec :: Int -> ExtWFAStakeDistr a -> ShowS
$cshow :: forall a. Show a => ExtWFAStakeDistr a -> String
show :: ExtWFAStakeDistr a -> String
$cshowList :: forall a. Show a => [ExtWFAStakeDistr a] -> ShowS
showList :: [ExtWFAStakeDistr a] -> ShowS
Show

-- | Construct an extended cumulative stake distribution.
--
-- Returns an error if the underlying stake distribution is empty.
mkExtWFAStakeDistr ::
  WFATiebreaker ->
  Map PoolId (LedgerStake, a) ->
  Either WFAError (ExtWFAStakeDistr a)
mkExtWFAStakeDistr :: forall a.
WFATiebreaker
-> Map PoolId (LedgerStake, a)
-> Either WFAError (ExtWFAStakeDistr a)
mkExtWFAStakeDistr WFATiebreaker
tiebreaker Map PoolId (LedgerStake, a)
pools
  | Map PoolId (LedgerStake, a) -> Bool
forall k a. Map k a -> Bool
Map.null Map PoolId (LedgerStake, a)
pools =
      WFAError -> Either WFAError (ExtWFAStakeDistr a)
forall a b. a -> Either a b
Left
        WFAError
EmptyStakeDistribution
  | Bool
otherwise =
      ExtWFAStakeDistr a -> Either WFAError (ExtWFAStakeDistr a)
forall a b. b -> Either a b
Right
        ExtWFAStakeDistr
          { unExtWFAStakeDistr :: Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
unExtWFAStakeDistr = Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
stakeDistrArray
          , numPoolsWithPositiveStake :: NumPoolsWithPositiveStake
numPoolsWithPositiveStake = NumPoolsWithPositiveStake
numPoolsWithPositiveStakeAcc
          }
 where
  stakeDistrArray :: Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
stakeDistrArray =
    (SeatIndex, SeatIndex)
-> [(PoolId, a, LedgerStake, Cumulative LedgerStake)]
-> Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray
      ( Word64 -> SeatIndex
SeatIndex Word64
0
      , Word64 -> SeatIndex
SeatIndex (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map PoolId (LedgerStake, a) -> Int
forall k a. Map k a -> Int
Map.size Map PoolId (LedgerStake, a)
pools) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)
      )
      [(PoolId, a, LedgerStake, Cumulative LedgerStake)]
cumulativeStakeAndPools

  -- Accumulate stake right-to-left so:
  --   * seat 0's cumulative stake == total stake, and
  --   * last seat's cumulative stake = its own stake.
  -- In addition, count the number of pools with positive stake in the same pass.
  ((Cumulative LedgerStake
_totalStake, NumPoolsWithPositiveStake
numPoolsWithPositiveStakeAcc), [(PoolId, a, LedgerStake, Cumulative LedgerStake)]
cumulativeStakeAndPools) =
    ((Cumulative LedgerStake, NumPoolsWithPositiveStake)
 -> (PoolId, (LedgerStake, a))
 -> ((Cumulative LedgerStake, NumPoolsWithPositiveStake),
     (PoolId, a, LedgerStake, Cumulative LedgerStake)))
-> (Cumulative LedgerStake, NumPoolsWithPositiveStake)
-> [(PoolId, (LedgerStake, a))]
-> ((Cumulative LedgerStake, NumPoolsWithPositiveStake),
    [(PoolId, a, LedgerStake, Cumulative LedgerStake)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumR
      (Cumulative LedgerStake, NumPoolsWithPositiveStake)
-> (PoolId, (LedgerStake, a))
-> ((Cumulative LedgerStake, NumPoolsWithPositiveStake),
    (PoolId, a, LedgerStake, Cumulative LedgerStake))
forall {a} {b}.
(Cumulative LedgerStake, NumPoolsWithPositiveStake)
-> (a, (LedgerStake, b))
-> ((Cumulative LedgerStake, NumPoolsWithPositiveStake),
    (a, b, LedgerStake, Cumulative LedgerStake))
accumStakeAndCountPoolsWithPositiveStake
      ( LedgerStake -> Cumulative LedgerStake
forall a. a -> Cumulative a
Cumulative (Rational -> LedgerStake
LedgerStake Rational
0)
      , Word64 -> NumPoolsWithPositiveStake
NumPoolsWithPositiveStake Word64
0
      )
      ([(PoolId, (LedgerStake, a))]
 -> ((Cumulative LedgerStake, NumPoolsWithPositiveStake),
     [(PoolId, a, LedgerStake, Cumulative LedgerStake)]))
-> (Map PoolId (LedgerStake, a) -> [(PoolId, (LedgerStake, a))])
-> Map PoolId (LedgerStake, a)
-> ((Cumulative LedgerStake, NumPoolsWithPositiveStake),
    [(PoolId, a, LedgerStake, Cumulative LedgerStake)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PoolId, (LedgerStake, a))
 -> (PoolId, (LedgerStake, a)) -> Ordering)
-> [(PoolId, (LedgerStake, a))] -> [(PoolId, (LedgerStake, a))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (PoolId, (LedgerStake, a))
-> (PoolId, (LedgerStake, a)) -> Ordering
forall {b} {b}.
(PoolId, (LedgerStake, b))
-> (PoolId, (LedgerStake, b)) -> Ordering
descendingStakeWithTiebreaker
      ([(PoolId, (LedgerStake, a))] -> [(PoolId, (LedgerStake, a))])
-> (Map PoolId (LedgerStake, a) -> [(PoolId, (LedgerStake, a))])
-> Map PoolId (LedgerStake, a)
-> [(PoolId, (LedgerStake, a))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PoolId (LedgerStake, a) -> [(PoolId, (LedgerStake, a))]
forall k a. Map k a -> [(k, a)]
Map.toList
      (Map PoolId (LedgerStake, a)
 -> ((Cumulative LedgerStake, NumPoolsWithPositiveStake),
     [(PoolId, a, LedgerStake, Cumulative LedgerStake)]))
-> Map PoolId (LedgerStake, a)
-> ((Cumulative LedgerStake, NumPoolsWithPositiveStake),
    [(PoolId, a, LedgerStake, Cumulative LedgerStake)])
forall a b. (a -> b) -> a -> b
$ Map PoolId (LedgerStake, a)
pools

  descendingStakeWithTiebreaker :: (PoolId, (LedgerStake, b))
-> (PoolId, (LedgerStake, b)) -> Ordering
descendingStakeWithTiebreaker
    (PoolId
poolId1, (LedgerStake Rational
stake1, b
_))
    (PoolId
poolId2, (LedgerStake Rational
stake2, b
_))
      -- The pools have the same stake => use the tiebreaker to sort them
      | Rational
stake1 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
stake2 = WFATiebreaker -> PoolId -> PoolId -> Ordering
unWFATiebreaker WFATiebreaker
tiebreaker PoolId
poolId1 PoolId
poolId2
      -- The pools have different stake => sort them in descending order
      | Bool
otherwise = Rational -> Rational -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Rational
stake2 Rational
stake1

  accumStakeAndCountPoolsWithPositiveStake :: (Cumulative LedgerStake, NumPoolsWithPositiveStake)
-> (a, (LedgerStake, b))
-> ((Cumulative LedgerStake, NumPoolsWithPositiveStake),
    (a, b, LedgerStake, Cumulative LedgerStake))
accumStakeAndCountPoolsWithPositiveStake
    (Cumulative (LedgerStake Rational
stakeAccR), NumPoolsWithPositiveStake Word64
numPoolsAccR)
    (a
poolId, (LedgerStake Rational
poolStake, b
poolPublicKey)) =
      let stakeAccR' :: Rational
stakeAccR' =
            Rational
stakeAccR Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
poolStake
          numPoolsAccR' :: Word64
numPoolsAccR'
            | Rational
poolStake Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
0 = Word64
numPoolsAccR Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
            | Bool
otherwise = Word64
numPoolsAccR
       in (
            ( LedgerStake -> Cumulative LedgerStake
forall a. a -> Cumulative a
Cumulative (Rational -> LedgerStake
LedgerStake Rational
stakeAccR')
            , Word64 -> NumPoolsWithPositiveStake
NumPoolsWithPositiveStake Word64
numPoolsAccR'
            )
          ,
            ( a
poolId
            , b
poolPublicKey
            , Rational -> LedgerStake
LedgerStake Rational
poolStake
            , LedgerStake -> Cumulative LedgerStake
forall a. a -> Cumulative a
Cumulative (Rational -> LedgerStake
LedgerStake Rational
stakeAccR')
            )
          )

-- | Check whether a given seat index is within bounds in a stake distribution.
seatIndexWithinBounds :: SeatIndex -> ExtWFAStakeDistr a -> Bool
seatIndexWithinBounds :: forall a. SeatIndex -> ExtWFAStakeDistr a -> Bool
seatIndexWithinBounds SeatIndex
seatIndex ExtWFAStakeDistr a
distr =
  SeatIndex -> Word64
unSeatIndex SeatIndex
seatIndex Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= SeatIndex -> Word64
unSeatIndex SeatIndex
lowerBound
    Bool -> Bool -> Bool
&& SeatIndex -> Word64
unSeatIndex SeatIndex
seatIndex Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= SeatIndex -> Word64
unSeatIndex SeatIndex
upperBound
 where
  (SeatIndex
lowerBound, SeatIndex
upperBound) =
    Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
-> (SeatIndex, SeatIndex)
forall i e. Array i e -> (i, i)
Array.bounds (ExtWFAStakeDistr a
-> Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall a.
ExtWFAStakeDistr a
-> Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
unExtWFAStakeDistr ExtWFAStakeDistr a
distr)

-- | Retrieve the candidate information associated to a given seat index, if the
-- seat index is within bounds in the stake distribution.
getCandidateIfSeatWithinBounds ::
  SeatIndex ->
  ExtWFAStakeDistr a ->
  Maybe (PoolId, a, LedgerStake, Cumulative LedgerStake)
getCandidateIfSeatWithinBounds :: forall a.
SeatIndex
-> ExtWFAStakeDistr a
-> Maybe (PoolId, a, LedgerStake, Cumulative LedgerStake)
getCandidateIfSeatWithinBounds SeatIndex
seatIndex ExtWFAStakeDistr a
distr
  | SeatIndex -> ExtWFAStakeDistr a -> Bool
forall a. SeatIndex -> ExtWFAStakeDistr a -> Bool
seatIndexWithinBounds SeatIndex
seatIndex ExtWFAStakeDistr a
distr =
      (PoolId, a, LedgerStake, Cumulative LedgerStake)
-> Maybe (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall a. a -> Maybe a
Just ((PoolId, a, LedgerStake, Cumulative LedgerStake)
 -> Maybe (PoolId, a, LedgerStake, Cumulative LedgerStake))
-> (PoolId, a, LedgerStake, Cumulative LedgerStake)
-> Maybe (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall a b. (a -> b) -> a -> b
$ Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
-> SeatIndex -> (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall i e. Ix i => Array i e -> i -> e
(Array.!) (ExtWFAStakeDistr a
-> Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall a.
ExtWFAStakeDistr a
-> Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
unExtWFAStakeDistr ExtWFAStakeDistr a
distr) SeatIndex
seatIndex
  | Bool
otherwise =
      Maybe (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall a. Maybe a
Nothing

-- | Same as 'getCandidateIfSeatWithinBounds', but assumming that the seat index
-- is within bounds in the stake distribution.
unsafeGetCandidateInSeat ::
  SeatIndex ->
  ExtWFAStakeDistr a ->
  (PoolId, a, LedgerStake, Cumulative LedgerStake)
unsafeGetCandidateInSeat :: forall a.
SeatIndex
-> ExtWFAStakeDistr a
-> (PoolId, a, LedgerStake, Cumulative LedgerStake)
unsafeGetCandidateInSeat SeatIndex
seatIndex ExtWFAStakeDistr a
distr =
  Bool
-> (PoolId, a, LedgerStake, Cumulative LedgerStake)
-> (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (SeatIndex -> ExtWFAStakeDistr a -> Bool
forall a. SeatIndex -> ExtWFAStakeDistr a -> Bool
seatIndexWithinBounds SeatIndex
seatIndex ExtWFAStakeDistr a
distr) ((PoolId, a, LedgerStake, Cumulative LedgerStake)
 -> (PoolId, a, LedgerStake, Cumulative LedgerStake))
-> (PoolId, a, LedgerStake, Cumulative LedgerStake)
-> (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall a b. (a -> b) -> a -> b
$
    Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
-> SeatIndex -> (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall i e. Ix i => Array i e -> i -> e
(Array.!) (ExtWFAStakeDistr a
-> Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
forall a.
ExtWFAStakeDistr a
-> Array SeatIndex (PoolId, a, LedgerStake, Cumulative LedgerStake)
unExtWFAStakeDistr ExtWFAStakeDistr a
distr) SeatIndex
seatIndex