/ListMonads.hs

http://github.com/batterseapower/haskell-kata · Haskell · 115 lines · 64 code · 27 blank · 24 comment · 0 complexity · 3255d3e06daeaf6c0ad4c8cbea3fb4e8 MD5 · raw file

  1. import Control.Monad
  2. import Data.Maybe
  3. newtype DfM a = DfM { unDfM :: [a] }
  4. instance Functor DfM where
  5. fmap f = DfM . fmap f . unDfM
  6. instance Monad DfM where
  7. return x = DfM [x]
  8. mx >>= fxmy = join $ fmap fxmy mx
  9. where
  10. join :: DfM (DfM a) -> DfM a
  11. join = DfM . dfs . map unDfM . unDfM
  12. dfs :: [[a]] -> [a]
  13. dfs = concat
  14. fail _ = mzero
  15. instance MonadPlus DfM where
  16. mzero = DfM []
  17. mx `mplus` my = DfM $ unDfM mx ++ unDfM my
  18. -- 1) Left-identity
  19. -- return a >>= f == f a
  20. -- <==>
  21. -- concat $ fmap f [a]
  22. -- == concat [f a]
  23. -- == f a
  24. --
  25. -- 2) Right-identity
  26. -- m >>= return == m
  27. -- <==>
  28. -- concat $ fmap (\x -> [x]) m
  29. -- == m
  30. --
  31. -- 3) Associativity
  32. -- (m >>= f) >>= g == m >>= (\x -> f x >>= g)
  33. -- <==>
  34. -- concat (fmap g (concat (fmap f m)))
  35. -- == ???
  36. -- == concat (fmap (\x -> concat (fmap g (f x))) m)
  37. newtype BfM a = BfM { unBfM :: [a] }
  38. instance Functor BfM where
  39. fmap f = BfM . fmap f . unBfM
  40. instance Monad BfM where
  41. return x = BfM [x]
  42. mx >>= fxmy = join $ fmap fxmy mx
  43. where
  44. join :: BfM (BfM a) -> BfM a
  45. join = BfM . bfs . map unBfM . unBfM
  46. bfs :: [[a]] -> [a]
  47. bfs [] = []
  48. bfs xss = ys ++ bfs yss
  49. where (ys, yss) = unzip $ mapMaybe unconsMaybe xss
  50. unconsMaybe [] = Nothing
  51. unconsMaybe (x:xs) = Just (x, xs)
  52. fail _ = mzero
  53. instance MonadPlus BfM where
  54. mzero = BfM []
  55. mx `mplus` my = BfM $ unBfM mx ++ unBfM my
  56. newtype OmegaM a = OmegaM { unOmegaM :: [a] }
  57. instance Functor OmegaM where
  58. fmap f = OmegaM . fmap f . unOmegaM
  59. instance Monad OmegaM where
  60. return x = OmegaM [x]
  61. mx >>= fxmy = join $ fmap fxmy mx
  62. where
  63. join :: OmegaM (OmegaM a) -> OmegaM a
  64. join = OmegaM . diagonal . map unOmegaM . unOmegaM
  65. -- | This is the hinge algorithm of the Omega monad,
  66. -- exposed because it can be useful on its own. Joins
  67. -- a list of lists with the property that for every i j
  68. -- there is an n such that @xs !! i !! j == diagonal xs !! n@.
  69. -- In particular, @n <= (i+j)*(i+j+1)/2 + j@.
  70. diagonal :: [[a]] -> [a]
  71. diagonal = concat . stripe
  72. where
  73. stripe [] = []
  74. stripe ([]:xss) = stripe xss
  75. stripe ((x:xs):xss) = [x] : zipCons xs (stripe xss)
  76. zipCons [] ys = ys
  77. zipCons xs [] = map (:[]) xs
  78. zipCons (x:xs) (y:ys) = (x:y) : zipCons xs ys
  79. fail _ = mzero
  80. instance MonadPlus OmegaM where
  81. mzero = OmegaM []
  82. mx `mplus` my = OmegaM $ unOmegaM mx ++ unOmegaM my
  83. mpluses :: MonadPlus m => [m a] -> m a
  84. mpluses = foldr mplus mzero
  85. main = do
  86. print $ unDfM $ liftM2 (,) (mpluses [return x | x <- [1..5]]) (mpluses [return x | x <- [-1,-2..(-5)]])
  87. print $ unBfM $ liftM2 (,) (mpluses [return x | x <- [1..5]]) (mpluses [return x | x <- [-1,-2..(-5)]])
  88. print $ unOmegaM $ liftM2 (,) (mpluses [return x | x <- [1..5]]) (mpluses [return x | x <- [-1,-2..(-5)]])