## A Different Probability Monad

One of the more unusual monads is the “probability monad”:

```
newtype Probability a = Probability
runProb :: [(a,Rational)] }
{
data Coin = Heads | Tails
toss :: Probability Coin
= Probability [(Heads, 1 % 2), (Tails, 1 % 2)] toss
```

Although it’s a little inefficient, it’s an elegant representation. I’ve written about it before here.

It has some notable deficiencies, though. For instance: the user has to constantly check that all the probabilities add up to one. Its list can be empty, which doesn’t make sense. Also, individual outcomes can appear more than once in the same list.

A first go a fixing the problem might look something like this:

```
newtype Distrib a = Distrib
runDist :: [(a,Rational)] }
{
tossProb :: Distrib Coin
= Distrib [(Heads, 1), (Tails, 1)] tossProb
```

The type is the same as before: it’s the semantics which have changed. The second field of the tuples no longer have to add up to one. The list can still be empty, though, and now finding the probability of, say, the head, looks like this:

```
probHead :: Distrib a -> Rational
Distrib xs@((_,p):_)) = p / sum [ q | (_,q) <- xs ] probHead (
```

Infinite lists aren’t possible, either.

One other way to look at the problem is to mimic the structure of cons-lists. Something like this:

```
data Odds a = Certainly a
| Odds a Rational (Odds a)
deriving (Eq, Functor, Foldable, Show)
```

Here, the `Odds`

constructor (analogous to `(:)`

) contains
the betting-style odds of the head element vs. *the rest of the
list*. The coin from before is represented by:

```
tossOdds :: Odds Coin
= Odds Heads (1 % 1) (Certainly Tails) tossOdds
```

This representation has tons of nice properties. First, let’s use some pattern-synonym magic for rationals:

```
pattern (:%) :: Integer -> Integer -> Rational
pattern n :% d <- (numerator &&& denominator -> (n,d)) where
:% d = n % d n
```

Then, finding the probability of the head element is this:

```
probHeadOdds :: Odds a -> Rational
Certainly _) = 1
probHeadOdds (Odds _ (n :% d) _) = n :% (n + d) probHeadOdds (
```

The representation can handle infinite lists no problem:

```
Odds 'a' (1 :% 1) undefined)
probHeadOdds (1 % 2
```

Taking the tail preserves semantics, also. To do some more involved manipulation, a fold helper is handy:

```
foldOdds :: (a -> Rational -> b -> b) -> (a -> b) -> Odds a -> b
= r where
foldOdds f b Certainly x) = b x
r (Odds x p xs) = f x p (r xs) r (
```

You can use this function to find the probability of a given item:

```
probOfEvent :: Eq a => a -> Odds a -> Rational
= foldOdds f b where
probOfEvent e = if e == x then 1 else 0
b x = (if e == x then n else r) / (n + 1) f x n r
```

This assumes that each item only occurs once. A function which combines multiple events might look like this:

```
probOf :: (a -> Bool) -> Odds a -> Rational
= foldOdds f b where
probOf p = if p x then 1 else 0
b x = (if p x then r + n else r) / (n + 1) f x n r
```

Some utility functions to create `Odds`

:

```
equalOdds :: Foldable f => f a -> Maybe (Odds a)
= case length xs of
equalOdds xs 0 -> Nothing
-> Just (foldr f undefined xs (n - 1)) where
n 0 = Certainly y
f y a = Odds y (1 % fromIntegral n) (a (n - 1))
f y a n
fromDistrib :: [(a,Integer)] -> Maybe (Odds a)
= Nothing
fromDistrib [] = Just $ f (tot*lst) xs where
fromDistrib xs = foldl' (\(!t,_) e -> (t+e,e)) (0,undefined) (map snd xs)
(tot,lst) = Certainly x
f _ [(x,_)] :xs) = Odds x (mp % np) (f np xs) where
f n ((x,p)= p * lst
mp = n - mp
np
probOfEach :: Eq a => a -> Odds a -> Rational
= probOf (x==) xs
probOfEach x xs
propOf :: Eq a => a -> [a] -> Maybe Rational
= Nothing
propOf _ [] = Just . uncurry (%) $
propOf x xs !n,!m) e -> (if x == e then n+1 else n, m+1)) (0,0) xs foldl' (\(
```

`== fmap (probOfEach x) (equalOdds xs) propOf x xs `

And finally, the instances:

```
append :: Odds a -> Rational -> Odds a -> Odds a
= foldOdds f Odds where
append = Odds e ip (a op ys) where
f e r a p ys = p * r / (p + r + 1)
ip = p / (r + 1)
op
flatten :: Odds (Odds a) -> Odds a
= foldOdds append id
flatten
instance Applicative Odds where
pure = Certainly
<*> xs = flatten (fmap (<$> xs) fs)
fs
instance Monad Odds where
>>= f = flatten (f <$> x) x
```