{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
-- |
-- Copyright: © 2022 IOHK
-- License: Apache-2.0
--
-- This module provides tools to estimate pool rewards
-- for the purpose of ranking pools.
module Cardano.Pool.Rank
    ( -- * Pool information
      -- $RewardEpochs
      RewardInfoPool (..)
    , RewardParams (..)
    , StakePoolsSummary (..)

    -- * Ranking formulas
    , poolSaturation
    , optimalRewards
    , currentROS
    , saturationROS

    -- * Redelegation warning
    , RedelegationWarning(..)
    , redelegationWarning

    -- * Legacy metrics
    , nonMyopicMemberReward
    , desirability
    , PoolScore (..)
    , scorePools
    )
    where

import Prelude

import Cardano.Wallet.Primitive.Types
    ( EpochNo, PoolId )
import Cardano.Wallet.Primitive.Types.Coin
    ( Coin (..) )
import Data.Map
    ( Map )
import Data.Ord
    ( Down (..) )
import Data.Quantity
    ( Percentage (..), clipToPercentage )
import Fmt
    ( Buildable (..), blockListF', listF', mapF )

import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
import qualified Data.List as L
import qualified Data.Map.Strict as Map

{-------------------------------------------------------------------------------
    Pool information necessary to compute rewards
-------------------------------------------------------------------------------}
-- | Information need for the computation of rewards, such as the
-- stake currently delegated to a pool, or the pool cost and margin.
data RewardInfoPool = RewardInfoPool
    { RewardInfoPool -> Percentage
stakeRelative :: Percentage -- ^ sigma = pool stake / total stake
    , RewardInfoPool -> Coin
ownerPledge :: Coin -- ^ pledge of pool owner(s)
    , RewardInfoPool -> Coin
ownerStake :: Coin -- ^ absolute stake delegated by pool owner(s)
    , RewardInfoPool -> Percentage
ownerStakeRelative :: Percentage -- ^ s = owner stake / total stake
    , RewardInfoPool -> Coin
cost :: Coin
    , RewardInfoPool -> Percentage
margin :: Percentage
    , RewardInfoPool -> Double
performanceEstimate :: Double
    } deriving (Int -> RewardInfoPool -> ShowS
[RewardInfoPool] -> ShowS
RewardInfoPool -> String
(Int -> RewardInfoPool -> ShowS)
-> (RewardInfoPool -> String)
-> ([RewardInfoPool] -> ShowS)
-> Show RewardInfoPool
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RewardInfoPool] -> ShowS
$cshowList :: [RewardInfoPool] -> ShowS
show :: RewardInfoPool -> String
$cshow :: RewardInfoPool -> String
showsPrec :: Int -> RewardInfoPool -> ShowS
$cshowsPrec :: Int -> RewardInfoPool -> ShowS
Show, RewardInfoPool -> RewardInfoPool -> Bool
(RewardInfoPool -> RewardInfoPool -> Bool)
-> (RewardInfoPool -> RewardInfoPool -> Bool) -> Eq RewardInfoPool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RewardInfoPool -> RewardInfoPool -> Bool
$c/= :: RewardInfoPool -> RewardInfoPool -> Bool
== :: RewardInfoPool -> RewardInfoPool -> Bool
$c== :: RewardInfoPool -> RewardInfoPool -> Bool
Eq)

instance Buildable RewardInfoPool where
    build :: RewardInfoPool -> Builder
build RewardInfoPool
            {Percentage
stakeRelative :: Percentage
stakeRelative :: RewardInfoPool -> Percentage
stakeRelative,Coin
ownerPledge :: Coin
ownerPledge :: RewardInfoPool -> Coin
ownerPledge,Coin
ownerStake :: Coin
ownerStake :: RewardInfoPool -> Coin
ownerStake,Percentage
ownerStakeRelative :: Percentage
ownerStakeRelative :: RewardInfoPool -> Percentage
ownerStakeRelative
            ,Coin
cost :: Coin
cost :: RewardInfoPool -> Coin
cost,Percentage
margin :: Percentage
margin :: RewardInfoPool -> Percentage
margin,Double
performanceEstimate :: Double
performanceEstimate :: RewardInfoPool -> Double
performanceEstimate
            }
      = (Builder -> Builder) -> [Builder] -> Builder
