Создайте деревья выражений из заданных наборов чисел и операций и найдите те, которые соответствуют целевому числу в Mathematica 8 или выше

Question

Учитывая набор чисел и набор двоичных операций, какой самый быстрый способ создания деревьев случайных выражений или исчерпывающей проверки каждой возможной комбинации в Mathematica?

Дается то, что я пытаюсь решить:

numbers={25,50,75,100,3,6}              (* each can ONLY be used ONCE  *)
operators={Plus,Subtract,Times,Divide}  (* each can be used repeatedly *)
target=99

найти деревья выражений, которые будут оценены для цели.

У меня есть два решения, характеристики которых я даю для случая, когда деревья выражений содержат ровно 4 числа и 3 оператора:

1. случайная выборка и выбор: ~ 25 тыс. Деревьев в секунду
2. полное сканирование: 806400 деревьев за ~ 2,15 секунды

(рассчитано на ноутбуке с: Intel (R)) Core (TM) 2 Duo CPU T9300 @ 2,50 ГГц, 3 ГБ ОЗУ, распараллеливание еще не использовалось, но было бы весьма кстати в ответах)

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

Самый большой возможный случай - это когда каждое дерево выражений использует все (6) чисел и длину[числа] -1 '(5) операторов.

Производительность методов в наибольшем случае:

1. случайная выборка и выбор: ~ 21K деревьев / сек
2. исчерпывающее сканирование: 23224320 деревьев за ~ 100 секунд

Также я использую Mathematica 8.0.1, поэтому я больше, чем все уши, если есть какие-либо способы сделать это в OpenCL или использовать скомпилированные функции с CompilationTarget-> "C" и т. Д.

Answer 1

Это был забавный вопрос. Вот мое полное решение:

ExprEval[nums_, ops_] := Fold[
  #2[[1]][#1, #2[[2]]] &,
  First@nums,
  Transpose[{ops, Rest@nums}]]

SymbolicEval[nums_, ops_] := ExprEval[nums, ToString /@ ops]

