LiveStreet

Скоротать время в транспорте помогают игры с билетом, требующие большего напряжения и времени, чем простое определение, счастливый ли достался билет. Возможно, самая популярная из таких игр — игра в сто.

Суть игры состоит в том, чтобы расставить арифметические знаки и скобки среди цифр билета так, чтобы получилось выражение, результатом которого является 100.

У любого, кто хоть раз играл в эту игру, сразу возникают вопросы: существуют ли вообще выражения, дающие для данного билетика 100? сколько билетов не имеют решения? сколько различных решений имеет билет? Мы получим ответы при помощи программы.

Для начала, уточним правила игры:
? из набора цифр билета необходимо составить такое арифметическое выражение, чтобы в результате нахождения его значения получилось число 100;
? разрешается использовать только знаки «+», «-», «*», «/»;
? разрешается использовать скобки;
? разрешается на этапе расстановки знаков собрать цифры в группы, например: имея номер 655803, можно сгруппировать и получить числа для операций «65», или «655», или «80», или «58». То есть такой билет 101001 можно решить так: 101 + 0 + 0 — 1 = 100;
? должен строго соблюдаться порядок цифр;
? результатом деления должно быть целое число, то есть для билета 591777 недопустимо решение вида 5 * (9 + 1 / (7 / 77)).

Эти правила основаны на посте habrahabr.ru/blogs/i_am_clever/40036 и уточнении из комментариев автора.

Чтобы ответить на приведённые вопросы, нужно перебрать все билеты и применить к ним все выражения. Откуда же их взять, эти выражения?

Все возможные формулы можно представить в виде деревьев, во внутренних узлах которых находятся арифметические действия, а на листьях — числа. Отдельные цифры билета я обозначил буквами «a», «b», «c», «d», «e» и «f» соответственно их позиции в номере билета. Таким образом, в билете 031337 вместо «a» в формулу будет подставлено число 0, а вместо «cdef» — число 1337. Соответствующая структура данных на haskell выглядит так:

data FElement = FNumber String
	| FSum FElement FElement
	| FMul FElement FElement
	| FSub FElement FElement
	| FDiv FElement FElement
	| FNeg FElement
	deriving (Show, Read, Eq, Ord)

Тип данных реализует классы Show и Read с целью хранения результатов поиска выражений для всех билетов (довольно продолжительного) в файле для использования во вспомогательных программах. Eq и Ord пригодятся для нормализации и отбрасывании дубликатов при генерации.

Определяю функцию, переводящую формулы в более человеческий вид, правда, я не стал убирать лишние скобки. Так, формула FSum (FNumber «a») (FSum (FNumber «b») (FNumber «c»)) будет переведена в (a + (b + c)).

prettyPrint :: FElement -> String
prettyPrint (FNumber c) = c
prettyPrint (FMul a b) = (prettyPrint a) ++ " * " ++ (prettyPrint b)
prettyPrint (FDiv a b) = (prettyPrint a) ++ " / " ++ (prettyPrint b)
prettyPrint (FSum a b) = "(" ++ (prettyPrint a) ++ " + " ++ (prettyPrint b) ++ ")"
prettyPrint (FSub a b) = "(" ++ (prettyPrint a) ++ " - " ++ (prettyPrint b) ++ ")"
prettyPrint (FNeg a) = "-" ++ (prettyPrint a)

В процессе генерации деревьев возможны ситуации, когда генерируются формулы разные по структуре, но преобразуемые к одному виду. Для исключения лишних формул определяю функцию нормализации, чьей стратегией будет вынесение функции negate как можно выше по дереву и перебалансировка влево при использовании одинаковых операций.

normalize :: FElement -> FElement
normalize (FNumber a) = FNumber a

normalize (FMul (a) (FNeg b)) = FNeg $ FMul (normalize a) (normalize b)
normalize (FMul (FNeg a) (b)) = FNeg $ FMul (normalize a) (normalize b)
normalize (FDiv (a) (FNeg b)) = FNeg $ FDiv (normalize a) (normalize b)
normalize (FDiv (FNeg a) (b)) = FNeg $ FDiv (normalize a) (normalize b)
normalize (FSum (a) (FNeg b)) = FSub (normalize a) (normalize b)
normalize (FSub (a) (FNeg b)) = FSum (normalize a) (normalize b)
normalize (FSub (FNeg a) b) = FNeg $ FSum (normalize a) (normalize b)
normalize (FSum (FNeg a) b) = FNeg $ FSub (normalize a) (normalize b)
normalize (FNeg (FNeg a)) = normalize a

