/ListMonads.hs
Haskell | 115 lines | 64 code | 27 blank | 24 comment | 0 complexity | 3255d3e06daeaf6c0ad4c8cbea3fb4e8 MD5 | raw file
Possible License(s): BSD-3-Clause
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)]])