Insert $+$, $-$, $\times$, $/$, $($, $)$ into $123456789$ to make it equal to $100$

Question

Insert $+$, $-$, $\times$, $/$, $($, $)$ into $123456789$ to make it equal to $100$.

Looks like a question for pupils, right?

In fact, if the available math symbols are limited to addition ($+$), subtraction ($-$), multiplication ($\times$), and division ($/$), then it's easy to solve:

Select[Tuples[{"+", "-", "*", "/", ""}, 8], 
       ToExpression[Flatten@Table[{ToString@i, #[[i]]}, {i, 1, 8}] <> "9==100"] &]

But when parentheses (that is, $($ and $)$) join in, it is totally different. After thinking about it for two days, I should admit that solving it with Mathematica is temporarily beyond my reach. Any ideas?

---

Since @wxffles mentioned that the number of possible solutions may be too large, I'd like to add a similar example which would have fewer solutions (I think…).

Filling the blanks with $+$, $-$, $\times$, $/$, $($, $)$ in the following expression (Of course there's no limit for the number of symbols in every blank, it can be 0, 1, 2, 3…):

$(34口5口6口8口9口1)口2=2008$

Answer 1

In a sense described below, this answer finds $422716$ distinct solutions.

The innovations presented here are

1. using postfix operators to eliminate problems with parentheses;

2. avoiding having to deal with unary negation;

3. initially computing "too many" solutions, some of which make no sense, and eliminating them at the end (rather than writing more complicated code to prevent them in the first place); and

4. casting the problem as one of "matching" certain "patterns" to tuples of operations, thereby enabling more sparing use of RAM.

---

Strategy

Let's sneak up on the result in controlled steps.

Dealing with unary operations

The problem as stated has infinitely many solutions, because one can go around sticking pairs of unary minuses in all over the place. Some rules need to be imposed to prevent this.

I will presently show that a unary minus will never be needed in a calculation if we supplement the five original operations (plus, subtract, time, divide, and base-10 concatenation of digits) with an "anti-subtraction" which subtracts its first argument from its second. It will be nice to display this operation cleanly. I find a simple way to do so is to use a (suggestively shaped) unassigned symbol (with appropriate operator precedence) for the definition, such as "$\leftarrow$", thus:

LeftTeeArrow[x_, y_] := -x + y;

While we're at it, one way to define the concatenation of two base-10 digits is

AngleBracket[t_Integer, u_Integer] := 10 t + u;

Concatenation of multiple digits is performed by repetition, bearing in mind that this operation is not associative. E.g., $\langle \langle 1,2\rangle, 3\rangle = 123$ but $\langle 1, \langle 2, 3 \rangle \rangle = 33$. We want the former, not the latter. Another problem is that this definition applies to circumstances in which concatenation would not make sense; e.g., $\langle \frac{1}{2}, 3\rangle = 8$. When the time comes we will need to rule out such invalid constructs.

We can't entirely do without unary minus, but we can control its application. I contend that if a unary minus is needed in a solution, then it can always be applied last. To see this, simply note that if a unary minus is applied before any of the binary operators, it can be moved after them. To check, we have to examine the possibilities of negating both arguments:

1. $a + (-b) = a-b$, $a - (-b) = a + b$, $a(-b) = -(ab)$, and $a/(-b) = -(a/b)$.

2. $(-a) + b = a \leftarrow b$, $(-a) - b = -(a + b)$, $(-a)b = -(ab)$, and $(-a)/b = -(a/b)$.

(Concatenation is irrelevant, because in the end we will allow it to apply only to digits, not to the results of any arithmetical operations.) From (2) it is now apparent why anti-subtraction is needed as one of the binary operations, and it is also apparent that its replacement by a negation and an addition will convert any solution involving antisubtraction into a solution involving only the original five binary operations.

We pay a price: in addition to finding ways to represent $+100$, we also need to find ways to represent $-100$ (and then negate them all at the end). But that's simple enough to do.

This use of antisubtraction in place of unary minus, and the convention of pushing all "inessential" applications of Minus to the end, determines what it means for two solutions to be the "same" or "different."

Parentheses

Parentheses are needed to disambiguate infix notation, but not prefix or postfix notation. For instance, the expression "$1 + 2 \times 3 - 4$" is ambiguous without parentheses (or applying precedence rules), but any postfix version of the same, such as $1 2 \text{+} 3 4 \text{-} \times = (1+2) \times (3-4)$ is unambiguous and needs no precedence rules. It is attractive to use a postfix notation because it eliminates having to cope with parentheses or operator precedence and it emulates how the problem would be solved on a hand calculator, which is easily visualized and explained.

Reducing RAM usage

A solution can be developed in two clearly distinct steps:

1. Choose a "pattern" of calculator keypresses. A pattern specifies which numbers are entered and where binary operations are entered, without stipulating which operations are involved. For instance, the pattern for the calculation $1 2 \text{+} 3 4 \text{-} \times$ might informally be written $(1,2,\#,3,4,\#,\#)$ where "$\#$" (a "slot") represents some (as yet unspecified) binary operator.

2. Fill the pattern in with all possible instances of binary operators. When a pattern has $k$ slots and $m$ operators are available, there will be $m^k$ ways to do this. (We worry later about which of those $m^k$ ways actually make sense.)

Although the problem admits only $2^{9+9-1} \vert\binom{1/2}{9}\vert = 1430$ such patterns, each needs to be filled in with $6^{9-1} \approx 1.7$ million operator sequences (easily created with Tuples). (This exponential growth based on the number, $6$, of binary operations is a strong inducement to limit the number of permissible operations!) What we shall do, then, is find all solutions for each specific pattern at a time. Rather than generating all $1430 \times 6^8 \approx 2.4$ billion combinations (which will be hard to fit in RAM on most machines), we only have to generate and work with $6^8$ operator patterns at a time. But because each such check involves such a large number of operator patterns, it will benefit from the usual functional programming constructs. In other words, explicitly looping over all patterns will barely slow things down, if at all.

Development of a Solution

As promised, we move in small steps, first generating too many "solutions" in manageable steps and then cleaning them up (by eliminating invalid ones) and prettifying them for display.

Framing

Let's begin with how the problem is framed. Above, we created the operations for concatenation (AngleBracket) and anti-subtraction (LeftTeeArrow). Let's collect them once and for all into a list of allowable binary operations:

ops = {Plus, Subtract, Times, Divide, AngleBracket, LeftTeeArrow};

Generating all possible patterns

The calculator works with a stack: each input of a number places it on the stack and each press of a binary operation button pops the stack twice and pushes the result. A valid pattern is one that never empties the stack. To test this, we can track the stack size as the calculation is executed: it increases by $1$ for each number and decreases by $1$ for each binary operation. So, let's just replace the numbers in a pattern by $1$ (or any positive constant $u$) and the slots by $-1$ (or $-u$) and check that the partial sums never drop to zero or below and end up at $1$. This last requirement implies there must be one less operation than there are numbers and that the first element of the pattern must be a number. This solution to create all patterns for some list of digits (like $\{1,2,3,4,5,6,7,8,9\}$) uses all these ideas; it executes quickly:

patterns[digits_] := 
  Module[{n = Length[digits], u = 2 Max[digits] + 1, places, evaluate}, 
   evaluate[n_List, m_Integer] := Append[n, m];
   evaluate[{n___, a_, b_}, op_] := {n, op[a, b]};
   places = Select[Permutations[ConstantArray[u, n - 1]~Join~ConstantArray[-u, n - 1]], 
     Min[Accumulate[#]] >= 0 &];
   Flatten[Function[{x}, Block[{i = 0, j = 1}, Fold[evaluate, {}, 
        Prepend[x, First[digits]] /. {u :>  digits[[++j]] , -u :> Slot[++i]} ]]] /@ places]
   ];

(The reason for using a number $u$ instead of $-1$ for the computation is that the substitutions work correctly provided $u$ is not among the entries in digits.)

As an example:

patterns[Range[4]] // TableForm

$\begin{array}{l} \text{$\#$3}[1,\text{$\#$2}[2,\text{$\#$1}[3,4]]] \\ \text{$\#$3}[1,\text{$\#$2}[\text{$\#$1}[2,3],4]] \\ \text{$\#$3}[\text{$\#$2}[1,\text{$\#$1}[2,3]],4] \\ \text{$\#$3}[\text{$\#$1}[1,2],\text{$\#$2}[3,4]] \\ \text{$\#$3}[\text{$\#$2}[\text{$\#$1}[1,2],3],4] \end{array}$

Let's find out how many patterns we're going to have to deal with:

Length[patterns[Range[9]]]

$1430$

Matching patterns with sequences of operations

Because the output of patterns uses Mathematica's Slot formalism, it is easy to turn it into something that can be "evaluated" against a list of operations. As an example, look at the first pattern constructed from four digits:

Evaluate[First[patterns[Range[4]]]] &

$\text{$\#$3}[1,\text{$\#$2}[2,\text{$\#$1}[3,4]]]\&$

This is all ready to be applied to tuples of operations, like this:

Evaluate[First[patterns[Range[4]]]] & @@@ Tuples[ops, 3]

$\{10,-8,9,\frac{1}{9},19,8,-4,6 \ldots$

For instance, the first tuple is $(+,+,+)$ which, when inserted into the first pattern $\text{$\#$3}[1,\text{$\#$2}[2,\text{$\#$1}[3,4]]]$, yields $\text{Plus}[1, \text{Plus}[2, \text{Plus}[3,4]]] = 1+2+3+4 = 10$.

Let's encapsulate this in a function that evaluates a single pattern against a list of operator tuples and selects those equal to a target number:

find[opsStrings_, pattern_, target_] := 
   Select[opsStrings, Function[{x}, Evaluate[pattern] & @@ x == target]];

This single line of code is the heart of the solution: having constructed all possible patterns and all possible tuples of operations to slot into them, we just have to apply each pattern to each tuple and check the resulting value.

We're practically done, but let's pause for some niceties before proceeding to the solution itself. At some point we will need to eliminate "solutions" in which concatenation is applied to the results of operations rather than to raw numbers themselves. These can be detected and ruled out with some pattern matching:

acceptableQ[x_] := Length[Cases[x, AngleBracket[_, Except[_Integer]] | 
   AngleBracket[Except[_Integer], _], -1]] == 0

(NB: This is not quite right, because it rules out multiple concatenations. But it is what I used to obtain the solution counts reported below.)

It won't be good enough just to select sequences of operations to fill into a pattern: we will want to display the pattern as filled in by those operations:

display[pattern_, ops_] := HoldForm[pattern] & @@@ ops;
display[pattern_, {}] := Sequence[];

HoldForm (or Hold or Unevaluated) is essential to keep the filled-in pattern from being evaluated.

The intention is to apply display to the results of find:

match[opsStrings_, pattern_, target_] := 
   With[{m = find[opsStrings, pattern, target]}, display[pattern, m]];

The Solution

Using match, we can apply all patterns to all tuples of operations, then weed out the unacceptable ones. We will need to do this both for a target of $100$ and a target of $-100$, so we might as well extent the solution to search for multiple targets:

solve[n_Integer, target_?NumericQ] := 
  Select[Flatten[match[Tuples[ops, n - 1], #, target] & /@  (patterns[Range[n]])] , acceptableQ];
solve[n_Integer, target_List] := Flatten[Map[solve[n, #] & , target]];

---

Examples

We test with smaller versions of the problem. Noticing that $100=(9+1)^2$, I ask for the ways of using the digits $1, 2, \ldots, n$ to form $(n+1)^2$. The smallest $n$ for which there are solutions is $n=4$:

With[{n = 4, target = 25}, AbsoluteTiming[solutions = solve[n, {target, -target}];]]

$\{0.0156000,\text{Null}\}$

Here is a nice display of the solutions along with a check to verify they really are solutions:

TableForm[{#, ReleaseHold[#]} & /@ solutions, TableHeadings -> {{}, {"Expression", "Value"}}]

$\begin{array}{l|ll} & \text{Expression} & \text{Value} \\ \hline & 1+2 (3\ 4) & 25 \\ & 1+(2\ 3) 4 & 25 \end{array}$

It is wonderful to see how Mathematica has automatically handled the parentheses!

Look at the case $n=5$: the output is

$\begin{array}{l|ll} & \text{Expression} & \text{Value} \\ \hline & 1\leftarrow 2+(3+4) 5 & 36 \\ & 1\leftarrow (2\leftarrow \langle 3,4\rangle +5) & 36 \\ & 1\leftarrow (2-\langle 3,4\rangle \leftarrow 5) & 36 \\ & 1\leftarrow (2\leftarrow \langle 3,4\rangle )+5 & 36 \\ & 1+(2-\langle 3,4\rangle )\leftarrow 5 & 36 \\ \cdots \\ & (\langle 1,2\rangle -3)-\langle 4,5\rangle & -36 \\ & (\langle 1,2\rangle 3) (4-5) & -36 \\ & \frac{\langle 1,2\rangle 3}{4-5} & -36 \end{array}$

(I haven't bothered to insert the necessary unary minus in the expressions yielding $-36$.) In case my notation looks too strange, these solutions are $-1 + 2 + (3+4)\times 5$, $-1 + (-2 + 34 + 5)$, $-1 + -(2 - 34) + 5))$, $-1 + (-2 + 34) + 5$, $\ldots$, $-(12 - 3 - 45)$, $-(12\times 3\times(4-5))$, and $-(12\times 3) / (4-5)$.

A solution

Finally,

With[{n = 9, target = 100}, AbsoluteTiming[solutions1 = solve[n, target];]]
With[{n = 9, target = 100}, Timing[solutions2 = solve[n, -target];]]

produces $246086 + 176630 = 422716$ distinct solutions in $11.5$ hours (with a single kernel committing no more than 1.25 GB RAM). Of these, $214357$ do not use concatenation (and so employ only the four basic arithmetic binary operations along with unary minus).

Here is a random selection of $10$ of each kind of solution (slightly cleaned up for presentation):

$$\begin{array} (2 ((3-4)-(5\leftarrow 6))\leftarrow 7)+89 \\ \frac{(1-2\times 3) (4\times 5)}{6-7} (8\leftarrow 9) \\ 1 ((23\leftarrow 4)-5\leftarrow (6\leftarrow (7\leftarrow 89))) \\ (1+2\times 3)-(4-(5-6)) 7\leftarrow 8\times 9 \\ 1\times 2+(((3-4)+5)-(6+7)\leftarrow 89) \\ (1-((((2\leftarrow 3-4)\leftarrow 5)+6) 7\leftarrow 8))+9 \\ 1+(2+(((3\leftarrow 45)\leftarrow 67)+8\times 9)) \\ 1-\frac{23\leftarrow 4+5\times 6}{\frac{7-8}{9}} \\ 1 (2-3)+(4-((5-6)-(7+89))) \\ (1+(2 (3-4\leftarrow 56-7)+8))-9 \\ -\left((1\leftarrow (2\leftarrow (3\leftarrow 4))) \left(5 \frac{6 (7+8)}{9}\right)\right) \\ -(1\leftarrow (2-(3\times 4) 5)+(6\times 7+8\leftarrow 9)) \\ -(1+(2+(3\leftarrow 4 (5-((6+(7+8))+9))))) \\ -(((((1\leftarrow 2)+3\times 4)+5) 6\leftarrow 7)+(8\leftarrow 9)) \\ -\left(\left(\left(\left(1+\frac{2}{3}\right)-4\times 5\right) 6-(7-8)\right)+9\right) \\ -\left(\left((1-2)-\left(3+((4\times 5) 6) \frac{7}{8}\right)\right)+9\right) \\ -(1+(((2\leftarrow (3+4\times 5\leftarrow 6))+7)-89)) \\ -\left(\left(\frac{1+((2\leftarrow 3)\leftarrow 4)}{5-6}-7\right)-89\right) \\ -(((1+(2\leftarrow 3) 4\leftarrow (5\leftarrow 6))-7)-89) \\ -\left(\left(1-\frac{2}{\frac{\frac{3\times 4}{5}}{6}}\right)-(7+89)\right) \end{array}$$

---

The Second Question

With these tools in hand, let's solve the second part of the question. It imposes a particular form on the patterns, which can be constructed thus:

patterns2 = Slot[6][#, 2] & /@ patterns[{34, 5, 6, 8, 9, 1}]

Within a few seconds, $85$ solutions emerge:

solution2008 = Select[Flatten[match[Tuples[ops, 6], #, 2008] & /@ patterns2], acceptableQ];
solution2008m = Select[Flatten[match[Tuples[ops, 6], #, -2008] & /@ patterns2], acceptableQ];
TableForm[{#, ReleaseHold[#]} & /@ (solution2008~Join~solution2008m), 
   TableHeadings -> {{}, {"Expression", "Value"}}]

$\begin{array}{lll} & \text{Expression} & \text{Value} \\ \hline & 34 \left(5-\frac{6}{\frac{8}{9}-1}\right)+2 & 2008 \\ & 34 \left(5\leftarrow \frac{6}{\frac{8}{9}-1}\right)\leftarrow 2 & 2008 \\ ...\\ & (((34\times 5) 6\leftarrow 8)-(9\leftarrow 1)) 2 & -2008 \\ & (((34\times 5) 6-8\leftarrow 9)-1) 2 & -2008 \\ & ((((34\times 5) 6\leftarrow 8)+9)-1) 2 & -2008 \end{array}$

---

Timing

For the problem itself, with $n=9$, checking a single one of the $1430$ patterns takes about $15$ seconds. (In C or some other compiled language this should go several orders of magnitude faster when coded well.) This has to be done twice over, remember: once for $100$ and again for $-100$. That's why it takes $11.5$ hours. That's a rate of $10$ solutions per second, so if you only want to find some solutions, it's fast enough.

My efforts to use ParallelMap in place of Map (aka /@) in solve or find are to no avail: only one processor is used at a time, so the calculation takes the same length of time, yet only about 5% of the solutions are actually returned. I don't know why such erroneous behavior occurs.

Comments

You need not stop here: these solutions now can rapidly be filtered by additional criteria: how many of them use all four arithmetic operators? How many require concatenation? Etc. You can introduce more rules for rewriting the solutions, let Mathematica normalize the solutions (by applying Simplify), and count the unique expression that remain (via Union). So, if my conventions for what makes a solution unique do not match yours, you likely still can still post-process these results to find what you want.

It is also fun to apply these tools to related problems, such as finding how to represent integers using four fours. (Can you find a way to represent $11$?)

In solving the four fours problem I realized I have not coded acceptableQ as intended: by forcing both arguments of AngleBracket to be integral, it rules out concatenations of three or more digits. Fixing that might create a few more solutions.

Answer 2

EDIT: As @Rojo points out in the comments, my code doesn't really find all solutions. For example, a term of the form a * (b * c + d) can't be represented with "precedence plus/minus" operators. I'm not sure if it is salvageable, but as it is, the code below does not find all solutions.

A very simple solution would be to define two new operators $\oplus$ and $\ominus$ that work like plus and minus, but have higher precedence than multiplication and division. Then we can again use a simple algorithm that inserts all combinations of operators (without parenthesis) and evaluates the result. Only problem is, Mathematica doesn't know these new operators, so I had to write my own quick&dirty "operator sequence parser". (I have no idea how you would write an efficient parser in Mathematica, so I'm sure this can be improved.)

So we have 7 operators ("concat digits", "plus with precedence", "minus with precedence", multiplication, division, ordinary plus and minus). In order of precedence:

operatorFunctions = {#1*10 + #2 &, Plus, Subtract, Times, Divide, Plus, Subtract};

(not that I can use #1*10 + #2 & because I know evaluation is done left to right, so the #2 will always be a single digit.)

There are 5764801 ways to combine these operators:

allCombinations = Tuples[Range[Length[operatorFunctions]], 8];

Now I need a function that takes an array of digits and an array of operators and evaluates them with these precedences:

(*evaluate operator at index operatorIndex and return the evaluated digit/operator sequence*)
applyOperator[{digits_, operators_}, operatorIndex_, 
  operatorFunctions_] :=
 Module[{newDigits = digits},
  (
   newDigits[[operatorIndex]] = 
    operatorFunctions[[operators[[operatorIndex]]]] @@ 
     digits[[operatorIndex ;; operatorIndex + 1]];
   {
    Delete[newDigits, operatorIndex + 1],
    Delete[operators, operatorIndex]
    }
   )]

(*apply the operator with highest precedence*)
applyHighestPrecedence[{digits_, operators_}, operatorFunctions_] := 
 applyOperator[{digits, operators}, Ordering[operators][[1]], 
  operatorFunctions]

(*apply all operators in order of precedence*)
applyAllOperators[{digits_, operators_}, operatorFunctions_] := 
 Nest[applyHighestPrecedence[#, operatorFunctions] &, {digits, 
    operators}, Length[operators]][[1, 1]]

(*calculate the results for all 5.8 million \
combinations*)AbsoluteTiming[
 allResults = 
   ParallelMap[applyAllOperators[{Range[9], #}, operatorFunctions] &, 
    allCombinations];]

This takes 243s on my PC.

Now we can just use Position[allResults, 100] to get the combinations that evaluate to 100. Formatting the operator sequences with parenthesis can be done using the same functions:

results100 = Position[allResults, 100][[All, 1]];

stringOperatorFunctions = {StringJoin, 
   StringJoin["(", #1, "+", #2, ")"] &, 
   StringJoin["(", #1, "-", #2, ")"] &, Times, Divide, Plus, Subtract};

applyAllOperators[{Characters["123456789"], 
  allCombinations[[results100[[1]]]]}, stringOperatorFunctions]

=> (1234+5) - 67 (8+9)

In total, I get Length[results100] -> 1999 results. However, this will contain duplicates. For example, $3\oplus4+5$ and $3+4+5$ are actually the same operation, but counted as two different operator combinations.

EDIT: I think there's a bug in the code above, but it should be easy to fix. For example, the term a/(b/(c/d)) can't be represented by the code above. But the term is equivalent to a/b*c/d, if multiplication and division have the same precedence and evaluation is done left to right. This should be possible for any fraction, no matter how deep the parenthesis is nested, because every term either goes in the numerator or in the denominator (except the first one, which is always in the numerator). If terms in the numerator are prefixed with * and terms in the denominator are prefixed with / you get an equivalent expression with the same order of terms but without parenthesis. (The same applies to + and -)

To fix this, all you have to do is declare a precedence for each operator:

operatorFunctions = {#1*10 + #2 &, Plus, Subtract, Times, Divide, Plus, Subtract};
operatorPrecedence = {1, 2, 2, 3, 3, 4, 4};

and use that precedence for the operation order:

(*apply the operator with highest precedence*)
applyHighestPrecedence[{digits_, operators_}, operatorFunctions_] := 
 applyOperator[{digits, operators}, Ordering[operatorPrecedence[[operators]]][[1]], 
  operatorFunctions]

Answer 3

Here's a possibility

next`ops = HoldForm /@ {Plus, Times, Divide, Subtract};
(nextOp[#1] = #2) & @@@ Most@Transpose@{next`ops, RotateLeft@next`ops};
next`children = True;
SetAttributes[{next`Plus, next`Times}, Flat];
next[{i_}] := False;
next[l_List] := HoldForm[Plus][{l[[1]]}, l[[2 ;;]]];
next[op_[arg1_, arg2_]] /; next`children := 
  With[{res = next[arg1]}, op[res, arg2] /; res =!= False];
next[op_[arg1_, arg2_]] /; next`children := 
  With[{res = next[arg2]}, op[arg1, res] /; res =!= False];
next[HoldForm[Subtract][arg1_, arg2 : {_}]] := False;
next[op_[arg1_, arg2_]] := 
  Block[{next`children = False}, next[op[flatten@arg1, flatten@arg2]]];
next[op_[arg1_List, {arg2_}]] := 
  nextOp[op][{arg1[[1]]}, arg1[[2 ;;]]~Append~arg2];
next[op_[arg1_List, arg2_List]] := 
  op[arg1~Append~First@arg2, Rest@arg2];
flatten[exp_] := Flatten@Cases[exp, {_}, {0, Infinity}]

next is a function that receives a current candidate expression of the form HoldForm[operator][...] where the ultimate integers are introduced as a list of digits, and returns the next candidate to try in the same format, or False if there are no more.

Defining

formattingRules = {i : {__Integer} :> FromDigits@i, 
   HoldForm[Plus] -> next`Plus, HoldForm[Times] -> next`Times, 
   HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] &), 
   HoldForm[Divide] -> next`Divide};

try

NestList[next, Range[9], 30] /. formattingRules // Column

To search

doMath[expr_] := 
 expr /. List -> Composition[FromDigits, List] // ReleaseHold

search[l_, target_] := 
 Module[{curr = l, tag}, 
  Reap[Quiet[
      While[curr =!= False, 
       If[doMath@curr == target, 
        PrintTemporary@Sow[curr /. formattingRules, tag]];
       curr = next@curr], Divide::infy], tag][[-1, 1]] // 
   DeleteDuplicates]

Now you do

search[Range[9], 100]

After 25 minutes I got 2145 solutions. Speed wasn't on my mind when I coded this, so surely it can be made faster. As it is, it prints temporarily the partial results, including a few duplicates due to the associative property of Plus and Times. Perphaps you want to remove that PrintTemporary behaviour or change it to an option. The final result has these duplicates removed. It also outputs the subtraction as "+ -". This can also be fixed without much work. The output cell can be evaluated to verify the results

Answer 4

Similar to whuber's answer, we can use Groupings(introduced in version 11) to simplify the generation patterns, the number of patterns is related to the CatalanNumber, and use parallel computing, which is a little faster.

LaunchKernels[];
st=AbsoluteTime[];
n=7;
sets=Range[n];
target=100;

patterns=Thread[Evaluate[HoldForm/@Block[{i=1},Groupings[sets,o->2]/.o:>
  Slot[Mod[i++,Length@sets-1,1]]]]&];

OP1[x_,y_]:=-x+y;
OP2[t_Integer,u_Integer]:=10 t+u;
op=Tuples[{Plus,Subtract,Times,Divide,OP1,OP2},Length@sets-1];

SetSharedVariable[L];
L={};
ParallelDo[Block[{expr=f@@o,val:=Quiet@ReleaseHold@expr},
If[val==target||val==-target,AppendTo[L,InputForm/@expr]]],{o,op},{f,patterns}];

Length[ans=Select[L,FreeQ[#,OP2[_,Except[_Integer]]|OP2[Except[_Integer],_],-1]&]]
AbsoluteTime[]-st

For $n=\{{6,7,8}\}$, it take about $\{{1.43,\;19.69,\;860.85}\}$ seconds.
When $n=9$, it doesn't finished for $4$ hours, still very slow, I terminate it.

I tried to convert all the patterns to C code, it's not difficult, the generated C code is more than 5,700 lines, the efficiency improvement is very obvious.

Finally, the program takes about $8$ seconds to finds $422716$ distinct solutions, same result as whuber.

Code

n=9;
gps=Block[{i=1,j=1},Groupings[Table[x,n],f->2]/.
  {f:>(F[#,Symbol["i"<>ToString@Mod[i++,n-1,1]],#2]&),x:>Symbol["n"<>ToString[Mod[j++,n,1]]]}];

gen=StringTemplate["if(check1(``)){
    sprintf(buffer, \"``\\n\", ``);
    if(check2(buffer)) printf(\"%s\", buffer);
}"][ToString@CForm@#, 
  StringReplace[ToString@#,{"F"|", "->"","["->"(","]"->")",
    "n"~~DigitCharacter:>"%d","i"~~DigitCharacter:>"%c"}],
  StringReplace[StringRiffle[#//.F[x___]:>{x}//Flatten,","],"i"->"o"]
]&/@gps//StringRiffle[#,"\n"]&;

src="#include <stdio.h>
#include <math.h>
#include <string.h>
#include <time.h>

#define NUM 100
#define N 6
#define EPS 1e-8

char ops[N] = {'+', '-', '*', '/', '#', '@'};
char buffer[128];

double F(double x, int op, double y) {
    double arr[] = {x + y, x - y, x * y, x / y, 10 * x + y, -x + y};
    return arr[op];
}

int check1(double x) {
    return fabs(x - NUM) < EPS || fabs(x + NUM) < EPS;
}

int check2(char buffer[]) {
    return (!strstr(buffer, \"#(\") && !strstr(buffer, \")#\"));
}

void calc(int a[]) {
    int len = 0;
    int n1 = a[0], n2 = a[1], n3 = a[2], n4 = a[3], n5 = a[4], n6 = a[5], n7 = a[6], n8 = a[7], n9 = a[8];
    #pragma omp parallel for reduction(+:buffer)
    for (int i1 = 0; i1 < N; i1++) {
        for (int i2 = 0; i2 < N; i2++)
            for (int i3 = 0; i3 < N; i3++)
                for (int i4 = 0; i4 < N; i4++)
                    for (int i5 = 0; i5 < N; i5++)
                        for (int i6 = 0; i6 < N; i6++)
                            for (int i7 = 0; i7 < N; i7++)
                                for (int i8 = 0; i8 < N; i8++) {
                                    char o1 = ops[i1], o2 = ops[i2], o3 = ops[i3], o4 = ops[i4], o5 = ops[i5], o6 = ops[i6], o7 = ops[i7], o8 = ops[i8];
``
                                }
    }
}

int main() {
    clock_t t0 = clock();
    freopen(\"output.txt\", \"w\", stdout);
    int a[] = {1,2,3,4,5,6,7,8,9};
    calc(a);
    printf(\"Elapsed time: %g sec\\n\", (clock() - t0) / (double) CLOCKS_PER_SEC);
    return 0;
}
";
Export["main.c",TemplateApply@StringTemplate[src,gen],"Text"]

Run["gcc -Og main.c -fopenmp"]

Run["a.exe"] // AbsoluteTiming

list=ReadList["output.txt","String"]
list // Most // Length

LeftTeeArrow[x_,y_]:=-x+y;
ans=ToExpression[StringReplace[Most@list,{"#"->"","@"->"~LeftTeeArrow~"}],InputForm,HoldForm]

ReleaseHold[ans]//Union

Answer 5

I am a bit late to the party, and with an incomplete answer. I will flesh this out if I find the time, but that is not likely for a little while.

Parentheses are a grouping operation. So, instead of using higher precedence operators, there is the potential for a lot of savings if we determine the non-overlapping partitions, first. Applying Mr. Wizard's code to the problem of combining $123$, for instance

data = Range[3];

parts = Join @@ Permutations /@ IntegerPartitions[Length@data];
results = (Internal`PartitionRagged[data, #] & /@ parts)
(* {{{1, 2, 3}}, {{1, 2}, {3}}, {{1}, {2, 3}}, {{1}, {2}, {3}}} *)

leaves us with 4 ways of uniquely grouping the numbers. This rises to 256 with data = Range[9]. But, the groupings {1}, {2}, etc. are redundant, however removing those will only reduce it to 3 (255) ways to group them. Instead, we want to reorganize our data to make use of the groupings, so

pieces = 
 MapIndexed[
   # -> a[#2[[1]]] &, 
   Union[Flatten[(Internal`PartitionRagged[data, #] & /@ parts), 1]
 ] /. a_List /; Length[a] == 1 :> Sequence[]]
(*{{1, 2} -> a[1], {2, 3} -> a[2], {1, 2, 3} -> a[3]}*)

which is 36 elements long with data = Range[9], and applying it to results

reduced = results /. List[b_]:> b /. pieces
(* {a[3], {1, a[2]}, {a[1], 3}} *)

This means we have

Length@pieces + Length@Select[reduced, Head[#] =!= a &]
(* 5, or 290 *)

sequences to work with.

At this point, there are two approaches that come to mind to save memory, and this is where my solution becomes a bit fuzzy. First, only work with specific lengths of the operator tuples at a time. Since the pieces have specific lengths, it makes sense only to work worth those tuples that we need at any specific point. The same technique can be applied to incorporating the parenthesized pieces into the larger lists as a second loop. For the second pass, the operator tuples could have been serialized to disk, first, so you do not have to recalculate them. Second, as each length of operator tuples contains the prior lengths as substrings, I would suggest using a prefix tree, or trie, to minimize the storage requirements. This method still requires at least two passes, though.

There are two concerns I have that I have not had time to address, hence the incompleteness of this answer. First, I have not said anything about concatenation. It, too, can be viewed as a grouping operation, and as it as the highest precedence, it could be implemented as a first pass. Obviously, this makes it a little messier, but that is what you get when engineering around constraints. Second, I have not yet addressed how to associate a particular operator tuple sequence with its result. Until I do, this method can be used to calculate the number of combinations, but that is about it.

Answer 6

The solution in this answer is quite incomplete, As @whuber points out in the comment below, $34(−5×6+89)+2$ or $34(5/(6/(8×9))−1)+2$ isn't involved in the output of my second sample, I think the reason is:

1 My solution only treat "$-$" as binary minus, while it can also be used as a unary operator. (This isn't hard to fix. )

2 My definition for the 8 new operators makes the priority of multiplication and division different: it's unable to rewrite $(34 (5/6×8×9-1)) + 2$ with the 8 operators below. What's more, as @nikie points out in the comment under his answer: Terms like a * (b * c + d) can be nested to any depth, in a * (b * c + d * (e * f + g)) has 2 different + precedences and 3 different precedences for *. The depth of the expression is limited (it's equal to or smaller than the number of digits - 1), but this defect is still horrible, to fix it, (maybe) I can form a list with all the possibilities of precedence, which occupies an unimaginable amount of time and memories…so even if this code can be fixed, it will be a bad approach…

---

Thanks for the hint from @nikie! Now I also find a solution with the method of creating new operators with a higher priority.

I first checked the help and found a sequence of 8 infix symbols which has a decreasing priority and no inner definition, then I defined this:

(* The numbers in the note is the Unicode for the operators *)

(* 2218 ∘ *)SmallCircle[x_, y_] := x y;
(* 2299 ⊙ *)CircleDot[x_, y_] := x/y;
(* 22c0 ⋀ *)Wedge[x_, y_] := x + y;
(* 22c1 ⋁ *)Vee[x_, y_] := x - y;
(* 2297 ⊗ *)CircleTimes[x_, y_] := x y;
(* 00B7 · *)CenterDot[x_, y_] := x/y;
(* 2295 ⊕ *)CirclePlus[x_, y_] := x + y;
(* 2296 ⊖ *)CircleMinus[x_, y_] := x - y;

Now it's easy：

list=Table[ToString@i, {i, 8}]~Join~{"9==100"}

base = Select[Tuples[{"∘", "⊙", "⋀", "⋁", "⊗", "·", "⊕", "⊖", ""}, 8], 
               ToExpression@StringJoin@Riffle[list, #] &];

 (*Change the operators to the normal ones*)

 rule = Thread[{SmallCircle, CircleDot, Wedge, Vee, 
                CircleTimes, CenterDot, CirclePlus, CircleMinus} 
               -> 
               {Times, Divide, Plus, Subtract, 
                Times, Divide, Plus, Subtract}];

 co = ReplaceAll[ToExpression[StringJoin@Riffle[list, #],          
                              InputForm, Hold], rule] &;

 sol = DeleteDuplicates[co /@ base] // InputForm

I'm sorry that I can't finish running this code, 2GB memory seems not to be enough… so I can't test it right now. I'd like to solve the second example in the question instead:

list = {"(34", "5", "6", "8", "9", "1)", "2==2008"};

long = {"∘", "⊙", "⋀", "⋁", "⊗", "·", "⊕", "⊖", ""};
ls = {"⊗", "·", "⊕", "⊖", ""}
short={"⊗", "·", "⊕", "⊖"}

base = Select[Tuples[{ls, long, long, long, long, short}], 
               ToExpression@StringJoin@Riffle[list, #] &];

 rule = Thread[{SmallCircle, CircleDot, Wedge, Vee, 
                CircleTimes, CenterDot, CirclePlus, CircleMinus} 
               -> 
               {Times, Divide, Plus, Subtract, 
                Times, Divide, Plus, Subtract}];

 co = ReplaceAll[ToExpression[StringJoin@Riffle[list, #],          
                              InputForm, Hold], rule] &;

 sol = DeleteDuplicates[co /@ base] // InputForm

This code is quick, getting 5 solutions:

(*
   => {Hold[(34*(5*6) - ((8 + 9) - 1))*2 == 2008], 
       Hold[(34*(5*6) - (8 + 9) + 1)*2 == 2008], 
       Hold[(34*(5*6) - 8 - (9 - 1))*2 == 2008], 
       Hold[(34*(5*6) - 8 - 9 + 1)*2 == 2008], 
       Hold[345*6 - 8*(9 - 1) + 2 == 2008]}
*)

Answer 7

Check the Wolfram Blog and the very nice contribution by Christopher Carlson:

Happy 10*9*8+7+6-5+4*321 !

February 2, 2012

http://blog.wolfram.com/2012/02/02/happy-109876-54321/

Answer 8

Here's a Compiled version of chyanog's answer, it's a pity the code is more than an order slower than that directly coded with C and I've no idea how to improve it further, but the timing is already acceptable so I'd like to share it.

n = 9;

original = Groupings[Table[x, n], f -> 2];

expr = Block[{i = 1, j = 1}, # /. f[x, x] -> froot[x, x] /.
      {(head : f | froot) :> (head[#, o[i++], #2] &), x :> j++}] & /@ original;

cf = Compile[{x, {oper, _Integer}, y}, 
    Switch[oper, 1, x + y, 2, x - y, 3, x y, 4, If[y == 0, Pi, x / y], 5, -x + y , _, 
     Pi], RuntimeOptions -> EvaluateSymbolically -> False]; // AbsoluteTiming
(* {0.0000956, Null} *)

cfroot = Compile[{x, {oper, _Integer}, y}, 
    Switch[oper, 1, x + y, 2, x - y, 3, x y, 4, If[y == 0, Pi, x / y], 5, -x + y , _, 
     10 x + y], RuntimeOptions -> EvaluateSymbolically -> False]; // AbsoluteTiming
(* {0.0000738, Null} *)

froot and cfroot are introduced because the operation 10 x + y (AngleBracket in whuber's answer) is valid only onf[x, x] in original.

It's hard to make Compile spit out an error message without slowing down, so Pi is used to filter out meaningless combinations.

cexprfunc = 
   Block[{f = cf, froot = cfroot}, 
    Compile[##, RuntimeOptions -> EvaluateSymbolically -> False, 
       CompilationTarget -> C] & @@ ({{o@#, _Integer} & /@ Range[n - 1], 
       expr})]; // AbsoluteTiming
(* {28.5959, Null} *)

$ContextPath = DeleteDuplicates@Append[$ContextPath, "Internal`"];

numberofoper = 6;
elemval = Flatten@{o /@ Range[n - 1], index};

calc = 
   With[{target = 100}, 
    Hold@Compile[{{o[8], _Integer}}, 
          Module[{list = Bag@Most@{0}}, 
           Do[With[{mid = cexpr}, 
             Do[If[Abs@mid[[index]] == target, StuffBag[list, elem, 1]], {index, 
               Length@mid}]], ##]; BagPart[list, All]], RuntimeAttributes -> {Listable},
          Parallelization -> True] & @@ ({o@#, numberofoper} & /@ 
         Range[n - 2]) /. {cexpr -> cexprfunc @@ o /@ Range[n - 1], elem -> elemval} //
     ReleaseHold]; // AbsoluteTiming
(* {0.123834, Null} *)

data = calc@Range@numberofoper; // AbsoluteTiming
(* {131.668, Null} *)

Partition[Flatten@data, n] // Dimensions
(* {422716, 9} *)

Only cexprfunc is compiled to C, because otherwise the compilation is too slow. Tested with TDM-GCC 10.3.0-2 64bit, "SystemCompileOptions"->"-Og", Mathematica 12.3.1, Win 10, 2GHz, 4-core laptop.

The obtained solution can be checked as follows:

visualf[x_, opernum_, y_] := 
 With[{ts = ToString}, 
  With[{o = str |-> "(" <> ts@x <> str <> ts@y <> ")"}, 
   Switch[opernum, 1, o@" + ", 2, o@" - ", 3, o@" × ", 4, o@" / ", 5, 
    StringInsert[o@" + ", "-", 2], _, ts@x <> ts@y]]]

check[lst_] := 
 Indexed[expr, lst[[-1]]] /. Thread[Most@elemval -> Most@lst] /. f | froot -> visualf

str = check@RandomChoice@Partition[Flatten@data, n]
str // ToExpression
(* "(1 - (((2 + (3 × (-4 + 5))) + 6) / ((7 - 8) / 9)))" *)
(* 100 *)