module Control.Permute ( Effects, perms, (*.) ) where
import Prelude hiding (length, sequence)
import Control.Applicative hiding (some, many)
import Data.Foldable
import Control.Replicate hiding (Nil, Cons)
import qualified Control.Replicate as R
data Effects f a where
Nil :: a -> Effects f a
Cons :: f x -> Replicate x y -> Effects f (y -> z) -> Effects f z
instance Functor (Effects f) where
fmap f (Nil x) = Nil (f x)
fmap f (Cons a r ps) = Cons a r (fmap (fmap f) ps)
instance Applicative (Effects f) where
pure = Nil
Nil g <*> y = fmap g y
Cons a r x <*> y = Cons a r (flip <$> x <*> y)
length :: Effects f a -> Int
length (Nil _) = 0
length (Cons _ _ xs) = 1 + length xs
(*.) :: Replicate a b -> f a -> Effects f b
freq *. act = Cons act freq (Nil id)
effectsMatchEpsilon :: Effects f a -> Maybe a
effectsMatchEpsilon eff =
case eff of
Nil x -> Just x
Cons _ (R.Cons mz _) ps -> mz <**> effectsMatchEpsilon ps
perms :: forall f a. Alternative f => Effects f a -> f a
perms (Nil x) = pure x
perms ps = eps . asum . map split . firsts $ ps
where
split :: Effects f a -> f a
split (Cons _ R.Nil _) = empty
split (Cons _ (R.Cons (Just z) R.Nil) ps') = perms (($ z) <$> ps')
split (Cons act (R.Cons _ s) ps') = act <**> perms (Cons act s ((.) <$> ps'))
eps :: f a -> f a
eps =
case effectsMatchEpsilon ps of
Just x -> (<|> pure x)
Nothing -> id
firsts :: Effects f a -> [Effects f a]
firsts (Nil _) = []
firsts (Cons a r ps) =
(Cons a r ps) : map (\ps' -> swap (Cons a r ps')) (firsts ps)
swap :: Effects f a -> Effects f a
swap (Cons a1 r1 (Cons a2 r2 ps)) = Cons a2 r2 (Cons a1 r1 (fmap flip ps))
swap ps = ps