No.1: 狼と山羊とキャベツ

A Wolf, a Goat and a Cabbage.

ある川の岸に男と狼と山羊とキャベツがいる。男は狼と山羊とキャベツを連れて舟で川を渡ろうとしているが、舟は小さいので、男の他には狼と山羊とキャベツのいずれかひとつしか乗せられない。また、男が見張っていないと狼は山羊を食べてしまい、山羊はキャベツを食べてしまう。どのようにすれば男は無事に全員を連れて対岸に渡れるだろうか。

WolfGoatCabbage.hs

module Main where
import Data.Maybe (fromJust)

data Shore = Here | There deriving (Eq, Show)
data Move = M | MW | MG | MC deriving (Eq)
instance Show Move where 
  show m = case m of {M->"男だけ"; MW->"男と狼"; MG->"男と山羊"; MC->"男とキャベツ";}

type Locations = (Shore, Shore, Shore, Shore) -- (man, wolf, goat, cabbage)
type History = (Locations, [Move]) -- (locations of characters, log of moves)


isLegal :: History -> Bool
isLegal ((m,w,g,c),l) = 
  if (w==g) && (m/=w)
    then False
    else if (g==c) && (m/=g)
           then False
           else True

step :: History -> [History]
step ((m,w,g,c),l) = filter isLegal $
  [((move m,w,g,c),M:l)] ++ 
  (if m==w then [((move m, move w, g, c),MW:l)] else []) ++
  (if m==g then [((move m, w, move g, c),MG:l)] else []) ++
  (if m==c then [((move m, w, g, move c),MC:l)] else [])
    where move x = if x==Here then There else Here

next = concat . map step
solve = fromJust . lookup (There,There,There,There) . concat . iterate next . return
format = ("":). (flip (zipWith (++))) (cycle ["が行く ","が戻る "]) . map show . reverse

main = mapM_ putStrLn $ format $ solve ((Here, Here, Here, Here),[])

出力

*Main> main

男と山羊が行く
男だけが戻る
男と狼が行く
男と山羊が戻る
男とキャベツが行く
男だけが戻る
男と山羊が行く