diff --git a/semantics/executable-spec/small-steps.cabal b/semantics/executable-spec/small-steps.cabal
index 5bddfc9b591..f32505a1594 100644
--- a/semantics/executable-spec/small-steps.cabal
+++ b/semantics/executable-spec/small-steps.cabal
@@ -34,6 +34,8 @@ library
                      , Data.CanonicalMaps
                      , Data.MemoBytes
                      , Data.Coders
+                     , Data.Pulse
+                     , Data.Closure
                      , Control.Provenance
                      , Control.Iterate.SetAlgebra
                      , Control.Iterate.Collect
diff --git a/semantics/executable-spec/src/Control/Provenance.hs b/semantics/executable-spec/src/Control/Provenance.hs
index 18fb3f5ebe5..877b9f9315c 100644
--- a/semantics/executable-spec/src/Control/Provenance.hs
+++ b/semantics/executable-spec/src/Control/Provenance.hs
@@ -31,6 +31,7 @@ module Control.Provenance
     runProv,
     runWithProv,
     runOtherProv,
+    liftProv,
     dump,
 
     -- * Operations in Prov instantiation
@@ -182,6 +183,15 @@ runOtherProv initial other = do
 {-# INLINE runOtherProv #-}
 
 
+-- | lift a provenenace computation from one provenance type (s1) to another (s2)
+liftProv :: Monad m => ProvM s1 m a -> s1 -> (a -> s1 -> s2 -> s2) -> ProvM s2 m a
+liftProv computation inits1 combine =
+  do (a,blackbox) <- runOtherProv inits1 computation
+     modifyWithBlackBox blackbox (combine a)
+     pure a
+{-# INLINE liftProv #-}
+
+
 -- =======================================================================
 {- | A special case of the ProvM Monad, where the state type is Store
 a (Map Text PObject), where PObject is a dynamically typed value. This
diff --git a/semantics/executable-spec/src/Data/Closure.hs b/semantics/executable-spec/src/Data/Closure.hs
new file mode 100644
index 00000000000..2fe03d7dbd4
--- /dev/null
+++ b/semantics/executable-spec/src/Data/Closure.hs
@@ -0,0 +1,136 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE StandaloneDeriving  #-}
+{-# LANGUAGE DerivingVia #-}
+
+-- | Supports the creation of objects with type (Closure name env (a -> b)) which are serializable functions.
+module Data.Closure
+   ( Named(..),
+     Closure(..),
+     apply,
+     rootName,
+     roundtrip,
+   )  where
+
+import Data.Kind(Type)
+import Cardano.Binary(ToCBOR(..),FromCBOR(..),serialize', decodeFull')
+import Data.Coders
+import Data.Typeable(Typeable)
+import NoThunks.Class(NoThunks,InspectHeapNamed(..))
+import Control.DeepSeq (NFData,rnf)
+
+-- ================================================
+
+{- | The type 'name', Names a unique value of type 'v'. Usually 'name'
+     is a Unit type, An enumeration with one constructor. When this is the
+     case, it creates a 1-to-1 correspondance between a type and a value, also
+     a 1-to-1 corresponance between the unique value of type 'name' and the value
+-}
+class Eq name => Named name v | name -> v where
+  value :: name -> v
+  name :: name -> String
+
+infixl 0 :$
+
+-- | A Closure is a serializable function. Apply it using 'apply'
+data Closure name (env::[Type]) t where
+  Close:: Named name (a -> b) => !name -> Closure name '[] (a -> b)
+  (:$):: !(Closure name env (a -> b)) -> !a -> Closure name (a ': env) b
+
+deriving via InspectHeapNamed "Closure" (Closure name env t) instance NoThunks (Closure name env t)
+
+-- | Lift a Closure to a real function
+apply :: Closure name env (a -> b) -> a -> b
+apply (Close nm) a = value nm a
+apply (cl :$ x) a = (apply cl x) a
+
+-- | Get the 'name' value of the underlying function in the closure
+rootName :: Closure name env x -> String
+rootName (Close nm) = name nm
+rootName ( cl :$ _ ) = rootName cl
+
+-- =====================================================================================
+-- Class instances for Closure come in pairs,
+-- one for the empty environment:       P(Closure n '[] t),
+-- and one for a non-empty environment: P(Closure n (a ': e) t).
+-- The instance for the non-empty case always has the inductive structure:
+-- (P a, P (Closure name env (a -> x))) => P (Closure name (a ': env) x) .
+-- Note how the 'env' gets smaller in the inductive case:  env < (a ': env) .
+
+-- ============
+-- NFData pair
+
+instance NFData name => NFData (Closure name '[]  x) where
+  rnf (Close x) = rnf x
+
+instance (NFData a, NFData (Closure name env (a -> x))) => NFData (Closure name (a ': env) x) where
+  rnf (cl :$ x) = seq (rnf cl) (rnf x)
+
+-- ==========
+-- Eq pair
+
+instance Eq (Closure name '[]  x) where
+  (Close x) == (Close y) = x==y
+
+instance (Eq a, Eq (Closure name env (a -> x))) => Eq (Closure name (a ': env) x) where
+  (cl1 :$ x1) == (cl2 :$ x2) = cl1==cl2 && x1 == x2
+
+-- ===========
+-- Show pair
+
+instance Show (Closure name '[]  x) where
+  show (Close x) = name x
+
+instance (Show a, Show (Closure name env (a -> x))) => Show (Closure name (a ': env) x) where
+  show (cl :$ x) = show cl++" :$ "++show x
+
+-- ============
+-- ToCBOR pair
+
+instance (ToCBOR name, Typeable x) => ToCBOR (Closure name '[]  x) where
+  toCBOR (Close nm) = encode(Sum Close 0 !> To nm)
+
+instance
+    ( Typeable env,
+      Typeable name,
+      Typeable x,
+      ToCBOR a,
+      ToCBOR (Closure name env (a -> x))
+    ) => ToCBOR (Closure name (a ': env) x) where
+  toCBOR (cl :$ a) = encode(Sum (:$) 1 !> To cl !> To a)
+
+-- =============
+-- FromCBOR pair
+
+instance (Named name (a -> b),Typeable (a->b),FromCBOR name) => FromCBOR (Closure name '[] (a -> b)) where
+  fromCBOR = decode(Summands "Close" decClose)
+    where decClose 0 = SumD Close <! From
+          decClose n = Invalid n
+
+instance
+    ( Typeable env,
+      Typeable name,
+      Typeable x,
+      FromCBOR a,
+      FromCBOR (Closure name env (a -> x))
+    ) => FromCBOR (Closure name (a ': env) x) where
+  fromCBOR = decode(Summands ":$" decDollar)
+    where decDollar 1 = SumD (:$) <! From <! From
+          decDollar n = Invalid n
+
+-- =============================================
+
+-- | useful for demonstrating (pulse x) == (pulse (roundtrip x))
+roundtrip :: (ToCBOR t, FromCBOR t) => t -> t
+roundtrip t =
+  case decodeFull' (serialize' t) of
+    Right x -> x
+    Left err -> error (show err)
diff --git a/semantics/executable-spec/src/Data/Coders.hs b/semantics/executable-spec/src/Data/Coders.hs
index 38e9800791c..e0f7b7845ef 100644
--- a/semantics/executable-spec/src/Data/Coders.hs
+++ b/semantics/executable-spec/src/Data/Coders.hs
@@ -78,6 +78,10 @@ module Data.Coders
     encodeNullMaybe,
     decodeNullMaybe,
     decodeSparse,
+    toMap,
+    fromMap,
+    toSet,
+    fromSet,
   )
 where
 
@@ -109,6 +113,7 @@ import Cardano.Binary
 import qualified Data.Sequence as Seq
 import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
+import qualified Data.Map as Map
 import qualified Data.Text as Text
 import Data.Sequence.Strict (StrictSeq)
 import Data.Sequence (Seq)
@@ -610,6 +615,21 @@ to xs = ED dualCBOR xs
 from ::  (ToCBOR t, FromCBOR t) => Decode ('Closed 'Dense) t
 from = DD dualCBOR
 
+
+-- Names for derived Encode and Decode combinators for Sets and Maps
+
+toMap :: (ToCBOR v) => Map.Map k v -> Encode ('Closed 'Dense) (Map.Map k v)
+toMap x = E encodeFoldable x
+
+fromMap:: (Ord k,FromCBOR k,FromCBOR v) => Decode ('Closed 'Dense) (Map.Map k v)
+fromMap = From
+
+toSet :: (ToCBOR v) => Set.Set v -> Encode ('Closed 'Dense) (Set.Set v)
+toSet x = E encodeFoldable x
+
+fromSet :: (Ord v,FromCBOR v) => Decode ('Closed 'Dense) (Set.Set v)
+fromSet = D (decodeSet fromCBOR)
+
 -- ==================================================================
 -- A Guide to Visual inspection of Duality in Encode and Decode
 --
diff --git a/semantics/executable-spec/src/Data/Pulse.hs b/semantics/executable-spec/src/Data/Pulse.hs
new file mode 100644
index 00000000000..d8333a7583f
--- /dev/null
+++ b/semantics/executable-spec/src/Data/Pulse.hs
@@ -0,0 +1,221 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE StandaloneDeriving  #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Data.Pulse where
+
+import qualified Data.List as List
+import Data.Kind
+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
+import Data.Closure(Closure(..),apply,rootName)
+import NoThunks.Class(NoThunks,InspectHeapNamed(..))
+import Control.DeepSeq (NFData,rnf)
+
+
+-- ====================================================
+
+
+{- | let T be a Pulse structure. A Pulse struture
+   is abstracted over a monad: m, and an answer type: t,
+   so the concrete type of a pulse structure is written: (T m a).
+   The Pulsable class supplies operations on the structure
+   that allow its computation to be split into many discrete
+   steps. One does this by running: "pulse p" or "pulseM p",
+   depending upon whether the computation is monadic or not,
+   to run a discrete step.  The scheduling infrastructure needs
+   to know nothing about what is going on inside the pulse structure.
+-}
+class Pulsable (pulse :: (Type -> Type) -> Type -> Type) where
+   done ::  pulse m ans -> Bool
+   current :: pulse m ans -> ans
+   pulseM :: Monad m => pulse m ans -> m(pulse m ans)
+   completeM :: Monad m => pulse m ans -> m ans
+   completeM p = if done p
+                    then pure (current p)
+                    else  do p' <- pulseM p; completeM p'
+
+-- =================================
+-- Pulse structure for List in an arbitray monad
+
+data PulseListM m ans where
+  PulseList:: Assoc -> !Int -> !(ans -> a -> m ans) -> ![a] -> !ans -> PulseListM m ans
+
+instance Show ans => Show (PulseListM m ans) where
+  show(PulseList ass n _ t a) = "(Pulse "++assoc ass++show n++status t++show a++")"
+    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++(if Map.null t then " Done " else " More ")++show a++")"
+
+-- ===============================================================
+-- Pulse structures can be Specialize to the Identity Monad
+
+type PulseList ans = PulseListM Identity ans
+type PulseMap ans = PulseListM Identity ans
+
+-- Use these 'pseudo constructors' to construct Pulse structures in
+-- the identity monad. They automatically lift the accumulating function
+
+pulseList:: Assoc -> Int -> (t1 -> t2 -> t1) -> [t2] -> t1 -> PulseListM Identity t1
+pulseList LeftA n accum xs zero =
+   PulseList LeftA n (\ ans x -> Identity(accum ans x)) xs zero
+pulseList RightA n accum xs zero =
+   PulseList RightA n (\ ans x -> Identity(accum ans x)) (reverse xs) zero
+
+
+pulseMap:: Int -> (a -> k -> v -> a) -> Map k v -> a -> PulseMapM Identity a
+pulseMap n accum ts zero = PulseMap n  (\ ans k v -> Identity(accum ans k v)) ts zero
+
+-- run Pulse structures in the Identity monad.
+
+pulse :: Pulsable p => p Identity ans -> p Identity ans
+pulse p = runIdentity (pulseM p)
+
+complete :: Pulsable p => p Identity ans -> ans
+complete p = runIdentity (completeM p)
+
+-- =================================================
+-- Some instances
+
+instance Pulsable PulseListM where
+   done (PulseList _ _ _ zs _) = isNil zs
+   current (PulseList _ _ _ _ ans) = ans
+   pulseM (ll@(PulseList _ _ _ balance _)) | isNil balance = pure ll
+   pulseM (PulseList ass n accum balance ans) = do
+       let (steps, balance') = List.splitAt n balance
+       ans' <- (foldM' ass) accum ans steps
+       pure (PulseList ass n accum balance' ans')
+
+instance Pulsable PulseMapM where
+   done (PulseMap _ _ m _) = Map.null m
+   current (PulseMap _ _ _ ans) = ans
+   pulseM (ll@(PulseMap _ _ balance _)) | Map.null balance = pure ll
+   pulseM (PulseMap n accum balance ans) = do
+      let (steps, balance') = Map.splitAt n balance
+      ans' <-  foldlWithKeyM' accum ans steps
+      pure (PulseMap n accum balance' ans')
+
+-- ================================================================
+-- Special monadic folds for use with PulseListM and PulseMapM
+-- They are strict, monadic, and their arguments are in the right order.
+-- These functions should appear somewhere in Data.List or Data.List or
+-- Data.Foldable or Data.Traversable, or Control.Monad, but they don't.
+
+-- | A strict, monadic, version of 'foldl' for lists. It  associates to the left.
+foldlM' :: Monad m => (ans -> k -> m ans) -> ans -> [k] -> m ans
+foldlM' _accum !ans [] = pure ans
+foldlM' accum !ans (k:more) = do { ans1 <- accum ans k; foldlM' accum ans1 more }
+
+
+-- | A strict, monadic, version of 'foldlr' for lists. It  associates to the right.
+foldrM' :: Monad m => (ans -> k -> m ans) -> ans -> [k] -> m ans
+foldrM' _accum !ans [] = pure ans
+foldrM' accum !ans (k : more) = do !ans1 <- foldrM' accum ans more; accum ans1 k
+
+data Assoc = LeftA | RightA
+
+-- | Choose either asscociating to the left or right.
+foldM' :: Monad m => Assoc -> (ans -> k -> m ans) -> ans -> [k] -> m ans
+foldM' LeftA  = foldlM'
+foldM' RightA = foldrM'
+
+-- | /O(n)/. A strict, monadic, version of 'foldlWithKey'. Each application of the
+--   operator is evaluated before using the result in the next application. This
+--   function is strict in the starting value. Associates to the left.
+foldlWithKeyM' :: Monad m => (a -> k -> b -> m a) -> a -> Map k b -> m a
+foldlWithKeyM' f z = go z
+  where
+    go !z' Tip              = pure z'
+    go z' (Bin _ kx x l r) =
+      do !ans1 <- (go z' l)
+         !ans2 <- (f ans1 kx x)
+         go ans2 r
+
+
+-- =========================================================
+
+-- | Serializable List based Pulser (SLP)
+data SLP name env i (m :: Type -> Type) ans where
+  SLP:: !Int -> !(Closure name env (ans -> i -> m ans)) -> ![i] -> !ans -> SLP name env i m ans
+
+deriving via InspectHeapNamed "SLP" (SLP n e i m t) instance NoThunks (SLP n e i m t)
+
+instance (NFData ans, NFData i, NFData (Closure name '[] (ans -> i -> m ans))) => NFData (SLP name '[] i m ans) where
+  rnf (SLP n1 c1 b1 a1) = seq (rnf n1) (seq (rnf c1) (seq (rnf b1) (rnf a1)))
+
+instance (NFData ans, NFData i, NFData (Closure name (z ': e) (ans -> i -> m ans))) => NFData (SLP name (z ': e) i m ans) where
+  rnf (SLP n1 c1 b1 a1) =  seq (rnf n1) (seq (rnf c1) (seq (rnf b1) (rnf a1)))
+
+instance (Show ans, Show i) => Show (SLP name env i m ans) where
+  show (SLP n cl cs ans) = "(SLP "++show n++" "++rootName cl++status cs++show ans++")"
+
+-- we need a pair of Eq instances
+
+instance (Eq ans, Eq i, Eq (Closure name '[] (ans -> i -> m ans))) => Eq (SLP name '[] i m ans) where
+  (SLP n1 c1 b1 a1) == (SLP n2 c2 b2 a2) = (n1==n2) && (c1==c2) && (b1==b2) && (a1==a2)
+
+instance (Eq ans, Eq i, Eq z, Eq (Closure name (z ': e) (ans -> i -> m ans))) => Eq (SLP name (z ': e) i m ans) where
+  (SLP n1 c1 b1 a1) == (SLP n2 c2 b2 a2) = (n1==n2) && (c1==c2) && (b1==b2) && (a1==a2)
+
+instance Pulsable (SLP name env i) where
+   done (SLP _n _cl zs _ans) = isNil zs
+   current (SLP _ _ _ ans) = ans
+   pulseM (ll@(SLP _ _ [] _)) = pure ll
+   pulseM (SLP n cl balance ans) = do
+       let (steps, balance') = List.splitAt n balance
+       ans' <- foldlM' (apply cl) ans steps
+       pure (SLP n cl balance' ans')
+   completeM (SLP _ cl balance ans) = foldlM' (apply cl) ans balance
+
+instance
+   ( ToCBOR ans,
+     ToCBOR i,
+     ToCBOR (Closure name env (ans -> i -> m ans)),
+     Typeable m,
+     Typeable name,
+     Typeable env
+   ) => ToCBOR (SLP name env i m ans) where
+   toCBOR (SLP n cl balance ans) = encode (Rec SLP !> To n !> To cl !> To balance !> To ans)
+
+instance
+   ( FromCBOR ans,
+     FromCBOR i,
+     FromCBOR (Closure name env (ans -> i -> m ans)),
+     Typeable m,
+     Typeable name,
+     Typeable env
+   )
+   => FromCBOR (SLP name env i m ans) where
+   fromCBOR = decode(RecD SLP <! From <! From <! From <! From)
diff --git a/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs b/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs
index c5357343559..22865f77e20 100644
--- a/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs
+++ b/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs
@@ -29,9 +29,12 @@ import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.Era hiding (Crypto)
 import Cardano.Ledger.Shelley (ShelleyEra)
 import Control.Monad.Except (throwError)
+import Data.Closure (rootName)
 import Data.Coerce (coerce)
 import qualified Data.Map.Strict as Map
+import Data.Pulse (SLP (..))
 import Shelley.Spec.Ledger.API
+import Shelley.Spec.Ledger.LedgerState (PulsingRewUpdate (..))
 import qualified Shelley.Spec.Ledger.LedgerState as LS
   ( returnRedeemAddrsToReserves,
   )
@@ -61,14 +64,18 @@ type instance PreviousEra (AllegraEra c) = ShelleyEra c
 type instance TranslationContext (AllegraEra c) = ()
 
 instance Crypto c => TranslateEra (AllegraEra c) NewEpochState where
-  translateEra ctxt nes =
+  type TranslationError (AllegraEra c) NewEpochState = PulseError
+  translateEra ctxt nes = do
+    nesRu' <- case nesRu nes of
+      SNothing -> pure SNothing
+      SJust pulsrew -> SJust <$> translateEra ctxt pulsrew
     return $
       NewEpochState
         { nesEL = nesEL nes,
           nesBprev = nesBprev nes,
           nesBcur = nesBcur nes,
           nesEs = translateEra' ctxt $ LS.returnRedeemAddrsToReserves . nesEs $ nes,
-          nesRu = nesRu nes,
+          nesRu = nesRu',
           nesPd = nesPd nes
         }
 
@@ -186,3 +193,11 @@ instance Crypto c => TranslateEra (AllegraEra c) WitnessSet where
 
 instance Crypto c => TranslateEra (AllegraEra c) Update where
   translateEra _ (Update pp en) = pure $ Update (coerce pp) en
+
+data PulseError = PulseError String
+
+instance Crypto c => TranslateEra (AllegraEra c) (PulsingRewUpdate m) where
+  type TranslationError (AllegraEra c) (PulsingRewUpdate m) = PulseError
+  translateEra _ (Pulsing _ (SLP _ cl _ _)) =
+    throwError (PulseError ("The pulsing reward update did not run to completions: " ++ rootName cl))
+  translateEra _ (Complete ru) = pure (Complete ru)
diff --git a/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs b/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs
index 6a31fcd68e6..06c64f05ab1 100644
--- a/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs
+++ b/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs
@@ -23,6 +23,7 @@ import Cardano.Binary
     serialize,
   )
 import Cardano.Ledger.Allegra (AllegraEra)
+import Cardano.Ledger.Allegra.Translation (PulseError (..))
 import Cardano.Ledger.Compactible (Compactible (..))
 import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.Era hiding (Crypto)
@@ -34,10 +35,13 @@ import Cardano.Ledger.ShelleyMA.AuxiliaryData
   )
 import qualified Cardano.Ledger.Val as Val
 import Control.Monad.Except (throwError)
+import Data.Closure (rootName)
 import Data.Coerce (coerce)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
+import Data.Pulse (SLP (..))
 import Shelley.Spec.Ledger.API hiding (Metadata, TxBody)
+import Shelley.Spec.Ledger.LedgerState (PulsingRewUpdate (..))
 import Shelley.Spec.Ledger.Tx
   ( decodeWits,
   )
@@ -66,14 +70,18 @@ type instance PreviousEra (MaryEra c) = AllegraEra c
 type instance TranslationContext (MaryEra c) = ()
 
 instance Crypto c => TranslateEra (MaryEra c) NewEpochState where
-  translateEra ctxt nes =
+  type TranslationError (MaryEra c) NewEpochState = PulseError
+  translateEra ctxt nes = do
+    nesRu' <- case nesRu nes of
+      SNothing -> pure SNothing
+      SJust pulsrew -> SJust <$> translateEra ctxt pulsrew
     return $
       NewEpochState
         { nesEL = nesEL nes,
           nesBprev = nesBprev nes,
           nesBcur = nesBcur nes,
           nesEs = translateEra' ctxt $ nesEs nes,
-          nesRu = nesRu nes,
+          nesRu = nesRu',
           nesPd = nesPd nes
         }
 
@@ -185,3 +193,9 @@ translateCompactValue =
   fromMaybe (error msg) . toCompact . translateValue . fromCompact
   where
     msg = "impossible error: compact coin is out of range"
+
+instance Crypto c => TranslateEra (MaryEra c) (PulsingRewUpdate m) where
+  type TranslationError (MaryEra c) (PulsingRewUpdate m) = PulseError
+  translateEra _ (Pulsing _ (SLP _ cl _ _)) =
+    throwError (PulseError ("The pulsing reward update did not run to completions: " ++ rootName cl))
+  translateEra _ (Complete ru) = pure (Complete ru)
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs
index 6119e540b7f..3c49e34ed4a 100644
--- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs
+++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs
@@ -260,7 +260,7 @@ getRewardInfo ::
 getRewardInfo globals newepochstate =
   runReader
     ( runWithProvM def $
-        createRUpd slotsPerEpoch blocksmade epochstate maxsupply
+        createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc
     )
     globals
   where
@@ -272,3 +272,4 @@ getRewardInfo globals newepochstate =
     epochnumber = nesEL newepochstate
     slotsPerEpoch :: EpochSize
     slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals
+    asc = activeSlotCoeff globals
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BaseTypes.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BaseTypes.hs
index 419c1638d62..d06b8f18011 100644
--- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BaseTypes.hs
+++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BaseTypes.hs
@@ -346,6 +346,8 @@ data ActiveSlotCoeff = ActiveSlotCoeff
 
 instance NoThunks ActiveSlotCoeff
 
+instance NFData ActiveSlotCoeff
+
 instance FromCBOR ActiveSlotCoeff where
   fromCBOR = do
     v <- fromCBOR
@@ -417,7 +419,7 @@ data Globals = Globals
     -- | The network ID
     networkId :: !Network
   }
-  deriving (Generic)
+  deriving (Show, Generic)
 
 instance NoThunks Globals
 
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs
index 749e816db31..4fe15837de8 100644
--- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs
+++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs
@@ -11,6 +11,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -32,6 +33,7 @@ module Shelley.Spec.Ledger.LedgerState
     DState (..),
     EpochState (..),
     UpecState (..),
+    PulsingRewUpdate (..),
     FutureGenDeleg (..),
     InstantaneousRewards (..),
     Ix,
@@ -41,6 +43,7 @@ module Shelley.Spec.Ledger.LedgerState
     PState (..),
     RewardAccounts,
     RewardUpdate (..),
+    RewardSnapShot (..),
     UTxOState (..),
     depositPoolChange,
     emptyRewardUpdate,
@@ -72,6 +75,11 @@ module Shelley.Spec.Ledger.LedgerState
     stakeDistr,
     applyRUpd,
     createRUpd,
+    completeRupd,
+    startStep,
+    pulseStep,
+    completeStep,
+    pulseOther,
     --
     NewEpochState (..),
     getGKeys,
@@ -112,11 +120,14 @@ import Cardano.Ledger.Shelley.Constraints
 import Cardano.Ledger.Val ((<+>), (<->), (<×>))
 import qualified Cardano.Ledger.Val as Val
 import Control.DeepSeq (NFData)
-import Control.Monad.Trans.Reader (asks)
-import Control.Provenance (ProvM, lift, modifyWithBlackBox, runOtherProv)
+--  runProvM)
+import Control.Monad.Identity ()
+import Control.Provenance (ProvM, liftProv)
 import Control.SetAlgebra (Bimap, biMapEmpty, dom, eval, forwards, range, (∈), (∪+), (▷), (◁))
 import Control.State.Transition (STS (State))
 import qualified Data.ByteString.Lazy as BSL (length)
+import Data.Closure (Closure (..))
+import Data.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
 import Data.Constraint (Constraint)
 import Data.Default.Class (Default, def)
 import Data.Foldable (fold, toList)
@@ -125,6 +136,7 @@ import Data.Kind (Type)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
+import Data.Pulse (Pulsable (..), SLP (..), completeM)
 import Data.Ratio ((%))
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
@@ -141,8 +153,9 @@ import Shelley.Spec.Ledger.Address.Bootstrap
     verifyBootstrapWit,
   )
 import Shelley.Spec.Ledger.BaseTypes
-  ( Globals (..),
+  ( ActiveSlotCoeff,
     ShelleyBase,
+    -- Globals,
     StrictMaybe (..),
     activeSlotVal,
     intervalValue,
@@ -193,15 +206,18 @@ import Shelley.Spec.Ledger.PParams
   )
 import Shelley.Spec.Ledger.RewardProvenance (Desirability (..), RewardProvenance (..))
 import Shelley.Spec.Ledger.Rewards
-  ( Likelihood (..),
+  ( FreeVars (..),
+    KeyHashPoolProvenance,
+    Likelihood (..),
     NonMyopic (..),
     PerformanceEstimate (..),
     Reward (..),
+    RewardPulser,
+    RewardStakePool (..),
     aggregateRewards,
     applyDecay,
     desirability,
     percentile',
-    reward,
     sumRewards,
   )
 import Shelley.Spec.Ledger.Serialization (decodeRecordNamed, mapFromCBOR, mapToCBOR)
@@ -608,7 +624,8 @@ data NewEpochState era = NewEpochState
     -- | Epoch state before current
     nesEs :: !(EpochState era),
     -- | Possible reward update
-    nesRu :: !(StrictMaybe (RewardUpdate (Crypto era))),
+    -- nesRu :: !(StrictMaybe (RewardUpdate (Crypto era))),
+    nesRu :: !(StrictMaybe (PulsingRewUpdate ShelleyBase era)),
     -- | Stake distribution within the stake pool
     nesPd :: !(PoolDistr (Crypto era))
   }
@@ -1023,33 +1040,47 @@ applyRUpd ::
   RewardUpdate (Crypto era) ->
   EpochState era ->
   EpochState era
-applyRUpd ru (EpochState as ss ls pr pp _nm) = EpochState as' ss ls' pr pp nm'
-  where
-    utxoState_ = _utxoState ls
-    delegState = _delegationState ls
-    dState = _dstate delegState
-    (regRU, unregRU) =
-      Map.partitionWithKey
-        (\k _ -> eval (k ∈ dom (_rewards dState)))
-        (aggregateRewards pr $ rs ru)
-    as' =
-      as
-        { _treasury = (addDeltaCoin (_treasury as) (deltaT ru)) <> fold (range unregRU),
-          _reserves = addDeltaCoin (_reserves as) (deltaR ru)
-        }
-    ls' =
-      ls
-        { _utxoState =
-            utxoState_ {_fees = _fees utxoState_ `addDeltaCoin` deltaF ru},
-          _delegationState =
-            delegState
-              { _dstate =
-                  dState
-                    { _rewards = eval (_rewards dState ∪+ regRU)
-                    }
-              }
-        }
-    nm' = nonMyopic ru
+applyRUpd -- pulsestate
+  ru
+  (EpochState as ss ls pr pp _nm) = EpochState as' ss ls' pr pp nm'
+    where
+      -- Identity ru = runProvM (completeRupd pulsestate)
+      utxoState_ = _utxoState ls
+      delegState = _delegationState ls
+      dState = _dstate delegState
+      (regRU, unregRU) =
+        Map.partitionWithKey
+          (\k _ -> eval (k ∈ dom (_rewards dState)))
+          (aggregateRewards pr $ rs ru)
+      as' =
+        as
+          { _treasury = (addDeltaCoin (_treasury as) (deltaT ru)) <> fold (range unregRU),
+            _reserves = addDeltaCoin (_reserves as) (deltaR ru)
+          }
+      ls' =
+        ls
+          { _utxoState =
+              utxoState_ {_fees = _fees utxoState_ `addDeltaCoin` deltaF ru},
+            _delegationState =
+              delegState
+                { _dstate =
+                    dState
+                      { _rewards = eval (_rewards dState ∪+ regRU)
+                      }
+                }
+          }
+      nm' = nonMyopic ru
+
+{-
+applyPulse ::
+  Monad m =>
+  PulsingRewUpdate m era ->
+  EpochState era ->
+  ProvM (RewardProvenance (Crypto era)) m (EpochState era)
+applyPulse pulsestate epochstate = do
+     ru <- completeRupd pulsestate
+     pure(applyRUpd ru epochstate)
+-}
 
 decayFactor :: Float
 decayFactor = 0.9
@@ -1073,16 +1104,97 @@ updateNonMyopic nm rPot newLikelihoods =
         <> newPerf
     updatedLikelihoods = Map.mapWithKey performance newLikelihoods
 
--- | Create a reward update
-createRUpd ::
-  forall era.
+-- =========================================
+-- Useful data to pass around interemdate results
+
+-- | To pulse the reward update, we need a snap shot of the EpochState particular to this computation
+data RewardSnapShot era = RewardSnapShot
+  { rewSnapshots :: !(SnapShots (Crypto era)),
+    rewPp :: !(PParams era),
+    rewNonMyopic :: !(NonMyopic (Crypto era)),
+    rewDeltaR1 :: !Coin, -- deltaR1
+    rewR :: !Coin, -- r
+    rewDeltaT1 :: !Coin, -- deltaT1
+    rewTotalStake :: !Coin, -- totalStake
+    rewRPot :: !Coin -- rPot
+  }
+  deriving (Show, Eq, Generic)
+
+instance NoThunks (RewardSnapShot era)
+
+instance NFData (RewardSnapShot era)
+
+instance Era era => ToCBOR (RewardSnapShot era) where
+  toCBOR (RewardSnapShot ss pp nm dr1 r dt1 tot pot) =
+    encode
+      ( Rec RewardSnapShot !> To ss !> To pp !> To nm !> To dr1
+          !> To r
+          !> To dt1
+          !> To tot
+          !> To pot
+      )
+
+instance Era era => FromCBOR (RewardSnapShot era) where
+  fromCBOR = decode (RecD RewardSnapShot <! From <! From <! From <! From <! From <! From <! From <! From)
+
+-- | State used in the STS rules
+data PulsingRewUpdate m era
+  = Pulsing !(RewardSnapShot era) !(RewardPulser m era)
+  | Complete !(RewardUpdate (Crypto era))
+  deriving (Eq, Show, Generic, NoThunks)
+
+instance NFData (PulsingRewUpdate m era)
+
+instance (Typeable m, Era era) => ToCBOR (PulsingRewUpdate m era) where
+  toCBOR (Pulsing s p) = encode (Sum Pulsing 0 !> To s !> To p)
+  toCBOR (Complete r) = encode (Sum (Complete @m @era) 1 !> To r)
+
+instance (Monad m, Typeable m, Era era) => FromCBOR (PulsingRewUpdate m era) where
+  fromCBOR = decode (Summands "PulsingRewUpdate" decPS)
+    where
+      decPS 0 = (SumD Pulsing <! From <! From)
+      decPS 1 = (SumD Complete <! From)
+      decPS n = Invalid n
+
+-- ====================================================================
+-- Some generic lifting functions to lift one provenance computation
+-- into another, and one to lift a Pulser from one provenance type to
+-- another.  Then a specialisation on the Provenance types we use here.
+
+-- | Lift a Pulser in the ProvM monad, from one type of provenance (s1) to another (s2)
+pulseProvM ::
+  (Monad m, Pulsable pulse) =>
+  s1 ->
+  (s1 -> s2 -> s2) ->
+  pulse (ProvM s1 m) ans ->
+  ProvM s2 m (pulse (ProvM s1 m) ans)
+pulseProvM initial combine tma = liftProv (pulseM tma) initial (\_ s1 s2 -> combine s1 s2)
+
+-- | lift a pulseM function from (KeyHashPoolProvenance (Crypto era))
+--   provenance to (RewardProvenance (Crypto er)) provenance
+pulseOther :: Monad m => RewardPulser m era -> ProvM (RewardProvenance (Crypto era)) m (RewardPulser m era)
+pulseOther tma = pulseProvM Map.empty incrementProvenance tma
+
+-- | How to merge KeyHashPoolProvenance into RewardProvenance
+incrementProvenance :: (KeyHashPoolProvenance crypto) -> RewardProvenance crypto -> RewardProvenance crypto
+incrementProvenance provpools (prov@(RewardProvenance {pools = old})) = prov {pools = Map.union provpools old}
+
+-- =============================
+-- Phase 1 of a reward upate is a pure computation, computing some
+-- parameters which become fixed at the time when we reach the stability point.
+-- One of these pure results is a Pulser, i.e. a computation that when pulseM'ed
+-- computes a portion of what is required, so that the whole compuation can be spread out in time.
+
+startStep ::
+  forall era m.
+  (Monad m) =>
   EpochSize ->
   BlocksMade (Crypto era) ->
   EpochState era ->
   Coin ->
-  ProvM (RewardProvenance (Crypto era)) ShelleyBase (RewardUpdate (Crypto era))
-createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) maxSupply = do
-  asc <- lift (asks activeSlotCoeff)
+  ActiveSlotCoeff ->
+  (PulsingRewUpdate m era)
+startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) maxSupply asc =
   let SnapShot stake' delegs' poolParams = _pstakeGo ss
       Coin reserves = _reserves acnt
       ds = _dstate $ _delegationState ls
@@ -1107,76 +1219,132 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) ma
       deltaT1 = floor $ intervalValue (_tau pr) * fromIntegral rPot
       _R = Coin $ rPot - deltaT1
       totalStake = circulation es maxSupply
-  ((rs_, newLikelihoods), blackBoxPools) <-
-    runOtherProv
-      Map.empty
-      ( reward
-          pr
-          b
-          _R
-          (Map.keysSet $ _rewards ds)
-          poolParams
-          stake'
+      rewsnap =
+        RewardSnapShot
+          { rewSnapshots = ss,
+            rewPp = pr,
+            rewNonMyopic = nm,
+            rewDeltaR1 = deltaR1,
+            rewR = _R,
+            rewDeltaT1 = (Coin deltaT1),
+            rewTotalStake = totalStake,
+            rewRPot = (Coin rPot)
+          }
+      free =
+        FreeVars
+          (unBlocksMade b)
           delegs'
-          totalStake
+          stake'
+          (Map.keysSet $ _rewards ds)
+          (unCoin totalStake)
+          (unCoin (fold . unStake $ stake'))
           asc
-          slotsPerEpoch
-      )
-  let deltaR2 = _R <-> (sumRewards pr rs_)
-      -- add under 'key' the pair (LikeliHoodEstimate,Desirability) to the Map 'ans'
-      addDesire ans key likelihood = case Map.lookup key poolParams of
-        Nothing ->
-          -- This case should be unreachable, since a likelihood is calculated
-          -- for every registered stake pool
-          Map.insert
-            key
-            ( Desirability
-                { hitRateEstimate = unPerformanceEstimate estimate,
-                  desirabilityScore = 0
-                }
-            )
-            ans
-        Just pp ->
-          Map.insert
-            key
-            ( Desirability
-                { hitRateEstimate = unPerformanceEstimate estimate,
-                  desirabilityScore =
-                    desirability pr (Coin rPot) pp estimate totalStake
-                }
-            )
-            ans
-        where
-          estimate = (percentile' likelihood)
-  modifyWithBlackBox
-    blackBoxPools
-    ( \provPools _ ->
-        RewardProvenance
-          (unEpochSize slotsPerEpoch)
-          b
-          maxSupply
-          deltaR1
-          deltaR2
+          (sum (unBlocksMade b))
           _R
-          totalStake
-          blocksMade
-          d
-          expectedBlocks
-          eta
-          (Coin rPot)
-          (Coin deltaT1)
-          (fold . unStake $ stake')
-          provPools
-          (Map.foldlWithKey' addDesire Map.empty newLikelihoods)
-    )
-  pure $
-    RewardUpdate
-      { deltaT = (DeltaCoin deltaT1),
-        deltaR = ((invert $ toDeltaCoin deltaR1) <> toDeltaCoin deltaR2),
-        rs = rs_,
-        deltaF = (invert (toDeltaCoin $ _feeSS ss)),
-        nonMyopic = (updateNonMyopic nm _R newLikelihoods)
-      }
+          pr
+          slotsPerEpoch
+      pulser :: RewardPulser m era
+      pulser = SLP 2 (Close RewardStakePool :$ free) (Map.toList poolParams) (Map.empty, Map.empty)
+   in (Pulsing rewsnap pulser)
+
+-- Phase 2
+
+pulseStep ::
+  Monad m =>
+  PulsingRewUpdate m era ->
+  ProvM (RewardProvenance (Crypto era)) m (PulsingRewUpdate m era)
+pulseStep (Complete r) = pure (Complete r)
+pulseStep (p@(Pulsing _ pulser)) | done pulser = completeStep p
+pulseStep (Pulsing rewsnap pulser) = do
+  p2 <- (pulseOther pulser)
+  pure (Pulsing rewsnap p2)
+
+-- Phase 3
+
+completeStep ::
+  Monad m =>
+  PulsingRewUpdate m era ->
+  ProvM (RewardProvenance (Crypto era)) m (PulsingRewUpdate m era)
+completeStep (Complete r) = pure (Complete r)
+completeStep (Pulsing rewsnap pulser) = do
+  p2 <- completeRupd (Pulsing rewsnap pulser)
+  pure (Complete p2)
+
+-- | Phase 3 of reward update has several parts
+--   a) completeM the pulser (in case there are still computions to run)
+--   b) Combine the pulser provenance with the RewardProvenance
+--   c) Construct the final RewardUpdate
+completeRupd ::
+  Monad m =>
+  PulsingRewUpdate m era ->
+  ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era))
+completeRupd (Complete x) = pure x
+completeRupd
+  ( Pulsing
+      ( RewardSnapShot
+          { rewDeltaR1 = deltaR1,
+            rewR = oldr,
+            rewDeltaT1 = (Coin deltaT1),
+            rewNonMyopic = nm,
+            rewTotalStake = totalstake,
+            rewRPot = rpot,
+            rewSnapshots = snaps,
+            rewPp = protparam
+          }
+        )
+      pulser
+    ) = do
+    let combine (rs, likely) provPools (rewprov@RewardProvenance {pools = old}) =
+          rewprov
+            { deltaR2 = oldr <-> (sumRewards protparam rs),
+              pools = Map.union provPools old,
+              desirabilities = (Map.foldlWithKey' addDesireability Map.empty likely)
+            }
+        -- A function to compute the 'desirablity' aggregate. Called only if we are computing
+        -- provenance. Adds nested pair ('key',(LikeliHoodEstimate,Desirability)) to the Map 'ans'
+        addDesireability ans key likelihood =
+          let SnapShot _ _ poolParams = _pstakeGo snaps
+              estimate = (percentile' likelihood)
+           in Map.insert
+                key
+                ( Desirability
+                    { hitRateEstimate = unPerformanceEstimate estimate,
+                      desirabilityScore = case Map.lookup key poolParams of
+                        Just ppx -> desirability protparam rpot ppx estimate totalstake
+                        Nothing -> 0
+                    }
+                )
+                ans
+    (rs_, newLikelihoods) <- liftProv (completeM pulser) Map.empty combine
+    let deltaR2 = oldr <-> (sumRewards protparam rs_)
+    pure $
+      RewardUpdate
+        { deltaT = (DeltaCoin deltaT1),
+          deltaR = ((invert $ toDeltaCoin deltaR1) <> toDeltaCoin deltaR2),
+          rs = rs_,
+          deltaF = (invert (toDeltaCoin $ _feeSS snaps)),
+          nonMyopic = (updateNonMyopic nm oldr newLikelihoods)
+        }
+
+-- | To create a reward update, run all 3 phases
+createRUpd ::
+  forall era m.
+  (Monad m) =>
+  EpochSize ->
+  BlocksMade (Crypto era) ->
+  EpochState era ->
+  Coin ->
+  ActiveSlotCoeff ->
+  ProvM (RewardProvenance (Crypto era)) m (RewardUpdate (Crypto era))
+createRUpd slotsPerEpoch blocksmade epstate maxSupply asc = do
+  step1 <- pure $ startStep slotsPerEpoch blocksmade epstate maxSupply asc
+  step2 <- pulseStep step1
+  step3 <- completeRupd step2
+  pure step3
+
+-- completeStep $ startStep slotsPerEpoch b es maxsupply asc
+
+-- =====================================================================
 
 -- | Calculate the current circulation
 --
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs
index aa125a131b5..c4ff6357f6d 100644
--- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs
+++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Orphans.hs
@@ -5,13 +5,14 @@
 
 module Shelley.Spec.Ledger.Orphans where
 
+import Cardano.Binary (FromCBOR, ToCBOR)
 import Cardano.Crypto.Hash (Hash (..))
 import qualified Cardano.Crypto.Hash as Hash
 import qualified Cardano.Crypto.Hash.Class as HS
 import Cardano.Crypto.Util (SignableRepresentation (..))
 import qualified Cardano.Crypto.Wallet as WC
 import Cardano.Prelude (HeapWords (..), readEither)
-import Cardano.Slotting.Slot (WithOrigin (..))
+import Cardano.Slotting.Slot (EpochSize (..), WithOrigin (..))
 import Control.DeepSeq (NFData (rnf))
 import Data.Aeson
 import qualified Data.ByteString as Long (ByteString, empty)
@@ -113,3 +114,9 @@ instance Default Bool where
   def = False
 
 deriving newtype instance HeapWords (HS.Hash h a)
+
+deriving newtype instance ToCBOR EpochSize
+
+deriving newtype instance NFData EpochSize
+
+deriving newtype instance FromCBOR EpochSize
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs
index f43827de0a8..64344103972 100644
--- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs
+++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/RewardProvenance.hs
@@ -78,12 +78,16 @@ instance NoThunks Desirability
 
 instance NFData Desirability
 
+-- | RewardProvenenace captures some of the intermediate calculations when computimg
+--     the statking reward distribution, most of these fields are simple scalar
+--     values, computed from the current State, and are fixed before we start to compute
+--     the distribution. 3 of them are aggregates computed when we compute the distribution.
 data RewardProvenance crypto = RewardProvenance
   { spe :: !Word64,
     blocks :: !(BlocksMade crypto),
     maxLL :: !Coin,
     deltaR1 :: !Coin,
-    deltaR2 :: !Coin,
+    deltaR2 :: !Coin, -- Aggregate
     r :: !Coin,
     totalStake :: !Coin,
     blocksCount :: !Integer,
@@ -93,12 +97,13 @@ data RewardProvenance crypto = RewardProvenance
     rPot :: !Coin,
     deltaT1 :: !Coin,
     activeStake :: !Coin,
-    pools ::
+    pools :: -- Aggregate
       !( Map
            (KeyHash 'StakePool crypto)
            (RewardProvenancePool crypto)
        ),
-    desirabilities :: !(Map (KeyHash 'StakePool crypto) Desirability)
+    desirabilities :: -- Aggregate
+      !(Map (KeyHash 'StakePool crypto) Desirability)
   }
   deriving (Eq, Generic)
 
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs
index d1d08470c76..90e48fe5a92 100644
--- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs
+++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs
@@ -2,12 +2,19 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Shelley.Spec.Ledger.Rewards
   ( desirability,
@@ -19,6 +26,7 @@ module Shelley.Spec.Ledger.Rewards
     RewardType (..),
     Reward (..),
     reward,
+    rewardPulser,
     nonMyopicStake,
     nonMyopicMemberRew,
     percentile',
@@ -32,6 +40,12 @@ module Shelley.Spec.Ledger.Rewards
     memberRew,
     aggregateRewards,
     sumRewards,
+    RewardStakePool (..),
+    FreeVars (..),
+    KeyHashPoolProvenance,
+    RewardAns,
+    PulseItem,
+    RewardPulser,
   )
 where
 
@@ -45,27 +59,31 @@ import Cardano.Binary
     encodeWord,
   )
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
-import Cardano.Ledger.Era (Crypto)
+import Cardano.Ledger.Era (Crypto, Era)
 import Cardano.Ledger.Val ((<->))
-import Cardano.Slotting.Slot (EpochSize)
+import Cardano.Slotting.Slot (EpochSize (..))
 import Control.DeepSeq (NFData)
 import Control.Provenance (ProvM, modifyM)
-import Data.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
+import Data.Closure (Closure (..), Named (..))
+import Data.Coders (Decode (..), Encode (..), decode, encode, fromMap, fromSet, toMap, toSet, (!>), (<!))
 import Data.Default.Class (Default, def)
 import Data.Foldable (find, fold)
 import Data.Function (on)
+import Data.Kind (Type)
 import Data.List (sortBy)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
+import Data.Pulse (SLP (..), completeM)
 import Data.Ratio ((%))
 import qualified Data.Sequence as Seq
 import Data.Sequence.Strict (StrictSeq)
 import qualified Data.Sequence.Strict as StrictSeq
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
-import NoThunks.Class (NoThunks (..))
+import NoThunks.Class (InspectHeapNamed (..), NoThunks (..))
 import Numeric.Natural (Natural)
 import Quiet
 import Shelley.Spec.Ledger.BaseTypes
@@ -546,9 +564,36 @@ rewardOnePool
             lRewardP = lReward
           }
 
+-- ==============================================================================
+-- Type synonyms for the complicated types that make up the reward calculation with Pulsing
+
+-- | The result of reward calculation is a pair of aggregate Maps.
+type RewardAns c =
+  ( Map (Credential 'Staking c) (Set (Reward c)),
+    Map (KeyHash 'StakePool c) Likelihood
+  )
+
+-- | We pulse on the list of these pairs
+type PulseItem c = (KeyHash 'StakePool c, PoolParams c)
+
+-- | The provenance we collect
+type KeyHashPoolProvenance c = Map (KeyHash 'StakePool c) (RewardProvenancePool c)
+
+-- | The type of a Pulser which uses 'rewardStakePool' as its underlying function
+--     which is partially applied to an argument of type (FreeVars era)
+type RewardPulser m era =
+  SLP
+    (RewardStakePool m era (Crypto era))
+    ('[FreeVars era])
+    (PulseItem (Crypto era))
+    (ProvM (KeyHashPoolProvenance (Crypto era)) m)
+    (RewardAns (Crypto era))
+
+-- ===============================================================================
+
 reward ::
   forall m era.
-  Monad m =>
+  (Monad m) =>
   PParams era ->
   BlocksMade (Crypto era) ->
   Coin ->
@@ -560,12 +605,29 @@ reward ::
   ActiveSlotCoeff ->
   EpochSize ->
   ProvM
-    (Map (KeyHash 'StakePool (Crypto era)) (RewardProvenancePool (Crypto era)))
+    (KeyHashPoolProvenance (Crypto era))
     m
     ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
       Map (KeyHash 'StakePool (Crypto era)) Likelihood
     )
-reward
+reward pp bm r addrsRew poolParams stake delegs tot asc slotsPerEpoch =
+  completeM (rewardPulser pp bm r addrsRew poolParams stake delegs tot asc slotsPerEpoch)
+
+rewardPulser ::
+  forall m era.
+  (Monad m) =>
+  PParams era ->
+  BlocksMade (Crypto era) ->
+  Coin ->
+  Set (Credential 'Staking (Crypto era)) ->
+  Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era)) ->
+  Stake (Crypto era) ->
+  Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)) ->
+  Coin ->
+  ActiveSlotCoeff ->
+  EpochSize ->
+  RewardPulser m era
+rewardPulser
   pp
   (BlocksMade b)
   r
@@ -575,39 +637,137 @@ reward
   delegs
   (Coin totalStake)
   asc
-  slotsPerEpoch = do
-    let totalBlocks = sum b
-        Coin activeStake = fold . unStake $ stake
-        combine = Map.unionWith Set.union
-        -- We fold 'action' over the pairs in the poolParams Map to compute a pair of maps.
-        -- we must use a right associative fold. See comments on foldListM below.
-        action (hk, pparams) (m1, m2) = 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 (combine m m1, Map.insert hk ls m2)
-    foldListM action (Map.empty, Map.empty) (Map.toList poolParams)
-
--- | Fold a monadic function 'accum' over a list. It is strict in its accumulating parameter.
---   since the order matters in 'aggregate' (used in reward above) we need to use the same
---   order as previous revisions. That's why we call foldListM before applying accum.
-foldListM :: Monad m => (k -> ans -> m ans) -> ans -> [k] -> m ans
-foldListM _accum ans [] = pure ans
--- Order matters so we don't use this clause (as it associates to the left)
--- foldListM accum ans (k:more) = do { !ans1 <- accum k ans; foldListM accum ans1 more }
--- instead we use this one that associates to the right.
-foldListM accum ans (k : more) = do ans1 <- foldListM accum ans more; accum k ans1
+  slotsPerEpoch = pulser
+    where
+      totalBlocks = sum b
+      Coin activeStake = fold . unStake $ stake
+      free = (FreeVars b delegs stake addrsRew totalStake activeStake asc totalBlocks r pp slotsPerEpoch)
+      closure = (Close RewardStakePool :$ free)
+      pulser :: RewardPulser m era
+      pulser = SLP 2 closure (Map.toList poolParams) (Map.empty, Map.empty)
+
+-- ========================================================
+-- FreeVars is the set of variables needed to compute
+-- rewardStakePool, so that it can be made into a serializable
+-- Pulsable function.
+
+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
+  }
+  deriving (Show, Eq, Generic)
+
+deriving via InspectHeapNamed "FreeVars" (FreeVars era) instance NoThunks (FreeVars era)
+
+instance NFData (FreeVars era)
+
+instance (Era era) => ToCBOR (FreeVars era) where
+  toCBOR (FreeVars {b, delegs, stake, addrsRew, totalStake, activeStake, asc, totalBlocks, r, pp, slotsPerEpoch}) =
+    encode
+      ( Rec FreeVars !> toMap b !> toMap delegs !> To stake !> toSet addrsRew
+          !> To totalStake
+          !> To activeStake
+          !> To asc
+          !> To totalBlocks
+          !> To r
+          !> To pp
+          !> To slotsPerEpoch
+      )
+
+instance Era era => FromCBOR (FreeVars era) where
+  fromCBOR =
+    decode
+      ( RecD FreeVars <! fromMap {- b -} <! fromMap {- delegs -} <! From {- stake -} <! fromSet {- addrsRew -}
+          <! From {- totalStake -}
+          <! From {- activeStake -}
+          <! From {- asc -}
+          <! From {- totalBlocks -}
+          <! From {- r -}
+          <! From {- pp -}
+          <! From {- slotsPerEpoch -}
+      )
+
+-- ==================================================
+-- The function rewardStakePool (below), is uniquely identified by the
+-- value    RewardStakePool :: (RewardStakePool m era c)
+-- in the (Names (RewardStakePool m era c) ...) instance below.
+-- The pulser folds rewardStakePool over the poolParams.
+
+-- The function that we call on each pulseM
+rewardStakePool ::
+  forall era.
+  FreeVars era ->
+  RewardAns (Crypto era) ->
+  PulseItem (Crypto era) ->
+  ( forall m.
+    Monad m =>
+    ProvM
+      (KeyHashPoolProvenance (Crypto era))
+      m
+      (RewardAns (Crypto era))
+  )
+rewardStakePool
+  (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)
+
+-- ====================================================
+
+-- | The Unit type uniquely associated with the rewardStakePool function
+data RewardStakePool (m :: Type -> Type) era c = RewardStakePool deriving (Eq, Show, Generic)
+
+instance NoThunks (RewardStakePool m era c)
+
+instance NFData (RewardStakePool m era c)
+
+instance (Typeable era, Typeable m, Typeable c) => ToCBOR (RewardStakePool m era c) where
+  toCBOR RewardStakePool = mempty
+
+instance (Typeable era, Typeable m, Typeable c) => FromCBOR (RewardStakePool m era c) where
+  fromCBOR = pure RewardStakePool
+
+-- | The Named instance that associates (RewardStakePool m era c) with the function rewardStakePool
+instance
+  (Monad m, c ~ Crypto era) =>
+  Named
+    (RewardStakePool m era c)
+    ( FreeVars era ->
+      RewardAns c ->
+      PulseItem c ->
+      ProvM
+        (KeyHashPoolProvenance c)
+        m
+        (RewardAns c)
+    )
+  where
+  value RewardStakePool = rewardStakePool
+  name RewardStakePool = "rewardStakePool"
+
+-- ==========================================================
 
 -- | Compute the Non-Myopic Pool Stake
 --
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs
index c9168b95725..a7b1e83aca6 100644
--- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs
+++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs
@@ -24,6 +24,7 @@ import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era (Crypto, Era)
 import Cardano.Ledger.Shelley.Constraints (UsesTxOut, UsesValue)
 import qualified Cardano.Ledger.Val as Val
+import Control.Provenance (runProvM)
 import Control.State.Transition
 import Data.Default.Class (Default, def)
 import qualified Data.Map.Strict as Map
@@ -79,7 +80,8 @@ instance
     Environment (Core.EraRule "EPOCH" era) ~ (),
     State (Core.EraRule "EPOCH" era) ~ EpochState era,
     Signal (Core.EraRule "EPOCH" era) ~ EpochNo,
-    Default (EpochState era)
+    Default (EpochState era),
+    Default (State (Core.EraRule "PPUP" era))
   ) =>
   STS (NEWEPOCH era)
   where
@@ -114,7 +116,10 @@ newEpochTransition ::
     Signal (Core.EraRule "MIR" era) ~ (),
     Environment (Core.EraRule "EPOCH" era) ~ (),
     State (Core.EraRule "EPOCH" era) ~ EpochState era,
-    Signal (Core.EraRule "EPOCH" era) ~ EpochNo
+    Signal (Core.EraRule "EPOCH" era) ~ EpochNo,
+    UsesTxOut era,
+    UsesValue era,
+    Default (State (Core.EraRule "PPUP" era))
   ) =>
   TransitionRule (NEWEPOCH era)
 newEpochTransition = do
@@ -129,7 +134,12 @@ newEpochTransition = do
     else do
       es' <- case ru of
         SNothing -> pure es
-        SJust ru' -> do
+        SJust (p@(Pulsing _ _)) -> do
+          ru'@(RewardUpdate dt dr rs_ df _) <- liftSTS $ runProvM $ completeRupd p
+          let totRs = sumRewards (esPrevPp es) rs_
+          Val.isZero (dt <> (dr <> (toDeltaCoin totRs) <> df)) ?! CorruptRewardUpdate ru'
+          pure $ applyRUpd ru' es
+        SJust (Complete ru') -> do
           let RewardUpdate dt dr rs_ df _ = ru'
               totRs = sumRewards (esPrevPp es) rs_
           Val.isZero (dt <> (dr <> (toDeltaCoin totRs) <> df)) ?! CorruptRewardUpdate ru'
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs
index dcb0d00c388..e5d21e73977 100644
--- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs
+++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Rupd.hs
@@ -9,10 +9,23 @@ module Shelley.Spec.Ledger.STS.Rupd
     RupdEnv (..),
     PredicateFailure,
     RupdPredicateFailure,
+    epochInfoRange,
+    PulsingRewUpdate (..),
+    startStep,
+    pulseStep,
+    completeStep,
+    lift,
+    Identity (..),
+    createRUpd,
   )
 where
 
 import Cardano.Ledger.Era (Crypto, Era)
+-- RewardUpdate,
+
+import Cardano.Slotting.EpochInfo.API (epochInfoRange)
+import Control.Monad.Identity (Identity (..))
+import Control.Monad.Trans (lift)
 import Control.Monad.Trans.Reader (asks)
 import Control.Provenance (runProvM)
 import Control.State.Transition
@@ -28,13 +41,21 @@ import NoThunks.Class (NoThunks (..))
 import Shelley.Spec.Ledger.BaseTypes
   ( ShelleyBase,
     StrictMaybe (..),
+    activeSlotCoeff,
     epochInfo,
     maxLovelaceSupply,
     randomnessStabilisationWindow,
   )
 import Shelley.Spec.Ledger.Coin (Coin (..))
 import Shelley.Spec.Ledger.EpochBoundary (BlocksMade)
-import Shelley.Spec.Ledger.LedgerState (EpochState, RewardUpdate, createRUpd)
+import Shelley.Spec.Ledger.LedgerState
+  ( EpochState,
+    PulsingRewUpdate (..),
+    completeStep,
+    createRUpd,
+    pulseStep,
+    startStep,
+  )
 import Shelley.Spec.Ledger.Slot
   ( Duration (..),
     SlotNo,
@@ -54,6 +75,7 @@ data RupdPredicateFailure era -- No predicate failures
 
 instance NoThunks (RupdPredicateFailure era)
 
+{-
 instance (Era era) => STS (RUPD era) where
   type State (RUPD era) = StrictMaybe (RewardUpdate (Crypto era))
   type Signal (RUPD era) = SlotNo
@@ -67,14 +89,15 @@ instance (Era era) => STS (RUPD era) where
 rupdTransition :: Era era => TransitionRule (RUPD era)
 rupdTransition = do
   TRC (RupdEnv b es, ru, s) <- judgmentContext
-  (slotsPerEpoch, slot, maxLL) <- liftSTS $ do
+  (slotsPerEpoch, slot, maxLL, asc) <- liftSTS $ do
     ei <- asks epochInfo
     sr <- asks randomnessStabilisationWindow
     e <- epochInfoEpoch ei s
     slotsPerEpoch <- epochInfoSize ei e
     slot <- epochInfoFirst ei e <&> (+* (Duration sr))
     maxLL <- asks maxLovelaceSupply
-    return (slotsPerEpoch, slot, maxLL)
+    asc <- asks activeSlotCoeff
+    return (slotsPerEpoch, slot, maxLL, asc)
   if s <= slot
     then pure ru
     else case ru of
@@ -87,5 +110,48 @@ rupdTransition = do
                       b
                       es
                       (Coin (fromIntegral maxLL))
+                      asc
               )
       SJust _ -> pure ru
+-}
+
+instance (Era era) => STS (RUPD era) where
+  type State (RUPD era) = StrictMaybe (PulsingRewUpdate ShelleyBase era)
+  type Signal (RUPD era) = SlotNo
+  type Environment (RUPD era) = RupdEnv era
+  type BaseM (RUPD era) = ShelleyBase
+  type PredicateFailure (RUPD era) = RupdPredicateFailure era
+
+  initialRules = [pure SNothing]
+  transitionRules = [rupdTransition]
+
+rupdTransition :: Era era => TransitionRule (RUPD era)
+rupdTransition = do
+  TRC (RupdEnv b es, ru, s) <- judgmentContext
+  (slotsPerEpoch, slot, maxLL, asc, lastblock) <- liftSTS $ do
+    ei <- asks epochInfo
+    sr <- asks randomnessStabilisationWindow
+    e <- epochInfoEpoch ei s
+    slotsPerEpoch <- epochInfoSize ei e
+    slot <- epochInfoFirst ei e <&> (+* (Duration sr))
+    (_first, lastblock) <- lift (epochInfoRange ei e)
+    maxLL <- asks maxLovelaceSupply
+    asc <- asks activeSlotCoeff
+    return (slotsPerEpoch, slot, maxLL, asc, lastblock)
+  let maxsupply = Coin (fromIntegral maxLL)
+  case (s <= slot, s == lastblock) of
+    -- Waiting for the stabiliy point, do nothing, keep waiting
+    (True, _) -> pure SNothing
+    -- (False, _) | ((2 * 2 == 2 + (2 :: Int))) -> liftSTS $ runProvM $ (SJust . Complete) <$> createRUpd slotsPerEpoch b es maxsupply asc
+    -- We are in the last block, finish everything up
+    (False, True) ->
+      case ru of
+        SNothing -> liftSTS $ runProvM $ SJust <$> completeStep (startStep slotsPerEpoch b es maxsupply asc)
+        (SJust (p@(Pulsing _ _))) -> SJust <$> (liftSTS $ runProvM $ completeStep p)
+        (SJust (p@(Complete _))) -> pure (SJust p)
+    -- More blocks to come, get things started or take a step
+    (False, False) ->
+      case ru of
+        SNothing -> liftSTS $ runProvM $ pure $ SJust $ startStep slotsPerEpoch b es maxsupply asc
+        (SJust (p@(Pulsing _ _))) -> liftSTS $ runProvM $ (SJust <$> pulseStep p)
+        (SJust (p@(Complete _))) -> pure (SJust p)
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs
index 31a3e021656..aa3a280c1f4 100644
--- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs
+++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Tick.hs
@@ -23,7 +23,7 @@ module Shelley.Spec.Ledger.STS.Tick
 where
 
 import qualified Cardano.Ledger.Core as Core
-import Cardano.Ledger.Era (Era (Crypto))
+import Cardano.Ledger.Era (Era)
 import Cardano.Ledger.Shelley.Constraints (UsesTxOut, UsesValue)
 import Control.Monad.Trans.Reader (asks)
 import Control.SetAlgebra (eval, (⨃))
@@ -31,17 +31,9 @@ import Control.State.Transition
 import qualified Data.Map.Strict as Map
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
-import Shelley.Spec.Ledger.BaseTypes (ShelleyBase, StrictMaybe, epochInfo)
+import Shelley.Spec.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..), epochInfo)
 import Shelley.Spec.Ledger.Keys (GenDelegs (..))
-import Shelley.Spec.Ledger.LedgerState
-  ( DPState (..),
-    DState (..),
-    EpochState (..),
-    FutureGenDeleg (..),
-    LedgerState (..),
-    NewEpochState (..),
-    RewardUpdate,
-  )
+import Shelley.Spec.Ledger.LedgerState (DPState (..), DState (..), EpochState (..), FutureGenDeleg (..), LedgerState (..), NewEpochState (..), PulsingRewUpdate)
 import Shelley.Spec.Ledger.STS.NewEpoch (NEWEPOCH, NewEpochPredicateFailure)
 import Shelley.Spec.Ledger.STS.Rupd (RUPD, RupdEnv (..), RupdPredicateFailure)
 import Shelley.Spec.Ledger.Slot (EpochNo, SlotNo, epochInfoEpoch)
@@ -80,7 +72,7 @@ instance
     State (TICK era) ~ NewEpochState era,
     BaseM (TICK era) ~ ShelleyBase,
     Environment (Core.EraRule "RUPD" era) ~ RupdEnv era,
-    State (Core.EraRule "RUPD" era) ~ StrictMaybe (RewardUpdate (Crypto era)),
+    State (Core.EraRule "RUPD" era) ~ StrictMaybe (PulsingRewUpdate ShelleyBase era),
     Signal (Core.EraRule "RUPD" era) ~ SlotNo,
     Environment (Core.EraRule "NEWEPOCH" era) ~ (),
     State (Core.EraRule "NEWEPOCH" era) ~ NewEpochState era,
@@ -163,7 +155,7 @@ bheadTransition ::
     State (TICK era) ~ NewEpochState era,
     BaseM (TICK era) ~ ShelleyBase,
     Environment (Core.EraRule "RUPD" era) ~ RupdEnv era,
-    State (Core.EraRule "RUPD" era) ~ StrictMaybe (RewardUpdate (Crypto era)),
+    State (Core.EraRule "RUPD" era) ~ StrictMaybe (PulsingRewUpdate ShelleyBase era),
     Signal (Core.EraRule "RUPD" era) ~ SlotNo,
     Environment (Core.EraRule "NEWEPOCH" era) ~ (),
     State (Core.EraRule "NEWEPOCH" era) ~ NewEpochState era,
diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs
index 8770f6db8ba..51e8e207d48 100644
--- a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs
+++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs
@@ -30,7 +30,7 @@ import Shelley.Spec.Ledger.Address
     mkRwdAcnt,
   )
 import Shelley.Spec.Ledger.BaseTypes
-  ( Globals (epochInfo),
+  ( Globals (epochInfo,activeSlotCoeff),
     Network (Testnet),
     StrictMaybe (..),
     truncateUnitInterval,
@@ -177,7 +177,7 @@ createRUpd ::
 createRUpd globals cs =
   runIdentity $
     runReaderT
-      (runProvM (LS.createRUpd epochSize bm es total))
+      (runProvM (LS.createRUpd epochSize bm es total asc))
       globals
   where
     nes = chainNes cs
@@ -187,6 +187,7 @@ createRUpd globals cs =
     epochSize =
       runIdentity $
         epochInfoSize (epochInfo globals) (LS.nesEL nes)
+    asc = activeSlotCoeff globals
 
 
 -- | Benchmark creating a reward update.
@@ -197,7 +198,7 @@ createRUpdWithProv ::
 createRUpdWithProv globals cs =
   runIdentity $
     runReaderT
-      (runWithProvM def (LS.createRUpd epochSize bm es total))
+      (runWithProvM def (LS.createRUpd epochSize bm es total asc))
       globals
   where
     nes = chainNes cs
@@ -207,3 +208,4 @@ createRUpdWithProv globals cs =
     epochSize =
       runIdentity $
         epochInfoSize (epochInfo globals) (LS.nesEL nes)
+    asc = activeSlotCoeff globals
diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs
index 7975f9cd63b..855f0a0abda 100644
--- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs
+++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs
@@ -92,6 +92,7 @@ import Shelley.Spec.Ledger.Delegation.Certificates (IndividualPoolStake (..))
 import Shelley.Spec.Ledger.EpochBoundary (BlocksMade (..))
 import Shelley.Spec.Ledger.LedgerState
   ( FutureGenDeleg,
+    PulsingRewUpdate(..),
   )
 import qualified Shelley.Spec.Ledger.Metadata as MD
 import Shelley.Spec.Ledger.RewardProvenance
@@ -899,3 +900,7 @@ instance
       <*> arbitrary
       <*> arbitrary
       <*> arbitrary
+
+instance (Monad m,Era era) => Arbitrary (PulsingRewUpdate m era) where
+   arbitrary = Complete <$> arbitrary
+      -- We don't generate any (Pulsing _ _), because they follow from SNothing
\ No newline at end of file
diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs
index 35c7d70384f..10d975caa2c 100644
--- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs
+++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs
@@ -57,7 +57,7 @@ import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
 import Data.Word (Word64)
 import GHC.Records (HasField)
-import Shelley.Spec.Ledger.BaseTypes (Nonce (..), StrictMaybe (..), (⭒))
+import Shelley.Spec.Ledger.BaseTypes (Nonce (..), StrictMaybe(..), (⭒))
 import Shelley.Spec.Ledger.BlockChain
   ( BHBody (..),
     Block (..),
@@ -93,6 +93,7 @@ import Shelley.Spec.Ledger.LedgerState
     PPUPState (..),
     PState (..),
     RewardUpdate (..),
+    PulsingRewUpdate(..),
     UTxOState (..),
     applyRUpd,
   )
@@ -481,7 +482,7 @@ rewardUpdate ::
   ChainState era
 rewardUpdate ru cs = cs {chainNes = nes'}
   where
-    nes' = (chainNes cs) {nesRu = SJust ru}
+    nes' = (chainNes cs) {nesRu = SJust(Complete ru)}
 
 -- | = Apply a Reward Update
 --
diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs
index 172b83be03a..1b6a44dae6b 100644
--- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs
+++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs
@@ -387,7 +387,7 @@ justRewardInfo ::
   RewardUpdate (Crypto era)
 justRewardInfo globals newepochstate  =
   runReader
-    (runProvM $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply)
+    (runProvM $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc)
     globals
   where
     epochstate = nesEs newepochstate
@@ -398,6 +398,7 @@ justRewardInfo globals newepochstate  =
     epochnumber = nesEL newepochstate
     slotsPerEpoch :: EpochSize
     slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals
+    asc = activeSlotCoeff globals
 
 sameWithOrWithoutProvenance ::
  forall era.
@@ -410,7 +411,7 @@ sameWithOrWithoutProvenance globals newepochstate = with == without
 nothingInNothingOut :: forall era. NewEpochState era -> Bool
 nothingInNothingOut newepochstate  =
   runReader
-    (preservesNothing $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply)
+    (preservesNothing $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc)
     globals
   where
     globals = testGlobals
@@ -422,11 +423,12 @@ nothingInNothingOut newepochstate  =
     epochnumber = nesEL newepochstate
     slotsPerEpoch :: EpochSize
     slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals
+    asc = activeSlotCoeff globals
 
 justInJustOut :: forall era. NewEpochState era -> Bool
 justInJustOut newepochstate  =
   runReader
-    (preservesJust def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply)
+    (preservesJust def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc)
     globals
   where
     globals = testGlobals
@@ -438,6 +440,7 @@ justInJustOut newepochstate  =
     epochnumber = nesEL newepochstate
     slotsPerEpoch :: EpochSize
     slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals
+    asc = activeSlotCoeff globals
 
 -- ====================================================================================
 -- To demonstrate that the code we wrote that enables provenance collection does not
@@ -651,9 +654,10 @@ oldEqualsNew  newepochstate  = old == new
     epochnumber = nesEL newepochstate
     slotsPerEpoch :: EpochSize
     slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals
-    unAggregated = runReader (runProvM $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply) globals
+    unAggregated = runReader (runProvM $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc) globals
     old = rsOld $ runReader (createRUpdOld slotsPerEpoch blocksmade epochstate maxsupply) globals
     new = aggregateRewards @era (emptyPParams {_protocolVersion = ProtVer 2 0}) (rs unAggregated)
+    asc = activeSlotCoeff globals
 
 oldEqualsNewOn:: forall era. NewEpochState era -> Bool
 oldEqualsNewOn  newepochstate  = old == new
@@ -667,9 +671,10 @@ oldEqualsNewOn  newepochstate  = old == new
     epochnumber = nesEL newepochstate
     slotsPerEpoch :: EpochSize
     slotsPerEpoch = runReader (epochInfoSize (epochInfo globals) epochnumber) globals
-    (unAggregated,_) = runReader (runWithProvM def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply) globals
+    (unAggregated,_) = runReader (runWithProvM def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc) globals
     old = rsOld $ runReader (createRUpdOld slotsPerEpoch blocksmade epochstate maxsupply) globals
     new = aggregateRewards @era (emptyPParams {_protocolVersion = ProtVer 2 0}) (rs unAggregated)
+    asc = activeSlotCoeff globals
 
 
 -- ==================================================================
diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs
index 874ab8620e1..05acc50d342 100644
--- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs
+++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs
@@ -127,6 +127,7 @@ import Shelley.Spec.Ledger.LedgerState
     EpochState (..),
     NewEpochState (..),
     RewardUpdate (..),
+    PulsingRewUpdate(Complete),
   )
 import qualified Shelley.Spec.Ledger.Metadata as MD
 import Shelley.Spec.Ledger.OCert
@@ -1294,7 +1295,7 @@ tests =
           nm = def
           es = EpochState @C ac ss ls pps pps nm
           ru =
-            ( SJust
+            ( Complete $
                 RewardUpdate
                   { deltaT = DeltaCoin 100,
                     deltaR = DeltaCoin (-200),
@@ -1302,8 +1303,7 @@ tests =
                     deltaF = DeltaCoin (-10),
                     nonMyopic = nm
                   }
-            ) ::
-              StrictMaybe (RewardUpdate C_Crypto)
+            )
           pd = PoolDistr @C_Crypto Map.empty
           nes =
             NewEpochState
@@ -1311,7 +1311,7 @@ tests =
               (BlocksMade bs)
               (BlocksMade bs)
               es
-              ru
+              (SJust ru)
               pd
        in checkEncodingCBOR
             "new_epoch_state"
@@ -1321,7 +1321,7 @@ tests =
                 <> S (BlocksMade @C_Crypto bs)
                 <> S (BlocksMade @C_Crypto bs)
                 <> S es
-                <> S ru
+                <> S (SJust ru)
                 <> S pd
             )
     ]