Решение "хитроумной задачи для любителей матана"

Сегодня человек с ником _darkus_ (как оказалось - это тот самый Роман Душкин) разместил в LiveJournal пост, с названием "Хитроумная задача для любителей матана", где он призывал решить её на любимом языке программирования.


Для начала рассмотрим условие задачи:

Встречаются два математика, не видевшиеся много лет. Расспрашивают друг друга о житии-бытии, и в ходе разговора происходит следующий разговор:
М1: Дети-то есть?
М2: Да, трое сыновей.
М1: И сколько же им лет?
М2: Ну ты же математик, попробуй сам рассчитать. Если перемножить их возрасты, то получится 36.
М1: Недостаточно информации.
М2: Сумма их возрастов равна номеру вон того троллейбуса.
М1: Опять недостаточно информации.
М2: Младший — рыжий.
М1: Теперь всё понятно!
Назовите возраст детей.

Итак. Если перемножить возрасты трех детей - информации будет недостаточно.
Но просмотрим различные варианты возрастов:

(36,1,1)
(18,1,2)
(12,1,3)
(9,1,4)
(6,1,6)
(9,2,2)
(6,2,3)
(4,3,3)

Для подбора я писал функцию, но показывать не буду, ибо стыдно. Но свою задачу она выполнила.

"Сумма их возрастов равна номеру вон того троллейбуса". Сгруппируем найденные варианты по равенству суммы возрастов.

[(36,1,1)]
[(18,1,2)]
[(12,1,3)]
[(9,1,4)]
[(6,1,6),(9,2,2)]
[(6,2,3)]
[(4,3,3)]

"Недостаточно информации". Т.е. даже зная номер троллейбуса, математик не мог узнать возраст. Значит списки с одним элементом мы убираем, т.к. если бы сумма из возрастов, записанных в этом списке была равна номеру трамвая - математик бы дал ответ.

Осталось - [(6,1,6),(9,2,2)].

"Младший — рыжий". Значит младший - один! Убираем элемент с младшими близнецами.

Ответ - 6, 6 и 1!

Код решения на Haskell:

solution n = concatMap smallest $ group' $ cMap (\x -> cMap (\y -> cMap (pred x y) y) x) 1
    where cMap f s           = concatMap f [s..n]
          pred x y z         = [(x,y,z) | z * y * x == n]
          group'             = concat . filter (\x -> length x /= 1) . groupBy (\x y -> sum3 x == sum3 y)
          sum3 (x,y,z)       = x + y + z
          smallest l@(x,y,z) = [l | length (head $ group $ sort [x, y, z]) == 1]

Код выше был написан в спешке. Ниже попытка упростить с помощью list-comprehension:

solution n = smallest $ group' [(x,y,z) | x <- [1..n], y <- [x..n], z <- [y..n], x * y * z == n]
    where group'             = concat . filter ((/= 1) . length) . groupBy (\x y -> sum3 x == sum3 y)
          sum3 (x,y,z)       = x + y + z
          smallest l         = [o | o@(x,y,z) <- l, length (head $ group $ sort [x, y, z]) == 1]

Видимо это верный вариант.