## Probability Trees

Previously, I tried to figure out how to make the probability monad more “listy”. I read a little more about the topic (especially Erwig and Kollmansberger 2006; and Kidd 2007).

I then thought about what a probability monad would look like if it was based on other data structures. I feel like the standard version really wants to be:

```
newtype ProperProb a = ProperProb
yes :: Map a (Product Rational) } {
```

But of course a monad instance isn’t allowed.

Similar to a map, though, is a binary tree:

```
data BinaryTree a = Leaf
| Node (BinaryTree a) a (BinaryTree a)
```

And it feels better for probability - *flatter*, somehow.
Transmuting it into a probability-thing:

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

That looks good to me. A choice between two different branches feels more natural than a choice between a head and a tail.

The fold is similar to before, with an unfold for good measure:

```
foldOdds :: (b -> Rational -> b -> b) -> (a -> b) -> Odds a -> b
= r where
foldOdds f b Certain x) = b x
r (Choice xs p ys) = f (r xs) p (r ys)
r (
unfoldOdds :: (b -> Either a (b,Rational,b)) -> b -> Odds a
= r where
unfoldOdds f = case f b of
r b Left a -> Certain a
Right (x,p,y) -> Choice (r x) p (r y)
fi :: Bool -> a -> a -> a
True t _ = t
fi False _ f = f fi
```

I changed the pattern synonym a little:

```
unRatio :: Num a => Rational -> (a,a)
= numerator &&& denominator
unRatio >>> fromInteger *** fromInteger
pattern n :% d <- (unRatio -> (n,d))
```

Then, the `probOf`

function:

```
probOf :: Eq a => a -> Odds a -> Rational
= foldOdds f b where
probOf e = fi (e == x) 1 0
b x :%d) y = (x * n + y * d) / (n + d) f x (n
```

This version doesn’t have the option for short-circuiting on the first value it finds.

For generating from lists, you can try to evenly divide the list among each branch.

```
fromListOdds :: (([b], Int) -> Integer) -> (b -> a) -> [b] -> Maybe (Odds a)
= r where
fromListOdds fr e = Nothing
r [] = Just (unfoldOdds f (xs, length xs))
r xs = Left (e x)
f ([x],_) = Right ((ys,l), fr (ys,l) % fr (zs,r), (zs,r)) where
f (xs ,n) = n `div` 2
l = n - l
r = splitAt l xs
(ys,zs)
equalOdds :: [a] -> Maybe (Odds a)
= fromListOdds (fromIntegral . snd) id
equalOdds
fromDistrib :: [(a,Integer)] -> Maybe (Odds a)
= fromListOdds (sum . map snd . fst) fst fromDistrib
```

What’s really nice about this version is the fact that the old `append`

is just the `Choice`

constructor, leaving the instances to be really nice:

```
flatten :: Odds (Odds a) -> Odds a
= foldOdds Choice id
flatten
instance Applicative Odds where
pure = Certain
<*> xs = flatten (fmap (<$> xs) fs)
fs
instance Monad Odds where
>>= f = flatten (f <$> x) x
```

Finally, as a bonus, to remove duplicates:

```
lcd :: Foldable f => f Rational -> Integer
= foldl' (\a e -> lcm a (denominator e)) 1
lcd
toDistrib :: Odds a -> [(a,Integer)]
= factorOut . foldOdds f b where
toDistrib = [(x,1)]
b x = (map.fmap) (n%t*) l ++ (map.fmap) (d%t*) r where
f l p r = numerator p
n = denominator p
d = n + d
t = (map.fmap) (numerator . (lcd'*)) xs where
factorOut xs = fromIntegral . lcd . map snd $ xs
lcd'
counts :: (Ord a, Num n) => [(a,n)] -> [(a,n)]
=
counts .
Map.assocs +)
Map.fromListWith (
compress :: Ord a => Odds a -> Odds a
= let Just ys = (fromDistrib . counts . toDistrib) xs in ys compress xs
```

After reading yet more on this, I found that the main issue with the monad is its performance. Two articles in particular: Larsen (2011), and Ścibior, Ghahramani, and Gordon (2015), refer to a GADT implementation of the monad which maximises laziness.

### References

*Journal of Functional Programming*16 (1): 21–34. doi:10.1017/S0956796805005721.

*Proceedings of the 2015 ACM SIGPLAN Symposium on Haskell*, 50:165–176. Haskell ’15. New York, NY, USA: ACM. doi:10.1145/2804302.2804317.