Weird Science

書き初め

毎年年の初めはなにがしかいい感じのことを書くのが我が家の習わしだ。

今年は確率 Monad を(Neighborhood of infinity で読んだのをうろ覚えながら)書いた。

*Main> runProb $ (+) <$> choose [1,2,3] <*> choose [1,2,3]
[(1 % 9,2),(2 % 9,3),(1 % 3,4),(2 % 9,5),(1 % 9,6)]

(>>=) は構文木を与えられたルールに従って接ぎはぎする操作だと考えることはおもしろい。

import Control.Arrow
import Control.Monad
import Control.Applicative
import Data.List
import Data.Ratio
import Data.Function

newtype Prob b = Prob { unProb :: [(Rational,b)] }

exact :: b -> Prob b
exact b = choose [b]

prob_map :: (b -> w) -> Prob b -> Prob w
prob_map f (Prob p) = Prob $ map (second f) p

prob_join :: (Prob (Prob b)) -> Prob b
prob_join p = Prob [ (x*y,b) | (x,p') <- unProb p, (y,b) <- unProb p' ]

collect :: (Ord b) => Prob b -> Prob b
collect = Prob . map ((sum . map fst) &&& (snd . head))
               . groupBy ((==) `on` snd)
               . sortBy (compare `on` snd)
               . unProb

runProb :: (Ord b) => Prob b -> [(Rational,b)]
runProb = unProb . collect

instance Monad Prob where
  return = exact
  m >>= f = prob_join (prob_map f m)

instance Functor Prob where fmap = prob_map
instance Applicative Prob where
  pure = exact
  f <*> x = f `ap` x

choose :: [b] -> Prob b
choose ls = Prob [ (p,x) | x <- ls ]
  where p = recip . fromIntegral $ length ls