歪んだコイン

Main.hs

import Data.List
import Data.Ratio

--
newtype Probs a = Probs { getProbs :: [(a, Rational)] } deriving Show

instance Functor Probs where
    fmap f (Probs xs) = Probs $ do
        (a, rate) <- xs
        return (f a, rate)
        
instance Applicative Probs where
    pure a = Probs [(a, 1%1)]
    (Probs fs) <*> (Probs xs) = Probs $ do
        (f, prob1) <- fs
        (x, prob2) <- xs
        return $ (f x, prob1 * prob2)
        
flatten :: Probs (Probs a) -> Probs a
flatten outer = Probs $ do
    (inner, pOut) <- getProbs outer
    (e,     pIn)  <- getProbs inner
    return (e, pIn*pOut)
    
instance Monad Probs where
    return = pure
    m >>= f = flatten . fmap f $ m

--
data Coin = Heads | Tails deriving (Eq, Show)

main :: IO ()
main = do
    let
        coin =       Probs [(Heads, 1% 2), (Tails, 1% 2)] :: Probs Coin
        loadedCoin = Probs [(Heads, 1%10), (Tails, 9%10)] :: Probs Coin
        
        throwThree :: Probs Bool
        throwThree = do
            a <- coin
            b <- coin
            c <- loadedCoin
            return (all (==Tails) [a,b,c])

        bind :: Ord a => Probs a -> Probs a
        bind = Probs
            -- . map (\block -> (fst . head $ block, sum . map snd $ block))
            . map (foldl1 (\acc (_,p1) -> let (a,p2) = acc in (a,p1+p2)))
            . groupBy (\a b -> fst a == fst b)
            . sort . getProbs

    mapM_ print (getProbs $ bind throwThree)