GetExpression[nums_, ops_, target_] := Select[
  Tuples[ops, Length@nums - 1],
  (target == ExprEval[nums, #]) &]

Пример использования:

nums = {-1, 1, 2, 3};
ops = {Plus, Subtract, Times, Divide};
solutions = GetExpression[nums, ops, 3]

ExprEval[nums, #] & /@ solutions
SymbolicEval[nums, #] & /@ solutions

Выходы:

{{Plus, Times, Plus}, {Plus, Divide, Plus}, {Subtract, Plus, 
  Plus}, {Times, Plus, Times}, {Divide, Plus, Times}}

{3, 3, 3, 3, 3}

{"Plus"["Times"["Plus"[-1, 1], 2], 3], 
 "Plus"["Divide"["Plus"[-1, 1], 2], 3], 
 "Plus"["Plus"["Subtract"[-1, 1], 2], 3], 
 "Times"["Plus"["Times"[-1, 1], 2], 3], 
 "Times"["Plus"["Divide"[-1, 1], 2], 3]}

---

Как это работает

Функция ExprEval принимает числа и операции и применяет их, используя (я думаю) RPN:

ExprEval[{1, 2, 3}, {Plus, Times}] == (1 + 2) * 3

Это осуществляется путем непрерывного сложения пар чисел с использованием соответствующей операции.

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

Как только вы получите все возможные операции, я использовал Select, чтобы выбрать те, которые соответствуют целевому числу.

---

Недостатки

Решение выше - действительно медленно. Генерация всех возможных кортежей экспоненциальна во времени. Если есть k операций и n чисел, это порядка O (k ^ n).

Для n = 10 на Win 7 x64, Core i7 860, 12 ГБ ОЗУ потребовалось 6 секунд. Сроки запусков почти точно соответствуют теоретической сложности времени:

Красная линия - теоретическая, синяя - экспериментальная. Ось X - это размер ввода чисел, а ось Y - время в секундах для перечисления всех решений.

Приведенное выше решение также решает проблему с использованием стиля функционального программирования. Это выглядит красиво, но эта штука также поглощает массу памяти, так как она сохраняет полные результаты практически на каждом этапе.

Он даже не использует распараллеливание, и я не совсем уверен, как вы распараллелите решение, которое я создал.

---

Некоторые ограничения

г. Мастер обратил мое внимание на то, что этот код решает только для определенного набора решений. Учитывая некоторый ввод, такой как {a, b, c, d, e, ... }, он только переставляет операторы между числами. Это не переставляет порядок чисел. Если бы он также переставлял числа, сложность времени возрастала бы до O(k^n * n!), где k - количество операторов, а n - длина массива входных чисел.

Следующее создаст множество решений для любой перестановки входных чисел и операторов:

(* generates a lists of the form 
{
 {number permutation, {{op order 1}, {op order 2}, ... }
 }, ...
}*)

GetAllExpressions[nums_, ops_, target_] :=
 ParallelMap[{#, GetExpression[#, ops, target]} &, 
  Tuples[nums, Length@nums]]

Answer 2

ОК, это не элегантно и не быстро, и глючит, но работает (иногда).Он использует метод monte carlo , реализующий алгоритм метрополиса для весовой функции, которую я (произвольно) выбрал, просто чтобы посмотреть, сработает ли это.Это было некоторое время назад для аналогичной проблемы;Я полагаю, что мои навыки по математике улучшились, поскольку теперь это выглядит ужасно, но у меня нет времени, чтобы исправить это в данный момент.

Выполните это (это выглядит более разумно, когда вы вставляете его в блокнот):

ClearAll[swap];
swap[lst_, {p1_, p2_}] := 
 ReplacePart[
  lst, {p1 \[Rule] lst\[LeftDoubleBracket]p2\[RightDoubleBracket], 
   p2 \[Rule] lst\[LeftDoubleBracket]p1\[RightDoubleBracket]}]

ClearAll[evalops];
(*first element of opslst is Identity*)

evalops[opslst_, ord_, nums_] := 
 Module[{curval}, curval = First@nums;
  Do[curval = 
    opslst\[LeftDoubleBracket]p\[RightDoubleBracket][curval, 
     nums\[LeftDoubleBracket]ord\[LeftDoubleBracket]p\
\[RightDoubleBracket]\[RightDoubleBracket]], {p, 2, Length@nums}];
  curval]

ClearAll[randomizeOrder];
randomizeOrder[ordlst_] := 
 swap[ordlst, RandomInteger[{1, Length@ordlst}, 2]]

ClearAll[randomizeOps];
(*never touch the first element*)

randomizeOps[oplst_, allowedOps_] := 
 ReplacePart[
  oplst, {RandomInteger[{2, Length@oplst}] \[Rule] RandomChoice[ops]}]

ClearAll[takeMCstep];
takeMCstep[goal_, opslst_, ord_, nums_, allowedops_] := 
 Module[{curres, newres, newops, neword, p}, 
  curres = evalops[opslst, ord, nums];
  newops = randomizeOps[opslst, allowedops];
  neword = randomizeOrder[ord];
  newres = evalops[newops, neword, nums];
  Switch[Abs[newres - goal], 
   0, {newops, 
    neword}, _, (p = Abs[curres - goal]/Abs[newres - goal];
    If[RandomReal[] < p, {newops, neword}, {opslst, ord}])]]

затем, чтобы решить вашу реальную проблему, выполните

ops = {Times, Plus, Subtract, Divide}
nums = {25, 50, 75, 100, 3, 6}
ord = Range[Length@nums]
(*the first element is identity to simplify the logic later*)
oplist = {Identity}~Join~RandomChoice[ops, Length@nums - 1]
out = NestList[
  takeMCstep[
    99, #\[LeftDoubleBracket]1\[RightDoubleBracket], #\
\[LeftDoubleBracket]2\[RightDoubleBracket], nums, ops] &, {oplist, 
   ord}, 10000]

, а затем убедитесь, что она работает,

ev = Map[evalops[#\[LeftDoubleBracket]1\[RightDoubleBracket], #\
\[LeftDoubleBracket]2\[RightDoubleBracket], nums] &, out];
ev // Last // N
ev // ListPlot[#, PlotMarkers \[Rule] None] &

, что дает

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

Как я уже сказал, это уродливо, неэффективно и плохо запрограммировано, поскольку это была быстрая и грязная адаптациябыстрого и грязного взлома.Если вам интересно, я могу привести в порядок и объяснить код.