normalize (FSub a (FSub b c)) = FSum (FSub (normalize a) (normalize b)) (normalize c)
normalize (FSum a (FSum b c)) = FSum (FSum (normalize a) (normalize b)) (normalize c)
normalize (FSum a (FSub b c)) = FSub (FSum (normalize a) (normalize b)) (normalize c)
normalize (FSub a (FSum b c)) = FSub (FSub (normalize a) (normalize b)) (normalize c)
normalize (FMul a (FMul b c)) = FMul (FMul (normalize a) (normalize b)) (normalize c)
-- это преобразование не делаем, т.к. оно не работает например для 2, 8, 4: 
--  2 / (8 / 4) = 1, 
--  но 2 / 8 * 4 нельзя посчитать в рамках правил игры
-- normalize (FDiv a (FDiv b c)) = FMul (FDiv (normalize a) (normalize b)) (normalize c)
normalize (FMul a (FDiv b c)) = FDiv (FMul (normalize a) (normalize b)) (normalize c)
normalize (FDiv a (FMul b c)) = FDiv (FDiv (normalize a) (normalize b)) (normalize c)

normalize (FSum a b) = FSum (normalize a) (normalize b)
normalize (FMul a b) = FMul (normalize a) (normalize b)
normalize (FSub a b) = FSub (normalize a) (normalize b)
normalize (FDiv a b) = FDiv (normalize a) (normalize b)
normalize (FNeg a) = FNeg (normalize a)

Функция генерации деревьев:

makeTrees' :: String -> String -> [FElement]
makeTrees' as [] = [FNumber as, FNeg $ FNumber as]
makeTrees' (as) bb@(b:bs) = trees ++ (makeTrees' (as ++ [b]) bs)
	where
	trees = (concatMap addOp [FSum, FSub, FMul, FDiv])
	addOp op = [op a b | a <- makeTrees as, b <- makeTrees bb]

makeTrees :: String -> [FElement]
makeTrees [] = []
makeTrees [a, b] = t ++ (map FNeg t)
	where
	t = (FNumber [a, b]) : (map (\con -> con (FNumber [a]) (FNumber [b])) [FSum, FSub, FMul, FDiv])
makeTrees (f:fs) = makeTrees' [f] fs

Поскольку функция нормализации иногда не выдаёт сразу конечный результат, вот функция, применяющая операцию нормализации к формуле до тех пор, пока дерево не перестаёт изменяться:

normalizeFully :: FElement -> FElement
normalizeFully a = let b = normalize a in if a == b then a else normalizeFully b

Теперь функция применения выражения к билетику. Билет будет представляться в виде кортежа из шести целых чисел, результат функции — типа Maybe, чтобы отразить невозможность придержаться правил игры (деление не должно давать остатка) и арифметики (на ноль не делим) при вычислении значения выражения.

applyFormula :: (Int, Int, Int, Int, Int, Int) -> FElement -> Maybe Int
applyFormula params (FNeg a) = do
	num <- applyFormula params a
	if num == 0 then Nothing else Just $ negate num
applyFormula params (FMul a b) = liftM2 (*) (applyFormula params a) (applyFormula params b)
applyFormula params (FSum a b) = liftM2 (+) (applyFormula params a) (applyFormula params b)
applyFormula params (FSub a b) = liftM2 (-) (applyFormula params a) (applyFormula params b)
applyFormula params (FDiv a b) = do
	ar <- (applyFormula params a)
	br <- (applyFormula params b)
	(d, m) <- if br == 0 then Nothing else Just (divMod ar br)
	if m == 0 then Just d else Nothing
applyFormula params (FNumber str) = Just (toNumber' 0 params str)
	where
	toNumber' _ params [] = 0
	toNumber' p params [x] = p * 10 + (toNumber'' params x)
	toNumber' p params (x:xs) = let np = p * 10 + (toNumber'' params x) in (toNumber' np params xs)
	toNumber'' (a, _, _, _, _, _) 'a' = a
	toNumber'' (_, b, _, _, _, _) 'b' = b
	toNumber'' (_, _, c, _, _, _) 'c' = c
	toNumber'' (_, _, _, d, _, _) 'd' = d
	toNumber'' (_, _, _, _, e, _) 'e' = e
	toNumber'' (_, _, _, _, _, f) 'f' = f

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

uniqueFunctions = Set.toList $ Set.fromList $ map normalizeFully $ makeTrees "abcdef"

Загрузив модуль в ghci, можно узнать ответ на вопрос, сколько существует различных формул:

$ ghci Formulae.hs
Prelude Formulae> length uniqueFunctions
51920

Итак, у нас миллион билетов и 51920 всевозможных формул. Ответы на остальные вопросы ждите скоро во второй части исследования.