Haskell | 115 lines | 64 code | 27 blank | 24 comment | 0 complexity | 3255d3e06daeaf6c0ad4c8cbea3fb4e8 MD5 | raw file
```  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)]])
```