----------------------------------------------
-- |
-- Module : Control.Monad.Omega
-- Copyright : (c) Luke Palmer 2008
-- License : Public Domain
--
-- Maintainer : Luke Palmer <lrpalmer@gmail.com>
-- Stability : experimental
-- Portability : portable
--
-- A monad for enumerating sets: like the list monad, but
-- \"breadth-first\".
--
-- It addresses the problem seen when trying to generate
-- the list of all pairs of naturals with
-- @[ (x,y) | x <- [0..], y <- [0..] ]@, which is broken
-- since the first element of every reachable pair will
-- be 0.
--
-- Using Omega this can be written
--
-- > pairs = runOmega $ do
-- > x <- each [0..]
-- > y <- each [0..]
-- > return (x,y)
--
-- More precisely, if @x@ appears at a finite index in
-- @xs@, and @y@ appears at a finite index in @f x@,
-- then @y@ will appear at a finite index in
-- @each xs >>= f@.
----------------------------------------------
module Control.Monad.Omega
(diagonal, Omega, runOmega, each)
where
import qualified Control.Monad as Monad
import qualified Control.Applicative as Applicative
import qualified Data.Foldable as Foldable
import qualified Data.Traversable as Traversable
-- | This is the hinge algorithm of the Omega monad,
-- exposed because it can be useful on its own. Joins
-- a list of lists with the property that for every x y
-- there is an n such that @xs !! x !! y == diagonal xs !! n@.
diagonal :: [[a]] -> [a]
diagonal = diagonal' 0
where
diagonal' _ [] = []
diagonal' n xss =
let (str, xss') = stripe n xss
in str ++ diagonal' (n+1) xss'
stripe 0 xss = ([],xss)
stripe n [] = ([],[])
stripe n ([]:xss) = stripe n xss
stripe n ((x:xs):xss) =
let (nstripe, nlists) = stripe (n-1) xss
in (x:nstripe, xs:nlists)
newtype Omega a = Omega { runOmega :: [a] }
each :: [a] -> Omega a
each = Omega
instance Functor Omega where
fmap f (Omega xs) = Omega (map f xs)
instance Monad Omega where
return x = Omega [x]
Omega m >>= f = Omega $ diagonal $ map (runOmega . f) m
fail _ = Omega []
instance Applicative.Applicative Omega where
pure = return
(<*>) = Monad.ap
instance Foldable.Foldable Omega where
foldMap f (Omega xs) = Foldable.foldMap f xs
instance Traversable.Traversable Omega where
traverse f (Omega xs) = fmap Omega $ Traversable.traverse f xs