{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}

module Shelley.Spec.Ledger.OverlaySchedule
  ( -- * Overlay schedule
    isOverlaySlot,
    classifyOverlaySlot,
    lookupInOverlaySchedule,

    -- * OBftSlot
    OBftSlot (..),

    -- * Testing
    overlaySlots,
  )
where

import Cardano.Binary
  ( FromCBOR (..),
    ToCBOR (..),
    TokenType (TypeNull),
    decodeNull,
    encodeNull,
    peekTokenType,
  )
import Cardano.Ledger.Crypto
import Cardano.Slotting.Slot
import Control.DeepSeq (NFData)
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Shelley.Spec.Ledger.BaseTypes
import Shelley.Spec.Ledger.Keys
  ( KeyHash (..),
    KeyRole (..),
  )
import Shelley.Spec.Ledger.Slot

data OBftSlot crypto
  = NonActiveSlot
  | ActiveSlot !(KeyHash 'Genesis crypto)
  deriving (Int -> OBftSlot crypto -> ShowS
[OBftSlot crypto] -> ShowS
OBftSlot crypto -> String
(Int -> OBftSlot crypto -> ShowS)
-> (OBftSlot crypto -> String)
-> ([OBftSlot crypto] -> ShowS)
-> Show (OBftSlot crypto)
forall crypto. Int -> OBftSlot crypto -> ShowS
forall crypto. [OBftSlot crypto] -> ShowS
forall crypto. OBftSlot crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OBftSlot crypto] -> ShowS
$cshowList :: forall crypto. [OBftSlot crypto] -> ShowS
show :: OBftSlot crypto -> String
$cshow :: forall crypto. OBftSlot crypto -> String
showsPrec :: Int -> OBftSlot crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> OBftSlot crypto -> ShowS
Show, OBftSlot crypto -> OBftSlot crypto -> Bool
(OBftSlot crypto -> OBftSlot crypto -> Bool)
-> (OBftSlot crypto -> OBftSlot crypto -> Bool)
-> Eq (OBftSlot crypto)
forall crypto. OBftSlot crypto -> OBftSlot crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OBftSlot crypto -> OBftSlot crypto -> Bool
$c/= :: forall crypto. OBftSlot crypto -> OBftSlot crypto -> Bool
== :: OBftSlot crypto -> OBftSlot crypto -> Bool
$c== :: forall crypto. OBftSlot crypto -> OBftSlot crypto -> Bool
Eq, Eq (OBftSlot crypto)
Eq (OBftSlot crypto)
-> (OBftSlot crypto -> OBftSlot crypto -> Ordering)
-> (OBftSlot crypto -> OBftSlot crypto -> Bool)
-> (OBftSlot crypto -> OBftSlot crypto -> Bool)
-> (OBftSlot crypto -> OBftSlot crypto -> Bool)
-> (OBftSlot crypto -> OBftSlot crypto -> Bool)
-> (OBftSlot crypto -> OBftSlot crypto -> OBftSlot crypto)
-> (OBftSlot crypto -> OBftSlot crypto -> OBftSlot crypto)
-> Ord (OBftSlot crypto)
OBftSlot crypto -> OBftSlot crypto -> Bool
OBftSlot crypto -> OBftSlot crypto -> Ordering
OBftSlot crypto -> OBftSlot crypto -> OBftSlot crypto
forall crypto. Eq (OBftSlot crypto)
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
forall crypto. OBftSlot crypto -> OBftSlot crypto -> Bool
forall crypto. OBftSlot crypto -> OBftSlot crypto -> Ordering
forall crypto.
OBftSlot crypto -> OBftSlot crypto -> OBftSlot crypto
min :: OBftSlot crypto -> OBftSlot crypto -> OBftSlot crypto
$cmin :: forall crypto.
OBftSlot crypto -> OBftSlot crypto -> OBftSlot crypto
max :: OBftSlot crypto -> OBftSlot crypto -> OBftSlot crypto
$cmax :: forall crypto.
OBftSlot crypto -> OBftSlot crypto -> OBftSlot crypto
>= :: OBftSlot crypto -> OBftSlot crypto -> Bool
$c>= :: forall crypto. OBftSlot crypto -> OBftSlot crypto -> Bool
> :: OBftSlot crypto -> OBftSlot crypto -> Bool
$c> :: forall crypto. OBftSlot crypto -> OBftSlot crypto -> Bool
<= :: OBftSlot crypto -> OBftSlot crypto -> Bool
$c<= :: forall crypto. OBftSlot crypto -> OBftSlot crypto -> Bool
< :: OBftSlot crypto -> OBftSlot crypto -> Bool
$c< :: forall crypto. OBftSlot crypto -> OBftSlot crypto -> Bool
compare :: OBftSlot crypto -> OBftSlot crypto -> Ordering
$ccompare :: forall crypto. OBftSlot crypto -> OBftSlot crypto -> Ordering
$cp1Ord :: forall crypto. Eq (OBftSlot crypto)
Ord, (forall x. OBftSlot crypto -> Rep (OBftSlot crypto) x)
-> (forall x. Rep (OBftSlot crypto) x -> OBftSlot crypto)
-> Generic (OBftSlot crypto)
forall x. Rep (OBftSlot crypto) x -> OBftSlot crypto
forall x. OBftSlot crypto -> Rep (OBftSlot crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x. Rep (OBftSlot crypto) x -> OBftSlot crypto
forall crypto x. OBftSlot crypto -> Rep (OBftSlot crypto) x
$cto :: forall crypto x. Rep (OBftSlot crypto) x -> OBftSlot crypto
$cfrom :: forall crypto x. OBftSlot crypto -> Rep (OBftSlot crypto) x
Generic)

instance
  Crypto crypto =>
  ToCBOR (OBftSlot crypto)
  where
  toCBOR :: OBftSlot crypto -> Encoding
toCBOR OBftSlot crypto
NonActiveSlot = Encoding
encodeNull
  toCBOR (ActiveSlot KeyHash 'Genesis crypto
k) = KeyHash 'Genesis crypto -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR KeyHash 'Genesis crypto
k

instance
  Crypto crypto =>
  FromCBOR (OBftSlot crypto)
  where
  fromCBOR :: Decoder s (OBftSlot crypto)
fromCBOR = do
    Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType Decoder s TokenType
-> (TokenType -> Decoder s (OBftSlot crypto))
-> Decoder s (OBftSlot crypto)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TokenType
TypeNull -> do
        Decoder s ()
forall s. Decoder s ()
decodeNull
        OBftSlot crypto -> Decoder s (OBftSlot crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure OBftSlot crypto
forall crypto. OBftSlot crypto
NonActiveSlot
      TokenType
_ -> KeyHash 'Genesis crypto -> OBftSlot crypto
forall crypto. KeyHash 'Genesis crypto -> OBftSlot crypto
ActiveSlot (KeyHash 'Genesis crypto -> OBftSlot crypto)
-> Decoder s (KeyHash 'Genesis crypto)
-> Decoder s (OBftSlot crypto)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (KeyHash 'Genesis crypto)
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance NoThunks (OBftSlot crypto)

instance NFData (OBftSlot crypto)

isOverlaySlot ::
  SlotNo -> -- starting slot
  UnitInterval -> -- decentralization parameter
  SlotNo -> -- slot to check
  Bool
isOverlaySlot :: SlotNo -> UnitInterval -> SlotNo -> Bool
isOverlaySlot SlotNo
firstSlotNo UnitInterval
dval SlotNo
slot = Rational -> Integer
step Rational
s Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Rational -> Integer
step (Rational
s Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
1)
  where
    s :: Rational
s = Duration -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Duration -> Rational) -> Duration -> Rational
forall a b. (a -> b) -> a -> b
$ SlotNo
slot SlotNo -> SlotNo -> Duration
-* SlotNo
firstSlotNo
    d :: Rational
d = UnitInterval -> Rational
unitIntervalToRational UnitInterval
dval
    step :: Rational -> Integer
    step :: Rational -> Integer
step Rational
x = Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
d)

classifyOverlaySlot ::
  SlotNo -> -- first slot of the epoch
  Set (KeyHash 'Genesis crypto) -> -- genesis Nodes
  UnitInterval -> -- decentralization parameter
  ActiveSlotCoeff -> -- active slot coefficent
  SlotNo -> -- overlay slot to classify
  OBftSlot crypto
classifyOverlaySlot :: SlotNo
-> Set (KeyHash 'Genesis crypto)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> OBftSlot crypto
classifyOverlaySlot SlotNo
firstSlotNo Set (KeyHash 'Genesis crypto)
gkeys UnitInterval
dval ActiveSlotCoeff
ascValue SlotNo
slot =
  if Bool
isActive
    then
      let genesisIdx :: Int
genesisIdx = (Int
position Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
ascInv) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Set (KeyHash 'Genesis crypto) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set (KeyHash 'Genesis crypto)
gkeys)
       in Set (KeyHash 'Genesis crypto)
gkeys Set (KeyHash 'Genesis crypto) -> Int -> OBftSlot crypto
forall crypto.
Set (KeyHash 'Genesis crypto) -> Int -> OBftSlot crypto
`getAtIndex` Int
genesisIdx
    else OBftSlot crypto
forall crypto. OBftSlot crypto
NonActiveSlot
  where
    d :: Rational
d = UnitInterval -> Rational
unitIntervalToRational UnitInterval
dval
    position :: Int
position = Rational -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Duration -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo
slot SlotNo -> SlotNo -> Duration
-* SlotNo
firstSlotNo) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
d)
    isActive :: Bool
isActive = Int
position Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
ascInv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    getAtIndex :: Set (KeyHash 'Genesis crypto) -> Int -> OBftSlot crypto
getAtIndex Set (KeyHash 'Genesis crypto)
gs Int
i = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Set (KeyHash 'Genesis crypto) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set (KeyHash 'Genesis crypto)
gs then KeyHash 'Genesis crypto -> OBftSlot crypto
forall crypto. KeyHash 'Genesis crypto -> OBftSlot crypto
ActiveSlot (Int -> Set (KeyHash 'Genesis crypto) -> KeyHash 'Genesis crypto
forall a. Int -> Set a -> a
Set.elemAt Int
i Set (KeyHash 'Genesis crypto)
gs) else OBftSlot crypto
forall crypto. OBftSlot crypto
NonActiveSlot
    ascInv :: Int
ascInv = Rational -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
1 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (UnitInterval -> Rational
unitIntervalToRational (UnitInterval -> Rational)
-> (ActiveSlotCoeff -> UnitInterval) -> ActiveSlotCoeff -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSlotCoeff -> UnitInterval
activeSlotVal (ActiveSlotCoeff -> Rational) -> ActiveSlotCoeff -> Rational
forall a b. (a -> b) -> a -> b
$ ActiveSlotCoeff
ascValue))

lookupInOverlaySchedule ::
  SlotNo -> -- first slot of the epoch
  Set (KeyHash 'Genesis crypto) -> -- genesis Nodes
  UnitInterval -> -- decentralization parameter
  ActiveSlotCoeff -> -- active slot coefficent
  SlotNo -> -- slot to lookup
  Maybe (OBftSlot crypto)
lookupInOverlaySchedule :: SlotNo
-> Set (KeyHash 'Genesis crypto)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe (OBftSlot crypto)
lookupInOverlaySchedule SlotNo
firstSlotNo Set (KeyHash 'Genesis crypto)
gkeys UnitInterval
dval ActiveSlotCoeff
ascValue SlotNo
slot =
  if SlotNo -> UnitInterval -> SlotNo -> Bool
isOverlaySlot SlotNo
firstSlotNo UnitInterval
dval SlotNo
slot
    then OBftSlot crypto -> Maybe (OBftSlot crypto)
forall a. a -> Maybe a
Just (OBftSlot crypto -> Maybe (OBftSlot crypto))
-> OBftSlot crypto -> Maybe (OBftSlot crypto)
forall a b. (a -> b) -> a -> b
$ SlotNo
-> Set (KeyHash 'Genesis crypto)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> OBftSlot crypto
forall crypto.
SlotNo
-> Set (KeyHash 'Genesis crypto)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> OBftSlot crypto
classifyOverlaySlot SlotNo
firstSlotNo Set (KeyHash 'Genesis crypto)
gkeys UnitInterval
dval ActiveSlotCoeff
ascValue SlotNo
slot
    else Maybe (OBftSlot crypto)
forall a. Maybe a
Nothing

-- | Return the list of overlaySlots for a given epoch.
-- Note that this linear in the size of the epoch, and should probably
-- only be used for testing.
-- If something more performant is needed, we could probably use
-- [start + floor(x/d) | x <- [0 .. (spe -1)], floor(x/d) < spe]
-- but we would need to make sure that this is equivalent.
overlaySlots ::
  SlotNo -> -- starting slot
  UnitInterval -> -- decentralization parameter
  EpochSize ->
  [SlotNo]
overlaySlots :: SlotNo -> UnitInterval -> EpochSize -> [SlotNo]
overlaySlots SlotNo
start UnitInterval
d (EpochSize Word64
spe) =
  [Word64 -> SlotNo
SlotNo Word64
x | Word64
x <- [SlotNo -> Word64
unSlotNo SlotNo
start .. Word64
end], SlotNo -> UnitInterval -> SlotNo -> Bool
isOverlaySlot SlotNo
start UnitInterval
d (Word64 -> SlotNo
SlotNo Word64
x)]
  where
    end :: Word64
end = SlotNo -> Word64
unSlotNo SlotNo
start Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
spe Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1