boys-soldiers.hs

{- Два солдата подошли к реке, по которой на лодке катаются двое
мальчиков. Как солдатам переправиться на другой берег, если лодка
вмещает только одного солдата либо двух мальчиков, а солдата и
мальчика уже не вмещает? -}

import Data.List (intercalate, (\\), sort, nub, permutations)

data C = Boy | Soldier deriving (Show, Eq, Ord)
data S = S { thisbank :: [C], otherbank :: [C] } deriving (Show)
type Move = [C]
type Log = [Move]
type Game = (Log, S)

start = S [Boy, Boy, Soldier, Soldier] []

newGame :: S -> Game
newGame s = ([], s)

safe :: S -> Bool
safe _ = True

allowed :: Move -> Bool
allowed cs = let n = length cs
                 w Boy = 1
                 w Soldier = 2
                 m = sum $ map w cs
             in  n >= 1 && n <= 2 && m <= 2

move :: Game -> Move -> Game
move (l,s) cs = (cs:l, S (cs ++ otherbank s) ((thisbank s) \\ cs))

safeMoves :: S -> [Move]
safeMoves s =
  let ms = nub . sort $ map (:[]) (thisbank s)
      ms2 = nub . sort . map (take 2) . permutations $ thisbank s
  in  filter (safe . snd . move (newGame s)) . filter allowed $ ms ++ ms2

deeper :: [Game] -> [Game]
deeper = concatMap deeper1
  where
  deeper1 :: Game -> [Game]
  deeper1 g@(l,s) = map (move g) . filter (notLast l) $ safeMoves s
  notLast (m':_) m = m' /= m
  notLast [] _ = True

isSolution :: Game -> Bool
isSolution (l, s) = (odd . length $ l) &&
                    (null . filter (==Soldier) . otherbank $ s)

someSolution :: Game
someSolution = let ss = iterate deeper [newGame start]
               in  head . head . dropWhile null . map (filter isSolution) $ ss 

showSolution :: Game -> String
showSolution = intercalate "\n" . map show . reverse . fst

main = putStrLn . showSolution $ someSolution

[Boy,Boy]
[Boy]
[Soldier]
[Boy]
[Soldier]