{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
{-# LANGUAGE CPP #-}
module GF.Data.BacktrackM (
BacktrackM,
member,
cut,
foldBM, runBM,
foldSolutions, solutions,
foldFinalStates, finalStates,
module Control.Monad.State.Class,
) where
import Data.List
import Control.Applicative
import Control.Monad
import Control.Monad.State.Class
import qualified Control.Monad.Fail as Fail
newtype BacktrackM s a = BM (forall b . (a -> s -> b -> b) -> s -> b -> b)
runBM :: BacktrackM s a -> s -> [(s,a)]
runBM :: BacktrackM s a -> s -> [(s, a)]
runBM (BM forall b. (a -> s -> b -> b) -> s -> b -> b
m) s
s = (a -> s -> [(s, a)] -> [(s, a)]) -> s -> [(s, a)] -> [(s, a)]
forall b. (a -> s -> b -> b) -> s -> b -> b
m (\a
x s
s [(s, a)]
xs -> (s
s,a
x) (s, a) -> [(s, a)] -> [(s, a)]
forall a. a -> [a] -> [a]
: [(s, a)]
xs) s
s []
foldBM :: (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b
foldBM :: (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b
foldBM a -> s -> b -> b
f b
b (BM forall b. (a -> s -> b -> b) -> s -> b -> b
m) s
s = (a -> s -> b -> b) -> s -> b -> b
forall b. (a -> s -> b -> b) -> s -> b -> b
m a -> s -> b -> b
f s
s b
b
foldSolutions :: (a -> b -> b) -> b -> BacktrackM s a -> s -> b
foldSolutions :: (a -> b -> b) -> b -> BacktrackM s a -> s -> b
foldSolutions a -> b -> b
f b
b (BM forall b. (a -> s -> b -> b) -> s -> b -> b
m) s
s = (a -> s -> b -> b) -> s -> b -> b
forall b. (a -> s -> b -> b) -> s -> b -> b
m (\a
x s
s b
b -> a -> b -> b
f a
x b
b) s
s b
b
solutions :: BacktrackM s a -> s -> [a]
solutions :: BacktrackM s a -> s -> [a]
solutions = (a -> [a] -> [a]) -> [a] -> BacktrackM s a -> s -> [a]
forall a b s. (a -> b -> b) -> b -> BacktrackM s a -> s -> b
foldSolutions (:) []
foldFinalStates :: (s -> b -> b) -> b -> BacktrackM s () -> s -> b
foldFinalStates :: (s -> b -> b) -> b -> BacktrackM s () -> s -> b
foldFinalStates s -> b -> b
f b
b (BM forall b. (() -> s -> b -> b) -> s -> b -> b
m) s
s = (() -> s -> b -> b) -> s -> b -> b
forall b. (() -> s -> b -> b) -> s -> b -> b
m (\()
x s
s b
b -> s -> b -> b
f s
s b
b) s
s b
b
finalStates :: BacktrackM s () -> s -> [s]
finalStates :: BacktrackM s () -> s -> [s]
finalStates BacktrackM s ()
bm = ((s, ()) -> s) -> [(s, ())] -> [s]
forall a b. (a -> b) -> [a] -> [b]
map (s, ()) -> s
forall a b. (a, b) -> a
fst ([(s, ())] -> [s]) -> (s -> [(s, ())]) -> s -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BacktrackM s () -> s -> [(s, ())]
forall s a. BacktrackM s a -> s -> [(s, a)]
runBM BacktrackM s ()
bm
instance Applicative (BacktrackM s) where
pure :: a -> BacktrackM s a
pure = a -> BacktrackM s a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: BacktrackM s (a -> b) -> BacktrackM s a -> BacktrackM s b
(<*>) = BacktrackM s (a -> b) -> BacktrackM s a -> BacktrackM s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad (BacktrackM s) where
return :: a -> BacktrackM s a
return a
a = (forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
forall s a.
(forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
BM (\a -> s -> b -> b
c s
s b
b -> a -> s -> b -> b
c a
a s
s b
b)
BM forall b. (a -> s -> b -> b) -> s -> b -> b
m >>= :: BacktrackM s a -> (a -> BacktrackM s b) -> BacktrackM s b
>>= a -> BacktrackM s b
k = (forall b. (b -> s -> b -> b) -> s -> b -> b) -> BacktrackM s b
forall s a.
(forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
BM (\b -> s -> b -> b
c s
s b
b -> (a -> s -> b -> b) -> s -> b -> b
forall b. (a -> s -> b -> b) -> s -> b -> b
m (\a
a s
s b
b -> BacktrackM s b -> (b -> s -> b -> b) -> s -> b -> b
forall s a b. BacktrackM s a -> (a -> s -> b -> b) -> s -> b -> b
unBM (a -> BacktrackM s b
k a
a) b -> s -> b -> b
c s
s b
b) s
s b
b)
where unBM :: BacktrackM s a -> (a -> s -> b -> b) -> s -> b -> b
unBM (BM forall b. (a -> s -> b -> b) -> s -> b -> b
m) = (a -> s -> b -> b) -> s -> b -> b
forall b. (a -> s -> b -> b) -> s -> b -> b
m
#if !(MIN_VERSION_base(4,13,0))
fail = Fail.fail
#endif
instance Fail.MonadFail (BacktrackM s) where
fail :: String -> BacktrackM s a
fail String
_ = BacktrackM s a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
instance Functor (BacktrackM s) where
fmap :: (a -> b) -> BacktrackM s a -> BacktrackM s b
fmap a -> b
f (BM forall b. (a -> s -> b -> b) -> s -> b -> b
m) = (forall b. (b -> s -> b -> b) -> s -> b -> b) -> BacktrackM s b
forall s a.
(forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
BM (\b -> s -> b -> b
c s
s b
b -> (a -> s -> b -> b) -> s -> b -> b
forall b. (a -> s -> b -> b) -> s -> b -> b
m (\a
a s
s b
b -> b -> s -> b -> b
c (a -> b
f a
a) s
s b
b) s
s b
b)
instance Alternative (BacktrackM s) where
empty :: BacktrackM s a
empty = BacktrackM s a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
<|> :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a
(<|>) = BacktrackM s a -> BacktrackM s a -> BacktrackM s a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance MonadPlus (BacktrackM s) where
mzero :: BacktrackM s a
mzero = (forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
forall s a.
(forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
BM (\a -> s -> b -> b
c s
s b
b -> b
b)
(BM forall b. (a -> s -> b -> b) -> s -> b -> b
f) mplus :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a
`mplus` (BM forall b. (a -> s -> b -> b) -> s -> b -> b
g) = (forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
forall s a.
(forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
BM (\a -> s -> b -> b
c s
s b
b -> (a -> s -> b -> b) -> s -> b -> b
forall b. (a -> s -> b -> b) -> s -> b -> b
g a -> s -> b -> b
c s
s (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$! (a -> s -> b -> b) -> s -> b -> b
forall b. (a -> s -> b -> b) -> s -> b -> b
f a -> s -> b -> b
c s
s b
b)
instance MonadState s (BacktrackM s) where
get :: BacktrackM s s
get = (forall b. (s -> s -> b -> b) -> s -> b -> b) -> BacktrackM s s
forall s a.
(forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
BM (\s -> s -> b -> b
c s
s b
b -> s -> s -> b -> b
c s
s s
s b
b)
put :: s -> BacktrackM s ()
put s
s = (forall b. (() -> s -> b -> b) -> s -> b -> b) -> BacktrackM s ()
forall s a.
(forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
BM (\() -> s -> b -> b
c s
_ b
b -> () -> s -> b -> b
c () s
s b
b)
member :: [a] -> BacktrackM s a
member :: [a] -> BacktrackM s a
member [a]
xs = (forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
forall s a.
(forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
BM (\a -> s -> b -> b
c s
s b
b -> (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\b
b a
x -> a -> s -> b -> b
c a
x s
s b
b) b
b [a]
xs)
cut :: BacktrackM s a -> BacktrackM s [(s,a)]
cut :: BacktrackM s a -> BacktrackM s [(s, a)]
cut BacktrackM s a
f = (forall b. ([(s, a)] -> s -> b -> b) -> s -> b -> b)
-> BacktrackM s [(s, a)]
forall s a.
(forall b. (a -> s -> b -> b) -> s -> b -> b) -> BacktrackM s a
BM (\[(s, a)] -> s -> b -> b
c s
s b
b -> [(s, a)] -> s -> b -> b
c (BacktrackM s a -> s -> [(s, a)]
forall s a. BacktrackM s a -> s -> [(s, a)]
runBM BacktrackM s a
f s
s) s
s b
b)