農夫過河

解題動機來自 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 f，unfoldt 會用 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 xs 在 b 為 True 時是 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。