{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Avoid restricted function" #-}
----------------------------------------------
-- |
-- 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
-- impervious to infinite descent.
--
-- A depth-first search of a data structure can fail to give a full traversal
-- if it has an infinitely deep path.  Likewise, a breadth-first search of a
-- data structure can fall short if it has an infinitely branching node.
-- Omega addresses this problem by using a \"diagonal\" traversal
-- that gracefully dissolves such data.
--
-- So while @liftM2 (,) [0..] [0..]@ gets \"stuck\" generating tuples whose
-- first element is zero, @"runOmega" $ liftM2 (,) ("each" [0..]) ("each"
-- [0..])@ generates all pairs of naturals.
--
-- 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@. 
--
-- This monad gets its name because it is a monad over sets of order type
-- omega.
--
-- Warning: Omega is only a monad when the results of @runOmega@ are
-- interpreted as a set; that is, a valid transformation according to the
-- monad laws may change the order of the results.  However, the same
-- set of results will always be reachable.  If you are using this as a monad, 
-- I recommend that you use the newer weighted-search package instead 
-- (it's also faster).
----------------------------------------------

module Control.Monad.Omega 
    (diagonal, Omega, runOmega, each) 
where

import qualified Control.Applicative as Applicative
import Control.Exception
import qualified Control.Monad as Monad
import qualified Control.Monad.Fail as Fail
import qualified Data.Foldable as Foldable
import Data.List (tails)
import qualified Data.Traversable as Traversable
import System.IO.Unsafe

-- | 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 i j 
-- there is an n such that @xs !! i !! j == diagonal xs !! n@.
-- In particular, @n <= (i+j)*(i+j+1)/2 + j@.
diagonal :: [[a]] -> [a]
diagonal :: forall a. [[a]] -> [a]
diagonal = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> ([[a]] -> [[a]]) -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> [[a]]
forall {a}. [[a]] -> [[a]]
stripe
    where
    stripe :: [[a]] -> [[a]]
stripe [] = []
    stripe ([]:[[a]]
xss) = [[a]] -> [[a]]
stripe [[a]]
xss
    stripe ((a
x:[a]
xs):[[a]]
xss) = [a
x] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]] -> [[a]]
forall {a}. [a] -> [[a]] -> [[a]]
zipCons [a]
xs ([[a]] -> [[a]]
stripe [[a]]
xss)

    zipCons :: [a] -> [[a]] -> [[a]]
zipCons [] [[a]]
ys = [[a]]
ys
    zipCons [a]
xs [] = (a -> [a]) -> [a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]) [a]
xs
    zipCons (a
x:[a]
xs) ([a]
y:[[a]]
ys) = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
y) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]] -> [[a]]
zipCons [a]
xs [[a]]
ys

newtype Omega a = Omega { forall a. Omega a -> [a]
runOmega :: [a] }

each :: [a] -> Omega a
each :: forall a. [a] -> Omega a
each = [a] -> Omega a
forall a. [a] -> Omega a
Omega

instance Functor Omega where
    fmap :: forall a b. (a -> b) -> Omega a -> Omega b
fmap a -> b
f (Omega [a]
xs) = [b] -> Omega b
forall a. [a] -> Omega a
Omega ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
xs)

instance Monad Omega where
    return :: forall a. a -> Omega a
return = a -> Omega a
forall a. a -> Omega a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Omega [a]
m >>= :: forall a b. Omega a -> (a -> Omega b) -> Omega b
>>= a -> Omega b
f
        | (a -> Omega b) -> Bool
forall a b. (a -> Omega b) -> Bool
isConstEmpty a -> Omega b
f = [b] -> Omega b
forall a. [a] -> Omega a
Omega []
        | Bool
otherwise = [b] -> Omega b
forall a. [a] -> Omega a
Omega ([b] -> Omega b) -> [b] -> Omega b
forall a b. (a -> b) -> a -> b
$ [[b]] -> [b]
forall a. [[a]] -> [a]
diagonal ([[b]] -> [b]) -> [[b]] -> [b]
forall a b. (a -> b) -> a -> b
$ (a -> [b]) -> [a] -> [[b]]
forall a b. (a -> b) -> [a] -> [b]
map (Omega b -> [b]
forall a. Omega a -> [a]
runOmega (Omega b -> [b]) -> (a -> Omega b) -> a -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Omega b
f) [a]
m

#if !(MIN_VERSION_base(4,13,0))
    fail = Fail.fail
#endif

