test-consensus: replace suchThat with a binary search

IntersectMBO · Dec 3, 2019 · ccf0ef0 · ccf0ef0
1 parent f0bcbf7
commit ccf0ef0
Show file tree

Hide file tree

Showing 4 changed files with 18 additions and 3 deletions.
diff --git a/nix/.stack.nix/ouroboros-consensus.nix b/nix/.stack.nix/ouroboros-consensus.nix
diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -306,6 +306,7 @@ test-suite test-consensus
                     io-sim-classes,
                     io-sim,
 
+                    binary-search,
                     cborg,
                     containers,
                     contra-tracer,

diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs
@@ -15,6 +15,7 @@ import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromJust)
 import           Data.Time (Day (..), UTCTime (..))
 
+import           Numeric.Search.Range (searchFromTo)
 import           Test.QuickCheck
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
@@ -255,10 +256,20 @@ genRealPBFTNodeJoinPlan params numSlots@(NumSlots t)
             -- *always* suffice?)
         let check s' =
                 Ref.viable params lastSlot
-                    (NodeJoinPlan (Map.insert nid s' m))
+                    (NodeJoinPlan (Map.insert nid (SlotNo s') m))
                     st
-        s' <- genSlot (Ref.nextSlot st) lastSlot
-            `suchThat` check
+            lo = Ref.nextSlot st
+              -- @check@ is downward-closed, but 'searchFromTo' requires
+              -- upward-closed, so we instead search to find the first slot
+              -- that is /not/ /viable/ and then decrement it to find the
+              -- latest slot that is /viable/
+        s' <- case searchFromTo (not . check) (unSlotNo lo) (unSlotNo lastSlot) of
+            Nothing                -> genSlot lo lastSlot
+            Just succHi
+              | SlotNo succHi > lo -> genSlot lo $ SlotNo $ pred succHi
+              | otherwise          -> error $
+                "Cannot find viable RealPBFT NodeJoinPlan: " ++
+                show (SlotNo succHi, nodeJoinPlan, st)
 
         let m'  = Map.insert nid s' m
 

diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Ref/RealPBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Ref/RealPBFT.hs
@@ -83,8 +83,10 @@ data State = State
   , outs     :: !(Seq Outcome)
     -- ^ the outcome of each the last @2k@ slots
   }
+  deriving (Eq, Show)
 
 newtype NumNominals = NumNominals Int
+  deriving (Eq, Ord, Show)
 
 emptyState :: State
 emptyState = State Seq.empty (NumNominals 0) 0 Seq.empty