Решение задачи «кто на ком женат» с помощью Haskell

6 сентября 2011

В рамках серии экспериментов с прокачкой мозгов, я решил принять участие в небольшом программистском конкурсе от Романа Душкина. И я не без удовольствия воспринял новость о том, что вошел в пятерку победителей, полностью решивших задачу (места не пронумерованы, но если бы были, то я бы точно занял не первое и не второе место).

Конкурс состоял в том, чтобы написать программу (на любом языке), решающую следующую задачу:

Трое крестьян – Иван, Петр и Алексей – пришли на рынок с женами – Марией, Екатериной и Анной. Каждый из этих шести человек заплатил за каждый купленный предмет столько копеек, сколько предметов он купил.

Каждый мужчина истратил на 48 копеек больше своей жены.

Кроме того, Иван купил на 9 предметов больше Екатерины, а Петр – на 7 предметов больше Марии.

Кто на ком женат?

Также после решения задачи требовалось ответить на кое-какие дополнительные вопросы, которые заранее были неизвестны.

В первую очередь я решил составить математическую модель задачи. Пусть m_i – количество предметов, купленных i-м мужчиной, а w_j – количество предметов, купленных j-ой женщиной, где i, j ∈ {0,1,2}. Номер женщины, на которой женат i-ый мужчина, обозначим x_i. Дано:

m_i² – w_{x_i}² = 48
m₀ – w₁ = 9
m₁ – w₀ = 7
m_i, w_j ∈ ℕ₀
i, j ∈ {0,1,2}

Требуется найти такое множество {x_i}, чтобы приведенная система уравнений имела решение для каких-нибудь {m_i} и {w_j}.

Теперь задачу несложно решить простым перебором, для реализации которого был выбран Haskell:

-- Решение задачи "Кто на ком женат"
-- (c) Alexandr Alexeev 2011 | http://eax.me/
import Data.List
-- для простоты реализации перебираем число покупок "тупым" способом
maxNumbers = 20
itemsNumbersM =
  [ [x, y, z] |
    x <- [1..maxNumbers], y <- [1..maxNumbers], z <- [1..maxNumbers]]
itemsNumbersW =
  [ [x, y, z] |
    x <- [1..maxNumbers], y <- [1..maxNumbers], z <- [1..maxNumbers]]

-- заплачено денег в зависимости от числа покупок
paid x = x*x

solve =
  [ (x, m, w) | 
    -- i-ый мужчина женат на Xi-ой женщине
    x <- permutations [0..2],
    -- все возможные варианты, сколько купилa i-ая женщина
    w <- itemsNumbersW, 
    -- все возможные варианты, сколько купил i-ый мужчина
    m <- itemsNumbersM,
    -- кроме того:
      (m !! 0) - (w !! 1) == 9,
      (m !! 1) - (w !! 0) == 7,
      paid (m !! 0) - paid (w !! (x !! 0)) == 48,
      paid (m !! 1) - paid (w !! (x !! 1)) == 48,
      paid (m !! 2) - paid (w !! (x !! 2)) == 48
 ]

main = do
  printPair 0 
  printPair 1 
  printPair 2 
  where
    man = ["Ivan", "Petr", "Alexey"]
    woman = ["Maria", "Katya", "Anna"]
    (solution, _, _) = head solve
    printPair n = do
      putStrLn $ (man !! n) ++ " -- " ++ (woman !! (solution !! n))

Ответ: Иван (13) женат на Анне (11), Петр (8) на Екатерине (4), а Алексей (7) – на Марии (1). В скобках указанно количество купленных вещей.

С первой частью задания справится было легко. Последующие за этим дополнительные вопросы оказались куда сложнее:

1. Сколько уникальных пар коэффициентов (a, b) даёт уникальное распределение людей по парам для разницы в паре в 48 копеек?

2. Для каких значений коэффициента k, меньших или равных 100, задача имеет решения для каких-либо пар коэффициентов (a, b)?

Коэффициенты (a, b) – это разницы типа (9, 7) в условии. Коэффициент k – это как 48 копеек.

Более того, вопросы эти по ряду причин не совсем корректны. Ответить на них с помощью приведенной ранее программы можно, но займет это очень много времени. В общем, после уточнения вопросов и существенной оптимизации изначальной программы, я получил следующее:

