newtype D a = D { unD :: [(a, Double)] } deriving(Eq, Show, Ord)instance Functor D where -- fmap :: (a -> b) -> D a -> D b fmap f (D xs) = D $ fmap (\(a, d) -> (f a, d)) xsinstance Monad D where return x = D $ [(x, 1.0)] -- f :: a -> (D b) (D as) >>= f = D $ do -- list monad (a, p) <- as (b, p2) <- unD (f a) return $ (b, p * p2)-- [(a, 0.5), (b, 0.5)]-- [(a, 0.3), (a, 0.2), (b, 0.1), (b, 0.4)]--instance Applicative D where pure = return ff <*> fa = do f <- ff a <- fa return $ f acondition :: Bool -> D ()condition True = D [((), 1.0)]condition False = D [((), 0.0)]dice :: D Intdice = let p = 1.0 / 6 in D $ [(x, p) | x <- [1..6]]dice_hard :: D Intdice_hard = do x <- dice condition $ x > 3 return $ xmain :: IO ()main = do print dice print dice_hardThis gives the output:
D {unD = [(1,0.16666666666666666), (2,0.16666666666666666), (3,0.16666666666666666), (4,0.16666666666666666), (5,0.16666666666666666), (6,0.16666666666666666)]}D {unD = [(1,0.0), (2,0.0), (3,0.0), (4,0.16666666666666666), (5,0.16666666666666666), (6,0.16666666666666666)]}Notice that D a ~= WriterT (Product Float) []!