Added the class MAccum in Data.Pulse to make first order pulsable dat…

…a. Simple exampe in that file, and an exampke for dong the full reward calculation at the end of the file for Shelley.Spec.Ledger.Rewards.

semantics/executable-spec/src/Data/Pulse.hs

@@ -3,6 +3,12 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
 
 module Data.Pulse where
 
@@ -12,6 +18,10 @@ import Data.Map(Map)
 import qualified Data.Map.Strict as Map
 import Data.Map.Internal (Map (..))
 import Control.Monad.Identity(Identity(..))
+import Data.Coders
+import Cardano.Binary(ToCBOR(..),FromCBOR(..))
+import Data.Typeable
+
 
 -- ====================================================
 
@@ -43,20 +53,25 @@ data PulseListM m ans where
 
 instance Show ans => Show (PulseListM m ans) where
   show(PulseList ass n _ t a) = "(Pulse "++assoc ass++show n++status t++show a++")"
-    where status [] = " Done "
-          status (_ : _) = " More "
-          assoc LeftA = "left "
+    where assoc LeftA = "left "
           assoc RightA = "right "
 
+isNil :: [a] -> Bool
+isNil [] = True
+isNil (_ : _) = False
+
+status :: [a] -> String
+status x = if isNil x then " Done " else " More "
+
 -- =================================
 -- Pulse structure for Map in an arbitray monad
 
 data PulseMapM m ans where
   PulseMap:: !Int ->  !(ans -> k -> v -> m ans) -> !(Map k v) -> !ans -> PulseMapM m ans
 
 instance Show ans => Show (PulseMapM m ans) where
-  show(PulseMap n _ t a) = "(Pulse "++show n++status t++show a++")"
-    where status x = if Map.null x then " Done " else " More "
+  show(PulseMap n _ t a) =
+    "(Pulse "++show n++(if Map.null t then " Done " else " More ")++show a++")"
 
 -- ===============================================================
 -- Pulse structures can be Specialize to the Identity Monad
@@ -89,8 +104,7 @@ complete p = runIdentity (completeM p)
 -- Some instances
 
 instance Pulsable PulseListM where
-   done (PulseList _ _ _ [] _) = True
-   done (PulseList _ _ _ (_: _) _) = False
+   done (PulseList _ _ _ zs _) = isNil zs
    current (PulseList _ _ _ _ ans) = ans
    pulseM (PulseList ass n accum balance ans) = do
        let (steps, balance') = List.splitAt n balance
@@ -247,4 +261,81 @@ iosum = PulseList LeftA 2 (\ () k -> putStrLn (show k)) [(1::Int)..5] ()
 *Pulse> pulseM it
 5
 (Pulse left 2 Done ())
--}
+-}
+
+{-
+Need to serialize
+
+-}
+
+-- =========================================================
+-- Every instance of MAccum, refers to exactly one function
+
+class MAccum unique (m :: Type -> Type) free item ans | unique -> m free item ans where
+  maccum :: unique -> free -> ans -> item -> m ans
+
+-- Here is an example instance
+
+-- Make a Unique Unit type. (I.e. an enumeration with one constructor)
+data XXX = XXX
+  deriving Show
+
+instance ToCBOR XXX where toCBOR XXX = encode(Rec XXX)
+instance FromCBOR XXX where fromCBOR = decode(RecD XXX)
+
+-- | The unique 'maccum' function of the (MAccum XXX _ _ _ _) instance
+
+fooAccum :: [a] -> Int -> Int -> Identity Int
+fooAccum bs ans v = Identity (v+ans + length bs)
+
+instance MAccum XXX Identity [Bool] Int Int where
+  maccum XXX = fooAccum
+
+-- =========================================================
+-- LL is a first order data type (no embedded functions)
+-- that can be given a (Pulsable (LL name)) instance, We
+--  can also make ToCBOR and FromCBOR instances for it.
+
+data LL name (m :: Type -> Type) ans where
+  LL:: (MAccum name m free v ans, ToCBOR v, ToCBOR free) =>
+       name -> !Int -> !free -> ![v] -> !ans -> LL name m ans
+
+instance (Show ans, Show name) => Show (LL name m ans) where
+  show (LL name n _ vs ans) = "(LL "++show name++" "++show n++status vs++" "++show ans++")"
+
+
+-- There is a single ToCBOR instance for (LL name m ans)
+-- But because of the uniqueness of the name, which implies
+-- the hidden types (free and v for LL), We must supply
+-- a unique FromCBOR instance for each name. See the XXX example below.
+
+instance (Typeable m, ToCBOR name, ToCBOR ans) => ToCBOR (LL name m ans) where
+  toCBOR (LL name n free vs ans) = encode(Rec (LL name) !> To n !> To free !> To vs !> To ans)
+
+instance Pulsable (LL name) where
+   done (LL _name _n _free zs _ans) = isNil zs
+   current (LL _ _ _ _ ans) = ans
+   pulseM (LL name n free balance ans) = do
+       let (steps, balance') = List.splitAt n balance
+       ans' <- foldlM' (maccum name free) ans steps
+       pure (LL name n free balance' ans')
+
+
+-- =================================================
+-- To make a serializable type that has a (Pulsable (LL name)) instance,
+-- first, define a Unit type (an enumeration with 1 constructor).
+-- This will have a unique MAccum instance, which
+-- will refer to a unique function with no free variables.
+-- If we follow the pattern below, then the Pulsable instance
+-- will refer to that (MAccum) instance, but will store only
+-- first order data.
+
+-- We must supply a unique FromCBOR instance for each 'name'. The 'name'
+-- fixes the monad 'm' and 'ans' type, as well as the 'maccum' function
+-- for XXX at the value level.
+
+instance FromCBOR (LL XXX Identity Int) where
+  fromCBOR = decode (RecD (LL XXX) <! From <! From <! From <! From)
+
+foo :: LL XXX Identity Int
+foo = LL XXX 3 [True] [1,2,3,5,6,7,8] 0

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs

@@ -8,6 +8,12 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
 
 module Shelley.Spec.Ledger.Rewards
   ( desirability,
@@ -32,6 +38,7 @@ module Shelley.Spec.Ledger.Rewards
     memberRew,
     aggregateRewards,
     sumRewards,
+    rewardLL,
   )
 where
 
@@ -45,7 +52,7 @@ import Cardano.Binary
     encodeWord,
   )
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
-import Cardano.Ledger.Era (Crypto)
+import Cardano.Ledger.Era (Era,Crypto)
 import Cardano.Ledger.Val ((<->))
 import Cardano.Slotting.Slot (EpochSize)
 import Control.DeepSeq (NFData)
