From 14aa88cc65e5001b1cb111b60b0c0ce8cf0334a2 Mon Sep 17 00:00:00 2001
From: Lars Kuhtz <lars@kadena.io>
Date: Fri, 13 Dec 2024 09:28:18 -0800
Subject: [PATCH] some fixes to cut

---
 src/Chainweb/Cut.hs | 47 ++++++++++++++++++++++-----------------------
 1 file changed, 23 insertions(+), 24 deletions(-)

diff --git a/src/Chainweb/Cut.hs b/src/Chainweb/Cut.hs
index f30d820ddb..ee21acb3cd 100644
--- a/src/Chainweb/Cut.hs
+++ b/src/Chainweb/Cut.hs
@@ -109,7 +109,7 @@ import qualified Data.HashMap.Strict as HM
 import qualified Data.HashSet as HS
 import qualified Data.Heap as H
 import qualified Data.List as List
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.Maybe (fromMaybe)
 import Data.Monoid
 import Data.Ord
 import Data.Text (Text)
@@ -729,16 +729,17 @@ join_
     -> HM.HashMap ChainId BlockHeader
     -> IO (Join a)
 join_ wdb prioFun a b = do
-    (m, h) <- foldM f (mempty, mempty) (zipChainIdMaps a' b')
+    (m, h) <- ifoldlM f (mempty, mempty) (HM.intersectionWith (,) a' b')
     return $! Join (Cut' m (_chainwebVersion wdb)) h
   where
     (a', b') = joinChains a b
 
     f
-        :: (HM.HashMap ChainId BlockHeader, JoinQueue a)
-        -> (ChainId, BlockHeader, BlockHeader)
+        :: ChainId
+        -> (HM.HashMap ChainId BlockHeader, JoinQueue a)
+        -> (BlockHeader, BlockHeader)
         -> IO (HM.HashMap ChainId BlockHeader, JoinQueue a)
-    f (m, q) (cid, x, y) = do
+    f cid (m, q) (x, y) = do
         db <- getWebBlockHeaderDb wdb cid
         (q' :> !h) <- S.fold g q id $ branchDiff_ db x y
         let h' = HM.insert cid h m
@@ -754,18 +755,6 @@ join_ wdb prioFun a b = do
     maybeInsert !q (_, Nothing) = q
     maybeInsert !q (!h, (Just !p)) = H.insert (H.Entry (view blockHeight h, p) h) q
 
-    -- | Only chain ids of the intersection are included in the result.
-    --
-    zipChainIdMaps
-        :: HM.HashMap ChainId BlockHeader
-        -> HM.HashMap ChainId BlockHeader
-        -> [(ChainId, BlockHeader, BlockHeader)]
-    zipChainIdMaps m0 m1 = catMaybes
-        [ (cida, x, y) <$ guard (cida == cidb)
-        | (cida, x) <- itoList m0
-        | (cidb, y) <- itoList m1
-        ]
-
 -- | If the cuts are from different graphs only the chain ids of the
 -- intersection are included in the result.
 --
@@ -845,7 +834,7 @@ prioritizeHeavier = prioritizeHeavier_ `on` _cutHeaders
 --
 prioritizeHeavier_
     :: Foldable f
-    => Ord (f BlockHeader)
+    => Eq (f BlockHeader)
     => f BlockHeader
     -> f BlockHeader
     -> DiffItem BlockHeader
@@ -867,9 +856,18 @@ prioritizeHeavier_ a b = f
         , sumOf (folded . blockHeight) c
             -- for scenarios with trivial difficulty height is added as
             -- secondary metrics
-        , c
+
+        -- NOTE:
+        -- We could consider prioritizing the latest block in the cut here as
+        -- first-level tie breaker. That would further incentivize miners to use
+        -- a block creation time that is close to the real world time (note that
+        -- blocks from the future are rejected, so post-dating blocks is risky
+        -- for miners.)
+
+        , List.sort (toList c)
             -- the block hashes of the cut are added as tie breaker in order
             -- to guarantee commutativity.
+            --
         )
 
 -- -------------------------------------------------------------------------- --
@@ -883,10 +881,10 @@ meet
     -> Cut
     -> IO Cut
 meet wdb a b = do
-    !r <- HM.fromList <$> mapM f (zipCuts a b)
+    !r <- imapM f $ HM.intersectionWith (,) (_cutHeaders a) (_cutHeaders b)
     return $! Cut' r (_chainwebVersion wdb)
   where
-    f (!cid, !x, !y) = (cid,) <$!> do
+    f !cid (!x, !y) = do
         db <- getWebBlockHeaderDb wdb cid
         forkEntry db x y
 
@@ -899,9 +897,10 @@ forkDepth wdb a b = do
     m <- meet wdb a b
     return $! int $ max (maxDepth m a) (maxDepth m b)
   where
-    maxDepth l u = maximum
-        $ (\(_, x, y) -> view blockHeight y - view blockHeight x)
-        <$> zipCuts l u
+    maxDepth l u = maximum $ HM.intersectionWith
+        (\x y -> view blockHeight y - view blockHeight x)
+        (_cutHeaders l)
+        (_cutHeaders u)
 
 cutToTextShort :: Cut -> [Text]
 cutToTextShort c =