diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # Changelog +- 0.2.2 (2026-07-02) + * Adds a Numeric.Eproc.Bernoulli.TwoSided module for a two-sided + Bernoulli rate test. + - 0.2.1 (2026-07-02) * Two-sided bounded-mean tests now reject faster, or at least never later. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -5,6 +5,7 @@ import Control.DeepSeq import qualified Numeric.Eproc.Bernoulli as Bern +import qualified Numeric.Eproc.Bernoulli.TwoSided as BernTS import qualified Numeric.Eproc.Bounded as Bounded import qualified Numeric.Eproc.Paired as P import Criterion.Main @@ -15,6 +16,7 @@ instance NFData Bounded.State where rnf !_ = () instance NFData P.State where rnf !_ = () instance NFData Bern.State where rnf !_ = () +instance NFData BernTS.State where rnf !_ = () instance NFData Bounded.Verdict where rnf !_ = () -- partial helper for benches: configs here are hardcoded valid, so a @@ -31,6 +33,8 @@ , twosample , bern_update , bern_stream + , bern_ts_update + , bern_ts_stream ] update :: Benchmark @@ -104,6 +108,33 @@ !cfg_o = ok (Bern.config 0.05 1.0e-3 Bern.Newton) run_b cfg = foldl' (Bern.update cfg) (Bern.initial cfg) in bgroup "Bernoulli.update (1000-sample fold)" [ + bench "fixed" $ nf (run_b cfg_f) xs + , bench "adaptive" $ nf (run_b cfg_a) xs + , bench "newton" $ nf (run_b cfg_o) xs + ] + +bern_ts_update :: Benchmark +bern_ts_update = + let !cfg_f = ok (BernTS.config 0.5 1.0e-3 (BernTS.Fixed 1.0)) + !cfg_a = ok (BernTS.config 0.5 1.0e-3 BernTS.Adaptive) + !cfg_o = ok (BernTS.config 0.5 1.0e-3 BernTS.Newton) + !st_f = BernTS.initial cfg_f + !st_a = BernTS.initial cfg_a + !st_o = BernTS.initial cfg_o + in bgroup "Bernoulli.TwoSided.update (one step)" [ + bench "fixed" $ nf (BernTS.update cfg_f st_f) True + , bench "adaptive" $ nf (BernTS.update cfg_a st_a) True + , bench "newton" $ nf (BernTS.update cfg_o st_o) True + ] + +bern_ts_stream :: Benchmark +bern_ts_stream = + let !xs = force (take 1000 (cycle [True, False])) + !cfg_f = ok (BernTS.config 0.5 1.0e-3 (BernTS.Fixed 1.0)) + !cfg_a = ok (BernTS.config 0.5 1.0e-3 BernTS.Adaptive) + !cfg_o = ok (BernTS.config 0.5 1.0e-3 BernTS.Newton) + run_b cfg = foldl' (BernTS.update cfg) (BernTS.initial cfg) + in bgroup "Bernoulli.TwoSided.update (1000-sample fold)" [ bench "fixed" $ nf (run_b cfg_f) xs , bench "adaptive" $ nf (run_b cfg_a) xs , bench "newton" $ nf (run_b cfg_o) xs diff --git a/bench/Weight.hs b/bench/Weight.hs --- a/bench/Weight.hs +++ b/bench/Weight.hs @@ -5,6 +5,7 @@ import Control.DeepSeq import qualified Numeric.Eproc.Bernoulli as Bern +import qualified Numeric.Eproc.Bernoulli.TwoSided as BernTS import qualified Numeric.Eproc.Bounded as Bounded import qualified Numeric.Eproc.Paired as P import Weigh @@ -12,6 +13,7 @@ instance NFData Bounded.State where rnf !_ = () instance NFData P.State where rnf !_ = () instance NFData Bern.State where rnf !_ = () +instance NFData BernTS.State where rnf !_ = () instance NFData Bounded.Verdict where rnf !_ = () -- partial helper for benches: configs here are hardcoded valid. @@ -28,6 +30,8 @@ twosample bern_update bern_stream + bern_ts_update + bern_ts_stream update :: Weigh () update = @@ -94,6 +98,31 @@ !cfg_o = ok (Bern.config 0.05 1.0e-3 Bern.Newton) run_b cfg = foldl' (Bern.update cfg) (Bern.initial cfg) in wgroup "Bernoulli.update (1000-sample fold)" $ do + func "fixed" (run_b cfg_f) xs + func "adaptive" (run_b cfg_a) xs + func "newton" (run_b cfg_o) xs + +bern_ts_update :: Weigh () +bern_ts_update = + let !cfg_f = ok (BernTS.config 0.5 1.0e-3 (BernTS.Fixed 1.0)) + !cfg_a = ok (BernTS.config 0.5 1.0e-3 BernTS.Adaptive) + !cfg_o = ok (BernTS.config 0.5 1.0e-3 BernTS.Newton) + !st_f = BernTS.initial cfg_f + !st_a = BernTS.initial cfg_a + !st_o = BernTS.initial cfg_o + in wgroup "Bernoulli.TwoSided.update (one step)" $ do + func "fixed" (BernTS.update cfg_f st_f) True + func "adaptive" (BernTS.update cfg_a st_a) True + func "newton" (BernTS.update cfg_o st_o) True + +bern_ts_stream :: Weigh () +bern_ts_stream = + let !xs = force (take 1000 (cycle [True, False])) + !cfg_f = ok (BernTS.config 0.5 1.0e-3 (BernTS.Fixed 1.0)) + !cfg_a = ok (BernTS.config 0.5 1.0e-3 BernTS.Adaptive) + !cfg_o = ok (BernTS.config 0.5 1.0e-3 BernTS.Newton) + run_b cfg = foldl' (BernTS.update cfg) (BernTS.initial cfg) + in wgroup "Bernoulli.TwoSided.update (1000-sample fold)" $ do func "fixed" (run_b cfg_f) xs func "adaptive" (run_b cfg_a) xs func "newton" (run_b cfg_o) xs diff --git a/lib/Numeric/Eproc/Bernoulli.hs b/lib/Numeric/Eproc/Bernoulli.hs --- a/lib/Numeric/Eproc/Bernoulli.hs +++ b/lib/Numeric/Eproc/Bernoulli.hs @@ -8,7 +8,9 @@ -- License: MIT -- Maintainer: Jared Tobin -- --- One-sided Bernoulli rate anytime-valid test. +-- One-sided Bernoulli rate anytime-valid test. See +-- "Numeric.Eproc.Bernoulli.TwoSided" for the two-sided companion +-- (used for the sign test at @p_0 = 1\/2@, among other things). -- -- For samples @x_t@ in @{0, 1}@, tests -- @@ -36,9 +38,9 @@ -- 'Reject' even if subsequent observations drive the current -- wealth back below threshold. -- --- Unlike "Numeric.Eproc.Bounded", the alternative here is one-sided, --- so a single wealth process suffices and no Bonferroni adjustment --- is needed -- the rejection threshold is @log(1 \/ alpha)@. +-- The alternative here is one-sided, so a single wealth process +-- suffices and no Bonferroni or hedge adjustment is needed -- the +-- rejection threshold is @log(1 \/ alpha)@. -- -- == Example -- @@ -73,6 +75,7 @@ , samples ) where +import GHC.Float (log1p) import Numeric.Eproc.Common ( Bettor(..), Verdict(..), ConfigError(..) , BetState, init_bet, bet_lambda, step_bet @@ -198,8 +201,7 @@ let !xd = if x then 1 else 0 !z = xd - cfg_p0 !lam = bet_lambda cfg_bettor cfg_lam_max st_bet - !fac = 1 + lam * z - !logw' = st_log_w + log fac + !logw' = st_log_w + log1p (lam * z) !maxw' = max st_max_log_w logw' !s' = step_bet cfg_bettor cfg_lam_max st_bet z in State (st_n + 1) logw' maxw' s' diff --git a/lib/Numeric/Eproc/Bernoulli/TwoSided.hs b/lib/Numeric/Eproc/Bernoulli/TwoSided.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/Eproc/Bernoulli/TwoSided.hs @@ -0,0 +1,139 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module: Numeric.Eproc.Bernoulli.TwoSided +-- Copyright: (c) 2026 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Two-sided Bernoulli rate anytime-valid test. Companion to +-- "Numeric.Eproc.Bernoulli", which handles the one-sided case; +-- reach for this module when you want to test +-- +-- @H_0: E[x_t | F_{t-1}] = p_0 for all t@ +-- +-- against the negation. The canonical case is the sign test at +-- @p_0 = 1\/2@. +-- +-- This is exactly the two-sided bounded-mean test on @[0, 1]@ with +-- null mean @p_0@, so the module is a thin newtype wrapper over +-- "Numeric.Eproc.Bounded" (much as "Numeric.Eproc.Paired" is a +-- wrapper for the paired difference case). See the Bounded module +-- for the mathematical detail: convex-hedge combination of two +-- per-direction e-processes, threshold @log(2 \/ alpha)@, latched +-- rejection, etc. +-- +-- == Example +-- +-- Sign test at @p_0 = 1\/2@ with a downward shift: +-- +-- >>> let Right cfg = config 0.5 1.0e-3 Newton +-- >>> let s0 = initial cfg +-- >>> let xs = take 500 (cycle [False, False, False, True]) +-- >>> decide cfg (foldl' (update cfg) s0 xs) +-- Reject + +module Numeric.Eproc.Bernoulli.TwoSided ( + -- * Test configuration and state + Config + , State + , Verdict(..) + , ConfigError(..) + + -- * Bettor strategies + , Bettor(..) + + -- * Construction + , config + , initial + + -- * Streaming + , update + , decide + + -- * Inspection + , log_wealth + , samples + ) where + +import qualified Numeric.Eproc.Bounded as Bounded +import Numeric.Eproc.Common (Bettor(..), Verdict(..), ConfigError(..)) + +-- types ---------------------------------------------------------------------- + +-- | Two-sided Bernoulli rate test configuration. Build with 'config'. +-- Wraps a 'Numeric.Eproc.Bounded.Config' on @[0, 1]@ with null +-- mean @p_0@. +newtype Config = Config Bounded.Config + +-- | Streaming test state. Construct with 'initial' and fold +-- observations through 'update'. +newtype State = State Bounded.State + +-- construction --------------------------------------------------------------- + +-- | Build a 'Config' for the two-sided Bernoulli rate test. +-- +-- Returns 'Left' with a 'ConfigError' on inputs that would leave +-- the mathematical regime: @p_0@ outside @(0, 1)@ (or non-finite), +-- or @alpha@ outside @(0, 1)@ (or non-finite). +-- +-- >>> let Right cfg = config 0.5 1.0e-3 Newton +config + :: Double -- ^ baseline rate @p_0@, in @(0, 1)@ + -> Double -- ^ significance level @alpha@, in @(0, 1)@ + -> Bettor -- ^ bettor strategy + -> Either ConfigError Config +config !p0 !alpha b + -- NaN comparisons return False and (-Inf, +Inf) fail the range + -- check, so this catches non-finite p_0 without a separate guard. + | not (p0 > 0 && p0 < 1) = Left (InvalidBaselineRate p0) + | otherwise = fmap Config (Bounded.config p0 0 1 alpha b) +{-# INLINE config #-} + +-- | The initial 'State' for a fresh streaming test. +-- +-- >>> let s0 = initial cfg +initial :: Config -> State +initial (Config c) = State (Bounded.initial c) +{-# INLINE initial #-} + +-- streaming ------------------------------------------------------------------ + +-- | Fold one observation into the running 'State'. Equivalent to +-- feeding the numeric @1@\/@0@ encoding of the observation into +-- the underlying bounded-mean test. +-- +-- >>> let s1 = update cfg s0 True +update :: Config -> State -> Bool -> State +update (Config c) (State s) !x = + State (Bounded.update c s (if x then 1 else 0)) +{-# INLINE update #-} + +-- | Compute the current 'Verdict' from the running 'State'. +-- +-- >>> decide cfg s0 +-- Continue +decide :: Config -> State -> Verdict +decide (Config c) (State s) = Bounded.decide c s +{-# INLINE decide #-} + +-- inspection ----------------------------------------------------------------- + +-- | The supremum-so-far of @log(K^+_t + K^-_t)@ from the underlying +-- bounded-mean test. Starts at @log 2@. +-- +-- >>> log_wealth s0 +-- 0.6931471805599453 +log_wealth :: State -> Double +log_wealth (State s) = Bounded.log_wealth s +{-# INLINE log_wealth #-} + +-- | The number of samples consumed so far. +-- +-- >>> samples s0 +-- 0 +samples :: State -> Int +samples (State s) = Bounded.samples s +{-# INLINE samples #-} diff --git a/lib/Numeric/Eproc/Bounded.hs b/lib/Numeric/Eproc/Bounded.hs --- a/lib/Numeric/Eproc/Bounded.hs +++ b/lib/Numeric/Eproc/Bounded.hs @@ -90,7 +90,7 @@ import Numeric.Eproc.Common ( Bettor(..), Verdict(..), ConfigError(..) , BetState, init_bet, bet_lambda, step_bet - , finite + , finite, log_sum_exp, log2_dbl ) -- types ---------------------------------------------------------------------- @@ -210,7 +210,7 @@ st_n = 0 , st_log_w_pos = 0 , st_log_w_neg = 0 - , st_max_log_sum = log 2 + , st_max_log_sum = log2_dbl , st_bet_pos = s0 , st_bet_neg = s0 } @@ -243,23 +243,21 @@ let !z = x - cfg_null_mean !lam_p = bet_lambda cfg_bettor cfg_lam_max_pos st_bet_pos !lam_n = bet_lambda cfg_bettor cfg_lam_max_neg st_bet_neg - !fac_p = 1 + lam_p * z - !fac_n = 1 - lam_n * z - !logw_p = st_log_w_pos + log fac_p - !logw_n = st_log_w_neg + log fac_n - !log_sum = log_sum_exp logw_p logw_n - !max_sum = max st_max_log_sum log_sum + !logw_p = st_log_w_pos + log1p (lam_p * z) + !logw_n = st_log_w_neg + log1p (negate lam_n * z) + -- Skip 'log_sum_exp' when the cheap upper bound + -- log_sum_exp a b <= max a b + log 2 + -- already sits at or below the running max: no update can + -- move it. Under H_0 (calibration) this is the common case. + !cheap_ub = max logw_p logw_n + log2_dbl + !max_sum + | cheap_ub <= st_max_log_sum = st_max_log_sum + | otherwise = + max st_max_log_sum (log_sum_exp logw_p logw_n) !sp = step_bet cfg_bettor cfg_lam_max_pos st_bet_pos z !sn = step_bet cfg_bettor cfg_lam_max_neg st_bet_neg (negate z) in State (st_n + 1) logw_p logw_n max_sum sp sn {-# INLINE update #-} - --- | @log(exp a + exp b)@, computed without intermediate overflow. -log_sum_exp :: Double -> Double -> Double -log_sum_exp !a !b - | a >= b = a + log1p (exp (b - a)) - | otherwise = b + log1p (exp (a - b)) -{-# INLINE log_sum_exp #-} -- | Compute the current 'Verdict' from the running 'State'. -- diff --git a/lib/Numeric/Eproc/Common.hs b/lib/Numeric/Eproc/Common.hs --- a/lib/Numeric/Eproc/Common.hs +++ b/lib/Numeric/Eproc/Common.hs @@ -32,8 +32,12 @@ -- * Internal: helpers , finite + , log_sum_exp + , log2_dbl ) where +import GHC.Float (log1p) + -- | A predictable bettor. -- -- A bettor describes how, given the history of centred @@ -116,6 +120,25 @@ finite :: Double -> Bool finite x = not (isNaN x) && not (isInfinite x) {-# INLINE finite #-} + +-- | @log(exp a + exp b)@, computed without intermediate overflow. +-- Used by the convex-hedge two-sided combinations to update the +-- running @log(K^+ + K^-)@ statistic from the two per-direction +-- log-wealths. +log_sum_exp :: Double -> Double -> Double +log_sum_exp !a !b + | a >= b = a + log1p (exp (b - a)) + | otherwise = b + log1p (exp (a - b)) +{-# INLINE log_sum_exp #-} + +-- | @log 2@ as a shared constant. Used both as the initial value of +-- the two-sided running max-log-sum (since @K^+_0 + K^-_0 = 2@) and +-- as the tight upper-bound slack in the fast-path skip inside +-- 'Numeric.Eproc.Bounded.update' / +-- 'Numeric.Eproc.Bernoulli.TwoSided.update'. +log2_dbl :: Double +log2_dbl = log 2 +{-# INLINE log2_dbl #-} -- | Per-bettor state. One constructor per 'Bettor' alternative; the -- constructor used in any given state matches the 'Bettor' chosen diff --git a/ppad-eproc.cabal b/ppad-eproc.cabal --- a/ppad-eproc.cabal +++ b/ppad-eproc.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ppad-eproc -version: 0.2.1 +version: 0.2.2 synopsis: Anytime-valid sequential testing via e-processes. license: MIT license-file: LICENSE @@ -13,8 +13,8 @@ description: Anytime-valid sequential hypothesis testing for bounded random variables, via the e-process / betting framework of Waudby-Smith and - Ramdas (2024). Provides bounded-mean, paired two-sample, and - one-sided Bernoulli rate tests with fixed, adaptive (aGRAPA), and + Ramdas (2024). Provides bounded-mean, paired two-sample, and one- and + two-sided Bernoulli rate tests with fixed, adaptive (aGRAPA), and online Newton bettors. flag llvm @@ -35,6 +35,7 @@ ghc-options: -fllvm -O2 exposed-modules: Numeric.Eproc.Bernoulli + Numeric.Eproc.Bernoulli.TwoSided Numeric.Eproc.Bounded Numeric.Eproc.Common Numeric.Eproc.Paired diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -5,6 +5,7 @@ import Data.Bits import Data.Word import qualified Numeric.Eproc.Bernoulli as Bern +import qualified Numeric.Eproc.Bernoulli.TwoSided as BernTS import qualified Numeric.Eproc.Bounded as Bounded import qualified Numeric.Eproc.Common as C import qualified Numeric.Eproc.Paired as P @@ -23,6 +24,7 @@ , latched_rejection_tests , config_validation_tests , safety_property_tests + , two_sided_bernoulli_tests ] -- partial helper: tests below hardcode valid configs. @@ -391,6 +393,93 @@ Left _ -> pure () Right _ -> assertFailure "expected Left" +-- two-sided bernoulli -------------------------------------------------------- + +run_ts_bernoulli + :: BernTS.Config + -> Double -- ^ true rate p + -> Int -- ^ budget + -> Gen + -> (BernTS.Verdict, Int) +run_ts_bernoulli cfg p budget g0 = + go 0 g0 (BernTS.initial cfg) + where + go !n !g !st + | n >= budget = (BernTS.decide cfg st, n) + | otherwise = case BernTS.decide cfg st of + BernTS.Reject -> (BernTS.Reject, n) + BernTS.Continue -> + let (u, g') = next_double g + !x = u < p + st' = BernTS.update cfg st x + in go (n + 1) g' st' + +ts_bernoulli_rate + :: BernTS.Config + -> Double + -> Int + -> Int + -> Word64 + -> Double +ts_bernoulli_rate cfg p budget trials seed = + let gens = take trials (gen_seq (mk_gen seed)) + rejects = length + [ () | g <- gens + , let (v, _) = run_ts_bernoulli cfg p budget g + , v == BernTS.Reject ] + in fromIntegral rejects / fromIntegral trials + +two_sided_bernoulli_tests :: TestTree +two_sided_bernoulli_tests = testGroup "two-sided bernoulli" [ + testCase "constant at p_0 doesn't reject" $ do + -- Bernoulli(0.5) with p_0 = 0.5 is under the null. + let cfg = ok (BernTS.config 0.5 1.0e-6 BernTS.Newton) + -- alternating True/False keeps the empirical rate at 0.5. + xs = take 5000 (cycle [True, False]) + st = foldl' (BernTS.update cfg) (BernTS.initial cfg) xs + BernTS.decide cfg st @?= BernTS.Continue + , testCase "detects upward shift (p = 0.7 vs p_0 = 0.5)" $ do + let cfg = ok (BernTS.config 0.5 1.0e-3 BernTS.Newton) + rate = ts_bernoulli_rate cfg 0.7 5000 100 111222 + assertBool ("power " ++ show rate ++ " too low") $ + rate >= 0.95 + , testCase "detects downward shift (p = 0.3 vs p_0 = 0.5)" $ do + let cfg = ok (BernTS.config 0.5 1.0e-3 BernTS.Newton) + rate = ts_bernoulli_rate cfg 0.3 5000 100 333444 + assertBool ("power " ++ show rate ++ " too low") $ + rate >= 0.95 + , testCase "Adaptive detects shift (p = 0.7 vs p_0 = 0.5)" $ do + let cfg = ok (BernTS.config 0.5 1.0e-3 BernTS.Adaptive) + rate = ts_bernoulli_rate cfg 0.7 5000 100 777888 + assertBool ("power " ++ show rate ++ " too low") $ + rate >= 0.95 + , testCase "FPR at p = p_0 = 0.5 within slack" $ do + let cfg = ok (BernTS.config 0.5 0.05 BernTS.Newton) + rate = ts_bernoulli_rate cfg 0.5 2000 200 555666 + assertBool ("FPR " ++ show rate ++ " exceeded slack") $ + rate <= 0.08 + , testCase "latched: cross then drown stays rejected" $ do + let cfg = ok (BernTS.config 0.5 0.5 (BernTS.Fixed 1.0)) + -- ten 1s push the positive side well past threshold. + xs1 = replicate 10 True + -- then two hundred 0s drop the current wealth, but the + -- latch must hold. + xs2 = replicate 200 False + st1 = foldl' (BernTS.update cfg) (BernTS.initial cfg) xs1 + st2 = foldl' (BernTS.update cfg) st1 xs2 + BernTS.decide cfg st1 @?= BernTS.Reject + BernTS.decide cfg st2 @?= BernTS.Reject + , testCase "config: NaN p0 rejected" $ do + let nan = 0/0 :: Double + case BernTS.config nan 0.05 BernTS.Newton of + Left _ -> pure () + Right _ -> assertFailure "expected Left" + , testCase "config: alpha out of range rejected" $ + case BernTS.config 0.5 1.5 BernTS.Newton of + Left _ -> pure () + Right _ -> assertFailure "expected Left" + ] + -- safety properties ---------------------------------------------------------- unit_double :: QC.Gen Double @@ -416,6 +505,11 @@ monotone_reject_bern (Bern.Continue : rest) = monotone_reject_bern rest monotone_reject_bern (Bern.Reject : rest) = all (== Bern.Reject) rest +monotone_reject_bern_ts :: [BernTS.Verdict] -> Bool +monotone_reject_bern_ts [] = True +monotone_reject_bern_ts (BernTS.Continue : rest) = monotone_reject_bern_ts rest +monotone_reject_bern_ts (BernTS.Reject : rest) = all (== BernTS.Reject) rest + safety_property_tests :: TestTree safety_property_tests = testGroup "safety properties" [ QC.testProperty "Bounded: log_wealth finite after any admissible stream" $ @@ -477,4 +571,34 @@ sts = scanl (Bern.update cfg) (Bern.initial cfg) (xs :: [Bool]) vs = map (Bern.decide cfg) sts in monotone_reject_bern vs + + , QC.testProperty "BernTS: log_wealth finite after any admissible stream" $ + QC.forAll arb_bettor $ \b -> + QC.forAll QC.arbitrary $ \xs -> + let cfg = ok (BernTS.config 0.5 1.0e-3 b) + st = foldl' (BernTS.update cfg) (BernTS.initial cfg) (xs :: [Bool]) + in finite (BernTS.log_wealth st) + + , QC.testProperty "BernTS: Fixed with arbitrary lambda is safe" $ + QC.forAll (QC.choose (-1000, 1000)) $ \lam -> + QC.forAll QC.arbitrary $ \xs -> + let cfg = ok (BernTS.config 0.5 1.0e-3 (C.Fixed lam)) + st = foldl' (BernTS.update cfg) (BernTS.initial cfg) (xs :: [Bool]) + in finite (BernTS.log_wealth st) + + , QC.testProperty "BernTS: log_wealth is monotone nondecreasing" $ + QC.forAll arb_bettor $ \b -> + QC.forAll QC.arbitrary $ \xs -> + let cfg = ok (BernTS.config 0.5 1.0e-3 b) + sts = scanl (BernTS.update cfg) (BernTS.initial cfg) (xs :: [Bool]) + lws = map BernTS.log_wealth sts + in and (zipWith (<=) lws (drop 1 lws)) + + , QC.testProperty "BernTS: rejection is latched" $ + QC.forAll arb_bettor $ \b -> + QC.forAll QC.arbitrary $ \xs -> + let cfg = ok (BernTS.config 0.5 0.5 b) + sts = scanl (BernTS.update cfg) (BernTS.initial cfg) (xs :: [Bool]) + vs = map (BernTS.decide cfg) sts + in monotone_reject_bern_ts vs ]