----------------------------------------------------------------------
-- |
-- Module      : BacktrackM
-- Maintainer  : PL
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:00 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.4 $
--
-- Backtracking state monad, with r\/o environment
-----------------------------------------------------------------------------

{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
{-# LANGUAGE CPP #-}
module GF.Data.BacktrackM (
                    -- * the backtracking state monad
                    BacktrackM,
                    -- * monad specific utilities
                    member,
                    cut,
                    -- * running the monad
                    foldBM,          runBM,
                    foldSolutions,   solutions,
                    foldFinalStates, finalStates,

                    -- * reexport the 'MonadState' class
                    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

----------------------------------------------------------------------
-- Combining endomorphisms and continuations
-- a la Ralf Hinze

-- BacktrackM = state monad transformer over the backtracking monad

newtype BacktrackM s a = BM (forall b . (a -> s -> b -> b) -> s -> b -> b)

-- * running the monad

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)

-- * specific functions on the backtracking monad

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)