@@ -98,6 +105,9 @@ import Shelley.Spec.Ledger.Serialization
     encodeFoldable,
   )
 import Shelley.Spec.Ledger.TxBody (PoolParams (..), getRwdCred)
+import Data.Pulse(LL(..),MAccum(..))
+import Data.Kind(Type)
+import Data.Typeable
 
 newtype LogWeight = LogWeight {unLogWeight :: Float}
   deriving (Eq, Generic, Ord, Num, NFData, NoThunks, ToCBOR, FromCBOR)
@@ -661,3 +671,84 @@ nonMyopicMemberRew
         f = maxPool pp rPot (unStakeShare nm) (unStakeShare s)
         fHat = floor (p * (fromRational . coinToRational) f)
      in memberRew (Coin fHat) pool t nm
+
+
+-- ==========================================
+
+
+data FreeVars era =
+     FreeVars{ b:: Map (KeyHash 'StakePool (Crypto era)) Natural,
+               delegs:: Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)),
+               stake:: Stake (Crypto era),
+               addrsRew :: Set (Credential 'Staking (Crypto era)),
+               totalStake :: Integer,
+               activeStake :: Integer,
+               asc :: ActiveSlotCoeff,
+               totalBlocks :: Natural,                                       --
+               r :: Coin,
+               pp ::  PParams era,
+               slotsPerEpoch :: EpochSize }
+
+
+actionFree
+  :: (Monad m) =>
+     FreeVars era
+     -> ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
+        , Map (KeyHash 'StakePool (Crypto era)) Likelihood)
+     -> (KeyHash 'StakePool (Crypto era), PoolParams (Crypto era))
+     -> ProvM
+          (Map
+             (KeyHash 'StakePool (Crypto era))
+             (RewardProvenancePool (Crypto era)))
+          m
+          ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
+          , Map (KeyHash 'StakePool (Crypto era)) Likelihood)
+actionFree (FreeVars{b,delegs,stake,addrsRew,totalStake,activeStake,asc,totalBlocks,r,pp,slotsPerEpoch})
+       (m1, m2) (hk, pparams) = do
+          let blocksProduced = Map.lookup hk b
+              actgr@(Stake s) = poolStake hk delegs stake
+              Coin pstake = fold s
+              sigma = if totalStake == 0 then 0 else fromIntegral pstake % fromIntegral totalStake
+              sigmaA = if activeStake == 0 then 0 else fromIntegral pstake % fromIntegral activeStake
+              ls =
+                likelihood
+                  (fromMaybe 0 blocksProduced)
+                  (leaderProbability asc sigma (_d pp))
+                  slotsPerEpoch
+          case blocksProduced of
+            Nothing -> pure (m1, Map.insert hk ls m2)
+            Just n -> do
+              m <- rewardOnePool pp r n totalBlocks pparams actgr sigma sigmaA (Coin totalStake) addrsRew
+              pure (Map.unionWith Set.union m m1, Map.insert hk ls m2)
+
+data RewardCalc (m:: Type -> Type) era c = RewardCalc
+
+instance (Monad m, c ~ Crypto era) =>
+    MAccum (RewardCalc m era c)
+           (ProvM (Map (KeyHash 'StakePool c) (RewardProvenancePool c)) m)
+           (FreeVars era)
+           (KeyHash 'StakePool c, PoolParams c)
+           ( Map (Credential 'Staking c) (Set (Reward c)),
+             Map (KeyHash 'StakePool c) Likelihood )
+   where maccum RewardCalc = actionFree
+
+-- Make an example LL
+
+instance Typeable era => ToCBOR (FreeVars era) where
+   toCBOR _x = undefined
+
+freevars :: FreeVars era
+freevars = undefined
+
+rewardLL :: (Monad m, Era era) =>
+     LL
+       (RewardCalc m era (Crypto era))
+       (ProvM
+          (Map
+             (KeyHash 'StakePool (Crypto era))
+             (RewardProvenancePool (Crypto era)))
+          m)
+       (Map
+          (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
+        Map (KeyHash 'StakePool (Crypto era)) Likelihood)
+rewardLL = LL RewardCalc 10 freevars [] (Map.empty, Map.empty)