forall (f :: * -> *) a.
Foldable f =>
(a -> Builder) -> f a -> Builder
listF' Builder -> Builder
forall a. a -> a
id
        [ Builder
"Stake (relative): " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Percentage -> Builder
forall p. Buildable p => p -> Builder
build Percentage
stakeRelative
        , Builder
"Pledge: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Coin -> Builder
forall p. Buildable p => p -> Builder
build Coin
ownerPledge
        , Builder
"Owner stake: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Coin -> Builder
forall p. Buildable p => p -> Builder
build Coin
ownerStake
        , Builder
"Owner stake (relative): " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Percentage -> Builder
forall p. Buildable p => p -> Builder
build Percentage
ownerStakeRelative
        , Builder
"Pool cost: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Coin -> Builder
forall p. Buildable p => p -> Builder
build Coin
cost
        , Builder
"Pool margin: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Percentage -> Builder
forall p. Buildable p => p -> Builder
build Percentage
margin
        , Builder
"Pool performance: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Double -> Builder
forall p. Buildable p => p -> Builder
build Double
performanceEstimate
        ]

-- | Global parameters used for computing rewards
data RewardParams = RewardParams
    { RewardParams -> Int
nOpt :: Int -- ^ desired number of stake pools
    , RewardParams -> Rational
a0   :: Rational -- ^ influence of the pool owner's pledge on rewards
    , RewardParams -> Coin
r    :: Coin -- ^ Total rewards available for the given epoch
    , RewardParams -> Coin
totalStake :: Coin -- ^ Maximum lovelace supply minus treasury
    } deriving (Int -> RewardParams -> ShowS
[RewardParams] -> ShowS
RewardParams -> String
(Int -> RewardParams -> ShowS)
-> (RewardParams -> String)
-> ([RewardParams] -> ShowS)
-> Show RewardParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RewardParams] -> ShowS
$cshowList :: [RewardParams] -> ShowS
show :: RewardParams -> String
$cshow :: RewardParams -> String
showsPrec :: Int -> RewardParams -> ShowS
$cshowsPrec :: Int -> RewardParams -> ShowS
Show, RewardParams -> RewardParams -> Bool
(RewardParams -> RewardParams -> Bool)
-> (RewardParams -> RewardParams -> Bool) -> Eq RewardParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RewardParams -> RewardParams -> Bool
$c/= :: RewardParams -> RewardParams -> Bool
== :: RewardParams -> RewardParams -> Bool
$c== :: RewardParams -> RewardParams -> Bool
Eq)
    -- NOTE: In the ledger, @a0@ has type 'NonNegativeInterval'.

instance Buildable RewardParams where
    build :: RewardParams -> Builder
build RewardParams{Int
nOpt :: Int
nOpt :: RewardParams -> Int
nOpt,Rational
a0 :: Rational
a0 :: RewardParams -> Rational
a0,Coin
r :: Coin
r :: RewardParams -> Coin
r,Coin
totalStake :: Coin
totalStake :: RewardParams -> Coin
totalStake} = Text -> (Builder -> Builder) -> [Builder] -> Builder
forall (f :: * -> *) a.
Foldable f =>
Text -> (a -> Builder) -> f a -> Builder
blockListF' Text
"" Builder -> Builder
forall a. a -> a
id
        [ Builder
"Desired number of stake pools: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall p. Buildable p => p -> Builder
build Int
nOpt
        , Builder
"Pledge influence parameter, a0: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Rational -> Builder
forall p. Buildable p => p -> Builder
build Rational
a0
        , Builder
"Total rewards for this epoch: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Coin -> Builder
forall p. Buildable p => p -> Builder
build Coin
r
        , Builder
"Total stake: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Coin -> Builder
forall p. Buildable p => p -> Builder
build Coin
totalStake
        ]

{- $RewardEpochs

NOTE [RewardEpochs]

We need to be careful to show the right information at the right time
in order prevent manipulation of the proof-of-stake (PoS) protocol.

In particular, we need to show those pool costs, margins, and owner stakes
that will affect the rewards for a delegation choice made at the present moment.

The reward cycle is illustrated in Section 11.2 of SL-D1, here a brief sketch.

@
                    mark   set     go
                  +------.------.------
                  |
    |e0----|e1----|e2----|e3----|e4----|e5----|
              ^
          we are here
@

We imagine that we are in epoch /e1/, and choose to delegate to a pool.
At the end of epoch /e1/, a snapshot of the stake distribution will be taken.
This snapshot will be labeled "mark" during epoch /e2/, "set" during epoch /e3/,
and "go" during epoch /e4/.
Blocks will be produced randomly according to this stake distribution when
it is labeled "set", i.e. in epoch /e3/.
Rewards for this block production will be computed when this stake
distribution is labeled "go", i.e. during epoch /e4/, and these rewards will
paid out at the beginning of epoch /e5/.

The owner stake is part of the snapshot taken at the end of epoch /e1/.
If the pool is newly registered, its cost, margin and pledge are also
immediately available in epoch /e1/. However, if a pool re-registers,
the changes to its cost, margin and pledge will not be visible until the
next epoch; put differently, the rewards for the stake snapshot taken
at the end of epoch /e1/ will only depend on changes to cost, margin,
and pledge that the pool owner initiated in epoch /e0/.
This prevents pool owners from duping delegators by changing pool costs
during an epoch. However, the pool owner could still choose to undelegate
his stake, and fail to meet his pledge at the end of epoch /e1/,
which results in zero rewards paid out at the beginning of /e5/.

To summarize, in order to make an informed delegation choice
during epoch /e1/, the delegator needs to know 'RewardInfoPool' where

* 'stakeRelative', 'ownerStake', and 'ownerStakeRelative' are
   taken at the time of decision (in epoch /e1/).
* 'ownerPledge', 'margin', 'cost' are the values of the last pool
   registration certificate
   from epoch /e0/ in case of an update,
   or from epoch /e1/ in case of a newly created pool.

For the 'performanceEstimate', it's best to estimate it from recent pool
block production using functions provided here.

-}

