Add foldBM, foldSolutions and foldFinalStates functions

1 files changed, 39 insertions, 67 deletions

diff --git a/src/GF/Data/BacktrackM.hs b/src/GF/Data/BacktrackM.hs
index 29bfe0e10..736699c16 100644
--- a/src/GF/Data/BacktrackM.hs
+++ b/src/GF/Data/BacktrackM.hs
@@ -24,97 +24,69 @@ module GF.Data.BacktrackM ( -- * the backtracking state monad
 		    -- * monad specific utilities
 		    member,
 		    -- * running the monad
-		    runBM,
-		    solutions,
-		    finalStates
+		    foldBM,          runBM,
+		    foldSolutions,   solutions,
+		    foldFinalStates, finalStates
 		  ) where
 
 import Control.Monad
 
-------------------------------------------------------------
--- type declarations
-
--- * controlling the monad
-
-failure :: BacktrackM s a
-(|||)   :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a
-
-instance MonadPlus (BacktrackM s) where
-    mzero = failure
-    mplus = (|||)
+----------------------------------------------------------------------
+-- Combining endomorphisms and continuations
+-- a la Ralf Hinze
 
--- * handling the state & environment
+-- BacktrackM = state monad transformer over the backtracking monad
 
-readState  :: BacktrackM s s
-writeState :: s -> BacktrackM s ()
+newtype BacktrackM s a = BM (forall b . (a -> s -> b -> b) -> s -> b -> b)
 
--- * specific functions on the backtracking monad
+-- * running the monad
 
-member :: [a] -> BacktrackM s a
-member = msum . map return 
+runBM :: BacktrackM s a -> s -> [(s,a)]
+runBM (BM m) s = m (\x s xs -> (s,x) : xs) s []
 
--- * running the monad
+foldBM :: (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b
+foldBM f b (BM m) s = m f s b
 
-runBM       :: BacktrackM s a  -> s -> [(s, a)]
+foldSolutions   :: (a -> b -> b) -> b -> BacktrackM s a -> s -> b
+foldSolutions f b (BM m) s = m (\x s b -> f x b) s b
 
 solutions   :: BacktrackM s a  -> s -> [a]
-solutions   bm = map snd . runBM bm 
+solutions = foldSolutions (:) []
+
+foldFinalStates :: (s -> b -> b) -> b -> BacktrackM s () -> s -> b
+foldFinalStates f b (BM m) s = m (\x s b -> f s b) s b
 
 finalStates :: BacktrackM s () -> s -> [s]
 finalStates bm = map fst . runBM bm
 
 
-{-
-----------------------------------------------------------------------
--- implementation as lists of successes
-
-newtype BacktrackM s a = BM (s -> [(s, a)])
-
-runBM       (BM m) = m
+-- * handling the state & environment
 
-readState    = BM (\s -> [(s, s)])
-writeState s = BM (\_ -> [(s, ())])
+readState :: BacktrackM s s
+readState    = BM (\c s b -> c s s b)
 
-failure       = BM (\s -> [])
-BM m ||| BM n = BM (\s -> m s ++ n s)
+writeState :: s -> BacktrackM s ()
+writeState s = BM (\c _ b -> c () s b)
 
 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
--}
-
-----------------------------------------------------------------------
--- Combining endomorphisms and continuations
--- a la Ralf Hinze
-
-newtype Backtr a = B (forall b . (a -> b -> b) -> b -> b)
-
-instance Monad Backtr where
-    return a  = B (\c f -> c a f)
-    B m >>= k = B (\c f -> m (\a -> unBacktr (k a) c) f)
-        where unBacktr (B m) = m
-    fail _ = failureB
-
-failureB     = B (\c f -> f)
-B m |||| B n = B (\c f -> m c (n c f))
-
-runB (B m) = m (:) []
+    return a   = BM (\c s b -> c a s b)
+    BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
+	where unBM (BM m) = m
+    fail _ = failure
 
--- BacktrackM = state monad transformer over the backtracking monad
+-- * controlling the monad
 
-newtype BacktrackM s a = BM (s -> Backtr (s, a))
+failure :: BacktrackM s a
+failure = BM (\c s b -> b)
 
-runBM (BM m) s = runB (m s)
+(|||) :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a
+(BM f) ||| (BM g) = BM (\c s b -> f c s (g c s b))
 
-readState    = BM (\s -> return (s, s))
-writeState s = BM (\_ -> return (s, ()))
+instance MonadPlus (BacktrackM s) where
+    mzero = failure
+    mplus = (|||)
 
-failure = BM (\s -> failureB)
-BM m ||| BM n = BM (\s -> m s |||| n s)
+-- * specific functions on the backtracking monad
 
-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
-    fail _ = failure
+member :: [a] -> BacktrackM s a
+member = msum . map return