Insert $+$, $-$, $\times$, $/$, $($, $)$ into $123456789$ to make it equal to $100$
In a sense described below, this answer finds $422716$ distinct solutions.
The innovations presented here are
using postfix operators to eliminate problems with parentheses;
avoiding having to deal with unary negation;
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
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:
$a + (-b) = a-b$, $a - (-b) = a + b$, $a(-b) = -(ab)$, and $a/(-b) = -(a/b)$.
$(-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:
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.
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.
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]
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