-- | Summary of stake distribution and stake pools obtained from network.
data StakePoolsSummary = StakePoolsSummary
    { StakePoolsSummary -> RewardParams
rewardParams :: RewardParams
    , StakePoolsSummary -> Map PoolId RewardInfoPool
pools :: Map PoolId RewardInfoPool
    } deriving (Int -> StakePoolsSummary -> ShowS
[StakePoolsSummary] -> ShowS
StakePoolsSummary -> String
(Int -> StakePoolsSummary -> ShowS)
-> (StakePoolsSummary -> String)
-> ([StakePoolsSummary] -> ShowS)
-> Show StakePoolsSummary
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StakePoolsSummary] -> ShowS
$cshowList :: [StakePoolsSummary] -> ShowS
show :: StakePoolsSummary -> String
$cshow :: StakePoolsSummary -> String
showsPrec :: Int -> StakePoolsSummary -> ShowS
$cshowsPrec :: Int -> StakePoolsSummary -> ShowS
Show, StakePoolsSummary -> StakePoolsSummary -> Bool
(StakePoolsSummary -> StakePoolsSummary -> Bool)
-> (StakePoolsSummary -> StakePoolsSummary -> Bool)
-> Eq StakePoolsSummary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StakePoolsSummary -> StakePoolsSummary -> Bool
$c/= :: StakePoolsSummary -> StakePoolsSummary -> Bool
== :: StakePoolsSummary -> StakePoolsSummary -> Bool
$c== :: StakePoolsSummary -> StakePoolsSummary -> Bool
Eq)

instance Buildable StakePoolsSummary where
    build :: StakePoolsSummary -> Builder
build StakePoolsSummary{RewardParams
rewardParams :: RewardParams
rewardParams :: StakePoolsSummary -> RewardParams
rewardParams,Map PoolId RewardInfoPool
pools :: Map PoolId RewardInfoPool
pools :: StakePoolsSummary -> Map PoolId RewardInfoPool
pools} = Text -> (Builder -> Builder) -> [Builder] -> Builder
forall (f :: * -> *) a.
Foldable f =>
Text -> (a -> Builder) -> f a -> Builder
blockListF' Text
"" Builder -> Builder
forall a. a -> a
id
        [ Builder
"Global reward parameters: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> RewardParams -> Builder
forall p. Buildable p => p -> Builder
build RewardParams
rewardParams
        , Builder
"Individual pools: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [(PoolId, RewardInfoPool)] -> Builder
forall t k v.
(IsList t, Item t ~ (k, v), Buildable k, Buildable v) =>
t -> Builder
mapF (Map PoolId RewardInfoPool -> [(PoolId, RewardInfoPool)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PoolId RewardInfoPool
pools)
        ]

{-------------------------------------------------------------------------------
    Reward formulas
-------------------------------------------------------------------------------}
fractionOf :: RealFrac r => r -> Coin -> Coin
fractionOf :: r -> Coin -> Coin
fractionOf r
r (Coin Natural
x) = Natural -> Coin
Coin (Natural -> Coin) -> (r -> Natural) -> r -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Natural
forall a b. (RealFrac a, Integral b) => a -> b
floor (r -> Coin) -> r -> Coin
forall a b. (a -> b) -> a -> b
$ r
r r -> r -> r
forall a. Num a => a -> a -> a
* Natural -> r
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
x

proportionTo :: Coin -> Coin -> Rational
proportionTo :: Coin -> Coin -> Rational
proportionTo Coin
_        (Coin Natural
0) = Rational
0
proportionTo (Coin Natural
x) (Coin Natural
y) = Natural -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
x Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Natural -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
y

z0 :: RewardParams -> Rational
z0 :: RewardParams -> Rational
z0 RewardParams{Int
nOpt :: Int
nOpt :: RewardParams -> Int
nOpt} = Rational
1 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nOpt

epochsPerYear :: Int
epochsPerYear :: Int
epochsPerYear = Int
73

-- | The yearly rate of return per unit of stake,
-- assuming that the pool's stake remains at the same level.
-- Rewards compound every epoch.
currentROS :: RewardParams -> RewardInfoPool -> Coin -> Percentage
currentROS :: RewardParams -> RewardInfoPool -> Coin -> Percentage
currentROS RewardParams
rp RewardInfoPool{Double
Percentage
Coin
performanceEstimate :: Double
margin :: Percentage
cost :: Coin
ownerStakeRelative :: Percentage
ownerStake :: Coin
ownerPledge :: Coin
stakeRelative :: Percentage
performanceEstimate :: RewardInfoPool -> Double
margin :: RewardInfoPool -> Percentage
cost :: RewardInfoPool -> Coin
ownerStakeRelative :: RewardInfoPool -> Percentage
ownerStake :: RewardInfoPool -> Coin
ownerPledge :: RewardInfoPool -> Coin
stakeRelative :: RewardInfoPool -> Percentage
..} Coin
x
    | Coin
ownerStake Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
ownerPledge = Rational -> Percentage
clipToPercentage Rational
0
    | Bool
otherwise = Rational -> Percentage
clipToPercentage (Rational -> Percentage) -> Rational -> Percentage
forall a b. (a -> b) -> a -> b
$ (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
astar)Rational -> Int -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^Int
epochsPerYear Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
1
  where
    s :: Percentage
s     = Rational -> Percentage
clipToPercentage (Rational -> Percentage) -> Rational -> Percentage
forall a b. (a -> b) -> a -> b
$ Coin
ownerPledge Coin -> Coin -> Rational
`proportionTo` (RewardParams -> Coin
totalStake RewardParams
rp)
    sigma :: Rational
sigma = Percentage -> Rational
getPercentage Percentage
stakeRelative Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Coin
x Coin -> Coin -> Rational
`proportionTo` RewardParams -> Coin
totalStake RewardParams
rp)

    astar :: Rational
