/ListMonads.hs

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