Question

Given a set of numbers and a set of binary operations,
what is the fastest way to create random expression trees or exhaustively check every possible combination in Mathematica?

What I am trying to solve is given:

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

find expression trees that would evaluate to target.

I have two solutions whose performances I give for the case where expression trees contain exactly 4 of the numbers and 3 operators:

1. random sample & choice: ~25K trees / second
2. exhaustive scan: 806400 trees in ~2.15 seconds

(timed on a laptop with: Intel(R) Core(TM)2 Duo CPU T9300 @ 2.50GHz, 3GB ram, no parallelization used yet but would be most welcome in answers)

My notebooks are a bit messy at the moment. So I would first love to pose the question and hope for original ideas and answers while I clean up my code for sharing.

Largest possible case is where every expression tree uses up all the (6) numbers and ‘Length[numbers]-1’ (5) operators.

Performance of methods in the largest case is:

1. random sample & choice: ~21K trees / second
2. exhaustive scan: 23224320 trees in ~100 seconds

Also I am using Mathematica 8.0.1 so I am more than all ears if there are any ways to do it in OpenCL or using compiled functions wiht CompilationTarget->”C”, etc.

Answer 1

OK, this is not elegant or fast, and it’s buggy, but it works (sometimes). It uses a monte carlo method, implementing the metropolis algorithm for a weight function that I (arbitrarily) selected just to see if this would work. This was some time ago for a similar problem; I suppose my mathematica skills have improved as it looks ugly now, but I have no time to fix it at the moment.

Execute this (it looks more reasonable when you paste it into a notebook):

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}])]]

then to solve your actual problem, do

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]

and then to see that it worked,

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

giving

thus, it obtained the correct order of operators and numbers after around 2000 tries.

As I said, it’s ugly, inefficient, and badly programmed as it was a quick-and-dirty adaptation of a quick-and-dirty hack. If you’re interested I can clean up and explain the code.