astar
        | Rational
sigma Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 = Rational
0
        | Bool
otherwise  = Rational -> Coin -> Percentage -> Coin -> Coin
shareAfterFees (Rational
1Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
sigma) Coin
cost Percentage
margin Coin
fhat
            Coin -> Coin -> Rational
`proportionTo` RewardParams -> Coin
totalStake RewardParams
rp
    fhat :: Coin
fhat  = RewardParams -> Percentage -> Rational -> Coin
optimalRewards RewardParams
rp Percentage
s Rational
sigma

-- | The (yearly) return per unit of stake
-- for a pool that has reached saturation.
saturationROS :: RewardParams -> RewardInfoPool -> Percentage
saturationROS :: RewardParams -> RewardInfoPool -> Percentage
saturationROS RewardParams
rp RewardInfoPool{Double
Percentage
Coin
performanceEstimate :: Double
margin :: Percentage
cost :: Coin
ownerStakeRelative :: Percentage
ownerStake :: Coin
ownerPledge :: Coin
stakeRelative :: Percentage
performanceEstimate :: RewardInfoPool -> Double
margin :: RewardInfoPool -> Percentage
cost :: RewardInfoPool -> Coin
ownerStakeRelative :: RewardInfoPool -> Percentage
ownerStake :: RewardInfoPool -> Coin
ownerPledge :: RewardInfoPool -> Coin
stakeRelative :: RewardInfoPool -> Percentage
..}
    | Coin
ownerStake Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
ownerPledge = Rational -> Percentage
clipToPercentage Rational
0
    | Bool
otherwise = Rational -> Percentage
clipToPercentage (Rational -> Percentage) -> Rational -> Percentage
forall a b. (a -> b) -> a -> b
$ (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
bstar)Rational -> Int -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^Int
epochsPerYear Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
1
  where
    s :: Percentage
s     = Rational -> Percentage
clipToPercentage (Rational -> Percentage) -> Rational -> Percentage
forall a b. (a -> b) -> a -> b
$ Coin
ownerPledge Coin -> Coin -> Rational
`proportionTo` (RewardParams -> Coin
totalStake RewardParams
rp)
    sigma :: Rational
sigma = RewardParams -> Rational
z0 RewardParams
rp -- saturation, never = 0

    bstar :: Rational
bstar = Rational -> Coin -> Percentage -> Coin -> Coin
shareAfterFees (Rational
1Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
sigma) Coin
cost Percentage
margin Coin
fhat
        Coin -> Coin -> Rational
`proportionTo` RewardParams -> Coin
totalStake RewardParams
rp
    fhat :: Coin
