2008/12/28

農夫過河

解題動機來自 scm 老師在嵐達網上貼的 forum post,摘錄其中的問題描述:

大家都知道這個農夫過河問題:農夫、羊、狼、與包心菜準備過河,河中有一條小船。只有農夫能撐船,而農夫每次只能帶一樣東西過河。當農夫不在時,狼會吃羊,羊會吃包心菜。怎麼讓他們安然過河呢?

雖然不太了解農夫為什麼要帶著狼,但單純的 searching 就可以輕鬆解決這道題目,而 searching 在 Haskell 裡面可以很乾淨地分成兩段,第一段造出 search tree,第二段對這棵 search tree 做 breadth-first search。

先引入 module Data.List。

> import Data.List  -- using (unfoldr)
我們的 search tree 採用 "rose tree":這種樹有一個 root,其下是一群 subtrees,收納在一個 list 裡面。
> data Tree a = Node a [Tree a]  deriving Show
在 rose tree 上一樣可以定義 unfold,拿一個種子和「展開一步」的 function funfoldt 會用 f 把種子變成 root element 和新一列種子,然後遞迴地把那一列種子長成 subtrees。
> unfoldt :: (b -> (a, [b])) -> b -> Tree a
> unfoldt f b = let (a, bs) = f b in Node a (map (unfoldt f) bs)
接下來我們要寫一個函式
> bfs :: Tree a -> [a]
對一棵 rose tree 做 breadth-first traversal。傳統的 breadth-first search 用一個 queue 記錄尚未拜訪的 nodes,每次從這個 queue 拿出一個 node,然後把這個 node(尚未拜訪過)的鄰居放進 queue 裡面,直到 queue 全部清空。bfs 實作的是同一個想法,直接把尚未巡訪過的 (sub-) trees 記錄在一個充當 queue 的 list 裡面,每次拿出一棵樹就輸出它的 root,然後把其下的 list of subtrees 串在 queue 後面。因此 bfs 可以寫成一個 unfoldr,用 queue 當作種子:
> bfs :: Tree a -> [a]
> bfs = unfoldr f . (:[])
>   where
>     f [] = Nothing
>     f (Node a ts : xs) = Just (a, xs ++ ts)

接下來才真正開始解農夫過河問題。我們用一個 4-tuple 代表過河的狀態:

> type State = (Bool, Bool, Bool, Bool)
四個 components 分別是農夫、狼、羊、包心菜的狀態,False 代表還沒過河,True 代表已經過河。我們希望造一棵 Tree State,滿足
  • root 是 (False, False, False, False)
  • 當某個 state s 可經過一步抵達 state t 時,就讓 t 成為 s 的 child,而且
  • 出現在樹中的 state 都沒有慘劇發生,即不會有哪個生物被吞進別人的肚子裡。
實作上為了方便,我們把「從 root 走到某個 state」中間採取的所有行動記錄在一個字串裡面,並直接把這個字串和對應的 state 綁在一起。
> type Trace = String
於是 search tree 就寫成
> stateSpace :: Tree (State, Trace)
> stateSpace = unfoldt f ((False, False, False, False), "") 
>   where
其中 f 拿到一個 state(和對應的 trace)時應該告訴 unfoldt 那個 state 是新的元素,並從那個 state 算出所有可能到達的 feasible states 當作新的種子。所謂 "feasible" 就是「沒有慘劇發生」,而「慘劇發生」就是「狼羊同處、農夫卻不在一旁」或「羊菜同處、農夫卻不在一旁」,因此
>     feasible :: State -> Bool
>     feasible (a, w, g, c) = not (w == g && a /= w || g == c && a /= g)
為了方便表達「當農夫和狼同處時,農夫可帶狼過河」,我們寫一個 helper function
>     ccons :: Bool -> a -> [a] -> [a]
>     ccons b x = if b then (x:) else id
ccons 是 "conditional cons" 的縮寫:ccons b x xsbTrue 時是 x : xs,否則是 xs。如果舊的 state 是 (a, w, g, c),一步可抵達的 states 就是
ccons (a == w) (not a, not w,     g,     c) $
ccons (a == g) (not a,     w, not g,     c) $
ccons (a == c) (not a,     w,     g, not c) [ (not a, w, g, c) ]
例如 ccons (a == w) (not a, not w, g, c) 講的是「如果農夫和狼在一塊,就把『農夫和狼一起過河』後的 state 加入 list」。有了這個 list,再用 filter feasible 就可篩出一步可抵達的 feasible states。實際上我們還需要處理 traces,所以 unfoldt 用的 (coalgebra) f 寫成
>     f s @ ((a, w, g, c), tr) = (s, filter (feasible . fst)
>       $ ccons (a == w) ((not a, not w,     g,     c), 'W' : tr)  -- Wolf
>       $ ccons (a == g) ((not a,     w, not g,     c), 'G' : tr)  -- Goat
>       $ ccons (a == c) ((not a,     w,     g, not c), 'C' : tr)  -- Cabbage
>       $ (:[])          ((not a,     w,     g,     c), 'A' : tr)) -- Alone
至此就展開了一棵 search tree。最後我們只要對這棵樹做 BFS,找到那些 (True, True, True, True) states 並收集對應的 traces 就結束了。因為當初記錄的 traces 是反序的,所以要套個 reverse 把順序調整好。
> solutions :: [Trace]
> solutions = [ reverse tr | ((True, True, True, True), tr) <- bfs stateSpace ]
在 ghci 下打 head solutions 就可以看到最短的一組解:
*Main> head solutions
"GAWGCAG"

對於沒看過 Haskell 的人而言,其中一個令人好奇的現象應該是「stateSpace 是一棵 infinite search tree」。在「正常」的語言裡面,bfs stateSpace 會先試圖把 stateSpace 算完,但 Haskell 採用 lazy evaluation,除非真有需要否則不會把值算出來,於是程式執行時實際發生的事情會很類似用「正常」語言寫的 BFS,每次看一個 state 找出一步可抵達的 feasible states 放進 queue 裡面,然後重複。(算是自動做了某種程度的 deforestation 吧?)如果只要 solutions 的第一個元素,找到對應的 state 時程式就會停止,因為不需要算出其餘的解。

--
個人認為像這樣「拆成兩部份寫」是非常優雅的寫法 XD。

Labels:

<< 回到主頁