data MyException = MyException
  deriving (Int -> MyException -> ShowS
[MyException] -> ShowS
MyException -> String
(Int -> MyException -> ShowS)
-> (MyException -> String)
-> ([MyException] -> ShowS)
-> Show MyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MyException -> ShowS
showsPrec :: Int -> MyException -> ShowS
$cshow :: MyException -> String
show :: MyException -> String
$cshowList :: [MyException] -> ShowS
showList :: [MyException] -> ShowS
Show)

instance Exception MyException

isConstEmpty :: (a -> Omega b) -> Bool
isConstEmpty :: forall a b. (a -> Omega b) -> Bool
isConstEmpty a -> Omega b
f = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
  Either MyException (Omega b)
ret <- IO (Omega b) -> IO (Either MyException (Omega b))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Omega b) -> IO (Either MyException (Omega b)))
-> IO (Omega b) -> IO (Either MyException (Omega b))
forall a b. (a -> b) -> a -> b
$ Omega b -> IO (Omega b)
forall a. a -> IO a
evaluate (Omega b -> IO (Omega b)) -> Omega b -> IO (Omega b)
forall a b. (a -> b) -> a -> b
$ a -> Omega b
f (MyException -> a
forall a e. Exception e => e -> a
throw MyException
MyException)
  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ case Either MyException (Omega b)
ret of
    Left MyException
MyException -> Bool
False
    Right (Omega [b]
xs) -> [b] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
xs


instance Fail.MonadFail Omega where
    fail :: forall a. String -> Omega a
fail String
_ = [a] -> Omega a
forall a. [a] -> Omega a
Omega []

instance Monad.MonadPlus Omega where
    mzero :: forall a. Omega a
mzero = Omega a
forall a. Omega a
forall (f :: * -> *) a. Alternative f => f a
Applicative.empty
    mplus :: forall a. Omega a -> Omega a -> Omega a
mplus = Omega a -> Omega a -> Omega a
forall a. Omega a -> Omega a -> Omega a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(Applicative.<|>)

instance Applicative.Applicative Omega where
    pure :: forall a. a -> Omega a
pure = [a] -> Omega a
forall a. [a] -> Omega a
Omega ([a] -> Omega a) -> (a -> [a]) -> a -> Omega a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])
    liftA2 :: forall a b c. (a -> b -> c) -> Omega a -> Omega b -> Omega c
liftA2 a -> b -> c
f (Omega [a]
xs) = [c] -> Omega c
forall a. [a] -> Omega a
Omega ([c] -> Omega c) -> (Omega b -> [c]) -> Omega b -> Omega c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> [b] -> [c]
go [] ([b] -> [c]) -> (Omega b -> [b]) -> Omega b -> [c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Omega b -> [b]
forall a. Omega a -> [a]
runOmega
        where
            go :: [b] -> [b] -> [c]
go [b]
initYs [] = ([a] -> [c]) -> [[a]] -> [c]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([a] -> [b] -> [c]) -> [b] -> [a] -> [c]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> b -> c) -> [a] -> [b] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> c
f) [b]
initYs) ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs)
            go [b]
initYs (b
y : [b]
ys) = (a -> b -> c) -> [a] -> [b] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> c
f [a]
xs [b]
initYs  [c] -> [c] -> [c]
forall a. [a] -> [a] -> [a]
++ [b] -> [b] -> [c]
go (b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
initYs) [b]
ys

instance Applicative.Alternative Omega where
    empty :: forall a. Omega a
empty = [a] -> Omega a
forall a. [a] -> Omega a
Omega []
    Omega [a]
xs <|> :: forall a. Omega a -> Omega a -> Omega a
<|> Omega [a]
ys = [a] -> Omega a
forall a. [a] -> Omega a
Omega ([a] -> Omega a) -> [a] -> Omega a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
interleave [a]
xs [a]
ys

interleave :: [a] -> [a] -> [a]
interleave :: forall a. [a] -> [a] -> [a]
interleave [] [a]
ys = [a]
ys
interleave (a
x : [a]
xs) [a]
ys = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
interleave [a]
ys [a]
xs

instance Foldable.Foldable Omega where
    foldMap :: forall m a. Monoid m => (a -> m) -> Omega a -> m
foldMap a -> m
f (Omega [a]
xs) = (a -> m) -> [a] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Foldable.foldMap a -> m
f [a]
xs

instance Traversable.Traversable Omega where
    traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Omega a -> f (Omega b)
traverse a -> f b
f (Omega [a]
xs) = ([b] -> Omega b) -> f [b] -> f (Omega b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [b] -> Omega b
forall a. [a] -> Omega a
Omega (f [b] -> f (Omega b)) -> f [b] -> f (Omega b)
forall a b. (a -> b) -> a -> b
$ (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
Traversable.traverse a -> f b
f [a]
xs