Weight.hs (6428B)
1 {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-type-defaults #-} 2 {-# LANGUAGE BangPatterns #-} 3 4 module Main where 5 6 import Control.DeepSeq 7 import qualified Numeric.Eproc.Bernoulli as Bern 8 import qualified Numeric.Eproc.Bernoulli.TwoSided as BernTS 9 import qualified Numeric.Eproc.Bounded as Bounded 10 import qualified Numeric.Eproc.ConfSeq as CS 11 import qualified Numeric.Eproc.Mixture as Mix 12 import qualified Numeric.Eproc.Paired as P 13 import Weigh 14 15 instance NFData Bounded.State where rnf !_ = () 16 instance NFData P.State where rnf !_ = () 17 instance NFData Bern.State where rnf !_ = () 18 instance NFData BernTS.State where rnf !_ = () 19 instance NFData Mix.State where rnf !_ = () 20 instance NFData Bounded.Verdict where rnf !_ = () 21 22 -- partial helper for benches: configs here are hardcoded valid. 23 ok :: Either e a -> a 24 ok (Right x) = x 25 ok (Left _) = error "weigh: invalid config" 26 27 -- note that 'weigh' doesn't work properly in a repl 28 main :: IO () 29 main = mainWith $ do 30 update 31 decide 32 stream 33 twosample 34 bern_update 35 bern_stream 36 bern_ts_update 37 bern_ts_stream 38 mix_update 39 mix_stream 40 confseq_update 41 confseq_stream 42 43 update :: Weigh () 44 update = 45 let !cfg_f = ok (Bounded.config 0.5 0.0 1.0 1.0e-3 (Bounded.Fixed 0.5)) 46 !cfg_a = ok (Bounded.config 0.5 0.0 1.0 1.0e-3 Bounded.Adaptive) 47 !cfg_o = ok (Bounded.config 0.5 0.0 1.0 1.0e-3 Bounded.Newton) 48 !st_f = Bounded.initial cfg_f 49 !st_a = Bounded.initial cfg_a 50 !st_o = Bounded.initial cfg_o 51 in wgroup "Bounded.update (one step)" $ do 52 func "fixed" (Bounded.update cfg_f st_f) 0.7 53 func "adaptive" (Bounded.update cfg_a st_a) 0.7 54 func "newton" (Bounded.update cfg_o st_o) 0.7 55 56 decide :: Weigh () 57 decide = 58 let !cfg = ok (Bounded.config 0.5 0.0 1.0 1.0e-3 Bounded.Newton) 59 !st = Bounded.initial cfg 60 in wgroup "Bounded.decide" $ do 61 func "initial state" (Bounded.decide cfg) st 62 63 stream :: Weigh () 64 stream = 65 let !xs = force (take 1000 (cycle [0.3, 0.7])) 66 !cfg_f = ok (Bounded.config 0.5 0.0 1.0 1.0e-3 (Bounded.Fixed 0.5)) 67 !cfg_a = ok (Bounded.config 0.5 0.0 1.0 1.0e-3 Bounded.Adaptive) 68 !cfg_o = ok (Bounded.config 0.5 0.0 1.0 1.0e-3 Bounded.Newton) 69 run_m cfg = foldl' (Bounded.update cfg) (Bounded.initial cfg) 70 in wgroup "Bounded.update (1000-sample fold)" $ do 71 func "fixed" (run_m cfg_f) xs 72 func "adaptive" (run_m cfg_a) xs 73 func "newton" (run_m cfg_o) xs 74 75 twosample :: Weigh () 76 twosample = 77 let !ps = force (take 1000 (cycle [(0.3, 0.7), (0.7, 0.3)])) 78 !cfg_f = ok (P.config 0.0 1.0 1.0e-3 (Bounded.Fixed 0.5)) 79 !cfg_a = ok (P.config 0.0 1.0 1.0e-3 Bounded.Adaptive) 80 !cfg_o = ok (P.config 0.0 1.0 1.0e-3 Bounded.Newton) 81 run_t cfg = foldl' (P.update cfg) (P.initial cfg) 82 in wgroup "Paired.update (1000-sample fold)" $ do 83 func "fixed" (run_t cfg_f) ps 84 func "adaptive" (run_t cfg_a) ps 85 func "newton" (run_t cfg_o) ps 86 87 bern_update :: Weigh () 88 bern_update = 89 let !cfg_f = ok (Bern.config 0.05 1.0e-3 (Bern.Fixed 5.0)) 90 !cfg_a = ok (Bern.config 0.05 1.0e-3 Bern.Adaptive) 91 !cfg_o = ok (Bern.config 0.05 1.0e-3 Bern.Newton) 92 !st_f = Bern.initial cfg_f 93 !st_a = Bern.initial cfg_a 94 !st_o = Bern.initial cfg_o 95 in wgroup "Bernoulli.update (one step)" $ do 96 func "fixed" (Bern.update cfg_f st_f) True 97 func "adaptive" (Bern.update cfg_a st_a) True 98 func "newton" (Bern.update cfg_o st_o) True 99 100 bern_stream :: Weigh () 101 bern_stream = 102 let !xs = force (take 1000 (cycle [True, False])) 103 !cfg_f = ok (Bern.config 0.05 1.0e-3 (Bern.Fixed 5.0)) 104 !cfg_a = ok (Bern.config 0.05 1.0e-3 Bern.Adaptive) 105 !cfg_o = ok (Bern.config 0.05 1.0e-3 Bern.Newton) 106 run_b cfg = foldl' (Bern.update cfg) (Bern.initial cfg) 107 in wgroup "Bernoulli.update (1000-sample fold)" $ do 108 func "fixed" (run_b cfg_f) xs 109 func "adaptive" (run_b cfg_a) xs 110 func "newton" (run_b cfg_o) xs 111 112 bern_ts_update :: Weigh () 113 bern_ts_update = 114 let !cfg_f = ok (BernTS.config 0.5 1.0e-3 (BernTS.Fixed 1.0)) 115 !cfg_a = ok (BernTS.config 0.5 1.0e-3 BernTS.Adaptive) 116 !cfg_o = ok (BernTS.config 0.5 1.0e-3 BernTS.Newton) 117 !st_f = BernTS.initial cfg_f 118 !st_a = BernTS.initial cfg_a 119 !st_o = BernTS.initial cfg_o 120 in wgroup "Bernoulli.TwoSided.update (one step)" $ do 121 func "fixed" (BernTS.update cfg_f st_f) True 122 func "adaptive" (BernTS.update cfg_a st_a) True 123 func "newton" (BernTS.update cfg_o st_o) True 124 125 bern_ts_stream :: Weigh () 126 bern_ts_stream = 127 let !xs = force (take 1000 (cycle [True, False])) 128 !cfg_f = ok (BernTS.config 0.5 1.0e-3 (BernTS.Fixed 1.0)) 129 !cfg_a = ok (BernTS.config 0.5 1.0e-3 BernTS.Adaptive) 130 !cfg_o = ok (BernTS.config 0.5 1.0e-3 BernTS.Newton) 131 run_b cfg = foldl' (BernTS.update cfg) (BernTS.initial cfg) 132 in wgroup "Bernoulli.TwoSided.update (1000-sample fold)" $ do 133 func "fixed" (run_b cfg_f) xs 134 func "adaptive" (run_b cfg_a) xs 135 func "newton" (run_b cfg_o) xs 136 137 mix_update :: Weigh () 138 mix_update = 139 let !cfg = ok (Mix.config 4 1.0e-3) 140 !st = Mix.initial cfg 141 !v = force [0.1, -0.2, 0.3, 0.0] 142 in wgroup "Mixture.update (one step)" $ do 143 func "K=4" (Mix.update cfg st) v 144 145 mix_stream :: Weigh () 146 mix_stream = 147 let !vs = force (take 1000 (cycle 148 [[0.1, -0.2, 0.3, 0.0], [-0.3, 0.2, 0.0, 0.1]])) 149 !cfg = ok (Mix.config 4 1.0e-3) 150 run_x c = foldl' (Mix.update c) (Mix.initial c) 151 in wgroup "Mixture.update (1000-step fold)" $ do 152 func "K=4" (run_x cfg) vs 153 154 -- ConfSeq.State carries a list of live grid candidates rather than 155 -- only unboxed fields, but 'initial' and 'update' construct that 156 -- list fully forced, so WHNF == NF holds here by construction too. 157 instance NFData CS.State where rnf !_ = () 158 159 confseq_update :: Weigh () 160 confseq_update = 161 let !cfg = ok (CS.config 0.0 1.0 0.05 200) 162 !st = CS.initial cfg 163 in wgroup "ConfSeq.update (one step, g = 200)" $ do 164 func "plug-in" (CS.update cfg st) 0.7 165 166 confseq_stream :: Weigh () 167 confseq_stream = 168 let !xs = force (take 1000 (cycle [0.3, 0.7])) 169 !cfg = ok (CS.config 0.0 1.0 0.05 200) 170 run_c = foldl' (CS.update cfg) (CS.initial cfg) 171 in wgroup "ConfSeq.update (1000-sample fold, g = 200)" $ do 172 func "plug-in" run_c xs