fhat  = RewardParams -> Percentage -> Rational -> Coin
optimalRewards RewardParams
rp Percentage
s Rational
sigma

-- | Non-Myopic Pool Member Rewards
-- according to Eq.(3) of Section 5.6.4 in SL-D1.
nonMyopicMemberReward
    :: RewardParams
    -> RewardInfoPool
    -> Bool -- ^ The pool ranks in the top @nOpt@ pools
    -> Coin -- ^ stake that the member wants to delegate
    -> Coin
nonMyopicMemberReward :: RewardParams -> RewardInfoPool -> Bool -> Coin -> Coin
nonMyopicMemberReward RewardParams
rp RewardInfoPool{Double
Percentage
Coin
performanceEstimate :: Double
margin :: Percentage
cost :: Coin
ownerStakeRelative :: Percentage
ownerStake :: Coin
ownerPledge :: Coin
stakeRelative :: Percentage
performanceEstimate :: RewardInfoPool -> Double
margin :: RewardInfoPool -> Percentage
cost :: RewardInfoPool -> Coin
ownerStakeRelative :: RewardInfoPool -> Percentage
ownerStake :: RewardInfoPool -> Coin
ownerPledge :: RewardInfoPool -> Coin
stakeRelative :: RewardInfoPool -> Percentage
..} Bool
isTop Coin
tcoin
    | Coin
ownerStake Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
ownerPledge = Natural -> Coin
Coin Natural
0
    | Bool
otherwise
        = Rational -> Coin -> Percentage -> Coin -> Coin
shareAfterFees Rational
memberShare Coin
cost Percentage
margin
        (Coin -> Coin) -> Coin -> Coin
forall a b. (a -> b) -> a -> b
$ (Double
performanceEstimate Double -> Coin -> Coin
forall r. RealFrac r => r -> Coin -> Coin
`fractionOf`)
        (Coin -> Coin) -> Coin -> Coin
forall a b. (a -> b) -> a -> b
$ RewardParams -> Percentage -> Rational -> Coin
optimalRewards RewardParams
rp Percentage
s Rational
sigma_nonmyopic
  where
    s :: Percentage
s     = Rational -> Percentage
clipToPercentage (Rational -> Percentage) -> Rational -> Percentage
forall a b. (a -> b) -> a -> b
$ Coin
ownerPledge Coin -> Coin -> Rational
`proportionTo` (RewardParams -> Coin
totalStake RewardParams
rp)
    sigma :: Percentage
sigma = Percentage
stakeRelative
    t :: Rational
t     = Coin
tcoin Coin -> Coin -> Rational
`proportionTo` (RewardParams -> Coin
totalStake RewardParams
rp)

    memberShare :: Rational
memberShare = Rational
t Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
sigma_nonmyopic

    sigma_nonmyopic :: Rational
sigma_nonmyopic
        | Bool
isTop      = Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
max (Percentage -> Rational
getPercentage Percentage
sigma Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
t) (RewardParams -> Rational
z0 RewardParams
rp)
        | Bool
otherwise  = Percentage -> Rational
getPercentage Percentage
s Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
t

-- | Compute share of 'Coin' after subtracting fixed cost and
-- percentage margin.
shareAfterFees :: Rational -> Coin -> Percentage -> Coin -> Coin
shareAfterFees :: Rational -> Coin -> Percentage -> Coin -> Coin
shareAfterFees Rational
share Coin
cost Percentage
margin Coin
x = case Coin
x Coin -> Coin -> Maybe Coin
`Coin.subtract` Coin
cost of
    Just Coin
y  -> (Rational
share Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Percentage -> Rational
getPercentage Percentage
margin)) Rational -> Coin -> Coin
forall r. RealFrac r => r -> Coin -> Coin
`fractionOf` Coin
y
    Maybe Coin
Nothing -> Natural -> Coin
Coin Natural
0

-- | Optimal rewards for a stake pool
-- according to Eq.(2) of Section 5.5.3 in SL-D1.
--
-- > optimalRewards s sigma
--
-- NOTE: This computation uses 'Double' internally
-- and is only suitable for the purpose of ranking,
-- not for computing actual monetary rewards.
optimalRewards :: RewardParams -> Percentage -> Rational -> Coin
optimalRewards :: RewardParams -> Percentage -> Rational -> Coin
optimalRewards RewardParams
params Percentage
s Rational
sigma = Double
factor Double -> Coin -> Coin
forall r. RealFrac r => r -> Coin -> Coin
`fractionOf` RewardParams -> Coin
r RewardParams
params
  where
    factor :: Double
factor = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
a0_)
        Double -> Double -> Double
