オオカミとヤギとキャベツを移動させるやつ

Haskell

研究室の一部の人が uppaal で解こうとしていた問題。
オオカミとヤギとキャベツを対岸に移動させたいけど、オオカミとヤギ、あるいはヤギとキャベツを残したまま人が対岸に行ってはダメ、というやつ。
最初は prolog でやってやろうとしたけど、くじけて Haskell でお茶を濁しました。 Snow Leopard で GHC が動かないのもあって、最近 Haskell のコードを書いてなかったからいいんです。
いつか、圏論を使って考えてみました！とか言いたい。(適当)

人とオオカミとヤギとキャベツの位置を Bool で表してます。Move0 は人が対岸に渡り、Move1 Move2 Move3 はそれぞれ、オオカミとヤギとキャベツが移動します。move 関数のガードは、人なしで勝手にキャベツなどが移動しないようにするために必要です。

import Control.Monad
import List

type Game = (Bool, Bool, Bool, Bool)
data Move = Move0 | Move1 | Move2 | Move3 deriving (Eq,Show)

move :: Move -> Game -> Maybe Game
move Move0 (h,x,y,z)        = Just (not h,x,y,z)
move Move1 (h,x,y,z) | h==x = Just (not h,not x,y,z)
move Move2 (h,x,y,z) | h==y = Just (not h,x,not y,z)
move Move3 (h,x,y,z) | h==z = Just (not h,x,y,not z)
move _     _                = Nothing

ok (True,False,False,_) = False
ok (True,_,False,False) = False
ok (False,True,True,_)  = False
ok (False,_,True,True)  = False
ok _                    = True

solved (_,False,False,False) = True
solved _                     = False

step :: (Game, [Move]) -> [(Game, [Move])]
step (state, ops) = do op <- [Move0,Move1,Move2,Move3]
                       case move op state of
                         Nothing     -> mzero
                         Just state' -> do guard (ok $ state')
                                           return (state', op:ops)

calc :: [(Game, [Move])] -> [Move]
calc states = let states' = concatMap step states in
              case find (solved . fst) states' of
                Nothing -> calc states'
                Just (_, moves) -> reverse moves

main = print $ calc [((True,True,True,True), [])]

$ runhaskell tmp.hs
[Move2,Move0,Move1,Move2,Move3,Move0,Move2]
$