1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
----------------------------------------------------------------------
-- |
-- Module : BacktrackM
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/03/29 11:17:54 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.2 $
--
-- Backtracking state monad, with r\/o environment
-----------------------------------------------------------------------------
module GF.Data.BacktrackM ( -- * the backtracking state monad
BacktrackM,
-- * controlling the monad
failure,
(|||),
-- * handling the state & environment
readEnv,
readState,
writeState,
-- * monad specific utilities
member,
-- * running the monad
runBM,
solutions,
finalStates
) where
import Monad
------------------------------------------------------------
-- type declarations
-- * controlling the monad
failure :: BacktrackM e s a
(|||) :: BacktrackM e s a -> BacktrackM e s a -> BacktrackM e s a
instance MonadPlus (BacktrackM e s) where
mzero = failure
mplus = (|||)
-- * handling the state & environment
readEnv :: BacktrackM e s e
readState :: BacktrackM e s s
writeState :: s -> BacktrackM e s ()
-- * monad specific utilities
member :: [a] -> BacktrackM e s a
member = msum . map return
-- * running the monad
runBM :: BacktrackM e s a -> e -> s -> [(s, a)]
solutions :: BacktrackM e s a -> e -> s -> [a]
solutions bm e s = map snd $ runBM bm e s
finalStates :: BacktrackM e s () -> e -> s -> [s]
finalStates bm e s = map fst $ runBM bm e s
{-
----------------------------------------------------------------------
-- implementation as lists of successes
newtype BacktrackM e s a = BM (e -> s -> [(s, a)])
runBM (BM m) = m
readEnv = BM (\e s -> [(s, e)])
readState = BM (\e s -> [(s, s)])
writeState s = BM (\e _ -> [(s, ())])
failure = BM (\e s -> [])
BM m ||| BM n = BM (\e s -> m e s ++ n e 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 ])
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
failureB = B (\c f -> f)
B m |||| B n = B (\c f -> m c (n c f))
runB (B m) = m (:) []
-- BacktrackM = state monad transformer over the backtracking monad
newtype BacktrackM e s a = BM (e -> s -> Backtr (s, a))
runBM (BM m) e s = runB (m e s)
readEnv = BM (\e s -> return (s, e))
readState = BM (\e s -> return (s, s))
writeState s = BM (\e _ -> return (s, ()))
failure = BM (\e s -> failureB)
BM m ||| BM n = BM (\e s -> m e s |||| n e 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')
where unBM (BM m) = m
|
