diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs
index 3a337464cba..a2edd7eb9b4 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs
+++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs
@@ -116,7 +116,7 @@ reapRewards ::
   UMap c
 reapRewards (UMap tmap ptrmap) withdrawals = UMap (Map.mapWithKey g tmap) ptrmap
   where
-    g k (Triple x y z) = Triple (fmap (removeRewards k) x) y z
+    g k (Triple x y z w) = Triple (fmap (removeRewards k) x) y z w
     removeRewards k v@(RDPair _ d) =
       if k `Map.member` withdrawals then RDPair (CompactCoin 0) d else v
 
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs
index 4126a787bcd..57721c06fd9 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs
+++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs
@@ -265,7 +265,7 @@ delegsTransition = do
             | (RewardAcnt _ cred, coin) <- Map.toList withdrawals_
             ]
         f :: Coin -> Trip (EraCrypto era) -> Bool
-        f coin1 (Triple (SJust (UM.RDPair coin2 _)) _ _) = coin1 == (fromCompact coin2)
+        f coin1 (Triple (SJust (UM.RDPair coin2 _)) _ _ _) = coin1 == (fromCompact coin2)
         f _ _ = False
 
 instance
diff --git a/eras/shelley/test-suite/bench/BenchUTxOAggregate.hs b/eras/shelley/test-suite/bench/BenchUTxOAggregate.hs
index 5d4a993aa72..48580b5a77c 100644
--- a/eras/shelley/test-suite/bench/BenchUTxOAggregate.hs
+++ b/eras/shelley/test-suite/bench/BenchUTxOAggregate.hs
@@ -91,7 +91,7 @@ makeStatePair ::
   (DState c, PState c)
 makeStatePair rewards' delegs ptrs' poolParams =
   ( DState
-      (UM.unify (Map.map rdPair rewards') delegs ptrs')
+      (UM.unify (Map.map rdPair rewards') delegs ptrs' Map.empty)
       Map.empty
       (GenDelegs Map.empty)
       (InstantaneousRewards Map.empty Map.empty mempty mempty)
diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs
index 3065c0a9678..7bd1bfc1e30 100644
--- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs
+++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs
@@ -241,6 +241,7 @@ registerGenesisStaking
                 (Map.map pairWithDepositsButNoRewards . Map.mapKeys KeyHashObj . LM.toMap $ sgsStake)
                 (Map.mapKeys KeyHashObj $ LM.toMap sgsStake)
                 (UM.ptrView (dsUnified (dpsDState oldDPState)))
+                Map.empty
           }
 
       -- We consider pools as having been registered in slot 0
diff --git a/libs/cardano-data/cardano-data.cabal b/libs/cardano-data/cardano-data.cabal
index 8e3ead5d72e..21e7e2b8853 100644
--- a/libs/cardano-data/cardano-data.cabal
+++ b/libs/cardano-data/cardano-data.cabal
@@ -23,6 +23,7 @@ library
         Data.UMap
         Data.ListMap
         Data.Universe
+        Data.Incremental
 
     hs-source-dirs:   src
     default-language: Haskell2010
@@ -54,6 +55,7 @@ library testlib
 
     build-depends:
         base,
+        cardano-data,
         containers,
         hspec,
         QuickCheck
@@ -62,7 +64,10 @@ test-suite cardano-data-tests
     type:             exitcode-stdio-1.0
     main-is:          Main.hs
     hs-source-dirs:   test
-    other-modules:    Test.Cardano.Data.MapExtrasSpec
+    other-modules:
+        Test.Cardano.Data.MapExtrasSpec
+        Test.Cardano.Data.Incremental
+
     default-language: Haskell2010
     ghc-options:
         -Wall -Wcompat -Wincomplete-record-updates
diff --git a/libs/cardano-data/src/Data/Incremental.hs b/libs/cardano-data/src/Data/Incremental.hs
new file mode 100644
index 00000000000..774c98b3251
--- /dev/null
+++ b/libs/cardano-data/src/Data/Incremental.hs
@@ -0,0 +1,201 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Introduce the Incremental Lambda Calculus embodied in the ILC class.
+--   Instances for two patterns of use involving Maps.
+module Data.Incremental where
+
+import Control.DeepSeq (NFData (..))
+import Data.Kind
+import Data.Map.Internal (Map (..))
+import Data.Map.Strict
+import qualified Data.Map.Strict as Map
+import GHC.Generics (Generic (..))
+
+-- ===================================================
+-- Incremental lambda calculus
+
+class ILC t where
+  data Diff t :: Type
+  applyDiff :: t -> Diff t -> t
+  extend :: Diff t -> Diff t -> Diff t
+  zero :: Diff t
+
+infixr 0 $$
+($$) :: ILC t => t -> Diff t -> t
+x $$ y = applyDiff x y
+
+-- | Every (Diff t) is a Semigroup
+instance ILC t => Semigroup (Diff t) where
+  x <> y = extend x y
+
+-- | Every (Diff t) is a Monoid
+instance ILC t => Monoid (Diff t) where
+  mempty = zero
+
+-- ==============================================================
+-- Delta types.
+-- We are going to give the type (Map dom rng) an ILC instance.
+-- It turns out there are two reasonable choices for Map. The two
+-- reasonable choices differ on what properties the range of the Map
+-- has. If the range of the Map is a monoid, there are 3 ways the map
+-- might change.
+-- 1) entry is deleted,
+-- 2) an entry is changed or created, so there is a new range value
+-- 3) the range of an entry is combined (using monoid (actually semigroup) <>) with another value.
+--
+-- If the range is not a Monoid there are only two ways the map might change
+-- 1) entry is deleted,
+-- 2) an entry is changed or created, so there is a new range value
+--
+-- To do this we introduce two datatypes MonoidRngD and BinaryRngD. They
+-- will become part of the definition for the Diff(Map dom rng). It also
+-- turns out thet Both of them are Semigroups (but not Monoids as neither
+-- has a notion of No-Change. This is deliberate, but might be reconsidered
+-- at some point)
+
+-- | The range is deleted, overwritten, or combined using a Monoid
+data MonoidRngD v = Del | Write !v | Comb !v
+  deriving (Show, Eq, Generic, NFData)
+
+instance (Semigroup t) => Semigroup (MonoidRngD t) where
+  Del <> Del = Del
+  Del <> Write _ = Del
+  Del <> Comb _ = Del
+  Comb x <> Del = Write x
+  Comb x <> Write y = Write (x <> y)
+  Comb x <> Comb y = Comb (x <> y)
+  Write x <> Del = Write x
+  Write x <> Comb _ = Write x
+  Write x <> Write _ = Write x
+
+-- | The range is deleted or changed
+data BinaryRngD v = Omit | Edit !v
+  deriving (Eq, Generic, NFData)
+
+-- The show instance is manual because it supports cutting and pasting
+-- error messages, to get values for exploring failures. With out the
+-- parantheses they often won't read properly.
+instance Show v => Show (BinaryRngD v) where
+  show Omit = "Omit"
+  show (Edit d) = "Edit(" ++ show d ++ ")"
+
+instance Semigroup (BinaryRngD t) where
+  Omit <> Omit = Omit
+  Omit <> Edit _ = Omit
+  Edit x <> Omit = Edit x
+  Edit x <> Edit _ = Edit x
+
+-- ============================================================
+-- Since there are two reasonable ILC instances for the Map
+-- type we wrap the map in a newtype for the first instance.
+-- This is the special case of a Map where the range is a
+-- Monoid. We provide tools to enforce the invariant, that in a
+-- MonoidMap, we never store 'mempty' of the Monoid.
+
+newtype MonoidMap k v = MM (Map k v)
+  deriving newtype (Show, Eq, NFData)
+
+unMM :: MonoidMap k v -> Map k v
+unMM (MM x) = x
+
+monoidInsertWith :: (Monoid v, Eq v, Ord k) => k -> v -> MonoidMap k v -> MonoidMap k v
+monoidInsertWith k !v1 (MM m) = MM (alter ok k m)
+  where
+    ok Nothing = if v1 == mempty then Nothing else Just v1
+    ok (Just v2) = if total == mempty then Nothing else Just total
+      where
+        total = v1 <> v2
+{-# INLINEABLE monoidInsertWith #-}
+
+monoidInsert :: (Monoid v, Eq v, Ord k) => k -> v -> MonoidMap k v -> MonoidMap k v
+monoidInsert k !v1 (MM m) = if v1 == mempty then MM (delete k m) else MM (insert k v1 m)
+{-# INLINEABLE monoidInsert #-}
+
+-- =========================================
+-- ILC instances
+
+-- | Monoidal maps have special properties, so they get their
+--   own instance (wrapped in the newtype).
+instance (Ord k, Eq v, ILC v, Monoid v) => ILC (MonoidMap k v) where
+  newtype Diff (MonoidMap k v) = Dm (Map k (MonoidRngD (Diff v)))
+  applyDiff mm (Dm md) = Map.foldlWithKey' accum mm md
+    where
+      accum :: MonoidMap k v -> k -> MonoidRngD (Diff v) -> MonoidMap k v
+      accum (MM ans) cred Del = MM (Map.delete cred ans)
+      accum ans cred (Comb dv) =
+        monoidInsertWith cred (applyDiff mempty dv) ans
+      accum ans cred (Write dv) = monoidInsert cred (applyDiff mempty dv) ans
+  {-# INLINEABLE applyDiff #-}
+  zero = Dm Map.empty
+  extend (Dm x) (Dm y) = Dm (Map.unionWith (<>) x y)
+
+instance (Show (Diff v), Show k) => Show (Diff (MonoidMap k v)) where
+  show (Dm x) = show (Map.toList x)
+
+deriving newtype instance (NFData k, NFData (Diff v)) => NFData (Diff (MonoidMap k v))
+
+-- | Normal map can only be deleted or updated so they use BinaryRngD
+instance Ord k => ILC (Map k v) where
+  newtype Diff (Map k v) = Dn (Map k (BinaryRngD v))
+  applyDiff m (Dn md) = Map.foldlWithKey' accum m md
+    where
+      accum ans k Omit = Map.delete k ans
+      accum ans k (Edit drep) = Map.insert k drep ans
+  {-# INLINEABLE applyDiff #-}
+  zero = Dn Map.empty
+  extend (Dn x) (Dn y) = Dn (Map.unionWith (<>) x y)
+
+instance (Show k, Show v) => Show (Diff (Map k v)) where
+  show (Dn x) = show (Map.toList x)
+
+deriving newtype instance (NFData k, NFData v) => NFData (Diff (Map k v))
+
+-- =================================================================
+-- helper functions for making binary derivatives
+
+-- | insert a change (MonoidRngD c) into a Map.
+--   Note that if we wrap the (result :: Map k (MonoidRngD c)) with the constructor 'Dn'
+--   Dn :: Map k (BinaryRngD v) -> Diff (Map k v)
+--   then we get Diff(Map k v)
+insertC ::
+  (Ord k, Monoid c) =>
+  k ->
+  MonoidRngD c ->
+  Map k (MonoidRngD c) ->
+  Map k (MonoidRngD c)
+insertC d m x = insertWith (<>) d m x
+
+-- | Split two maps, x and y, into three parts
+--   1) the key appears only in x
+--   2) the key appears in both x and y
+--   3) the key appears only in y
+--   Given three 'C'ontinuation style functions, reduce
+--   the three parts to a single value.
+inter3C ::
+  Ord k =>
+  a ->
+  Map k u ->
+  Map k v ->
+  (a -> k -> u -> a) ->
+  (a -> k -> (u, v) -> a) ->
+  (a -> k -> v -> a) ->
+  a
+inter3C ans0 m0 n0 c1 c2 c3 = go ans0 m0 n0
+  where
+    go ans Tip Tip = ans
+    go !ans m Tip = Map.foldlWithKey' c1 ans m
+    go !ans Tip n = Map.foldlWithKey' c3 ans n
+    go !ans (Bin _ kx x l r) n = case Map.splitLookup kx n of
+      (ln, Nothing, rn) -> go (go (c1 ans kx x) l ln) r rn
+      (ln, Just y, rn) -> go (go (c2 ans kx (x, y)) l ln) r rn
diff --git a/libs/cardano-data/test/Main.hs b/libs/cardano-data/test/Main.hs
index ae18d769421..ee22a2052be 100644
--- a/libs/cardano-data/test/Main.hs
+++ b/libs/cardano-data/test/Main.hs
@@ -7,6 +7,7 @@ import System.IO (
   stdout,
   utf8,
  )
+import Test.Cardano.Data.Incremental (ilcTests)
 import Test.Cardano.Data.MapExtrasSpec (mapExtrasSpec)
 import Test.Hspec
 import Test.Hspec.Runner
@@ -22,6 +23,7 @@ spec :: Spec
 spec =
   describe "cardano-data" $ do
     describe "MapExtras" mapExtrasSpec
+    ilcTests
 
 main :: IO ()
 main = do
diff --git a/libs/cardano-data/test/Test/Cardano/Data/Incremental.hs b/libs/cardano-data/test/Test/Cardano/Data/Incremental.hs
new file mode 100644
index 00000000000..b8550091927
--- /dev/null
+++ b/libs/cardano-data/test/Test/Cardano/Data/Incremental.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.Cardano.Data.Incremental (ilcTests) where
+
+import Data.Incremental
+import Data.Map (Map)
+import qualified Data.Map.Strict as Map
+import Test.Cardano.Data (plusBinary, plusUnary, propExtend, propZero)
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+
+-- ==================================================================================
+-- These are standins for Coin and DRep which we can't import here
+
+newtype MockCoin = MockCoin Integer
+  deriving (Eq, Show, Ord)
+
+instance Semigroup MockCoin where
+  (MockCoin n) <> (MockCoin m) = MockCoin (n + m)
+
+instance Monoid MockCoin where
+  mempty = MockCoin 0
+
+instance ILC MockCoin where
+  newtype Diff MockCoin = DeltaMockCoin Integer
+    deriving (Eq, Show)
+  applyDiff (MockCoin n) (DeltaMockCoin m) = MockCoin (n + m)
+  zero = DeltaMockCoin 0
+  extend (DeltaMockCoin n) (DeltaMockCoin m) = DeltaMockCoin (n + m)
+
+newtype Rep = Rep String
+  deriving (Eq, Ord, Show)
+
+instance Arbitrary Rep where
+  arbitrary =
+    Rep <$> do
+      a <- choose ('A', 'Z')
+      b <- choose ('a', 'z')
+      c <- choose ('0', '9')
+      pure [a, b, c]
+
+instance Arbitrary (Diff MockCoin) where
+  arbitrary = DeltaMockCoin <$> arbitrary
+
+instance Arbitrary MockCoin where
+  arbitrary = MockCoin <$> arbitrary
+
+-- ==================================================================================
+-- derivative of a unary function
+
+sumCoins :: Map Int MockCoin -> MockCoin
+sumCoins xs = Map.foldl' accum (MockCoin 0) xs
+  where
+    accum (MockCoin i) (MockCoin j) = MockCoin (i + j)
+
+sumCoins' :: Map Int MockCoin -> Diff (Map Int MockCoin) -> Diff MockCoin
+sumCoins' m (Dn mb) = DeltaMockCoin $ Map.foldlWithKey' accum 0 mb
+  where
+    accum ans k Omit = case Map.lookup k m of
+      Nothing -> ans
+      Just (MockCoin i) -> ans - i
+    accum ans k (Edit (MockCoin i)) = case Map.lookup k m of
+      Nothing -> ans + i
+      Just (MockCoin j) -> ans + i - j
+
+-- ==================================================================================
+-- derivative of a binary function
+
+changeMockCoin :: MockCoin -> MockCoin -> MockCoin
+changeMockCoin (MockCoin n) (MockCoin m) = MockCoin (m * n)
+
+changeCoin' :: MockCoin -> Diff MockCoin -> MockCoin -> Diff MockCoin -> Diff MockCoin
+changeCoin' (MockCoin n) (DeltaMockCoin i) (MockCoin m) (DeltaMockCoin j) =
+  DeltaMockCoin (n * j + m * i + i * j)
+
+-- ================================================
+-- Property tests
+
+ilcTests :: Spec
+ilcTests = describe "ILC tests" $ do
+  describe "Coin" $ do
+    propZero (arbitrary @MockCoin)
+    propExtend (arbitrary @MockCoin) (arbitrary @(Diff MockCoin))
+
+  describe "Map cred Coin" $ do
+    propZero (arbitrary @(Map Int MockCoin))
+    propExtend (arbitrary @(Map Int MockCoin)) (arbitrary @(Diff (Map Int MockCoin)))
+
+  describe "MonoidMap cred Coin" $ do
+    propZero (arbitrary @(MonoidMap Int MockCoin))
+    propExtend (arbitrary @(MonoidMap Int MockCoin)) (arbitrary @(Diff (MonoidMap Int MockCoin)))
+
+  describe "Map cred Rep" $ do
+    propZero (arbitrary @(Map Int Rep))
+    propExtend (arbitrary @(Map Int Rep)) (arbitrary @(Diff (Map Int Rep)))
+
+  describe "Unary functions" $
+    prop "sumCoins' is derivative of unary function sumCoins" $
+      plusUnary sumCoins sumCoins'
+
+  describe "Binary functions" $ do
+    prop "changeCoin' is derivative of changeCoin" $
+      plusBinary changeMockCoin changeCoin' arbitrary arbitrary arbitrary arbitrary
+
+-- To run theses tests in ghci, uncomment and type 'main'
+-- main = hspec $ ilcTests
diff --git a/libs/cardano-data/testlib/Test/Cardano/Data.hs b/libs/cardano-data/testlib/Test/Cardano/Data.hs
index 43d30d8f90b..f1525ce0c87 100644
--- a/libs/cardano-data/testlib/Test/Cardano/Data.hs
+++ b/libs/cardano-data/testlib/Test/Cardano/Data.hs
@@ -1,12 +1,27 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Test.Cardano.Data (
   expectValidMap,
   genNonEmptyMap,
+  propZero,
+  propExtend,
+  plusUnary,
+  plusBinary,
+  genMonoidRngD,
+  genBinaryRngD,
 ) where
 
 import Control.Monad
+import Data.Incremental
 import qualified Data.Map.Internal.Debug as Map
 import qualified Data.Map.Strict as Map hiding (showTree)
 import Test.Hspec
+import Test.Hspec.QuickCheck
 import Test.QuickCheck
 
 expectValidMap :: HasCallStack => (Ord k, Show k, Show a) => Map.Map k a -> Expectation
@@ -23,3 +38,120 @@ expectValidMap m =
 
 genNonEmptyMap :: Ord k => Gen k -> Gen v -> Gen (Map.Map k v)
 genNonEmptyMap genKey genVal = Map.fromList <$> listOf1 ((,) <$> genKey <*> genVal)
+
+-- ======================================================================
+-- Reusable components for the Incremental Lambda Calculus (ILC)
+-- ======================================================================
+
+-- =================================
+-- Generic, reusable, Property tests
+
+propZero :: forall t. (Eq t, Show t, ILC t) => Gen t -> Spec
+propZero gent = prop "propZero" $ do
+  x <- gent
+  pure $ applyDiff @t x (zero @t) `shouldBe` x
+
+type ILCProp t = (ILC t, Show t, Eq t, Show (Diff t))
+
+propExtend :: forall t. (ILCProp t) => Gen t -> Gen (Diff t) -> Spec
+propExtend gent genDiff = prop "propExtend" $ do
+  x <- gent
+  dx1 <- genDiff
+  dx2 <- genDiff
+  let ext = extend @t dx2 dx1
+      appdif = applyDiff @t x dx1
+  pure
+    ( counterexample
+        ( unlines
+            [ "x= " ++ show x
+            , "dx1= " ++ show dx1
+            , "dx2= " ++ show dx2
+            , "extend dx2 dx1= " ++ show ext
+            , "applyDiff x dx1= " ++ show appdif
+            , "lhs (applyDiff x (extend dx2 dx1))= " ++ show (applyDiff x ext)
+            , "rhs (applyDiff (applyDiff x dx1) dx2)= " ++ show (applyDiff appdif dx2)
+            ]
+        )
+        (applyDiff x (extend @t dx2 dx1) `shouldBe` applyDiff (applyDiff @t x dx1) dx2)
+    )
+
+-- | Test that f' is really the derivative of the unary function f.
+plusUnary ::
+  forall a b.
+  (ILCProp a, ILCProp b) =>
+  (a -> b) ->
+  (a -> Diff a -> Diff b) ->
+  a ->
+  Diff a ->
+  Property
+plusUnary f f' a da =
+  counterexample
+    ( unlines
+        [ "a = " ++ show a
+        , "da = " ++ show da
+        , "f a = " ++ show (f a)
+        , "f' a da = " ++ show (f' a da)
+        , "applyDiff (f a) (f' a da)) = " ++ show (applyDiff (f a) (f' a da))
+        , "applyDiff a da = " ++ show (applyDiff a da)
+        , "f (applyDiff a da) = " ++ show (f (applyDiff a da))
+        ]
+    )
+    (f (applyDiff a da) `shouldBe` applyDiff (f a) (f' a da))
+
+-- | Test that f' is really the derivative of the binary function f.
+plusBinary ::
+  forall a b c.
+  (ILCProp a, ILCProp b, ILCProp c) =>
+  (a -> b -> c) ->
+  (a -> Diff a -> b -> Diff b -> Diff c) ->
+  Gen a ->
+  Gen (Diff a) ->
+  Gen b ->
+  Gen (Diff b) ->
+  Gen Property
+plusBinary f f' ga gda gb gdb = do
+  m <- ga
+  dm <- gda
+  n <- gb
+  dn <- gdb
+  pure $
+    counterexample
+      ( unlines
+          [ "m = " ++ show m
+          , "dm = " ++ show dm
+          , "n = " ++ show n
+          , "dn = " ++ show dn
+          , "f m n = " ++ show (f m n)
+          , "f' m dm n dn = " ++ show (f' m dm n dn)
+          , "applyDiff m dm = " ++ show (applyDiff m dm)
+          , "applyDiff n dn = " ++ show (applyDiff n dn)
+          , ""
+          , "f (applyDiff m dm) (applyDiff n dn) = " ++ show (f (applyDiff m dm) (applyDiff n dn))
+          , "applyDiff (f m n) (f' m dm n dn) = " ++ show (applyDiff (f m n) (f' m dm n dn))
+          ]
+      )
+      (f (applyDiff m dm) (applyDiff n dn) `shouldBe` applyDiff (f m n) (f' m dm n dn))
+
+-- ====================
+-- reusable ILC Generators
+
+instance Arbitrary t => Arbitrary (MonoidRngD t) where
+  arbitrary = genMonoidRngD arbitrary
+
+instance Arbitrary t => Arbitrary (BinaryRngD t) where
+  arbitrary = genBinaryRngD arbitrary
+
+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Diff (Map.Map k v)) where
+  arbitrary = Dn <$> arbitrary
+
+instance (Ord k, Eq v, Monoid v, Arbitrary k, Arbitrary v) => Arbitrary (MonoidMap k v) where
+  arbitrary = MM . Map.filter (/= mempty) <$> arbitrary
+
+instance (Ord k, Arbitrary (Diff v), Arbitrary k, Arbitrary v) => (Arbitrary (Diff (MonoidMap k v))) where
+  arbitrary = Dm <$> arbitrary
+
+genMonoidRngD :: Gen t -> Gen (MonoidRngD t)
+genMonoidRngD g = oneof [pure Del, Write <$> g, Comb <$> g]
+
+genBinaryRngD :: Gen t -> Gen (BinaryRngD t)
+genBinaryRngD g = oneof [pure Omit, Edit <$> g]
diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs
index 25118cf420c..1e64ed84fb2 100644
--- a/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs
+++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs
@@ -12,6 +12,7 @@ module Cardano.Ledger.Coin (
   Coin (..),
   CompactForm (..),
   DeltaCoin (..),
+  Diff (DiffCoin),
   word64ToCoin,
   coinToRational,
   rationalToCoinViaFloor,
@@ -41,6 +42,7 @@ import Cardano.Ledger.TreeDiff (ToExpr (toExpr))
 import Control.DeepSeq (NFData)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Group (Abelian, Group (..))
+import Data.Incremental (ILC (..))
 import Data.Monoid (Sum (..))
 import Data.PartialOrd (PartialOrd)
 import Data.Primitive.Types
@@ -150,3 +152,19 @@ decodePositiveCoin = do
   if n == 0
     then fail "Expected a positive Coin. Got 0 (zero)."
     else pure $ Coin (toInteger n)
+
+-- ===========================================
+-- Incremental Lambda Calculus instances
+
+-- The Diff of a Coin is Coin-like, except it can store negative values
+-- We could use DeltaCoin, but we need newtype for the instance
+instance ILC Coin where
+  {-# SPECIALIZE instance ILC Coin #-}
+  newtype Diff Coin = DiffCoin Integer
+    deriving newtype (Eq, Show, NFData)
+  applyDiff (Coin n) (DiffCoin m) = Coin (n + m)
+  zero = DiffCoin 0
+  extend (DiffCoin n) (DiffCoin m) = DiffCoin (n + m)
+
+-- {-# SPECIALIZE instance Semigroup (MonoidD Coin) #-}
+-- {-# SPECIALIZE instance Semigroup (BinaryD Coin) #-}
diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/UMapCompact.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/UMapCompact.hs
index d6056356bb3..b1243ee3603 100644
--- a/libs/cardano-ledger-core/src/Cardano/Ledger/UMapCompact.hs
+++ b/libs/cardano-ledger-core/src/Cardano/Ledger/UMapCompact.hs
@@ -30,6 +30,7 @@ module Cardano.Ledger.UMapCompact (
   -- * View and its components
   -- $VIEW
   View (..),
+  MapLike (..),
   unView,
   unUnify,
   viewToVMap,
@@ -38,6 +39,7 @@ module Cardano.Ledger.UMapCompact (
   delView,
   ptrView,
   depositView,
+  drepView,
   domRestrictedView,
   zero,
   zeroMaybe,
@@ -131,7 +133,7 @@ instance DecCBOR RDPair where
 -- ===================================================================
 -- UMAP
 
--- | a 'Trip' compactly represents the range of 4 maps with the same domain as a single triple.
+-- | a 'Trip' compactly represents the range of 5 maps with the same domain as a single triple.
 --   The space compacting Trip datatype, and the pattern Triple are equivalent to:
 --
 -- @
@@ -139,6 +141,7 @@ instance DecCBOR RDPair where
 --   { coinT :: !(StrictMaybe RDPair),
 --     ptrT :: !(Set Ptr),
 --     poolidT :: !(StrictMaybe (KeyHash 'StakePool c))
+--     drepidT :: !(StrictMaybe (KeyHash 'Voting c))
 --   }
 --  deriving (Show, Eq, Generic, NoThunks, NFData)
 -- @
@@ -148,18 +151,26 @@ instance DecCBOR RDPair where
 -- the component is not present. There are three components
 -- 1) the (CompactForm Coin) as a Word64,
 -- 2) the Ptr set, and
--- 3) the pool id (KeyHash 'StakePool c) . So TEEE means none of the
--- components are present, and TEEF means only the pool id is present. etc.
+-- 3) the pool id (KeyHash 'StakePool c) . So TEEEE means none of the
+-- components are present, and TEEFE means only the pool id is present. etc.
 -- The pattern 'Triple' will correctly use the optimal constructor.
 data Trip c
-  = TEEE
-  | TEEF !(KeyHash 'StakePool c)
-  | TEFE !(Set Ptr)
-  | TEFF !(Set Ptr) !(KeyHash 'StakePool c)
-  | TFEE {-# UNPACK #-} !RDPair
-  | TFEF {-# UNPACK #-} !RDPair !(KeyHash 'StakePool c)
-  | TFFE {-# UNPACK #-} !RDPair !(Set Ptr)
-  | TFFF {-# UNPACK #-} !RDPair !(Set Ptr) !(KeyHash 'StakePool c)
+  = TEEEE
+  | TEEFE !(KeyHash 'StakePool c)
+  | TEFEE !(Set Ptr)
+  | TEFFE !(Set Ptr) !(KeyHash 'StakePool c)
+  | TFEEE {-# UNPACK #-} !RDPair
+  | TFEFE {-# UNPACK #-} !RDPair !(KeyHash 'StakePool c)
+  | TFFEE {-# UNPACK #-} !RDPair !(Set Ptr)
+  | TFFFE {-# UNPACK #-} !RDPair !(Set Ptr) !(KeyHash 'StakePool c)
+  | TEEEF !(KeyHash 'Voting c)
+  | TEEFF !(KeyHash 'StakePool c) !(KeyHash 'Voting c)
+  | TEFEF !(Set Ptr) !(KeyHash 'Voting c)
+  | TEFFF !(Set Ptr) !(KeyHash 'StakePool c) !(KeyHash 'Voting c)
+  | TFEEF {-# UNPACK #-} !RDPair !(KeyHash 'Voting c)
+  | TFEFF {-# UNPACK #-} !RDPair !(KeyHash 'StakePool c) !(KeyHash 'Voting c)
+  | TFFEF {-# UNPACK #-} !RDPair !(Set Ptr) !(KeyHash 'Voting c)
+  | TFFFF {-# UNPACK #-} !RDPair !(Set Ptr) !(KeyHash 'StakePool c) !(KeyHash 'Voting c)
   deriving (Eq, Ord, Generic, NoThunks, NFData)
 
 instance (Crypto c) => ToJSON (Trip c) where
@@ -167,87 +178,141 @@ instance (Crypto c) => ToJSON (Trip c) where
   toEncoding = Aeson.pairs . mconcat . toTripPair
 
 toTripPair :: (Aeson.KeyValue a, Crypto c) => Trip c -> [a]
-toTripPair (Triple !rd !ptr !pool) =
+toTripPair (Triple !rd !ptr !pool !drep) =
   [ "reward" .= fmap rdReward rd
   , "deposit" .= fmap rdDeposit rd
   , "ptr" .= ptr
   , "pool" .= pool
+  , "drep" .= drep
   ]
 
 -- | We can view all of the constructors as a Triple.
-viewTrip :: Trip c -> (StrictMaybe RDPair, Set Ptr, StrictMaybe (KeyHash 'StakePool c))
-viewTrip TEEE = (SNothing, Set.empty, SNothing)
-viewTrip (TEEF x) = (SNothing, Set.empty, SJust x)
-viewTrip (TEFE x) = (SNothing, x, SNothing)
-viewTrip (TEFF x y) = (SNothing, x, SJust y)
-viewTrip (TFEE x) = (SJust x, Set.empty, SNothing)
-viewTrip (TFEF x y) = (SJust x, Set.empty, SJust y)
-viewTrip (TFFE x y) = (SJust x, y, SNothing)
-viewTrip (TFFF x y z) = (SJust x, y, SJust z)
+viewTrip :: Trip c -> (StrictMaybe RDPair, Set Ptr, StrictMaybe (KeyHash 'StakePool c), StrictMaybe (KeyHash 'Voting c))
+viewTrip TEEEE = (SNothing, Set.empty, SNothing, SNothing)
+viewTrip (TEEFE x) = (SNothing, Set.empty, SJust x, SNothing)
+viewTrip (TEFEE x) = (SNothing, x, SNothing, SNothing)
+viewTrip (TEFFE x y) = (SNothing, x, SJust y, SNothing)
+viewTrip (TFEEE x) = (SJust x, Set.empty, SNothing, SNothing)
+viewTrip (TFEFE x y) = (SJust x, Set.empty, SJust y, SNothing)
+viewTrip (TFFEE x y) = (SJust x, y, SNothing, SNothing)
+viewTrip (TFFFE x y z) = (SJust x, y, SJust z, SNothing)
+viewTrip (TEEEF d) = (SNothing, Set.empty, SNothing, SJust d)
+viewTrip (TEEFF x d) = (SNothing, Set.empty, SJust x, SJust d)
+viewTrip (TEFEF x d) = (SNothing, x, SNothing, SJust d)
+viewTrip (TEFFF x y d) = (SNothing, x, SJust y, SJust d)
+viewTrip (TFEEF x d) = (SJust x, Set.empty, SNothing, SJust d)
+viewTrip (TFEFF x y d) = (SJust x, Set.empty, SJust y, SJust d)
+viewTrip (TFFEF x y d) = (SJust x, y, SNothing, SJust d)
+viewTrip (TFFFF x y z d) = (SJust x, y, SJust z, SJust d)
 
 -- | Extract a delegated Reward-Deposit Pair if it is present. We can tell that the pair
 --   is present and active when Txxx has an F in the 1st position (present) and 3rd
 --   position (delegated).  I.e. TFFF and TFEF
 --                                ^ ^      ^ ^
---  This is equivalent to:  pattern (Triple (SJust c) _ (SJust _)) -> Just c
+--  This is equivalent to:  pattern (Triple (SJust c) _ (SJust _) _) -> Just c
 tripRewardActiveDelegation :: Trip c -> Maybe RDPair
 tripRewardActiveDelegation =
   \case
-    TFFF c _ _ -> Just c
-    TFEF c _ -> Just c
+    TFFFE c _ _ -> Just c
+    TFEFE c _ -> Just c
+    TFFFF c _ _ _ -> Just c
+    TFEFF c _ _ -> Just c
     _ -> Nothing
 
 -- | Extract the Reward-Deposit Pair if it is present. We can tell that the reward is
---   present when Txxx has an F in the first position TFFF TFFE TFEF TFEE
---                                                     ^    ^    ^    ^
---  equivalent to the pattern (Triple (SJust c) _ _) -> Just c
+--   present when Txxx has an F in the first position TFEEE TFEEF TFEFE TFEFF  ...
+
+---                                                    ^     ^     ^     ^
+--  equivalent to the pattern (Triple (SJust c) _ _ _) -> Just c
 tripReward :: Trip c -> Maybe RDPair
 tripReward =
   \case
-    TFFF c _ _ -> Just c
-    TFFE c _ -> Just c
-    TFEF c _ -> Just c
-    TFEE c -> Just c
+    TFEEE c -> Just c
+    TFEEF c _ -> Just c
+    TFEFE c _ -> Just c
+    TFEFF c _ _ -> Just c
+    TFFEE c _ -> Just c
+    TFFEF c _ _ -> Just c
+    TFFFE c _ _ -> Just c
+    TFFFF c _ _ _ -> Just c
     _ -> Nothing
 
 -- | Extract the Delegation PoolParams, if present. We can tell that the PoolParams are
---   present when Txxx has an F in the third position TFFF TFEF TEFF TEEF
---                                                       ^    ^    ^    ^
---  equivalent to the pattern (Triple _ _ (SJust p)) -> Just p
+--   present when Txxx has an F in the third position TFFFE TFEFE TEFFE TEEFE ...
+--                                                       ^     ^     ^     ^
+--  equivalent to the pattern (Triple _ _ (SJust p) _) -> Just p
 tripDelegation :: Trip c -> Maybe (KeyHash 'StakePool c)
 tripDelegation =
   \case
-    TFFF _ _ p -> Just p
-    TFEF _ p -> Just p
-    TEFF _ p -> Just p
-    TEEF p -> Just p
+    TEEFE p -> Just p
+    TEEFF p _ -> Just p
+    TEFFE _ p -> Just p
+    TEFFF _ p _ -> Just p
+    TFEFE _ p -> Just p
+    TFEFF _ p _ -> Just p
+    TFFFE _ _ p -> Just p
+    TFFFF _ _ p _ -> Just p
+    _ -> Nothing
+
+-- | Extract the Voting KeyHash, if present. We can tell that the KayHash is
+--   present when Txxx has an F in the fourth position TEEEF TEEFF TEFEF TEFEF ...
+--                                                         ^     ^     ^     ^
+--  equivalent to the pattern (Triple _ _ (SJust p) _) -> Just p
+tripDrep :: Trip c -> Maybe (KeyHash 'Voting c)
+tripDrep =
+  \case
+    TEEEF p -> Just p
+    TEEFF _ p -> Just p
+    TEFEF _ p -> Just p
+    TEFFF _ _ p -> Just p
+    TFEEF _ p -> Just p
+    TFEFF _ _ p -> Just p
+    TFFEF _ _ p -> Just p
+    TFFFF _ _ _ p -> Just p
     _ -> Nothing
 
 -- | A Triple can be extracted and injected into the TEEE ... TFFF constructors.
-pattern Triple :: StrictMaybe RDPair -> Set Ptr -> StrictMaybe (KeyHash 'StakePool c) -> Trip c
-pattern Triple a b c <-
-  (viewTrip -> (a, b, c))
+pattern Triple ::
+  StrictMaybe RDPair ->
+  Set Ptr ->
+  StrictMaybe (KeyHash 'StakePool c) ->
+  StrictMaybe (KeyHash 'Voting c) ->
+  Trip c
+pattern Triple a b c d <-
+  (viewTrip -> (a, b, c, d))
   where
-    Triple a b c =
-      case (a, b, c) of
-        (SNothing, SI.Tip, SNothing) -> TEEE
-        (SNothing, SI.Tip, SJust x) -> TEEF x
-        (SNothing, x, SNothing) -> TEFE x
-        (SNothing, x, SJust y) -> TEFF x y
-        (SJust x, SI.Tip, SNothing) -> TFEE x
-        (SJust x, SI.Tip, SJust y) -> TFEF x y
-        (SJust x, y, SNothing) -> TFFE x y
-        (SJust x, y, SJust z) -> TFFF x y z
+    Triple a b c d =
+      case (a, b, c, d) of
+        (SNothing, SI.Tip, SNothing, SNothing) -> TEEEE
+        (SNothing, SI.Tip, SJust x, SNothing) -> TEEFE x
+        (SNothing, x, SNothing, SNothing) -> TEFEE x
+        (SNothing, x, SJust y, SNothing) -> TEFFE x y
+        (SJust x, SI.Tip, SNothing, SNothing) -> TFEEE x
+        (SJust x, SI.Tip, SJust y, SNothing) -> TFEFE x y
+        (SJust x, y, SNothing, SNothing) -> TFFEE x y
+        (SJust x, y, SJust z, SNothing) -> TFFFE x y z
+        (SNothing, SI.Tip, SNothing, SJust d1) -> TEEEF d1
+        (SNothing, SI.Tip, SJust x, SJust d1) -> TEEFF x d1
+        (SNothing, x, SNothing, SJust d1) -> TEFEF x d1
+        (SNothing, x, SJust y, SJust d1) -> TEFFF x y d1
+        (SJust x, SI.Tip, SNothing, SJust d1) -> TFEEF x d1
+        (SJust x, SI.Tip, SJust y, SJust d1) -> TFEFF x y d1
+        (SJust x, y, SNothing, SJust d1) -> TFFEF x y d1
+        (SJust x, y, SJust z, SJust d1) -> TFFFF x y z d1
 
 {-# COMPLETE Triple #-}
 
 instance Show (Trip c) where
-  show (Triple a b c) = "(Triple " ++ show a ++ " " ++ show b ++ " " ++ show c ++ ")"
+  show (Triple a b c d) = "(Triple " ++ show a ++ " " ++ show b ++ " " ++ show c ++ " " ++ show d ++ ")"
 
 -- =====================================================
 
--- | A unified map represents 4 Maps with domain @(Credential 'Staking c)@ for
---   keys and one more in the inverse direction with @Ptr@ for keys and @(Credential 'Staking c)@ for values.
+-- | A unified map represents 4 Maps with domain @(Credential 'Staking c)@
+--   1) Map (Credential 'Staking c) RDPair  -- (RDPair rewardCoin depositCoin)
+--   2) Map (Credential 'Staking c) (Set Ptr)
+--   3) Map (Credential 'Staking c) (StrictMaybe (KeyHash 'StakePool c))
+--   4) Map (Credential 'Staking c) (StrictMaybe (KeyHash 'Voting c))
+--   and one more map in the inverse direction with @Ptr@ for keys and @(Credential 'Staking c)@ for values.
 data UMap c = UMap !(Map (Credential 'Staking c) (Trip c)) !(Map Ptr (Credential 'Staking c))
   deriving (Show, Eq, Generic, NoThunks, NFData)
 
@@ -269,7 +334,7 @@ umInvariant stake ptr (UMap tripmap ptrmap) = forwards && backwards
     forwards =
       case Map.lookup stake tripmap of
         Nothing -> all (stake /=) ptrmap
-        Just (Triple _c set _d) ->
+        Just (Triple _c set _d _) ->
           if Set.member ptr set
             then case Map.lookup ptr ptrmap of
               Nothing -> False
@@ -277,17 +342,18 @@ umInvariant stake ptr (UMap tripmap ptrmap) = forwards && backwards
             else True
     backwards =
       case Map.lookup ptr ptrmap of
-        Nothing -> all (\(Triple _ set _) -> Set.notMember ptr set) tripmap
+        Nothing -> all (\(Triple _ set _ _) -> Set.notMember ptr set) tripmap
         Just cred ->
           case Map.lookup cred tripmap of
             Nothing -> False
-            Just (Triple _ set _) -> Set.member ptr set
+            Just (Triple _ set _ _) -> Set.member ptr set
 
--- =====================================================
-
--- VIEW
+-- ===================================================================================
+-- VIEWS
+-- A View acts like a map, supporting efficient insert, delete, and lookup operations
+-- ===================================================================================
 
--- | A 'View' lets one view a 'UMap' in three different ways
+-- | A 'View' lets one view a 'UMap' in four different ways
 --   A view with type @(View c key value)@ can be used like a @(Map key value)@
 data View c k v where
   RewardDeposits ::
@@ -299,6 +365,30 @@ data View c k v where
   Ptrs ::
     !(UMap c) ->
     View c Ptr (Credential 'Staking c)
+  Dreps ::
+    !(UMap c) ->
+    View c (Credential 'Staking c) (KeyHash 'Voting c)
+
+-- | Does a type act like a Map?
+class MapLike m where
+  insertLike :: Ord k => k -> v -> m k v -> m k v
+  deleteLike :: Ord k => k -> m k v -> m k v
+  lookupLike :: Ord k => k -> m k v -> Maybe v
+  nullLike :: m k v -> Bool
+
+-- | Data.Map acts like a Map
+instance MapLike Map where
+  insertLike = Map.insert
+  deleteLike = Map.delete
+  lookupLike = Map.lookup
+  nullLike = Map.null
+
+-- | (View c) acts like a Map
+instance MapLike (View c) where
+  insertLike = insert'
+  deleteLike = delete'
+  lookupLike = lookup
+  nullLike = isNull
 
 -- ==================================================
 -- short hand constructors and selectors
@@ -317,6 +407,13 @@ delegations ::
   View c (Credential 'Staking c) (KeyHash 'StakePool c)
 delegations x y = Delegations (UMap x y)
 
+-- | Construct a Dreps View from the two maps that make up a UMap
+dreps ::
+  Map (Credential 'Staking c) (Trip c) ->
+  Map Ptr (Credential 'Staking c) ->
+  View c (Credential 'Staking c) (KeyHash 'Voting c)
+dreps x y = Dreps (UMap x y)
+
 -- | Construct a Ptrs View from the two maps that make up a UMap
 ptrs ::
   Map (Credential 'Staking c) (Trip c) ->
@@ -329,6 +426,7 @@ unView :: View c k v -> UMap c
 unView (RewardDeposits um) = um
 unView (Delegations um) = um
 unView (Ptrs um) = um
+unView (Dreps um) = um
 
 -- | Materialize a real 'Map' from a 'View'
 --   This is expensive, use it wisely (like maybe once per epoch boundary to make a SnapShot)
@@ -337,6 +435,7 @@ unUnify :: View c k v -> Map k v
 unUnify (RewardDeposits (UMap tripmap _)) = Map.mapMaybe tripReward tripmap
 unUnify (Delegations (UMap tripmap _)) = Map.mapMaybe tripDelegation tripmap
 unUnify (Ptrs (UMap _ ptrmap)) = ptrmap
+unUnify (Dreps (UMap tripmap _)) = Map.mapMaybe tripDrep tripmap
 
 -- | Materialize a real Vector Map from a 'View'
 --   This is expensive, use it wisely (like maybe once per epoch boundary to make a SnapShot)
@@ -348,9 +447,12 @@ viewToVMap view =
     Delegations (UMap tripmap _) ->
       VMap.fromListN (size view) . Maybe.mapMaybe toDelegation . Map.toList $ tripmap
     Ptrs (UMap _ ptrmap) -> VMap.fromMap ptrmap
+    Dreps (UMap tripmap _) ->
+      VMap.fromListN (size view) . Maybe.mapMaybe toDrep . Map.toList $ tripmap
   where
     toReward (key, t) = (,) key <$> tripReward t
     toDelegation (key, t) = (,) key <$> tripDelegation t
+    toDrep (key, t) = (,) key <$> tripDrep t
 
 -- | Materialize the RewardDeposits Map from a 'UMap'
 rewView :: UMap c -> Map.Map (Credential 'Staking c) Coin
@@ -371,6 +473,10 @@ delView x = unUnify (Delegations x)
 ptrView :: UMap c -> Map.Map Ptr (Credential 'Staking c)
 ptrView x = unUnify (Ptrs x)
 
+-- | Materialize the Dreps Map from a 'UMap'
+drepView :: UMap c -> Map.Map (Credential 'Staking c) (KeyHash 'Voting c)
+drepView x = unUnify (Dreps x)
+
 -- | Return the materialized View of a domain restricted Umap. if 'setk' is small this should be efficient.
 domRestrictedView :: Set k -> View c k v -> Map.Map k v
 domRestrictedView setk (RewardDeposits (UMap tripmap _)) =
@@ -378,27 +484,38 @@ domRestrictedView setk (RewardDeposits (UMap tripmap _)) =
 domRestrictedView setk (Delegations (UMap tripmap _)) =
   Map.mapMaybe tripDelegation (Map.restrictKeys tripmap setk)
 domRestrictedView setk (Ptrs (UMap _ ptrmap)) = Map.restrictKeys ptrmap setk
+domRestrictedView setk (Dreps (UMap tripmap _)) =
+  Map.mapMaybe tripDrep (Map.restrictKeys tripmap setk)
 
--- | All 3 'Views' are 'Foldable'
+-- | All 4 'Views' are 'Foldable'
 instance Foldable (View c k) where
   foldMap f (RewardDeposits (UMap tmap _)) = Map.foldlWithKey accum mempty tmap
     where
-      accum ans _ (Triple (SJust ccoin) _ _) = ans <> f ccoin
+      accum ans _ (Triple (SJust ccoin) _ _ _) = ans <> f ccoin
       accum ans _ _ = ans
   foldMap f (Delegations (UMap tmap _)) = Map.foldlWithKey accum mempty tmap
     where
-      accum ans _ (Triple _ _ (SJust c)) = ans <> f c
-      accum ans _ (Triple _ _ SNothing) = ans
+      accum ans _ (Triple _ _ (SJust c) _) = ans <> f c
+      accum ans _ (Triple _ _ SNothing _) = ans
   foldMap f (Ptrs (UMap _ ptrmap)) = foldMap f ptrmap
+  foldMap f (Dreps (UMap tmap _)) = Map.foldlWithKey accum mempty tmap
+    where
+      accum ans _ (Triple _ _ _ (SJust c)) = ans <> f c
+      accum ans _ (Triple _ _ _ SNothing) = ans
+
   foldr accum ans0 (RewardDeposits (UMap tmap _)) = Map.foldr accum2 ans0 tmap
     where
-      accum2 (Triple (SJust ccoin) _ _) ans = accum ccoin ans
+      accum2 (Triple (SJust ccoin) _ _ _) ans = accum ccoin ans
       accum2 _ ans = ans
   foldr accum ans0 (Delegations (UMap tmap _)) = Map.foldr accum2 ans0 tmap
     where
-      accum2 (Triple _ _ (SJust c)) ans = accum c ans
-      accum2 (Triple _ _ SNothing) ans = ans
+      accum2 (Triple _ _ (SJust c) _) ans = accum c ans
+      accum2 (Triple _ _ SNothing _) ans = ans
   foldr accum ans (Ptrs (UMap _ ptrmap)) = Map.foldr accum ans ptrmap
+  foldr accum ans0 (Dreps (UMap tmap _)) = Map.foldr accum2 ans0 tmap
+    where
+      accum2 (Triple _ _ _ (SJust c)) ans = accum c ans
+      accum2 (Triple _ _ _ SNothing) ans = ans
 
   foldl' accum ans0 (RewardDeposits (UMap tmap _)) = Map.foldl' accum2 ans0 tmap
     where
@@ -407,6 +524,10 @@ instance Foldable (View c k) where
     where
       accum2 ans = maybe ans (accum ans) . tripDelegation
   foldl' accum ans (Ptrs (UMap _ ptrmap)) = Map.foldl' accum ans ptrmap
+  foldl' accum ans0 (Dreps (UMap tmap _)) = Map.foldl' accum2 ans0 tmap
+    where
+      accum2 ans = maybe ans (accum ans) . tripDrep
+
   length = size
 
 -- =======================================================
@@ -414,7 +535,7 @@ instance Foldable (View c k) where
 
 -- | Is there no information in a Triple? If so then we can delete it from the UnifedMap
 zero :: Trip c -> Bool
-zero (Triple SNothing s SNothing) | Set.null s = True
+zero (Triple SNothing s SNothing SNothing) | Set.null s = True
 zero _ = False
 
 zeroMaybe :: Trip c -> Maybe (Trip c)
@@ -436,17 +557,21 @@ delete' ::
 delete' stakeid (RewardDeposits (UMap tripmap ptrmap)) =
   rewards (Map.update ok stakeid tripmap) ptrmap
   where
-    ok (Triple _ ptr poolid) = zeroMaybe (Triple SNothing ptr poolid)
+    ok (Triple _ ptr poolid d) = zeroMaybe (Triple SNothing ptr poolid d)
 delete' stakeid (Delegations (UMap tripmap ptrmap)) =
   delegations (Map.update ok stakeid tripmap) ptrmap
   where
-    ok (Triple c ptr _) = zeroMaybe (Triple c ptr SNothing)
+    ok (Triple c ptr _ d) = zeroMaybe (Triple c ptr SNothing d)
 delete' ptr (Ptrs (UMap tripmap ptrmap)) =
   case Map.lookup ptr ptrmap of
     Nothing -> Ptrs (UMap tripmap ptrmap)
     Just stakeid -> ptrs (Map.update ok stakeid tripmap) (Map.delete ptr ptrmap)
       where
-        ok (Triple coin ptrset poolid) = zeroMaybe (Triple coin (Set.delete ptr ptrset) poolid)
+        ok (Triple coin ptrset poolid d) = zeroMaybe (Triple coin (Set.delete ptr ptrset) poolid d)
+delete' stakeid (Dreps (UMap tripmap ptrmap)) =
+  dreps (Map.update ok stakeid tripmap) ptrmap
+  where
+    ok (Triple c ptr del _) = zeroMaybe (Triple c ptr del SNothing)
 
 delete :: k -> View c k v -> UMap c
 delete k m = unView (delete' k m)
@@ -479,15 +604,21 @@ insertWith' comb stakeid newpair (RewardDeposits (UMap tripmap ptrmap)) =
   where
     -- Here 'v' is (CompactForm Coin), but the UMap stores Word64,
     -- so there is some implict coercion going on here using the Triple pattern
-    comb2 Nothing = zeroMaybe (Triple (SJust newpair) Set.empty SNothing)
-    comb2 (Just (Triple (SJust oldpair) x y)) = zeroMaybe (Triple (SJust (comb oldpair newpair)) x y)
-    comb2 (Just (Triple SNothing x y)) = zeroMaybe (Triple (SJust newpair) x y)
+    comb2 Nothing = zeroMaybe (Triple (SJust newpair) Set.empty SNothing SNothing)
+    comb2 (Just (Triple (SJust oldpair) x y z)) = zeroMaybe (Triple (SJust (comb oldpair newpair)) x y z)
+    comb2 (Just (Triple SNothing x y z)) = zeroMaybe (Triple (SJust newpair) x y z)
 insertWith' comb stakeid newpoolid (Delegations (UMap tripmap ptrmap)) =
   delegations (Map.alter comb2 stakeid tripmap) ptrmap
   where
-    comb2 Nothing = Just (Triple SNothing Set.empty (SJust newpoolid))
-    comb2 (Just (Triple x y (SJust old))) = Just (Triple x y (SJust (comb old newpoolid)))
-    comb2 (Just (Triple x y SNothing)) = Just (Triple x y (SJust newpoolid))
+    comb2 Nothing = Just (Triple SNothing Set.empty (SJust newpoolid) SNothing)
+    comb2 (Just (Triple x y (SJust old) z)) = Just (Triple x y (SJust (comb old newpoolid)) z)
+    comb2 (Just (Triple x y SNothing z)) = Just (Triple x y (SJust newpoolid) z)
+insertWith' comb stakeid newvoteid (Dreps (UMap tripmap ptrmap)) =
+  dreps (Map.alter comb2 stakeid tripmap) ptrmap
+  where
+    comb2 Nothing = Just (Triple SNothing Set.empty SNothing (SJust newvoteid))
+    comb2 (Just (Triple x y z (SJust old))) = Just (Triple x y z (SJust (comb old newvoteid)))
+    comb2 (Just (Triple x y z SNothing)) = Just (Triple x y z (SJust newvoteid))
 insertWith' comb ptr stake (Ptrs (UMap tripmap ptrmap)) =
   let (oldstake, newstake) =
         case Map.lookup ptr ptrmap of -- This is tricky, because we need to retract the oldstake
@@ -496,11 +627,11 @@ insertWith' comb ptr stake (Ptrs (UMap tripmap ptrmap)) =
       -- Delete old pointer from set in Triple, but also delete the whole triple if it goes to Zero.
       retract stakeid pointer m = Map.update ok stakeid m
         where
-          ok (Triple c set d) = zeroMaybe (Triple c (Set.delete pointer set) d)
+          ok (Triple c set d r) = zeroMaybe (Triple c (Set.delete pointer set) d r)
       -- Add the new pointer to the set in Triple
       tripmap2 = Map.update addPtr newstake (retract oldstake ptr tripmap)
         where
-          addPtr (Triple a set b) = Just (Triple a (Set.insert ptr set) b)
+          addPtr (Triple a set b r) = Just (Triple a (Set.insert ptr set) b r)
       ptrmap2 = Map.insert ptr newstake ptrmap
    in Ptrs (UMap tripmap2 ptrmap2)
 
@@ -529,8 +660,8 @@ insert k v m = unView (insert' k v m)
 adjust :: (RDPair -> RDPair) -> k -> View c k RDPair -> UMap c
 adjust f k (RewardDeposits (UMap tripmap ptrmap)) = UMap (Map.adjust g k tripmap) ptrmap
   where
-    g (Triple (SJust rdp) x y) = Triple (SJust (f rdp)) x y
-    g (Triple SNothing x y) = Triple SNothing x y
+    g (Triple (SJust rdp) x y z) = Triple (SJust (f rdp)) x y z
+    g (Triple SNothing x y z) = Triple SNothing x y z
 
 -- ==================================================
 lookup :: k -> View c k v -> Maybe v
@@ -538,33 +669,44 @@ lookup stakeid (RewardDeposits (UMap tripmap _)) =
   Map.lookup stakeid tripmap >>= tripReward
 lookup stakeid (Delegations (UMap tripmap _)) =
   Map.lookup stakeid tripmap >>= tripDelegation
+lookup stakeid (Dreps (UMap tripmap _)) =
+  Map.lookup stakeid tripmap >>= tripDrep
 lookup ptr (Ptrs (UMap _ ptrmap)) = Map.lookup ptr ptrmap
 
 isNull :: View c k v -> Bool
 isNull (RewardDeposits (UMap tripmap _)) = all (isNothing . tripReward) tripmap
 isNull (Delegations (UMap tripmap _)) = all (isNothing . tripDelegation) tripmap
+isNull (Dreps (UMap tripmap _)) = all (isNothing . tripDrep) tripmap
 isNull (Ptrs (UMap _ ptrmap)) = Map.null ptrmap
 
 domain :: View c k v -> Set k
 domain (RewardDeposits (UMap tripmap _)) = Map.foldlWithKey' accum Set.empty tripmap
   where
-    accum ans k (Triple (SJust _) _ _) = Set.insert k ans
+    accum ans k (Triple (SJust _) _ _ _) = Set.insert k ans
     accum ans _ _ = ans
 domain (Delegations (UMap tripmap _)) = Map.foldlWithKey' accum Set.empty tripmap
   where
-    accum ans k (Triple _ _ (SJust _)) = Set.insert k ans
-    accum ans _k (Triple _ _ SNothing) = ans
+    accum ans k (Triple _ _ (SJust _) _) = Set.insert k ans
+    accum ans _k (Triple _ _ SNothing _) = ans
+domain (Dreps (UMap tripmap _)) = Map.foldlWithKey' accum Set.empty tripmap
+  where
+    accum ans k (Triple _ _ _ (SJust _)) = Set.insert k ans
+    accum ans _k (Triple _ _ _ SNothing) = ans
 domain (Ptrs (UMap _ ptrmap)) = Map.keysSet ptrmap
 
 range :: View c k v -> Set v
 range (RewardDeposits (UMap tripmap _)) = Map.foldlWithKey' accum Set.empty tripmap
   where
-    accum ans _ (Triple (SJust ccoin) _ _) = Set.insert ccoin ans
+    accum ans _ (Triple (SJust ccoin) _ _ _) = Set.insert ccoin ans
     accum ans _ _ = ans
 range (Delegations (UMap tripmap _)) = Map.foldlWithKey' accum Set.empty tripmap
   where
-    accum ans _ (Triple _ _ (SJust v)) = Set.insert v ans
-    accum ans _ (Triple _ _ SNothing) = ans
+    accum ans _ (Triple _ _ (SJust v) _) = Set.insert v ans
+    accum ans _ (Triple _ _ SNothing _) = ans
+range (Dreps (UMap tripmap _)) = Map.foldlWithKey' accum Set.empty tripmap
+  where
+    accum ans _ (Triple _ _ _ (SJust v)) = Set.insert v ans
+    accum ans _ (Triple _ _ _ SNothing) = ans
 range (Ptrs (UMap _tripmap ptrmap)) =
   Set.fromList (Map.elems ptrmap) -- tripmap is the inverse of ptrmap
 
@@ -597,7 +739,7 @@ view ∪ (k, v) = insertWith (\old _new -> old) k v view
   where
     accum !ansTripmap k (RDPair ccoin _) = Map.adjust overwrite k ansTripmap
       where
-        overwrite (Triple (SJust (RDPair _ deposit)) a b) = Triple (SJust (RDPair ccoin deposit)) a b
+        overwrite (Triple (SJust (RDPair _ deposit)) a b c) = Triple (SJust (RDPair ccoin deposit)) a b c
         overwrite x = x
 view ⨃ mp = unView $ Map.foldlWithKey' accum view mp
   where
@@ -628,8 +770,8 @@ unionHelp ::
   Map k (CompactForm Coin) ->
   Map k (Trip c)
 unionHelp tm mm =
-  let f _k (Triple p1 s deposit) delta =
-        Just (Triple (addCoinToJustRewardsPartOfRDPair p1 delta) s deposit)
+  let f _k (Triple p1 s deposit drep) delta =
+        Just (Triple (addCoinToJustRewardsPartOfRDPair p1 delta) s deposit drep)
       -- We use Map.empty below because mm is a subset of tm, we never add anything here.
       result = Map.mergeWithKey f id (const Map.empty) tm mm
    in assert (Map.valid result) result
@@ -654,7 +796,7 @@ set ⋪ view = unView (Set.foldl' (flip delete') view set)
 -- evalUnified (Ptrs u2 ⋫ setSingleton hk)
 -- evalUnified (Delegations u1 ⋫ retired)
 
--- | This is slow for Delegations and RewardDeposits Views, better hope the sets are small
+-- | This is slow for Delegations, RewardDeposits, and DReps Views, better hope the sets are small
 (⋫) ::
   View c k v ->
   Set v ->
@@ -663,23 +805,31 @@ Ptrs um ⋫ set = Set.foldl' removeCredStaking um set
   where
     removeCredStaking m@(UMap m2 m1) cred =
       case Map.lookup cred m2 of
-        Just (Triple _ kset _) ->
+        Just (Triple _ kset _ _) ->
           UMap (Map.update ok cred m2) (foldr (\k pset -> Map.delete k pset) m1 kset)
           where
-            ok (Triple coin _ poolid) = zeroMaybe (Triple coin Set.empty poolid)
+            ok (Triple coin _ poolid d) = zeroMaybe (Triple coin Set.empty poolid d)
         Nothing -> m
 Delegations (UMap tmap pmap) ⋫ delegset = UMap (Map.foldlWithKey' accum tmap tmap) pmap
   where
-    ok (Triple c set _) = zeroMaybe (Triple c set SNothing)
-    accum ans _key (Triple _ _ SNothing) = ans
-    accum ans key (Triple _ _ (SJust d)) =
+    ok (Triple c set _ d) = zeroMaybe (Triple c set SNothing d)
+    accum ans _key (Triple _ _ SNothing _) = ans
+    accum ans key (Triple _ _ (SJust d) _) =
+      if Set.member d delegset
+        then Map.update ok key ans
+        else ans
+Dreps (UMap tmap pmap) ⋫ delegset = UMap (Map.foldlWithKey' accum tmap tmap) pmap
+  where
+    ok (Triple c set d _) = zeroMaybe (Triple c set d SNothing)
+    accum ans _key (Triple _ _ _ SNothing) = ans
+    accum ans key (Triple _ _ _ (SJust d)) =
       if Set.member d delegset
         then Map.update ok key ans
         else ans
 RewardDeposits (UMap tmap pmap) ⋫ coinset = UMap (Map.foldlWithKey' accum tmap tmap) pmap
   where
-    ok (Triple _ set d) = zeroMaybe (Triple SNothing set d)
-    accum ans key (Triple (SJust ccoin) _ _) =
+    ok (Triple _ set d z) = zeroMaybe (Triple SNothing set d z)
+    accum ans key (Triple (SJust ccoin) _ _ _) =
       if Set.member ccoin coinset
         then Map.update ok key ans
         else ans
@@ -695,11 +845,15 @@ RewardDeposits (UMap tmap pmap) ⋫ coinset = UMap (Map.foldlWithKey' accum tmap
 member :: k -> View c k v -> Bool
 member k (RewardDeposits (UMap tmap _)) =
   case Map.lookup k tmap of
-    Just (Triple (SJust _) _ _) -> True
+    Just (Triple (SJust _) _ _ _) -> True
     _ -> False
 member k (Delegations (UMap tmap _)) =
   case Map.lookup k tmap of
-    Just (Triple _ _ (SJust _)) -> True
+    Just (Triple _ _ (SJust _) _) -> True
+    _ -> False
+member k (Dreps (UMap tmap _)) =
+  case Map.lookup k tmap of
+    Just (Triple _ _ _ (SJust _)) -> True
     _ -> False
 member k (Ptrs (UMap _ pmap)) = Map.member k pmap
 
@@ -717,11 +871,15 @@ notMember k um = not (member k um)
 domRestrict :: View c k v -> Map k u -> Map k u
 domRestrict (RewardDeposits (UMap tmap _)) m = intersectDomPLeft p m tmap
   where
-    p _ (Triple (SJust _) _ _) = True
+    p _ (Triple (SJust _) _ _ _) = True
     p _ _ = False
 domRestrict (Delegations (UMap tmap _)) m = intersectDomPLeft p m tmap
   where
-    p _ (Triple _ _ (SJust _)) = True
+    p _ (Triple _ _ (SJust _) _) = True
+    p _ _ = False
+domRestrict (Dreps (UMap tmap _)) m = intersectDomPLeft p m tmap
+  where
+    p _ (Triple _ _ _ (SJust _)) = True
     p _ _ = False
 domRestrict (Ptrs (UMap _ pmap)) m = Map.intersection m pmap
 
@@ -731,8 +889,8 @@ instance
   (Crypto c) =>
   EncCBOR (Trip c)
   where
-  encCBOR (Triple coin ptr pool) =
-    encodeListLen 3 <> encCBOR coin <> encCBOR ptr <> encCBOR pool
+  encCBOR (Triple coin ptr pool d) =
+    encodeListLen 3 <> encCBOR coin <> encCBOR ptr <> encCBOR pool <> encCBOR d
 
 instance Crypto c => DecShareCBOR (Trip c) where
   type Share (Trip c) = Interns (KeyHash 'StakePool c)
@@ -742,7 +900,8 @@ instance Crypto c => DecShareCBOR (Trip c) where
         a <- decCBOR
         b <- decCBOR
         c <- decShareMonadCBOR is
-        pure (Triple a b c)
+        d <- decCBOR
+        pure (Triple a b c d)
 
 instance Crypto c => EncCBOR (UMap c) where
   encCBOR (UMap tripmap ptrmap) =
@@ -777,17 +936,19 @@ size :: View c k a -> Int
 size (Ptrs (UMap _ ptrmap)) = Map.size ptrmap
 size x = foldl' (\count _v -> count + 1) 0 x
 
--- | Create a UMap from 3 separate maps. For use in tests only.
+-- | Create a UMap from 4 separate maps. For use in tests only.
 unify ::
   Map (Credential 'Staking c) RDPair ->
   Map (Credential 'Staking c) (KeyHash 'StakePool c) ->
   Map Ptr (Credential 'Staking c) ->
+  Map (Credential 'Staking c) (KeyHash 'Voting c) ->
   UMap c
-unify rews dels ptrss = um3
+unify rews dels ptrss ds = um4
   where
     um1 = unView $ Map.foldlWithKey' (\um k v -> insert' k v um) (RewardDeposits empty) rews
     um2 = unView $ Map.foldlWithKey' (\um k v -> insert' k v um) (Delegations um1) dels
     um3 = unView $ Map.foldlWithKey' (\um k v -> insert' k v um) (Ptrs um2) ptrss
+    um4 = unView $ Map.foldlWithKey' (\um k v -> insert' k v um) (Dreps um3) ds
 
 compactCoinOrError :: HasCallStack => Coin -> CompactForm Coin
 compactCoinOrError c =
diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs
index 672a3836010..bc10734a66e 100644
--- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs
+++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs
@@ -460,7 +460,7 @@ instance Arbitrary RDPair where
   shrink = genericShrink
 
 instance Crypto c => Arbitrary (Trip c) where
-  arbitrary = Triple <$> arbitrary <*> arbitrary <*> arbitrary
+  arbitrary = Triple <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
   shrink = genericShrink
 
 instance Crypto c => Arbitrary (UMap c) where
diff --git a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs
index 85942d65d75..e4f38a993f5 100644
--- a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs
+++ b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs
@@ -419,12 +419,13 @@ ppRDPair (RDPair rew dep) =
     ]
 
 ppTrip :: Trip c -> PDoc
-ppTrip (Triple mpair set mpool) =
+ppTrip (Triple mpair set mpool drep) =
   ppSexp
     "Triple"
     [ ppStrictMaybe ppRDPair mpair
     , ppSet ppPtr set
     , ppStrictMaybe ppKeyHash mpool
+    , ppStrictMaybe ppKeyHash drep
     ]
 
 ppUnifiedMap :: UMap c -> PDoc
diff --git a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/Incremental.hs b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/Incremental.hs
new file mode 100644
index 00000000000..fa9bdf282cb
--- /dev/null
+++ b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/Incremental.hs
@@ -0,0 +1,133 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Bench.Cardano.Ledger.Incremental where
+
+import Cardano.Ledger.Core (EraTxOut (..), TxOut)
+import Cardano.Ledger.Era (Era (..))
+import Cardano.Ledger.TxIn (TxIn (..))
+import Cardano.Ledger.UTxO (UTxO (..))
+import Criterion
+import Data.Incremental (Diff (Dn), ILC (..), MonoidMap (..), unMM)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Test.Cardano.Data (genBinaryRngD)
+import Test.Cardano.Ledger.Babbage.Arbitrary ()
+import Test.Cardano.Ledger.Core.Arbitrary ()
+import Test.Cardano.Ledger.Generic.Proof (Evidence (..), Proof (..), ShelleyEra, Standard)
+import Test.Cardano.Ledger.Incremental (
+  Cred,
+  DRep,
+  IncrementalState (..),
+  Pool,
+  credDistrFromUtxo,
+  slow,
+  smartIS,
+  update,
+ )
+import Test.QuickCheck
+
+-- ============================
+
+type TT = ShelleyEra Standard
+
+-- ===================================================================
+-- Arbitrary instances for tests and benchmarks
+-- ======================================================================================
+
+genUTxO ::
+  forall era proxy.
+  (EraTxOut era, Arbitrary (TxOut era)) =>
+  proxy era ->
+  Int ->
+  Gen (Map (TxIn (EraCrypto era)) (TxOut era))
+genUTxO _p n =
+  Map.fromList
+    <$> vectorOf
+      n
+      ( (,)
+          <$> arbitrary @(TxIn (EraCrypto era))
+          <*> arbitrary @(TxOut era)
+      )
+
+genDel :: (Ord cred, Era era) => proxy era -> Int -> Gen cred -> Gen (Map cred (Pool era))
+genDel _p n gcred = Map.fromList <$> vectorOf n ((,) <$> gcred <*> arbitrary)
+
+genVote :: (Era era, Ord cred) => proxy era -> Int -> Gen cred -> Gen (Map cred (DRep era))
+genVote _p n gcred = Map.fromList <$> vectorOf n ((,) <$> gcred <*> arbitrary)
+
+genKey :: Map k v -> Gen k
+genKey m = do
+  i <- chooseInt (0, Map.size m - 1)
+  pure (fst (Map.elemAt i m))
+
+-- | Generate a UTxO Diff with approximate size 'n', The actual
+--   size does not matter but the ord of magnitude does.
+genUtxoDiff ::
+  forall era proxy.
+  (Arbitrary (TxOut era)) =>
+  proxy era ->
+  Int ->
+  Gen (TxIn (EraCrypto era)) ->
+  Gen (Diff (Map (TxIn (EraCrypto era)) (TxOut era)))
+genUtxoDiff _p n genTxIn =
+  Dn . Map.fromList
+    <$> vectorOf n ((,) <$> genTxIn <*> genBinaryRngD (arbitrary @(TxOut era)))
+
+-- | Generate a Map Diff with approximate size 'n', The actual
+--   size does not matter but the ord of magnitude does.
+genMapDiff :: forall era k v proxy. Ord k => proxy era -> Int -> Gen k -> Gen v -> Gen (Diff (Map k v))
+genMapDiff _p n genK genVal =
+  Dn . Map.fromList <$> vectorOf n ((,) <$> genK <*> genBinaryRngD genVal)
+
+-- ==========================================================
+
+-- | An IO action used to precompute inputs for the benchmarks.
+setupEnv ::
+  IO
+    ( IncrementalState TT
+    , Diff (Map (TxIn Standard) (TxOut TT))
+    , Diff (Map (Cred TT) (Pool TT))
+    , Diff (Map (Cred TT) (DRep TT))
+    )
+setupEnv = do
+  let p = (Shelley Standard)
+  utxo <- generate (genUTxO p 1000000)
+  let MM creds = credDistrFromUtxo utxo
+      gcred = genKey creds
+  vote <- generate $ genVote p 3000 gcred
+  delegate <- generate $ genDel p 3000 gcred
+  let is = (smartIS (UTxO utxo) delegate vote)
+  putStrLn ("isUtxo = " ++ show (Map.size (isUtxo is)))
+  putStrLn ("isDelegate = " ++ show (Map.size (isDelegate is)))
+  putStrLn ("isVoteProxy = " ++ show (Map.size (isVoteProxy is)))
+  putStrLn ("isCredDistr = " ++ show (Map.size (unMM (isCredDistr is))))
+  putStrLn ("isPtrDistr = " ++ show (Map.size (unMM (isPtrDistr is))))
+  putStrLn ("isPoolDistr = " ++ show (Map.size (unMM (isPoolDistr is))))
+  putStrLn ("isDRepDistr = " ++ show (Map.size (unMM (isDRepDistr is))))
+  putStrLn ("creds size = " ++ show (Map.size creds))
+  diff1 <- generate $ genUtxoDiff p 3 (genKey utxo)
+  diff2 <- generate $ genMapDiff p 3 gcred (arbitrary @(Pool (ShelleyEra Standard)))
+  diff3 <- generate $ genMapDiff p 3 gcred arbitrary
+  pure (is, diff1, diff2, diff3)
+
+-- | The benchmark
+slowVsIncremental :: Benchmark
+slowVsIncremental =
+  env setupEnv $ \ ~(is, diff1, diff2, diff3) ->
+    bgroup
+      "main"
+      [ bench "just UTxO" $ whnf (justUTxO diff1) is
+      , bench "slow" $ whnf (slow diff1 diff2 diff3) is
+      , bench "incremental" $ whnf (update diff1 diff2 diff3) is
+      , bench "incremental on UTxO only" $ whnf (update diff1 (Dn Map.empty) (Dn Map.empty)) is
+      ]
+
+justUTxO ::
+  Diff (Map (TxIn (EraCrypto era)) (TxOut era)) ->
+  IncrementalState era ->
+  IncrementalState era
+justUTxO diff1 isState =
+  isState {isUtxo = (applyDiff (isUtxo isState) diff1)}
diff --git a/libs/cardano-ledger-test/bench/Main.hs b/libs/cardano-ledger-test/bench/Main.hs
index d92ac4713da..3440091b155 100644
--- a/libs/cardano-ledger-test/bench/Main.hs
+++ b/libs/cardano-ledger-test/bench/Main.hs
@@ -5,6 +5,7 @@ import qualified Bench.Cardano.Ledger.ApplyTx as ApplyTx
 -- TODO: re-enable, once the benchmark is fixed
 -- import qualified Bench.Cardano.Ledger.Balance as Balance
 import qualified Bench.Cardano.Ledger.EpochBoundary as Epoch
+import Bench.Cardano.Ledger.Incremental (slowVsIncremental)
 import qualified Bench.Cardano.Ledger.Serialisation.Generators as SerGen
 import qualified Bench.Cardano.Ledger.StakeDistr as StakeDistr (tickfRuleBench)
 import qualified Bench.Cardano.Ledger.SumStake as SumStake
@@ -12,7 +13,10 @@ import qualified Bench.Cardano.Ledger.TxOut as TxOut
 import Criterion.Main (defaultMain)
 
 main :: IO ()
-main =
+main = defaultMain [slowVsIncremental]
+
+_main2 :: IO ()
+_main2 =
   defaultMain
     [ StakeDistr.tickfRuleBench
     , TxOut.benchTxOut
diff --git a/libs/cardano-ledger-test/cardano-ledger-test.cabal b/libs/cardano-ledger-test/cardano-ledger-test.cabal
index 01b43d5343a..6fe3708d743 100644
--- a/libs/cardano-ledger-test/cardano-ledger-test.cabal
+++ b/libs/cardano-ledger-test/cardano-ledger-test.cabal
@@ -62,6 +62,7 @@ library
         Test.Cardano.Ledger.TestableEra
         Test.Cardano.Ledger.ValueFromList
         Test.Cardano.Ledger.Tickf
+        Test.Cardano.Ledger.Incremental
 
     hs-source-dirs:   src
     default-language: Haskell2010
@@ -76,6 +77,7 @@ library
         bytestring,
         cardano-data,
         cardano-crypto-class,
+        cardano-data:{cardano-data, testlib},
         cardano-ledger-allegra,
         cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib},
         cardano-ledger-alonzo-test,
@@ -97,6 +99,7 @@ library
         groups,
         vector-map,
         data-default-class,
+        deepseq,
         microlens,
         mtl,
         nothunks,
@@ -145,6 +148,7 @@ benchmark bench
         Bench.Cardano.Ledger.SumStake
         Bench.Cardano.Ledger.TxOut
         Bench.Cardano.Ledger.StakeDistr
+        Bench.Cardano.Ledger.Incremental
 
     default-language: Haskell2010
     ghc-options:
@@ -157,14 +161,16 @@ benchmark bench
         aeson,
         bytestring,
         cardano-crypto-class,
+        cardano-data:{cardano-data, testlib},
         cardano-ledger-allegra,
         cardano-ledger-alonzo,
         cardano-ledger-alonzo-test,
         cardano-ledger-binary,
         cardano-ledger-test,
-        cardano-ledger-core,
+        cardano-ledger-core:{cardano-ledger-core, testlib},
         cardano-ledger-shelley-ma-test,
         cardano-ledger-mary:{cardano-ledger-mary, testlib},
+        cardano-ledger-babbage:testlib,
         vector-map,
         containers,
         criterion,
diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Lenses.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Lenses.hs
index 55a0c990053..1ffeceb7ac9 100644
--- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Lenses.hs
+++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Lenses.hs
@@ -278,42 +278,69 @@ data Split c = Split
   { spRew :: Map (Credential 'Staking c) Coin
   , spDep :: Map (Credential 'Staking c) Coin
   , spDel :: Map (Credential 'Staking c) (KeyHash 'StakePool c)
+  , spDrep :: Map (Credential 'Staking c) (KeyHash 'Voting c)
   , spRevPtr :: Map (Credential 'Staking c) (Set Ptr)
   , spPtr :: Map Ptr (Credential 'Staking c)
   }
 
 -- | Used to build the abstract view from the map of triples
 accumUM :: Split c -> Credential 'Staking c -> Trip c -> Split c
-accumUM sp key (Triple (SJust (RDPair r d)) ptrs (SJust p)) =
+accumUM sp key (Triple (SJust (RDPair r d)) ptrs (SJust p) (SJust q)) =
   sp
     { spRew = Map.insert key (fromCompact r) (spRew sp)
     , spDep = Map.insert key (fromCompact d) (spDep sp)
     , spDel = Map.insert key p (spDel sp)
+    , spDrep = Map.insert key q (spDrep sp)
     , spRevPtr = Map.insertWith (Set.union) key ptrs (spRevPtr sp)
     }
-accumUM sp key (Triple SNothing ptrs (SJust p)) =
+accumUM sp key (Triple (SJust (RDPair r d)) ptrs (SJust p) SNothing) =
+  sp
+    { spRew = Map.insert key (fromCompact r) (spRew sp)
+    , spDep = Map.insert key (fromCompact d) (spDep sp)
+    , spDel = Map.insert key p (spDel sp)
+    , spRevPtr = Map.insertWith (Set.union) key ptrs (spRevPtr sp)
+    }
+accumUM sp key (Triple SNothing ptrs (SJust p) SNothing) =
   sp
     { spDel = Map.insert key p (spDel sp)
     , spRevPtr = Map.insertWith (Set.union) key ptrs (spRevPtr sp)
     }
-accumUM sp key (Triple (SJust (RDPair r d)) ptrs SNothing) =
+accumUM sp key (Triple SNothing ptrs (SJust p) (SJust q)) =
+  sp
+    { spDel = Map.insert key p (spDel sp)
+    , spRevPtr = Map.insertWith (Set.union) key ptrs (spRevPtr sp)
+    , spDrep = Map.insert key q (spDrep sp)
+    }
+accumUM sp key (Triple (SJust (RDPair r d)) ptrs SNothing SNothing) =
+  sp
+    { spRew = Map.insert key (fromCompact r) (spRew sp)
+    , spDep = Map.insert key (fromCompact d) (spDep sp)
+    , spRevPtr = Map.insertWith (Set.union) key ptrs (spRevPtr sp)
+    }
+accumUM sp key (Triple (SJust (RDPair r d)) ptrs SNothing (SJust q)) =
   sp
     { spRew = Map.insert key (fromCompact r) (spRew sp)
     , spDep = Map.insert key (fromCompact d) (spDep sp)
+    , spDrep = Map.insert key q (spDrep sp)
     , spRevPtr = Map.insertWith (Set.union) key ptrs (spRevPtr sp)
     }
-accumUM sp key (Triple SNothing ptrs SNothing) =
+accumUM sp key (Triple SNothing ptrs SNothing SNothing) =
   sp {spRevPtr = Map.insertWith (Set.union) key ptrs (spRevPtr sp)}
+accumUM sp key (Triple SNothing ptrs SNothing (SJust q)) =
+  sp
+    { spRevPtr = Map.insertWith (Set.union) key ptrs (spRevPtr sp)
+    , spDrep = Map.insert key q (spDrep sp)
+    }
 
 -- | The abstraction function, from concrete (UMap) to abstract (Split)
 splitUMap :: UMap c -> Split c
 splitUMap (UMap trips ptr) = Map.foldlWithKey' accumUM empty trips
   where
-    empty = Split Map.empty Map.empty Map.empty Map.empty ptr
+    empty = Split Map.empty Map.empty Map.empty Map.empty Map.empty ptr
 
 -- | The concretization function from abstract (Split) to concrete (UMap)
 unSplitUMap :: Split c -> UMap c
-unSplitUMap (Split rew dep deleg _revptr ptr) = unify (merge rew dep) deleg ptr
+unSplitUMap (Split rew dep deleg drep _revptr ptr) = unify (merge rew dep) deleg ptr drep
   where
     merge x y | Map.keysSet x /= Map.keysSet y = error "different domains"
     merge x y = Map.intersectionWith rdpair x y
diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Solver.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Solver.hs
index ec7ce87b828..6b7c302c1fb 100644
--- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Solver.hs
+++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Solver.hs
@@ -139,6 +139,7 @@ hasOrd rep xx = explain ("'hasOrd " ++ show rep ++ "' fails") (help rep xx)
     help (ProtVerR _) v = pure $ With v
     help SlotNoR v = pure $ With v
     help SizeR v = pure $ With v
+    help VoteHashR p = pure $ With p
 
 -- ===============================
 
diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs
index 84b401ba40a..d57a4c92ac0 100644
--- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs
+++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs
@@ -143,6 +143,7 @@ data Rep era t where
   MaybeR :: Rep era t -> Rep era (Maybe t)
   SlotNoR :: Rep era SlotNo
   SizeR :: Rep era Size
+  VoteHashR :: Rep era (KeyHash 'Voting (EraCrypto era))
 
 -- ===========================================================
 -- Proof of Rep equality
@@ -208,6 +209,7 @@ instance Singleton (Rep e) where
     do Refl <- testEql c d; pure Refl
   testEql SlotNoR SlotNoR = Just Refl
   testEql SizeR SizeR = Just Refl
+  testEql VoteHashR VoteHashR = Just Refl
   testEql _ _ = Nothing
   cmpIndex x y = compare (shape x) (shape y)
 
@@ -254,6 +256,7 @@ instance Show (Rep era t) where
   show (ProtVerR x) = "(ProtVer " ++ show x ++ ")"
   show SlotNoR = "(SlotNo c)"
   show SizeR = "Size"
+  show VoteHashR = "(KeyHash 'Voting c)"
 
 synopsis :: forall e t. Rep e t -> t -> String
 synopsis RationalR r = show r
@@ -306,6 +309,7 @@ synopsis NewEpochStateR _ = "NewEpochStateR ..."
 synopsis (ProtVerR _) (ProtVer x y) = "(" ++ show x ++ " " ++ show y ++ ")"
 synopsis SlotNoR x = show x
 synopsis SizeR x = show x
+synopsis VoteHashR k = "(KeyHash 'Voting " ++ show (keyHashSummary k) ++ ")"
 
 synSum :: Rep era a -> a -> String
 synSum (MapR _ CoinR) m = ", sum = " ++ show (pcCoin (Map.foldl' (<>) mempty m))
@@ -374,6 +378,7 @@ instance Shaped (Rep era) any where
   shape SlotNoR = Nullary 36
   shape SizeR = Nullary 37
   shape (PairR a b) = Nary 38 [shape a, shape b]
+  shape VoteHashR = Nullary 39
 
 compareRep :: forall era t s. Rep era t -> Rep era s -> Ordering
 compareRep x y = cmpIndex @(Rep era) x y
@@ -426,6 +431,7 @@ genSizedRep _ NewEpochStateR = undefined
 genSizedRep _ (ProtVerR proof) = genProtVer proof
 genSizedRep _ SlotNoR = arbitrary
 genSizedRep _ SizeR = do lo <- choose (1, 6); hi <- choose (6, 10); pure (SzRng lo hi)
+genSizedRep _ VoteHashR = arbitrary
 
 genRep ::
   Era era =>
diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs
index 8b90451a742..1da4243d791 100644
--- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs
+++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs
@@ -139,6 +139,9 @@ delegations = Var $ V "delegations" (MapR CredR PoolHashR) (Yes NewEpochStateR d
 delegationsL :: NELens era (Map (Credential 'Staking (EraCrypto era)) (KeyHash 'StakePool (EraCrypto era)))
 delegationsL = nesEsL . esLStateL . lsDPStateL . dpsDStateL . dsUnifiedL . delegationsUMapL
 
+voteproxy :: Term era (Map (Credential 'Staking (EraCrypto era)) (KeyHash 'Voting (EraCrypto era)))
+voteproxy = Var $ V "voteproxy" (MapR CredR VoteHashR) No
+
 stakeDeposits :: Term era (Map (Credential 'Staking (EraCrypto era)) Coin)
 stakeDeposits = Var $ V "stakeDeposits" (MapR CredR CoinR) (Yes NewEpochStateR stakeDepositsL)
 
@@ -648,6 +651,7 @@ dstateT =
     ^$ rewards
     ^$ stakeDeposits
     ^$ delegations
+    ^$ voteproxy
     ^$ ptrs
     ^$ futureGenDelegs
     ^$ genDelegs
@@ -658,13 +662,14 @@ dstate ::
   Map (Credential 'Staking c) Coin ->
   Map (Credential 'Staking c) Coin ->
   Map (Credential 'Staking c) (KeyHash 'StakePool c) ->
+  Map (Credential 'Staking c) (KeyHash 'Voting c) ->
   Map Ptr (Credential 'Staking c) ->
   Map (FutureGenDeleg c) (GenDelegPair c) ->
   Map (KeyHash 'Genesis c) (GenDelegPair c) ->
   DPS.InstantaneousRewards c ->
   DState c
-dstate rew dep deleg ptr fgen gen instR =
-  DState (unSplitUMap (Split rew dep deleg undefined ptr)) fgen (GenDelegs gen) instR
+dstate rew dep deleg drep ptr fgen gen instR =
+  DState (unSplitUMap (Split rew dep deleg drep undefined ptr)) fgen (GenDelegs gen) instR
 
 instantaneousRewardsT :: Target era (DPS.InstantaneousRewards (EraCrypto era))
 instantaneousRewardsT =
diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs
index afa19ce0303..4d0505bda37 100644
--- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs
+++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs
@@ -691,7 +691,7 @@ instance era ~ BabbageEra Mock => Show (GenState era) where
 initialLedgerState :: forall era. Reflect era => GenState era -> LedgerState era
 initialLedgerState gstate = LedgerState utxostate dpstate
   where
-    umap = UM.unify (Map.map rdpair (gsInitialRewards gstate)) (gsInitialDelegations gstate) Map.empty
+    umap = UM.unify (Map.map rdpair (gsInitialRewards gstate)) (gsInitialDelegations gstate) Map.empty Map.empty
     utxostate = smartUTxOState pp (UTxO (gsInitialUtxo gstate)) deposited (Coin 0) emptyGovernanceState
     dpstate = DPState dstate pstate
     dstate =
diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs
index 6925db46ab7..c8cb3f0de1d 100644
--- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs
+++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs
@@ -299,7 +299,7 @@ class Extract t era where
 instance EraCrypto era ~ c => Extract (DState c) era where
   extract x =
     DState
-      (UM.unify (makeRewards x) (mDelegations x) Map.empty)
+      (UM.unify (makeRewards x) (mDelegations x) Map.empty Map.empty)
       Map.empty
       genDelegsZero
       instantaneousRewardsZero
diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs
index 7bf4ddec8ee..74dc613aa05 100644
--- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs
+++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs
@@ -323,7 +323,7 @@ sameLedgerFail (Babbage _) x y = eqByShow x y
 sameLedgerFail (Conway _) x y = eqByShow x y
 {-# NOINLINE sameLedgerFail #-}
 
-sameTransCtx ::
+sameTransCtx :: -- Eq (TranslationContext (ShelleyEra c)) =>
   Proof era ->
   TranslationContext era ->
   TranslationContext era ->
diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Incremental.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Incremental.hs
new file mode 100644
index 00000000000..4e9c3160625
--- /dev/null
+++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Incremental.hs
@@ -0,0 +1,691 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- | This module is work in progress, exploring how we might
+--   compute parts of the ledger state in an incremental
+--   way. Here we focus on stake distribution relations.
+--   The idea is that 'Stake' is measured in 'Coin', and a
+--   stake distribution relation is a (Map xx Coin), where
+--   type 'xx' is some way of distributing some amount of
+--   Coin, over a finite domain. Examples of 'xx' include
+--   staking credentials, Voting representatives, Ptrs, etc.
+module Test.Cardano.Ledger.Incremental where
+
+import Cardano.Ledger.Address (Addr (..))
+import Cardano.Ledger.Coin (Coin (..), Diff (DiffCoin))
+import Cardano.Ledger.Core (EraTxOut (..), TxOut, coinTxOutL, EraPParams(..),PParams(..),ppProtocolVersionL)
+import Cardano.Ledger.Credential (Credential (..), Ptr (..), StakeReference (..))
+import Cardano.Ledger.Era (Era (..))
+import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
+import Cardano.Ledger.Shelley.LedgerState (LedgerState (..),DState (..),DPState (..),PState (..),delegations) -- UTxOState (..))
+import Cardano.Ledger.TxIn (TxIn (..))
+import Cardano.Ledger.UMapCompact (MapLike (..), View (..))
+import qualified Cardano.Ledger.UMapCompact as UM
+import Cardano.Ledger.UTxO (UTxO (..))
+import Control.DeepSeq (NFData (..))
+import Data.Incremental (
+  BinaryRngD (..),
+  Diff (Dm, Dn),
+  ILC (..),
+  MonoidMap (..),
+  MonoidRngD (..),
+  insertC,
+  inter3C,
+  monoidInsertWith,
+ )
+import Data.Map.Strict
+import qualified Data.Map.Strict as Map
+import Debug.Trace (trace)
+import GHC.Generics (Generic (..))
+import Lens.Micro
+import Test.Cardano.Data (plusBinary, plusUnary)
+import Test.Cardano.Ledger.Constrained.Lenses
+import Test.Cardano.Ledger.Core.Arbitrary ()
+import Test.Cardano.Ledger.Generic.Proof (ShelleyEra, Standard)
+import Test.Tasty
+import Test.Tasty.QuickCheck hiding (Fixed, total)
+import Cardano.Ledger.EpochBoundary (SnapShot (..),Stake(..))
+import qualified Data.VMap as VMap
+import qualified Cardano.Ledger.Shelley.HardForks as HardForks
+import Control.Exception (assert)
+
+type TT = ShelleyEra Standard
+
+-- ==================================================================================
+
+-- | Our problem in a nutshell, (Map cred Coin) is a finite source of Coin.
+--   (Map cred drep) assigns a 'drep' to each 'cred', Note that more than one 'cred'
+--   can assign its Coin to the same 'drep'. The question is, how much Coin is assigned
+--   to each 'drep'. We are going to use the incremental lambda calculus to make this
+--   kind of computation efficient. So it is cast in terms of things for which we have
+--   ILC instances. Note that we wrap (Map cred Coin) and (Map drep Coin) in the MonoidalMap newtype
+--   and that we depend upon (and enforce using monoidInsert) that no (Coin 0) entrys are
+--   in the input map or are added to the output map.
+agg :: (Ord cred, Ord drep) => MonoidMap cred Coin -> Map cred drep -> MonoidMap drep Coin
+agg (MM cc) cd = Map.foldlWithKey' accum (MM Map.empty) cc
+  where
+    accum ans cred coin =
+      case Map.lookup cred cd of
+        Just drep -> monoidInsertWith drep coin ans
+        Nothing -> ans
+
+-- | agg' considers changes in two of its inputs, So we need to write 3 'partial derivatives'
+--   1) considers changes only on M
+--   2) considers changes on both M and N
+--   3) considers changes only on N
+--  The function 'interC3' ties them all together
+--  Note also that we wrap (Map cred Coin) and (Map drep Coin) in the MonoidalMap
+--  newtype to get the right ILC instances. We can easliy unwrap them we we use
+--  this function.
+agg' ::
+  (Show k, Ord k, Show drep, Ord drep) =>
+  MonoidMap k Coin ->
+  Diff (MonoidMap k Coin) ->
+  Map k drep ->
+  Diff (Map k drep) ->
+  Diff (MonoidMap drep Coin)
+agg' (MM m) (Dm dm) n (Dn dn) =
+  Dm $
+    inter3C Map.empty dm dn (changeDm2 m n) (changeDmDn2 m n) (changeDn2 m n)
+
+traceOn :: Bool
+traceOn = False
+
+try :: (Show cred, Show x) => cred -> x -> x
+try cred x =
+  if traceOn
+    then trace ("cred=" ++ show cred ++ " " ++ show x) x
+    else x
+
+-- ======================================================
+ 
+
+instance (Arbitrary (Diff Coin)) where
+  arbitrary = DiffCoin <$> arbitrary
+
+-- ==========================================================
+-- Property tests, testing the correctness of the approach.
+
+main :: IO ()
+main =
+  defaultMain $
+    testGroup
+      "ILC"
+      [ testProperty
+          "agg' is derivative of agg"
+          ( withMaxSuccess 1000 $
+              plusBinary agg agg' (arbitrary @(MonoidMap Int Coin)) arbitrary (arbitrary @(Map Int (KeyHash 'Voting Standard))) arbitrary
+          )
+      , testProperty "credDistrFromUtxo' is derivative of credDistrFromUtxo" $
+          withMaxSuccess 1000 $
+            plusUnary @(Map Int (TxOut TT)) credDistrFromUtxo credDistrFromUtxo'
+      , testProperty "ptrDistrFromUtxo' is derivative of ptrDistrFromUtxo" $
+          withMaxSuccess 1000 $
+            plusUnary @(Map Int (TxOut TT)) ptrDistrFromUtxo ptrDistrFromUtxo'
+      ]
+
+-- ===============================================================
+-- Now we explore a data structure that encapsulates two things.
+-- 1) Roots that are easy to update (usually with Log time costs)
+-- 2) Dependencies, which are expensive to update (usually with N*Log time costs)
+-- Dependencies depend on the Roots, and any change to a root, means the
+-- Dependencies have to be recomputed. This data structure is just an
+-- exploration of how we may proceed, with enough detail that we can run
+-- benchmarks, that demonstrate that using incremental computation,
+-- we can compute both Roots and Dependencies cheaply.
+
+type Cred era = Credential 'Staking (EraCrypto era)
+type Pool era = KeyHash 'StakePool (EraCrypto era)
+type DRep era = KeyHash 'Voting (EraCrypto era)
+
+data IncrementalState era = IS
+  { isUtxo :: !(Map (TxIn (EraCrypto era)) (TxOut era))
+  , isDelegate :: !(Map (Cred era) (Pool era))
+  , isVoteProxy :: !(Map (Cred era) (DRep era))
+  , -- \^ These are the 'roots', which are updated directly
+    isCredDistr :: !(MonoidMap (Cred era) Coin)
+  , isPtrDistr :: !(MonoidMap Ptr Coin)
+  , isPoolDistr :: !(MonoidMap (Pool era) Coin)
+  , isDRepDistr :: !(MonoidMap (DRep era) Coin)
+  }
+
+-- \^ These are the 'dependencies', which are computed from the 'roots'
+--   the idea is to compute these incrementally so they always have the
+--   most recent results. They automatically get updated every time one
+--   or more of the roots change.
+
+deriving instance Era era => Generic (IncrementalState era)
+deriving instance (Era era, NFData (TxOut era)) => NFData (IncrementalState era)
+deriving instance Show (TxOut era) => Show (IncrementalState era)
+deriving instance EraTxOut era => Eq (IncrementalState era)
+
+instance (EraTxOut era, Arbitrary (TxOut era)) => Arbitrary (IncrementalState era) where
+  arbitrary = smartIS <$> arbitrary <*> arbitrary <*> arbitrary
+
+-- | This function demonstrates that we can aways compute the Dependencies
+--   directly from the roots. This has N*Log cost for each Dependency.
+--   Use this only for tests or intializations.
+smartIS ::
+  forall era.
+  (EraTxOut era) =>
+  UTxO era ->
+  Map (Cred era) (Pool era) ->
+  Map (Cred era) (DRep era) ->
+  IncrementalState era
+smartIS (UTxO u) d v = IS u d v cred' ptr' (computePoolDistr d cred') (computeDRepDistr v cred')
+  where
+    cred' = credDistrFromUtxo u
+    ptr' = ptrDistrFromUtxo u
+
+-- =============================================================
+-- Slow Brute force solution
+
+-- | This computes the changes in the 'dependencies' using brute force, that is
+--   the non-incremental functions credDistrFromUtxo, ptrDistrFromUtxo , computePoolDistr, and computeDRepDistr, which traverse the entirety
+--   of the 'roots' to compute the distribution of stake for each 'dependency'.
+slow ::
+  forall era.
+  (EraTxOut era) =>
+  Diff (Map (TxIn (EraCrypto era)) (TxOut era)) ->
+  Diff (Map (Cred era) (Pool era)) ->
+  Diff (Map (Cred era) (DRep era)) ->
+  IncrementalState era ->
+  IncrementalState era
+slow diff1 diff2 diff3 isState = IS utxo' delmap' votemap' cred' ptr' pool' drep'
+  where
+    utxo' = applyDiff (isUtxo isState) diff1
+    delmap' = applyDiff (isDelegate isState) diff2
+    votemap' = applyDiff (isVoteProxy isState) diff3
+    cred' = credDistrFromUtxo utxo'
+    ptr' = ptrDistrFromUtxo utxo'
+    pool' = computePoolDistr delmap' cred'
+    drep' = computeDRepDistr votemap' cred'
+
+-- =======================================================
+-- functions that compute the dependencies from the roots
+
+-- | Polymorphic function, that can be used at particular types to compute
+--   both computePoolDistr and computeDRepDistr. The first map assigns 'delegates'(k2) to keys(k1). The second
+--   map assigns 'stake'(Coin) to keys(k1). This agggregates the 'stake'(Coin) for
+--   each 'delegate'(k2). For the two uses 'delegates' are StakePools and Voting DReps.
+--   This is just a slight refactoring of 'agg' above
+f0 ::
+  (Ord k1, Ord k2) =>
+  Map k1 k2 ->
+  MonoidMap k1 Coin ->
+  MonoidMap k2 Coin
+f0 cd (MM cc) = MM $ Map.foldlWithKey' accum Map.empty cc
+  where
+    accum ans cred coin =
+      case Map.lookup cred cd of
+        Just khash -> Map.insertWith (<>) khash coin ans
+        Nothing -> ans
+
+-- | Aggregates the UTxO for each staking credential.
+credDistrFromUtxo :: (EraTxOut era) => Map k (TxOut era) -> MonoidMap (Cred era) Coin
+credDistrFromUtxo m = MM $ Map.foldl' accum Map.empty m
+  where
+    accum ans txout =
+      let coin = txout ^. coinTxOutL
+       in case txout ^. addrTxOutL of
+            Addr _ _ (StakeRefBase hk) -> Map.insertWith (<>) hk coin ans
+            _ -> ans
+
+-- | Aggregates the UTxO for each Ptr credential.
+ptrDistrFromUtxo :: (EraTxOut era) => Map k (TxOut era) -> MonoidMap Ptr Coin
+ptrDistrFromUtxo m = MM $ Map.foldl' accum Map.empty m
+  where
+    accum ans txout =
+      let coin = txout ^. coinTxOutL
+       in case txout ^. addrTxOutL of
+            Addr _ _ (StakeRefPtr p) -> Map.insertWith (<>) p coin ans
+            _ -> ans
+
+computePoolDistr ::
+  Map (Credential 'Staking c) (KeyHash 'StakePool c) ->
+  MonoidMap (Credential 'Staking c) Coin ->
+  MonoidMap (KeyHash 'StakePool c) Coin
+computePoolDistr = f0
+
+computeDRepDistr ::
+  Map (Credential 'Staking c) (KeyHash 'Voting c) ->
+  MonoidMap (Credential 'Staking c) Coin ->
+  MonoidMap (KeyHash 'Voting c) Coin
+computeDRepDistr = f0
+
+-- =============================================================
+-- Fast and efficient 'update' using incremental techniques
+
+-- | This computes the changes in the 'dependencies' using the incremental
+--   functions credDistrFromUtxo', ptrDistrFromUtxo' , computePoolDistr' , computeDRepDistr' which are the ILC derivatives of the
+--   brute force functions credDistrFromUtxo, ptrDistrFromUtxo , computePoolDistr, and computeDRepDistr. We expect this to orders of
+--   magnitude faster the 'slow'
+update ::
+  forall era.
+  (EraTxOut era) =>
+  Diff (Map (TxIn (EraCrypto era)) (TxOut era)) ->
+  Diff (Map (Cred era) (Pool era)) ->
+  Diff (Map (Cred era) (DRep era)) ->
+  IncrementalState era ->
+  IncrementalState era
+update diff1 diff2 diff3 isState = IS utxo' del' vote' cred' ptr' pool' drep'
+  where
+    utxo' = applyDiff (isUtxo isState) diff1
+    del' = applyDiff (isDelegate isState) diff2
+    vote' = applyDiff (isVoteProxy isState) diff3
+    cdiff :: Diff (MonoidMap (Cred era) Coin)
+    cdiff = credDistrFromUtxo' (isUtxo isState) diff1
+    cred' = applyDiff (isCredDistr isState) cdiff
+    ptr' = applyDiff (isPtrDistr isState) (ptrDistrFromUtxo' (isUtxo isState) diff1)
+    pool' = applyDiff (isPoolDistr isState) (computePoolDistr' (isDelegate isState) diff2 cred' cdiff)
+    drep' = applyDiff (isDRepDistr isState) (computeDRepDistr' (isVoteProxy isState) diff3 cred' cdiff)
+
+-- | The derivative of the polymorhphic function f0.
+--   A slight refactoring of the function agg'
+f0' ::
+  (Show k1, Show k2, Ord k1, Ord k2, MapLike m) =>
+  m k1 k2 ->
+  Diff (Map k1 k2) ->
+  MonoidMap k1 Coin ->
+  Diff (MonoidMap k1 Coin) ->
+  Diff (MonoidMap k2 Coin)
+f0' n (Dn dn) (MM m) (Dm dm) =
+  Dm $
+    inter3C Map.empty dm dn (changeDm2 m n) (changeDmDn2 m n) (changeDn2 m n)
+
+-- The derivative of credDistrFromUtxo. We make this polymorhic over 'k' so it is more likely
+-- we will test the unlikely cases.
+
+credDistrFromUtxo' ::
+  (EraTxOut era, Ord k) =>
+  Map k (TxOut era) ->
+  Diff (Map k (TxOut era)) ->
+  Diff (MonoidMap (Cred era) Coin)
+credDistrFromUtxo' utxo (Dn changes) = Dm $ Map.foldlWithKey' accum Map.empty changes
+  where
+    accum ans k Omit = case Map.lookup k utxo of
+      Nothing -> ans
+      (Just txout) -> case txout ^. addrTxOutL of
+        Addr _ _ (StakeRefBase hk) -> insertC hk (Comb (DiffCoin (-n))) ans
+          where
+            (Coin n) = txout ^. coinTxOutL
+        _ -> ans
+    accum ans k (Edit txout1) = case Map.lookup k utxo of
+      Nothing -> case txout1 ^. addrTxOutL of
+        Addr _ _ (StakeRefBase hk) -> insertC hk (Comb (DiffCoin n)) ans
+          where
+            (Coin n) = txout1 ^. coinTxOutL
+        _ -> ans
+      -- This case is highly unlikely, as k=TxIn, which is a cryptographic hash
+      (Just txout2) -> case (txout1 ^. addrTxOutL, txout2 ^. addrTxOutL) of
+        (Addr _ _ (StakeRefBase hk1), Addr _ _ (StakeRefBase hk2)) ->
+          insertC hk1 (Comb (DiffCoin n1)) (insertC hk2 (Comb (DiffCoin (-n2))) ans)
+          where
+            (Coin n1) = txout1 ^. coinTxOutL
+            (Coin n2) = txout2 ^. coinTxOutL
+        (Addr _ _ (StakeRefBase hk1), _) -> insertC hk1 (Comb (DiffCoin n1)) ans
+          where
+            (Coin n1) = txout1 ^. coinTxOutL
+        (_, Addr _ _ (StakeRefBase hk2)) -> insertC hk2 (Comb (DiffCoin (-n2))) ans
+          where
+            (Coin n2) = txout2 ^. coinTxOutL
+        (_, _) -> ans
+
+-- The derivative of ptrDistrFromUtxo
+ptrDistrFromUtxo' ::
+  (Ord k, EraTxOut era) =>
+  Map k (TxOut era) ->
+  Diff (Map k (TxOut era)) ->
+  Diff (MonoidMap Ptr Coin)
+ptrDistrFromUtxo' utxo (Dn changes) = Dm $ Map.foldlWithKey' accum Map.empty changes
+  where
+    accum ans k Omit = case Map.lookup k utxo of
+      Nothing -> ans
+      (Just txout) -> case txout ^. addrTxOutL of
+        Addr _ _ (StakeRefPtr p) -> insertC p (Comb (DiffCoin (-n))) ans
+          where
+            (Coin n) = txout ^. coinTxOutL
+        _ -> ans
+    accum ans k (Edit txout1) = case Map.lookup k utxo of
+      Nothing -> case txout1 ^. addrTxOutL of
+        Addr _ _ (StakeRefPtr p) -> insertC p (Comb (DiffCoin n)) ans
+          where
+            (Coin n) = txout1 ^. coinTxOutL
+        _ -> ans
+      -- This case is highly unlikely, as k=TxIn, which is a cryptographic hash
+      (Just txout2) -> case (txout1 ^. addrTxOutL, txout2 ^. addrTxOutL) of
+        (Addr _ _ (StakeRefPtr p1), Addr _ _ (StakeRefPtr p2)) ->
+          insertC p1 (Comb (DiffCoin n1)) (insertC p2 (Comb (DiffCoin (-n2))) ans)
+          where
+            (Coin n1) = txout1 ^. coinTxOutL
+            (Coin n2) = txout2 ^. coinTxOutL
+        (Addr _ _ (StakeRefPtr p1), _) -> insertC p1 (Comb (DiffCoin n1)) ans
+          where
+            (Coin n1) = txout1 ^. coinTxOutL
+        (_, Addr _ _ (StakeRefPtr p2)) -> insertC p2 (Comb (DiffCoin (-n2))) ans
+          where
+            (Coin n2) = txout2 ^. coinTxOutL
+        (_, _) -> ans
+
+-- The derivative of computePoolDistr (just instantiates f0' at the correct type)
+computePoolDistr' ::
+  forall c m.
+  MapLike m =>
+  m (Credential 'Staking c) (KeyHash 'StakePool c) ->
+  Diff (Map (Credential 'Staking c) (KeyHash 'StakePool c)) ->
+  MonoidMap (Credential 'Staking c) Coin ->
+  Diff (MonoidMap (Credential 'Staking c) Coin) ->
+  Diff (MonoidMap (KeyHash 'StakePool c) Coin)
+computePoolDistr' = f0'
+
+-- The derivative of computeDRepDistr (just instantiates f0' at the correct type)
+computeDRepDistr' ::
+  forall c.
+  Map (Credential 'Staking c) (KeyHash 'Voting c) ->
+  Diff (Map (Credential 'Staking c) (KeyHash 'Voting c)) ->
+  MonoidMap (Credential 'Staking c) Coin ->
+  Diff (MonoidMap (Credential 'Staking c) Coin) ->
+  Diff (MonoidMap (KeyHash 'Voting c) Coin)
+computeDRepDistr' = f0'
+
+-- =========================================================================
+utxoL :: Lens' (LedgerState era) (UTxO era)
+utxoL = lsUTxOStateL . utxosUtxoL
+
+poolL :: Lens' (LedgerState era) (View (EraCrypto era) (Cred era) (Pool era))
+poolL = lsDPStateL . dpsDStateL . dsUnifiedL . umapPool
+
+umapPool :: Lens' (UM.UMap c) (View c (Credential 'Staking c) (KeyHash 'StakePool c))
+umapPool = lens Delegations (\_umap (Delegations um) -> um)
+
+drepL :: Lens' (LedgerState era) (View (EraCrypto era) (Cred era) (DRep era))
+drepL = lsDPStateL . dpsDStateL . dsUnifiedL . umapD
+
+umapD :: Lens' (UM.UMap c) (View c (Credential 'Staking c) (KeyHash 'Voting c))
+umapD = lens Dreps (\_umap (Dreps um) -> um)
+
+
+ilcL :: Lens' (LedgerState era) (ILCState era)
+ilcL = lsDPStateL . undefined
+data ILCState era = ILCState
+  { ilcCredDistr :: !(MonoidMap (Cred era) Coin)
+  , ilcPtrDistr :: !(MonoidMap Ptr Coin)
+  , ilcPoolDistr :: !(MonoidMap (Pool era) Coin)
+  , ilcDRepDistr :: !(MonoidMap (DRep era) Coin)
+  }
+
+updateILC ::
+  forall era.
+  EraTxOut era =>
+  Diff (Map (TxIn (EraCrypto era)) (TxOut era)) ->
+  Diff (View (EraCrypto era) (Cred era) (Pool era)) ->
+  Diff (View (EraCrypto era) (Cred era) (DRep era)) ->
+  LedgerState era ->
+  LedgerState era
+updateILC dUtxo dPool dDrep ls =
+  ls
+    & ilcL .~ (ILCState cred' ptr' pool' drep')
+    & utxoL .~ (UTxO utxoNew)
+    & poolL .~ delNew
+    & drepL .~ voteNew
+  where
+    UTxO utxo = ls ^. utxoL
+    delegs = ls ^. poolL
+    votes = ls ^. drepL
+    (ILCState credDistr ptrDistr poolDistr drepDistr) = ls ^. ilcL
+    utxoNew = utxo `applyDiff` dUtxo
+    delNew = delegs `applyDiff` dPool
+    voteNew = votes `applyDiff` dDrep
+    cdiff :: Diff (MonoidMap (Cred era) Coin)
+    cdiff = credDistrFromUtxo' utxo dUtxo
+    cred' = credDistr `applyDiff` cdiff
+    ptr' = ptrDistr `applyDiff` (ptrDistrFromUtxo' utxo dUtxo)
+    pool' = poolDistr `applyDiff` (computePoolDistr'2 delegs dPool cred' cdiff)
+    drep' = drepDistr `applyDiff` (computeDRepDistr'2 votes dDrep cred' cdiff)
+
+addStakingDelegation
+  :: EraTxOut era =>
+     Credential 'Staking (EraCrypto era)
+     -> KeyHash 'StakePool (EraCrypto era)
+     -> LedgerState era
+     -> LedgerState era
+addStakingDelegation cred kh = updateILC (Dn Map.empty) (Dl (Map.singleton cred (Edit kh))) (Dl Map.empty)
+
+removeStakingDelegation
+  :: EraTxOut era =>
+     Credential 'Staking (EraCrypto era)
+     -> LedgerState era
+     -> LedgerState era
+removeStakingDelegation cred = updateILC (Dn Map.empty) (Dl (Map.singleton cred Omit)) (Dl Map.empty)
+
+addVotingProxy
+  :: EraTxOut era =>
+     Credential 'Staking (EraCrypto era)
+     -> KeyHash 'Voting (EraCrypto era)
+     -> LedgerState era
+     -> LedgerState era
+addVotingProxy cred kh = updateILC (Dn Map.empty) (Dl Map.empty) (Dl (Map.singleton cred (Edit kh)))
+
+removeVotingProxy
+  :: EraTxOut era =>
+     Credential 'Staking (EraCrypto era)
+     -> LedgerState era
+     -> LedgerState era
+removeVotingProxy cred = updateILC (Dn Map.empty) (Dl Map.empty) (Dl (Map.singleton cred Omit))
+
+updateUTxO ::
+  EraTxOut era =>
+  UTxO era ->
+  UTxO era ->
+  LedgerState era ->
+  LedgerState era
+updateUTxO (UTxO utxoDel) (UTxO utxoAdd) = updateILC (Dn diffs2) (Dl Map.empty) (Dl Map.empty)
+  where diffs1 = Map.foldlWithKey remove Map.empty utxoDel
+        remove ans txin _txout = Map.insert txin Omit ans
+        diffs2 = Map.foldlWithKey add diffs1 utxoAdd
+        add ans txin txout = Map.insert txin (Edit txout) ans
+
+-- The derivative of computePoolDistr adjusted for the fact that the the first
+-- arg is a View, rather than a Map.
+computePoolDistr'2 ::
+  View c (Credential 'Staking c) (KeyHash 'StakePool c) ->
+  Diff (View c (Credential 'Staking c) (KeyHash 'StakePool c)) ->
+  MonoidMap (Credential 'Staking c) Coin ->
+  Diff (MonoidMap (Credential 'Staking c) Coin) ->
+  Diff (MonoidMap (KeyHash 'StakePool c) Coin)
+computePoolDistr'2 n (Dl dn) (MM m) (Dm dm) =
+  Dm $
+    inter3C Map.empty dm dn (changeDm2 m n) (changeDmDn2 m n) (changeDn2 m n)
+
+-- The derivative of computeDRepDistr adjusted for the fact that the the first
+-- arg is a View, rather than a Map.
+computeDRepDistr'2 ::
+  View c (Credential 'Staking c) (KeyHash 'Voting c) ->
+  Diff (View c (Credential 'Staking c) (KeyHash 'Voting c)) ->
+  MonoidMap (Credential 'Staking c) Coin ->
+  Diff (MonoidMap (Credential 'Staking c) Coin) ->
+  Diff (MonoidMap (KeyHash 'Voting c) Coin)
+computeDRepDistr'2 n (Dl dn) (MM m) (Dm dm) =
+  Dm $
+    inter3C Map.empty dm dn (changeDm2 m n) (changeDmDn2 m n) (changeDn2 m n)
+
+-- ======================================
+
+instance Ord k => ILC (UM.View c k v) where
+  newtype Diff (UM.View c k v) = Dl (Map k (BinaryRngD v))
+  applyDiff view (Dl changes) = Map.foldlWithKey' accum view changes
+    where
+      accum ans k Omit = deleteLike k ans
+      accum ans k (Edit keyhash) = insertLike k keyhash ans
+  zero = Dl Map.empty
+  extend (Dl x) (Dl y) = Dl (Map.unionWith (<>) x y)
+
+instance ILC (UM.UMap c) where
+  newtype Diff (UM.UMap c) = Du (Map (Credential 'Staking c) (BinaryRngD (KeyHash 'StakePool c)))
+  applyDiff umap (Du changes) = Map.foldlWithKey' accum umap changes
+    where
+      accum ans k Omit = UM.delete k (UM.Delegations ans)
+      accum ans k (Edit keyhash) = UM.insert k keyhash (UM.Delegations ans)
+  zero = Du Map.empty
+  extend (Du x) (Du y) = Du (Map.unionWith (<>) x y)
+
+-- =========================================================================
+
+changeDm2 ::
+  (Show cred, Ord cred, Ord drep, Show drep, MapLike mapT, MapLike mapS) =>
+  mapT cred Coin ->
+  -- | either a Map or a View that behaves like a map.
+  mapS cred drep ->
+  Map drep (MonoidRngD (Diff Coin)) ->
+  cred ->
+  MonoidRngD (Diff Coin) ->
+  Map drep (MonoidRngD (Diff Coin))
+changeDm2 m n ans cred dcoin = case try cred (dcoin, lookupLike cred m, lookupLike cred n) of
+  (Del, Nothing, Nothing) -> ans
+  (Del, Nothing, Just _) -> ans
+  (Del, Just _, Nothing) -> ans
+  (Del, Just (Coin c2), Just r2) -> insertC r2 (Comb (DiffCoin (-c2))) ans
+  (Write _, Nothing, Nothing) -> ans
+  (Write c1, Nothing, Just r2) -> insertC r2 (Comb c1) ans
+  (Write _, Just _, Nothing) -> ans
+  (Write (DiffCoin c1), Just (Coin c2), Just r2) ->
+    insertC r2 (Comb (DiffCoin (c1 - c2))) ans
+  (Comb _, Nothing, Nothing) -> ans
+  (Comb c1, Nothing, Just r2) -> insertC r2 (Comb c1) ans
+  (Comb _, Just _, Nothing) -> ans
+  (Comb (DiffCoin c1), Just _, Just r2) -> insertC r2 (Comb (DiffCoin c1)) ans
+
+changeDmDn2 ::
+  forall mapT mapS cred drep.
+  (Show cred, Ord cred, Show drep, Ord drep, MapLike mapT, MapLike mapS) =>
+  mapT cred Coin ->
+  mapS cred drep ->
+  Map drep (MonoidRngD (Diff Coin)) ->
+  cred ->
+  (MonoidRngD (Diff Coin), BinaryRngD drep) ->
+  Map drep (MonoidRngD (Diff Coin))
+changeDmDn2 m n ans cred (dcoin, drep) =
+  case try cred (dcoin, drep, lookupLike cred m, lookupLike cred n) of
+    (Del, Omit, Nothing, Nothing) -> ans
+    (Del, Omit, Nothing, Just _) -> ans
+    (Del, Omit, Just _, Nothing) -> ans
+    (Del, Omit, Just (Coin c2), Just r2) ->
+      insertC r2 (Comb (DiffCoin (-c2))) ans
+    (Del, Edit _, Nothing, Nothing) -> ans
+    (Del, Edit _, Nothing, Just _) -> ans
+    (Del, Edit _, Just _, Nothing) -> ans
+    (Del, Edit _, Just (Coin c2), Just r2) ->
+      insertC r2 (Comb (DiffCoin (-c2))) ans
+    (Write _, Omit, Nothing, Nothing) -> ans
+    (Write _, Omit, Nothing, Just _) -> ans
+    (Write _, Omit, Just _, Nothing) -> ans
+    (Write _, Omit, Just (Coin c2), Just r2) ->
+      insertC r2 (Comb (DiffCoin (-c2))) ans
+    (Write c1, Edit r1, Nothing, Nothing) ->
+      insertC r1 (Comb c1) ans
+    (Write c1, Edit r1, Nothing, Just _) ->
+      insertC r1 (Comb c1) ans
+    (Write c1, Edit r1, Just _, Nothing) -> insertC r1 (Comb c1) ans
+    (Write c1, Edit r1, Just (Coin c2), Just r2) ->
+      insertC r1 (Comb c1) (insertC r2 (Comb (DiffCoin (-c2))) ans)
+    (Comb _, Omit, Nothing, Nothing) -> ans
+    (Comb _, Omit, Nothing, Just _) -> ans
+    (Comb _, Omit, Just _, Nothing) -> ans
+    (Comb _, Omit, Just (Coin c2), Just r2) ->
+      insertC r2 (Comb (DiffCoin (-c2))) ans
+    (Comb c1, Edit r1, Nothing, Nothing) ->
+      insertC r1 (Comb c1) ans
+    (Comb c1, Edit r1, Nothing, Just _) -> insertC r1 (Comb c1) ans
+    (Comb (DiffCoin c1), Edit r1, Just (Coin c2), Nothing) ->
+      insertC r1 (Comb (DiffCoin (c1 + c2))) ans
+    (Comb (DiffCoin c3), Edit r1, Just (Coin c2), Just r2) ->
+      insertC r1 (Comb (DiffCoin (c3 + c2))) (insertC r2 (Comb (DiffCoin (-c2))) ans)
+
+changeDn2 ::
+  (Show cred, Ord cred, Ord drep, Show drep, MapLike mapT, MapLike mapS) =>
+  mapT cred Coin ->
+  mapS cred drep ->
+  Map drep (MonoidRngD (Diff Coin)) ->
+  cred ->
+  BinaryRngD drep ->
+  Map drep (MonoidRngD (Diff Coin))
+changeDn2 m n ans cred dd = case try cred (dd, lookupLike cred m, lookupLike cred n) of
+  (Omit, Nothing, Nothing) -> ans
+  (Omit, Nothing, Just _) -> ans
+  (Omit, Just _, Nothing) -> ans
+  (Omit, Just (Coin c2), Just r2) ->
+    insertC r2 (Comb (DiffCoin (-c2))) ans
+  (Edit _, Nothing, Nothing) -> ans
+  (Edit _, Nothing, Just _) -> ans
+  (Edit r1, Just (Coin c2), Nothing) ->
+    insertC r1 (Comb (DiffCoin c2)) ans
+  (Edit r1, Just (Coin c2), Just r2) ->
+    insertC r2 (Comb (DiffCoin (-c2))) (insertC r1 (Comb (DiffCoin c2)) ans)
+
+-------------------------------------------------------------------
+
+makeSnapShot ::
+  forall era.
+  EraPParams era =>
+  PParams era ->
+  LedgerState era ->
+  SnapShot (EraCrypto era)
+makeSnapShot pp ledgerState =
+  SnapShot
+    (Stake $ VMap.fromMap (UM.compactCoinOrError <$> step2))
+    delegate
+    (VMap.fromMap poolParams)
+  where
+    dstate = (dpsDState . lsDPState) ledgerState
+    UM.UMap triplesMap ptrsMap = dsUnified dstate
+    poolParams = (psStakePoolParams . dpsPState . lsDPState) ledgerState
+    ILCState (MM credDistr) (MM ptrDistr) _poolDistr _voteDistr = ledgerState ^. ilcL
+    delegate = UM.viewToVMap (delegations dstate)
+    ignorePtrs = HardForks.forgoPointerAddressResolution (pp ^. ppProtocolVersionL)
+    -- pre Conway: (dom activeDelegs ◁ credStake) ∪ (dom activeDelegs ◁ ptrStake)
+    -- afterwards we forgo ptr resolution: (dom activeDelegs ◁ credStake)
+    step1 =
+      if ignorePtrs
+        then credDistr
+        else -- Resolve inserts and deletes which were indexed by ptrs, by looking them up 
+             -- in the ptrsMap and combining the result of the lookup with the credDistr.
+          Map.foldlWithKey' addResolvedPointer credDistr ptrDistr
+    addResolvedPointer ans ptr coin =
+      case Map.lookup ptr ptrsMap of 
+        Just cred | VMap.member cred delegate -> Map.insertWith (<>) cred coin ans
+        _ -> ans          
+    step2 = addRewardsAndCreds triplesMap step1
+
+
+-- | Aggregate active stake by merging two maps. The rewards map from the
+--   UMap, and the computed incremental stake. Only keep the active stake of
+--   the rewards. This can be determined by if there is a (SJust deleg) in
+--   the Triple.  The incemental stake is alway active, since it is recomputed
+--   on every change.
+addRewardsAndCreds :: Ord k => Map k (UM.Trip c) -> Map k Coin -> Map k Coin
+addRewardsAndCreds m1 m2 = assert (Map.valid m) m
+  where
+    m =
+      Map.mergeWithKey
+        -- How to merge the ranges of the two maps where they have a common key. Below
+        -- 'coin1' and 'coin2' have the same key, '_k', and the stake is active if the delegation is SJust
+        (\_k trip coin2 -> extractAndAdd coin2 <$> UM.tripRewardActiveDelegation trip)
+        -- what to do when a key appears just in 'tripmap', we only add the coin if the key is active
+        (Map.mapMaybe (\trip -> UM.fromCompact . UM.rdReward <$> UM.tripRewardActiveDelegation trip))
+        -- what to do when a key is only in 'incremental', keep everything, because we know it is active.
+        id
+        m1
+        m2
+    extractAndAdd :: Coin -> UM.RDPair -> Coin
+    extractAndAdd coin (UM.RDPair rew _dep) = coin <> UM.fromCompact rew
\ No newline at end of file
diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs
index 656ef3a4ea2..784da5791c2 100644
--- a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs
+++ b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs
@@ -565,7 +565,7 @@ getDStateNoSharing dstateId = do
         pure (Keys.coerceKeyRole credential, iRTreasuryCoin)
   pure
     Shelley.DState
-      { dsUnified = unify rewards delegations ptrs
+      { dsUnified = unify rewards delegations ptrs Map.empty
       , dsFutureGenDelegs = unEnc dStateFGenDelegs
       , dsGenDelegs = dStateGenDelegs
       , dsIRewards =
@@ -619,7 +619,7 @@ getDStateWithSharing dstateId = do
         pure (cred, iRTreasuryCoin)
   pure
     Shelley.DState
-      { dsUnified = unify rewards delegations ptrs
+      { dsUnified = unify rewards delegations ptrs Map.empty
       , dsFutureGenDelegs = unEnc dStateFGenDelegs
       , dsGenDelegs = dStateGenDelegs
       , dsIRewards =