diff options
| author | peb <unknown> | 2005-04-11 12:57:45 +0000 |
|---|---|---|
| committer | peb <unknown> | 2005-04-11 12:57:45 +0000 |
| commit | ac00f77dadd4d447803dd7cab5a36f47365325d0 (patch) | |
| tree | 2fd02b19234f8d1fcc20ee67a2367d4d4eebfcd8 /src/GF/Data/BacktrackM.hs | |
| parent | f6273f7033b85eea9a8d0cc7d31e9697ba95d5b7 (diff) | |
"Committed_by_peb"
Diffstat (limited to 'src/GF/Data/BacktrackM.hs')
| -rw-r--r-- | src/GF/Data/BacktrackM.hs | 67 |
1 files changed, 31 insertions, 36 deletions
diff --git a/src/GF/Data/BacktrackM.hs b/src/GF/Data/BacktrackM.hs index 555f5fec1..ba03884fd 100644 --- a/src/GF/Data/BacktrackM.hs +++ b/src/GF/Data/BacktrackM.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/03/29 11:17:54 $ +-- > CVS $Date: 2005/04/11 13:52:49 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ +-- > CVS $Revision: 1.3 $ -- -- Backtracking state monad, with r\/o environment ----------------------------------------------------------------------------- @@ -19,7 +19,6 @@ module GF.Data.BacktrackM ( -- * the backtracking state monad failure, (|||), -- * handling the state & environment - readEnv, readState, writeState, -- * monad specific utilities @@ -37,53 +36,51 @@ import Monad -- * controlling the monad -failure :: BacktrackM e s a -(|||) :: BacktrackM e s a -> BacktrackM e s a -> BacktrackM e s a +failure :: BacktrackM s a +(|||) :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a -instance MonadPlus (BacktrackM e s) where +instance MonadPlus (BacktrackM s) where mzero = failure mplus = (|||) -- * handling the state & environment -readEnv :: BacktrackM e s e -readState :: BacktrackM e s s -writeState :: s -> BacktrackM e s () +readState :: BacktrackM s s +writeState :: s -> BacktrackM s () --- * monad specific utilities +-- * specific functions on the backtracking monad -member :: [a] -> BacktrackM e s a +member :: [a] -> BacktrackM s a member = msum . map return -- * running the monad -runBM :: BacktrackM e s a -> e -> s -> [(s, a)] +runBM :: BacktrackM s a -> s -> [(s, a)] -solutions :: BacktrackM e s a -> e -> s -> [a] -solutions bm e s = map snd $ runBM bm e s +solutions :: BacktrackM s a -> s -> [a] +solutions bm = map snd . runBM bm -finalStates :: BacktrackM e s () -> e -> s -> [s] -finalStates bm e s = map fst $ runBM bm e s +finalStates :: BacktrackM s () -> s -> [s] +finalStates bm = map fst . runBM bm {- ---------------------------------------------------------------------- -- implementation as lists of successes -newtype BacktrackM e s a = BM (e -> s -> [(s, a)]) +newtype BacktrackM s a = BM (s -> [(s, a)]) runBM (BM m) = m -readEnv = BM (\e s -> [(s, e)]) -readState = BM (\e s -> [(s, s)]) -writeState s = BM (\e _ -> [(s, ())]) +readState = BM (\s -> [(s, s)]) +writeState s = BM (\_ -> [(s, ())]) -failure = BM (\e s -> []) -BM m ||| BM n = BM (\e s -> m e s ++ n e s) +failure = BM (\s -> []) +BM m ||| BM n = BM (\s -> m s ++ n s) -instance Monad (BacktrackM e s) where - return a = BM (\e s -> [(s, a)]) - BM m >>= k = BM (\e s -> concat [ n e s' | (s', a) <- m e s, let BM n = k a ]) +instance Monad (BacktrackM s) where + return a = BM (\s -> [(s, a)]) + BM m >>= k = BM (\s -> concat [ n s' | (s', a) <- m s, let BM n = k a ]) fail _ = failure -} @@ -105,19 +102,17 @@ runB (B m) = m (:) [] -- BacktrackM = state monad transformer over the backtracking monad -newtype BacktrackM e s a = BM (e -> s -> Backtr (s, a)) +newtype BacktrackM s a = BM (s -> Backtr (s, a)) -runBM (BM m) e s = runB (m e s) +runBM (BM m) s = runB (m s) -readEnv = BM (\e s -> return (s, e)) -readState = BM (\e s -> return (s, s)) -writeState s = BM (\e _ -> return (s, ())) +readState = BM (\s -> return (s, s)) +writeState s = BM (\_ -> return (s, ())) -failure = BM (\e s -> failureB) -BM m ||| BM n = BM (\e s -> m e s |||| n e s) +failure = BM (\s -> failureB) +BM m ||| BM n = BM (\s -> m s |||| n s) -instance Monad (BacktrackM e s) where - return a = BM (\e s -> return (s, a)) - BM m >>= k = BM (\e s -> do (s', a) <- m e s - unBM (k a) e s') +instance Monad (BacktrackM s) where + return a = BM (\s -> return (s, a)) + BM m >>= k = BM (\s -> do (s', a) <- m s ; unBM (k a) s') where unBM (BM m) = m |
