X-Git-Url: https://mattmccutchen.net/match/match.git/blobdiff_plain/0df1b3e1f3f98db39ed9aea22746fe9df77bf9c5..256efdfa511d8d7d820ac565b5125271bc58ccf6:/program/RandomizedMonad.hs

diff --git a/program/RandomizedMonad.hs b/program/RandomizedMonad.hs
index b58727c..22b98aa 100644
--- a/program/RandomizedMonad.hs
+++ b/program/RandomizedMonad.hs
@@ -3,7 +3,7 @@ module RandomizedMonad (
 	msplit,
 	runRandom1, runRandom, runRandomStd, runRandomNewStd,
 	mrandomR, mrandom,
-	withProb,
+	withProb, withWeight,
 	filterRandomized,
 	indReplicateRandom, indRepeatRandom, indRandomArray
 ) where
@@ -54,7 +54,8 @@ runRandomNewStd ra = do
 mrandom :: Random a => Randomized a
 mrandom = Randomized random
 mrandomR :: Random a => (a, a) -> Randomized a
-mrandomR lohi = Randomized $ randomR lohi
+-- Eta-expand this one to keep GHC 6.6.1 on birdy happy.
+mrandomR lohi = Randomized (\g -> randomR lohi g)
 
 chooseCase :: Double -> [(Double, a)] -> a -> a
 chooseCase val ifCs elseR = case ifCs of
@@ -69,6 +70,13 @@ withProb ifCs elseR = do
 	val <- mrandom
 	chooseCase val ifCs elseR
 
+-- Like withProb, but without an else case and with the "probabilities" scaled
+-- so that they sum to 1.
+withWeight :: [(Double, Randomized a)] -> Randomized a
+withWeight ifCs = do
+	val <- mrandomR (0, sum (map fst ifCs))
+	chooseCase val (tail ifCs) (snd (head ifCs))
+
 -- Keep trying until we get what we want.
 filterRandomized :: (a -> Bool) -> Randomized a -> Randomized a
 filterRandomized f ra = do