forall a. Num a => a -> a -> a
* ( Double
sigma' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
s' Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a0_ Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
sigma' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
s'Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
z0_Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
sigma')Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
z0_) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
z0_ )

    z0_, a0_, sigma', s' :: Double
    z0_ :: Double
z0_    = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (RewardParams -> Rational
z0 RewardParams
params)
    a0_ :: Double
a0_    = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (RewardParams -> Rational
a0 RewardParams
params)
    sigma' :: Double
sigma' = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
sigma) Double
z0_
    s' :: Double
s'     = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Percentage -> Rational
getPercentage Percentage
s) Double
z0_

-- | The desirabilty of a pool is equal to the total
-- member rewards at saturation
-- IF the owner meets their pledge.
desirability :: RewardParams -> RewardInfoPool -> Coin
desirability :: RewardParams -> RewardInfoPool -> Coin
desirability RewardParams
rp RewardInfoPool{Double
Percentage
Coin
performanceEstimate :: Double
margin :: Percentage
cost :: Coin
ownerStakeRelative :: Percentage
ownerStake :: Coin
ownerPledge :: Coin
stakeRelative :: Percentage
performanceEstimate :: RewardInfoPool -> Double
margin :: RewardInfoPool -> Percentage
cost :: RewardInfoPool -> Coin
ownerStakeRelative :: RewardInfoPool -> Percentage
ownerStake :: RewardInfoPool -> Coin
ownerPledge :: RewardInfoPool -> Coin
stakeRelative :: RewardInfoPool -> Percentage
..}
    = Rational -> Coin -> Percentage -> Coin -> Coin
shareAfterFees Rational
1 Coin
cost Percentage
margin
    (Coin -> Coin) -> Coin -> Coin
forall a b. (a -> b) -> a -> b
$ (Double
performanceEstimate Double -> Coin -> Coin
forall r. RealFrac r => r -> Coin -> Coin
`fractionOf`)
    (Coin -> Coin) -> Coin -> Coin
forall a b. (a -> b) -> a -> b
$ RewardParams -> Percentage -> Rational -> Coin
optimalRewards RewardParams
rp Percentage
s (RewardParams -> Rational
z0 RewardParams
rp)
  where
    s :: Percentage
s = Rational -> Percentage
clipToPercentage (Rational -> Percentage) -> Rational -> Percentage
forall a b. (a -> b) -> a -> b
$ Coin
ownerPledge Coin -> Coin -> Rational
`proportionTo` (RewardParams -> Coin
totalStake RewardParams
rp)

-- | The saturation of a pool is the ratio of the current pool stake
-- to the fully saturated stake.
poolSaturation :: RewardParams -> RewardInfoPool -> Double
poolSaturation :: RewardParams -> RewardInfoPool -> Double
poolSaturation RewardParams
rp RewardInfoPool{Percentage
stakeRelative :: Percentage
stakeRelative :: RewardInfoPool -> Percentage
stakeRelative}
    = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Percentage -> Rational
getPercentage Percentage
stakeRelative) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (RewardParams -> Rational
z0 RewardParams
rp)

data PoolScore = PoolScore
    { PoolScore -> Coin
_desirability :: Coin
    , PoolScore -> Coin
_nonMyopicMemberReward :: Coin
    }

-- | Compute the desirability and non-myopic rewards for all pools.
--
-- To compute the non-myopic rewards, we need to know all pools
-- in order to rank them by desirability,
-- and we need to know the stake that the user wants to delegate.
scorePools
    :: Ord poolId
    => RewardParams
    -> Map poolId (RewardInfoPool, a)
    -> Coin -- ^ Stake that the user wants to delegate
    -> Map poolId (PoolScore, RewardInfoPool, a)
scorePools :: RewardParams
-> Map poolId (RewardInfoPool, a)
-> Coin
-> Map poolId (PoolScore, RewardInfoPool, a)
scorePools RewardParams
params Map poolId (RewardInfoPool, a)
pools Coin
t
    = [(poolId, (PoolScore, RewardInfoPool, a))]
-> Map poolId (PoolScore, RewardInfoPool, a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(poolId, (PoolScore, RewardInfoPool, a))]
 -> Map poolId (PoolScore, RewardInfoPool, a))
-> [(poolId, (PoolScore, RewardInfoPool, a))]
-> Map poolId (PoolScore, RewardInfoPool, a)
forall a b. (a -> b) -> a -> b
$ ((Coin, (poolId, RewardInfoPool, a))
 -> Bool -> (poolId, (PoolScore, RewardInfoPool, a)))
