В восьмиэтажном супермаркете имеется два лифта, один — вместимостью два человека (в начальный момент времени находится на четвёртом этаже), второй рассчитан только на одного человека (находится на втором этаже).
Мужчина, что находится на втором этаже, сегодня идёт на свидание.
У женщины на пятом этаже есть сын, которому завтра исполнится семь лет.
Также на пятом этаже девочка только что выпросила у родителей денег на мороженое.
Мальчик, что находится на восьмом этаже, хочет поиграть в игровые автоматы.
Наконец, на седьмом этаже находится кошка Саши, которая жаждет вернуться домой.
За какое минимальное количество шагов лифты могут доставить людей и животных на требуемые этажи и что это за шаги, если известно, что:
Магазин игрушек находится на третьем этаже.
Кондитерские изделия продаются на шестом этаже.
Цветочный магазин находится на восьмом.
Игровые автоматы находятся прямо под магазином игрушек.
У кошки есть специальная бабушка, которая может нажать на кнопку требуемого этажа (и они вдвоём с кошкой занимают место одного человека в лифте).

{-# OPTIONS -Wall #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}

import Control.Monad.Identity
import Control.Monad.List
import Control.Monad.Writer
import Control.Monad.State
import Data.List


newtype History a = History
  { runH :: (WriterT [String] (StateT HouseState (ListT Identity))) a }
  deriving (Monad, MonadWriter [String], MonadState HouseState, MonadPlus)


runHistory :: History a -> HouseState -> [([String], HouseState)]
runHistory k s = runIdentity (runListT (runStateT (execWriterT (runH k)) s))


{-
newtype Min a = Min a deriving (Eq, Ord, Bounded)
instance (Ord a, Bounded a) => Monoid (Min a) where
  mempty = maxBound
  Min a `mappend` Min b = Min (a `min` b)

newtype Max a = Max a deriving (Eq, Ord, Bounded)
instance (Ord a, Bounded a) => Monoid (Max a) where
  mempty = minBound
  Max a `mappend` Max b = Max (a `max` b)
-}

type Floor = Int

data HouseState
  = HS
  { floorNum :: Floor
  , floorNum2 :: Floor
  , people :: [(Floor, Person)]
  } deriving (Show, Eq)

data Person
  = Person
  { personName :: String
  , personPlans :: [Floor]
  } deriving (Eq, Show)

initState :: HouseState
initState = let floorNum = 4
        floorNum2 = 2
        people =
          [ (2, Person "Man" [8])
          , (5, Person "Woman" [3])
          , (5, Person "Girl" [6])
          , (8, Person "Boy" [2])
          , (7, Person "Cat" [1])
          ]

      in HS {..}

peopleOnFloor :: Floor -> HouseState -> [Person]
peopleOnFloor f = map snd . filter ((== f) . fst) . people

goesRightDir :: Floor -> Floor -> Floor -> Bool
goesRightDir cur next planned = (cur - next) * (cur - planned) > 0

whoWantsToGetTo :: Floor -> Floor -> HouseState -> [Person]
whoWantsToGetTo cur next = map snd . getsCloserToTarget . atTheThisFloor . people
  where
    getsCloserToTarget = filter (goesRightDir cur next . head . personPlans . snd)
    atTheThisFloor = filter ((== cur) . fst)

tryAll :: [a] -> History a
tryAll = msum . map return

rideToTheFloor :: [Person] -> Floor -> History ()
rideToTheFloor ppl next = do
    tell $ map (\p -> personName p ++ " enters the elevator." ) ppl
    tell ["Elevator rides to the floor #" ++ show next]
    tell $ map (\p -> personName p ++ " leaves the elevator." ) ppl
    modify $ \s -> s { floorNum = next
             , people = foldl ridePerson (people s) ppl
             }
  where
    ridePerson ps p = (next, p) : filter ((/= (personName p)) . personName . snd) ps

rideToTheFloor2 :: [Person] -> Floor -> History ()
rideToTheFloor2 ppl next = do
    tell $ map (\p -> personName p ++ " enters the elevator 2." ) ppl
    tell ["Elevator rides to the floor #" ++ show next]
    tell $ map (\p -> personName p ++ " leaves the elevator 2." ) ppl
    modify $ \s -> s { floorNum2 = next
             , people = foldl ridePerson (people s) ppl
             }
  where
    ridePerson ps p = (next, p) : filter ((/= (personName p)) . personName . snd) ps



fitsInTheElevator :: [a] -> Bool
fitsInTheElevator x = length x <= 2

fitsInTheElevator2 :: [a] -> Bool
fitsInTheElevator2 x = length x <= 1



randomRides :: History ()
randomRides = do

  currentFloor <- gets floorNum
  tell ["Elevator 1 is at the floor #" ++ show currentFloor]
  nextFloor <- tryAll [currentFloor + 1, currentFloor - 1]

  guard $ nextFloor >= 1 && nextFloor <= 8

  personsMightTravel <- gets (whoWantsToGetTo currentFloor nextFloor)

  if fitsInTheElevator personsMightTravel
    then rideToTheFloor personsMightTravel nextFloor
    else do ppl <- tryAll $ filter fitsInTheElevator . tail . subsequences $ personsMightTravel
        rideToTheFloor ppl nextFloor

  currentFloor <- gets floorNum2
  tell ["Elevator 2 is at the floor #" ++ show currentFloor]
  nextFloor <- tryAll [currentFloor + 1, currentFloor - 1]

  guard $ nextFloor >= 1 && nextFloor <= 8


  ppl <- gets people
  ppl' <- forM ppl $ \i@(persFloor, Person name plans) ->
    if persFloor == head plans
      then do case tail plans of
            [] -> tell [name ++ " has reached his final destination"]
            x:_ -> tell [name ++ " has reached one of his destination and now will head to " ++ show x]
          return (persFloor, Person name (tail plans))
      else return i

  let stillGoing = filter (not . null . personPlans . snd) ppl'
  when (null stillGoing) $ tell ["Problem solved"]

  modify $ \s -> s { people = stillGoing }


  personsMightTravel <- gets (whoWantsToGetTo currentFloor nextFloor)

  if fitsInTheElevator2 personsMightTravel
    then rideToTheFloor2 personsMightTravel nextFloor
    else do ppl <- tryAll $ filter fitsInTheElevator . tail . subsequences $ personsMightTravel
        rideToTheFloor2 ppl nextFloor




  ppl <- gets people
  ppl' <- forM ppl $ \i@(persFloor, Person name plans) ->
    if persFloor == head plans
      then do case tail plans of
            [] -> tell [name ++ " has reached his final destination"]
            x:_ -> tell [name ++ " has reached one of his destination and now will head to " ++ show x]
          return (persFloor, Person name (tail plans))
      else return i

  let stillGoing = filter (not . null . personPlans . snd) ppl'
  when (null stillGoing) $ tell ["Problem solved"]

  modify $ \s -> s { people = stillGoing }
 


ridesX :: Int -> History ()
ridesX 0 = return ()
ridesX x = randomRides >> ridesX (x - 1)


isSolution :: ([String], HouseState) -> Bool
isSolution = null . people . snd

solDistance :: (Int, Person) -> Int
solDistance (i, Person _ [x]) = abs $ i - x



main :: IO ()
main = print $ filter isSolution $ runHistory (ridesX 11) initState

* This source code was highlighted with Source Code Highlighter.

[code]