-- Решение задачи "Кто на ком женат" (с доп. вопросами)
-- (c) Alexandr Alexeev 2011 | http://eax.me/
import Data.List

-- максимальное число покупок у одного человека
maxItemsNum = 100 

-- список возможных чисел покупок у женщин {W}
-- для любого W должен существовать M = sqrt(k + W**2)
possibleItemsNumbersW k =
  filter (\x -> manItemsNum k x > 0) [0..maxItemsNum]
  
-- все возможные пары числа покупок (M, W) : M**2 - W**2 = k
allPossibleItemsNumberMW k =
  filter (\(m, w) -> m*m - w*w == k) [
    (manItemsNum k w1, w2) |
      w1 <- possibleItemsNumbersW k,
      w2 <- possibleItemsNumbersW k ]
      
-- все возможные значения a и b для данного k
allPossibleAB k = nub $ filter (>0) [
   manItemsNum k w1 - w2 |
     w1 <- possibleItemsNumbersW k,
     w2 <- possibleItemsNumbersW k]

-- число покупок мужчины в зависимости от k и числа покупок его жены
manItemsNum k womanItemsNum =
  if (not $ null lst) && ((snd $ lastLst) == itemsNumberSquare)
    then fst $ lastLst
    else -1
  where
    -- квадрат искомого значения
    itemsNumberSquare = k + womanItemsNum*womanItemsNum 
    -- все квадраты
    squares = [ (x, x*x) | x <- [1..] ] 
    lst = takeWhile (\(_, x) -> x <= itemsNumberSquare) squares
    lastLst = last lst

-- все возможные решения задачи для заданных a, b и k
solve a b k =
  filter (\(x,[w0,w1,_]) ->
    (fst(x!!0) - snd(x!!w1) == a ) &&
      fst(x!!1) - snd(x!!w0) == b)
    [ ([pair1, pair2, pair3], womanPosList) |
      pair1 <- allPossibleItemsNumberMW k,
      pair2 <- allPossibleItemsNumberMW k,
      pair3 <- allPossibleItemsNumberMW k,
      womanPosList <- permutations [0..2]
    ]

-- существует ли пара (a,b), дающая единственное решиние для данного k?
hasAnySolutionForK k =
  not.null $ filter (\x -> length x == 1) [
    -- если 2 или больше ответа, то для такого k задача некорректна 
    take 2 $ solve a b k | 
      a <- allPossibleAB k, b <- allPossibleAB k
  ]
  
-- Сколько уникальных пар коэффициентов (a, b) даёт уникальное
-- распределение людей по парам для разницы в паре в 48 копеек?
task1 = 
  length $ nub $ filter (\x -> length x == 1) [
    take 2 $ solve a b k |
      a <- allPossibleAB k, b <- allPossibleAB k
  ]
  where k = 48

-- Для каких значений коэффициента k, меньших или равных 100,
-- задача имеет решения для каких-либо пар коэффициентов (a, b)?
task2 = [ k | k <- [1..100], hasAnySolutionForK k ]

main = do
  printPair 0
  printPair 1
  printPair 2
  putStrLn $ "task1: " ++ show task1
  putStrLn $ "task2: " ++ show task2
  where 
    man = ["Ivan", "Petr", "Alexey"]
    woman = ["Maria", "Katya", "Anna"]
    (items, wifeList) = head $ solve 9 7 48
    printPair n = do
      putStrLn $
        (man !! n) ++ " -- "
          ++ (woman !! (wifeList !! n))
          ++ " " ++ show (items !! n)

Ответ на первый вопрос – 12. На второй – 45, 48, 63, 64, 72, 75, 80, 81, 96, 99. Больше всего в ходе написания программы мой уровень ЧСВ подняло осознание того, как же круто я оптимизировал код. Если изначальный вариант программы не мог справиться с задачей за целую ночь, то теперь ответ находится где-то за минуту.

В целом от конкурса я получил исключительно положительные эмоции. А еще я наконец-то понял фразу «главное – участие». Потому что свой главный приз я получил не на финише, а именно во время участия.

Дополнение: А вот и обещанный приз:

Журнал "Потенциал" за август 2009

Если кому-то интересно, это журнал «Потенциал» за август 2009-го года со статьей Романа «Функциональный подход в программировании» и автографом на ней. Приятно, что уж тут :)