-> [(Coin, (poolId, RewardInfoPool, a))]
-> [Bool]
-> [(poolId, (PoolScore, RewardInfoPool, a))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Coin, (poolId, RewardInfoPool, a))
-> Bool -> (poolId, (PoolScore, RewardInfoPool, a))
forall a c.
(Coin, (a, RewardInfoPool, c))
-> Bool -> (a, (PoolScore, RewardInfoPool, c))
doScore [(Coin, (poolId, RewardInfoPool, a))]
sortedByDesirability [Bool]
areTop
  where
    RewardParams{Int
nOpt :: Int
nOpt :: RewardParams -> Int
nOpt} = RewardParams
params
    areTop :: [Bool]
areTop = Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate Int
nOpt Bool
True [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False

    doScore :: (Coin, (a, RewardInfoPool, c))
-> Bool -> (a, (PoolScore, RewardInfoPool, c))
doScore (Coin
d, (a
pid, RewardInfoPool
pool, c
a)) Bool
isTop = (a
pid, (PoolScore
score, RewardInfoPool
pool, c
a))
      where
        score :: PoolScore
score = PoolScore :: Coin -> Coin -> PoolScore
PoolScore
            { _nonMyopicMemberReward :: Coin
_nonMyopicMemberReward
                = RewardParams -> RewardInfoPool -> Bool -> Coin -> Coin
nonMyopicMemberReward RewardParams
params RewardInfoPool
pool Bool
isTop Coin
t
            , _desirability :: Coin
_desirability = Coin
d
            }

    sortedByDesirability :: [(Coin, (poolId, RewardInfoPool, a))]
sortedByDesirability
        = ((Coin, (poolId, RewardInfoPool, a)) -> Down Coin)
-> [(Coin, (poolId, RewardInfoPool, a))]
-> [(Coin, (poolId, RewardInfoPool, a))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (Coin -> Down Coin
forall a. a -> Down a
Down (Coin -> Down Coin)
-> ((Coin, (poolId, RewardInfoPool, a)) -> Coin)
-> (Coin, (poolId, RewardInfoPool, a))
-> Down Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin, (poolId, RewardInfoPool, a)) -> Coin
forall a b. (a, b) -> a
fst)
        ([(Coin, (poolId, RewardInfoPool, a))]
 -> [(Coin, (poolId, RewardInfoPool, a))])
-> ([(poolId, (RewardInfoPool, a))]
    -> [(Coin, (poolId, RewardInfoPool, a))])
-> [(poolId, (RewardInfoPool, a))]
-> [(Coin, (poolId, RewardInfoPool, a))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((poolId, (RewardInfoPool, a))
 -> (Coin, (poolId, RewardInfoPool, a)))
-> [(poolId, (RewardInfoPool, a))]
-> [(Coin, (poolId, RewardInfoPool, a))]
forall a b. (a -> b) -> [a] -> [b]
map (\(poolId
pid,(RewardInfoPool
pool, a
a)) -> (RewardParams -> RewardInfoPool -> Coin
desirability RewardParams
params RewardInfoPool
pool, (poolId
pid, RewardInfoPool
pool, a
a)))
        ([(poolId, (RewardInfoPool, a))]
 -> [(Coin, (poolId, RewardInfoPool, a))])
-> [(poolId, (RewardInfoPool, a))]
-> [(Coin, (poolId, RewardInfoPool, a))]
forall a b. (a -> b) -> a -> b
$ Map poolId (RewardInfoPool, a) -> [(poolId, (RewardInfoPool, a))]
forall k a. Map k a -> [(k, a)]
Map.toList Map poolId (RewardInfoPool, a)
pools

{-------------------------------------------------------------------------------
    Redelegation warning
-------------------------------------------------------------------------------}
data RedelegationWarning
    = AllGood
    | TooFewBlocks
    | OtherPoolsBetter
    deriving (RedelegationWarning -> RedelegationWarning -> Bool
(RedelegationWarning -> RedelegationWarning -> Bool)
-> (RedelegationWarning -> RedelegationWarning -> Bool)
-> Eq RedelegationWarning
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RedelegationWarning -> RedelegationWarning -> Bool
$c/= :: RedelegationWarning -> RedelegationWarning -> Bool
== :: RedelegationWarning -> RedelegationWarning -> Bool
$c== :: RedelegationWarning -> RedelegationWarning -> Bool
Eq, Int -> RedelegationWarning -> ShowS
[RedelegationWarning] -> ShowS
RedelegationWarning -> String
(Int -> RedelegationWarning -> ShowS)
-> (RedelegationWarning -> String)
-> ([RedelegationWarning] -> ShowS)
-> Show RedelegationWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedelegationWarning] -> ShowS
$cshowList :: [RedelegationWarning] -> ShowS
show :: RedelegationWarning -> String
$cshow :: RedelegationWarning -> String
showsPrec :: Int -> RedelegationWarning -> ShowS
$cshowsPrec :: Int -> RedelegationWarning -> ShowS
Show)

-- FIXME: Adapt message to take care of previous epoch.

instance Buildable RedelegationWarning where
    build :: RedelegationWarning -> Builder
build RedelegationWarning
AllGood = String -> Builder
forall p. Buildable p => p -> Builder
build (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
        [ String
"The pool to which you had delegated your stake"
        , String
"gives rewards within expectations."
        ]
    build RedelegationWarning
TooFewBlocks = String -> Builder
forall p. Buildable p => p -> Builder
build (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
        [ String
"The pool to which you have delegated your stake"
        , String
"may have not performed as expected,"
        , String
"please check your delegation choice."
        ]
    build RedelegationWarning
OtherPoolsBetter = String -> Builder
forall p. Buildable p => p -> Builder
build (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
        [ String
"Other pools may offer higher rewards,"
        , String
"please check your delegation choice."
        ]

-- | Compute redelegation warning from current pool performance.
--
-- Note: This function uses the 'performanceEstimate' for the pool
-- that we delegate to, but ignores this fields for the argument
-- 'StakePoolsSummary'.
redelegationWarning
    :: EpochNo
        -- ^ Epoch when delegation was made
    -> (RewardInfoPool, Coin)
        -- ^ ( Info about the pool that we delegate to
        --   , absolute stake that we delegate )
    -> StakePoolsSummary
        -- ^ Current summary of all stake pools (for comparison)
    -> EpochNo
        -- ^ Current epoch
    -> RedelegationWarning
redelegationWarning :: EpochNo
-> (RewardInfoPool, Coin)
-> StakePoolsSummary
-> EpochNo
-> RedelegationWarning
redelegationWarning EpochNo
timeOfDelegation (RewardInfoPool
info,Coin
user) StakePoolsSummary{Map PoolId RewardInfoPool
RewardParams
pools :: Map PoolId RewardInfoPool
rewardParams :: RewardParams
pools :: StakePoolsSummary -> Map PoolId RewardInfoPool
rewardParams :: StakePoolsSummary -> RewardParams
..} EpochNo
now
    | (Rational
sigma Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
0.6 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
s Bool -> Bool -> Bool
&& Double
p Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.85) Bool -> Bool -> Bool
|| (Rational
sigma Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
0.6 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
s Bool -> Bool -> Bool
&& Double
p Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.9)
        = RedelegationWarning
TooFewBlocks
    | Percentage -> Rational
getPercentage Percentage
mr Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Percentage -> Rational
getPercentage Percentage
mrstar Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
w
        = RedelegationWarning
OtherPoolsBetter
    | Bool
otherwise
        = RedelegationWarning
AllGood
  where
    sigma :: Rational
sigma = Percentage -> Rational
getPercentage (Percentage -> Rational) -> Percentage -> Rational
forall a b. (a -> b) -> a -> b
$ RewardInfoPool -> Percentage
stakeRelative RewardInfoPool
info
    s :: Rational
s = Rational
1 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (RewardParams -> Int
nOpt RewardParams
rewardParams)
    p :: Double
p = RewardInfoPool -> Double
performanceEstimate RewardInfoPool
info

    mr :: Percentage
mr = RewardParams -> RewardInfoPool -> Coin -> Percentage
currentROS RewardParams
rewardParams RewardInfoPool
info Coin
user
    mrstar :: Percentage
mrstar = [Percentage] -> Percentage
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Percentage
mrPercentage -> [Percentage] -> [Percentage]
forall a. a -> [a] -> [a]
:[Percentage]
returns)
    returns :: [Percentage]
returns = (RewardInfoPool -> Percentage) -> [RewardInfoPool] -> [Percentage]
forall a b. (a -> b) -> [a] -> [b]
map (\RewardInfoPool
i -> RewardParams -> RewardInfoPool -> Coin -> Percentage
currentROS RewardParams
rewardParams RewardInfoPool
i Coin
user) ([RewardInfoPool] -> [Percentage])
-> [RewardInfoPool] -> [Percentage]
forall a b. (a -> b) -> a -> b
$ Map PoolId RewardInfoPool -> [RewardInfoPool]
forall k a. Map k a -> [a]
Map.elems Map PoolId RewardInfoPool
pools

    w :: Rational
w = Rational
dtRational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
dt Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (Rational
25 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
dtRational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
dt) :: Rational
    dt :: Rational
dt = Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Rational) -> Int -> Rational
forall a b. (a -> b) -> a -> b
$ EpochNo -> Int
forall a. Enum a => a -> Int
fromEnum EpochNo
now Int -> Int -> Int
forall a. Num a => a -> a -> a
- EpochNo -> Int
forall a. Enum a => a -> Int
fromEnum EpochNo
timeOfDelegation
        -- time different in number of epochs.