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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
> {-# LANGUAGE ViewPatterns #-}
> module Cabbage where
> import Control.Monad
> import Control.Monad.State
> import Control.Monad.Trans.Iter
> import Control.Monad.Writer
> import Data.Functor.Identity
> import Data.Maybe
> import Data.Tuple
> import Data.List (inits, tails)
Consider the following problem:
A farmer must cross a river with a wolf, a sheep and a cabbage.
He owns a boat, which can only carry himself and one other item.
The sheep must not be left alone with the wolf, or with the cabbage:
if that happened, one of them would eat the other.
> data Item = Wolf | Sheep | Cabbage | Farmer deriving (Ord, Show, Eq)
>
> eats :: Item -> Item -> Bool
> Sheep `eats` Cabbage = True
> Wolf `eats` Sheep = True
> _ `eats` _ = False
The problem can be represented as the set of items on each side of the river.
> type Situation = ([Item],[Item])
> initial :: Situation
> initial = ([Farmer, Wolf, Sheep, Cabbage], [])
First, some helper functions to extract single elements from lists, leaving the
rest intact:
> plusTailOf :: [a] -> [a] -> (Maybe a, [a])
> a `plusTailOf` b = (listToMaybe b, a ++ drop 1 b)
> singleOut1 :: (a -> Bool) -> [a] -> (Maybe a,[a])
> singleOut1 sel = uncurry plusTailOf . break sel
@
*Cabbage> singleOut1 (== Sheep) [Wolf, Sheep, Cabbage]
(Just Sheep,[Wolf,Cabbage])
@
> singleOutAll :: [a] -> [(Maybe a,[a])]
> singleOutAll = zipWith plusTailOf <$> inits <*> tails
@
*Cabbage> singleOutAll [Wolf, Sheep, Cabbage]
[(Just Wolf,[Sheep,Cabbage]),(Just Sheep,[Wolf,Cabbage]),(Just Cabbage,[Wolf,Sheep]),(Nothing,[Wolf,Sheep,Cabbage])]
@
In every move, the farmer goes from one side of the river to the other,
together with (optionally) one item.
The remaining items must not eat each other for the move to be valid.
> move :: Situation -> [Situation]
> move = move2
> where
> move2 (singleOut1 (== Farmer) -> (Just Farmer,as), bs) = move1 as bs
> move2 (bs, singleOut1 (== Farmer) -> (Just Farmer,as)) = map swap $ move1 as bs
> move2 _ = []
>
> move1 as bs = [(as', [Farmer] ++ maybeToList b ++ bs) |
> (b, as') <- singleOutAll as,
> and [not $ x `eats` y | x <- as', y <- as']]
@
*Cabbage> move initial
[([Wolf,Cabbage],[Farmer,Sheep])]
@
When the starting side becomes empty, the farmer succeeds.
> success :: Situation -> Bool
> success ([],_) = True
> success _ = False
A straightforward implementation to solve the problem could use the
list monad, trying all possible solutions and
> solution1 :: Situation
> solution1 = head $ solutions' initial
> where
> solutions' a = if success a
> then return a
> else move a >>= solutions'
However, when it's run, it will get stuck in an infinite loop, as the sheep
is shuffled back and forth. The solution is being searched in depth.
To guarantee termination, we can use the 'Iter' monad with its MonadPlus instance.
As long as one of the possible execution paths finds a solution, the program
will terminate: the solution is looked for _in breadth_.
> solution2 :: Iter Situation
> solution2 = solution' initial
> where
> solution' a =
> if success a
> then return a
> else delay $ msum $ map solution' (move a)
Each of the alternative sequences of movements will be evaluated
concurrently; and the shortest one will be the result. In case of ties,
the leftmost solution takes priority.
@
*Cabbage> solution2
IterT (Identity (Right ( …
(IterT (Identity (Right
(IterT (Identity (Left
([],[Farmer,Sheep,Cabbage,Wolf]))))))))))))))))))))))))
@
For a cleaner display, use 'retract' to escape 'Iter' monad:
@
*Cabbage> retract solution2
Identity ([],[Farmer,Sheep,Cabbage,Wolf])
@
'unsafeIter' will also get rid of the 'Identity' wrapper:
> unsafeIter :: Iter a -> a
> unsafeIter = runIdentity . retract
@
*Cabbage> unsafeIter solution2
([],[Farmer,Sheep,Cabbage,Wolf])
@
Suppose that we not only want the solution, but also the steps that we
took to arrive there. Enter the Writer monad transformer:
> solution3 :: Iter (Situation, [Situation])
> solution3 = runWriterT $ solution' initial
> where
> solution' :: Situation -> WriterT [Situation] Iter Situation
> solution' a = do
> tell [a]
> if success a
> then return a
> else mapWriterT delay $ msum $ map solution' (move a)
The second component contains the complete path to the solution:
@
*Cabbage> snd $ unsafeIter solution3
[([Farmer,Wolf,Sheep,Cabbage],[]),
([Wolf,Cabbage],[Farmer,Sheep]),
([Farmer,Wolf,Cabbage],[Sheep]),
([Cabbage],[Farmer,Wolf,Sheep]),
([Farmer,Sheep,Cabbage],[Wolf]),
([Sheep],[Farmer,Cabbage,Wolf]),
([Farmer,Sheep],[Cabbage,Wolf]),
([],[Farmer,Sheep,Cabbage,Wolf])]
@
When the transformer is applied _over_ the Iter monad, it acts locally for each solution.
If we apply the IterT transformer over another monad,
the behaviour for that monad will be shared among all threads.
For example, let's keep track of how many moves we perform. We could
do so with the writer monad again (numbers form a monoid under addition), but
we'll use the state monad this time.
> solution4 :: Iter (Situation, Integer)
> solution4 = flip runStateT 0 $ solution' initial
> where
> solution' :: Situation -> StateT Integer Iter Situation
> solution' a =
> if success a
> then return a
> else do
> modify (+1)
> mapStateT delay $ msum $ map solution' (move a)
This gives us seven moves (one for each transition between two states).
@
*Cabbage> unsafeIter solution4
(([],[Farmer,Sheep,Cabbage,Wolf]),7)
@
On the other hand, if move the state inside Iter, we get a global count of
explored nodes until the solution was found.
> solution5 :: State Integer Situation
> solution5 = retract $ solution' initial
> where
> solution' :: Situation -> IterT (State Integer) Situation
> solution' a =
> if success a
> then return a
> else do
> modify (+1)
> delay $ msum $ map solution' (move a)
@
*Cabbage> runState solution5 0
(([],[Farmer,Sheep,Cabbage,Wolf]),113)
@
|
