Pandigital Expressions

by

Jaime Rangel-Mondragón
 Arturo González-Gutiérrez

 aglez@uaq.mx

Introduction

Arithmetic puzzles have been always a rich source of fascinating computational problems. Beside their natural numerical setting, their solving requires a knowledge of arithmetic operations beyond mere computation. Consider, for example, pandigital  sums. A pandigital sum is a valid addition which uses all of the digits 1 to 9 only once. For instance

128 + 439 = 567
26 + 48 + 79 = 153

are pandigital sums. In this work we would like to find all pandigital sums and generalize the scheme to include other operations. In teaching the subject of Data Structures and Algorithms to undergraduate Computer Science students, the authors came across this problem and used it to explain a variety of computational problem-solving strategies and techniques, which resulted extremely prolific in a laboratory-based teaching environment. Such interaction allowed the authors to introduce successfully new ideas and programming techniques within a unifying theme.

First approach

Let us consider the problem of finding all solutions to the expression 1x2x3x...x9 = 0, where each x can be either a plus or minus sign, or possibly be absent, in which case we concatenate the digits adjacent to it. Any solution to this problem will be called a pandigital expression. We are interested in the expression being equal to zero, so we do not include the possibility of a negative sign in front of the 1 as it will produce redundant solutions. Later we will allow the x symbols to stand for an arbitrary binary operation but in this section only additions and substractions are considered.

It is possible to design an operation "concatenate" so that we can avoid the phrase "or to be absent" and say that x stands for one of three binary operations. In fact, concatenation is a perfectly valid way of regarding the absence of operation between two numbers or, alternatively, the implicit presence of an operation f such that f(x, y)=x (10^(|y|)) + y, where | y | is equal to the length of number y. We note that Mathematica will not regard this absence as multiplication as it considers a space to implicitly define a multiplication; only in some cases adjacency of objects means also multiplication (for example, the symbol 2x stands for 2*x and a(b+c) stands for a*(b+c)). Consider the following code:

op={"+","-",""};
d=Distribute[{"1",op,"2",op,"3",op,"4",op,"5",op,"6",op,"7",op,"8",op,"9"},List];
Select[StringJoin/@d,(ToExpression[#]==0)&]

The Distribute command generated all (3^8) = 6561 possible expressions, from which we then selected the ones that evaluate to zero. Note that, although we can regard this approach as naive, Mathematica's internal functions, like Distribute, are highly optimized and allow us to afford this straightforward approach in essentially one line of code. This results in favoring rapid prototyping, which is a feature few programming languages support and which distinguishes Mathematica.

We can operate all throughout a number other than 9 and still obtain meaningful results. Let us say we want the operations performed on the numbers in Range[n], or better yet, we might provide a list (not a set, as the order is important here) and ask for the ways of inserting operations between the elements of this list resulting in a valid expression. Firstly, we need to mix the elements of the list and the "op" symbol to provide the argument to the Distribute function, which gives us a chance to apply function Thread, a powerful high-level function provided by Mathematica.

lis=ToString /@ Range[3,9];
Delete[Flatten[Thread[{lis,"op"}]],-1]

Alternatively, we can perform this last deletion with the command

Flatten[Thread[{lis,"op"}]] /. {x___,_}->{x}

So, the actual function is encapsulated as:

pandigital[lis:{_String..},op:{_String..}]:=Module[{a,d},
a=Delete[Flatten[Thread[{lis,"op"}]],-1]; 
a=a /. "op"-> op;
d=Distribute[a,List];
Select[StringJoin/@d,(ToExpression[#]==0)&]]

pandigital[ToString /@ Range[9],op]

Note that we could have provided CharacterRange["1", "9"] to function pandigital instead. We can make use of this function to solve the reversed version of the problem.

pandigital[ToString /@ Range[9,1,-1],op]

Or in fact, apply it to an arbitrary set.

pandigital[ToString /@ {1,2,1,2},op]

We can then solve families of pandigital problems; for instance, we can obtain all pandigital expressions using a few of the first positive integers

Column[Table[{i,pandigital[ToString/@Range[i],op]},{i,7}]]

Column[Table[{i,pandigital[ToString/@Range[i,1,-1],op]},{i,7}]]

In comparing the previous normal and backwards solutions we realize that we would be mistaken in thinking that we can get from one solution to the other just by reversing signs. Increasing the range, the number of solutions grows as:

Table[Length[pandigital[ToString /@ Range[i],op]],{i,12}]

What if there are repeated elements?. For instance, chains of even length of 1's (we know the problem has no solution for an odd number of 1's)

Column[Table[{i,pandigital[ToString /@ Table[1,{i}],op]},{i,2,6,2}]]

Of course, if we ever include a 0 in the list, it will have little effect, although it may spawn spurious results.

pandigital[Characters["1010"],op]

Let us see in how many ways we can operate with the first eleven prime numbers to obtain a zero answer.

pandigital[ToString /@ Prime[Range[11]],op]

The reason we choose to stop at the eleventh prime is to observe the merging of primes 2 and 3. If we want to prevent this merging we have to get rid of the concatenation operation.

pandigital[ToString /@ Prime[Range[11]],{"+","-"}]

The concatenation of 2 and 3 was interesting as 23 is the concatenation of prime numbers being prime itself. Let us momentarily pause to consider the following question: is there a number such that all its prefixes (including itself) are prime? For instance,  number 239933 is such because the list of prefixes {2, 23, 239, 2399, 23993, 239933} contains only primes. If the number (or numbers) we seek has more than one digit, it must be constructed from odd digits different from 5, except of course at its start. Also, the sum of its digits cannot be a multiple of 3, which narrows down the possibilities considerably.

pass[0]:=True
pass[n_]:=(PrimeQ[n]&& pass[⌊(n/10)⌋])

Here is the list of such numbers up to the first hundred prime numbers:

Select[Prime[Range[100]],pass]

This method of arriving at them is not very clever. We should "grow" them one digit at a time.

grow[n_]:=Select[10 n+Range[9],PrimeQ]

grow[2]

Let us find out how the "tree" has grown in m iterations

tree[m_]:=Nest[Flatten[grow /@ #]&,{2,3,5,7},m]

tree[2]

As tree[8] is empty, we conjecture that there is a finite number of such numbers (83 exactly). The reader may find instructive to solve the suffix version of this problem as it includes new features arriving at the result that the maximum number such that all its suffixes are primes is 357686312646216567629137.

Let us now return to our original problem. What positive numbers could we have chosen instead of zero and still be able to get an answer in this modified pandigital expression?

z=Select[Union[ToExpression/@StringJoin/@d],Positive];
Length[z]
Complement[Range[200],z]

Of the 1283 possible values (among which the greatest is 123456789 of course), the value 160 is the least such that we cannot find any combination of the form 1x2x3x...x9 that evaluates to it.

Let us now undertake the task of covering all the usual arithmetic operations. Including the multiplication and division operators; we get 167 solutions from searching (5^8) =390625 possibilities, a very time-consuming computation.

op={"+","-","","×","/"};
d=Distribute[{"1",op,"2",op,"3",op,"4",op,"5",op,"6",op,"7",op,"8",op,"9"},List];
e=Select[StringJoin /@ d,(ToExpression[#]==0)&];
e //Shallow

Of these,

Length[Select[e,StringMatchQ[#,"*×*"]&]]

involve at least one multiplication. We can see that our choice for the symbol of multiplication other than "*" was adequate.

Inserting brackets

Let us generalize further by allowing brackets in a pandigital expression. This time, among the possibilities for symbol x, we do not include the patterns "+(", ")+" or ")-" as they lead to what we might consider redundant expressions. The reason for this is that the elimination of opening-closing pairs of brackets preceded or followed by a plus sign does not change the value of the expression; a similar reason applies also to the pattern ")-". Similarly, we do not allow brackets surrounding expressions not containing at least a plus or minus sign; this is in order to get rid of brackets surrounding single numbers and to avoid redundancies involving the exclusive use of multiplications and divisions within brackets. Function notValidQ below is a predicate that verifies this last requirement. Let us note that the symbol "-" plays a double role in being an operation and a sign, that is, it can be considered either an unary or binary operator; In disallowing any substraction following a closed bracket we are considering all operations to be binary.

notValidQ[{"(",___,")"}]:=True
notValidQ[{___,"(",e__,")",___}]:=True /; (SyntaxQ[StringJoin[e]] && Not[MemberQ[{e},"+"]]&& Not[MemberQ[{e},"-"]])
notValidQ[_]:=False

We are now ready to obtain, under the previous considerations, all bracketed pandigital expressions. In order to illustrate this, we do not include divisions and stop at number 6 in the code below. Note that we have included optional brackets preceding  number 1 and following number 6. We also require that brackets occur only on the given patterns.

op={"+","-","","*","-(",")*","*("};d=Distribute[{{"(",""},"1",op,"2",op,"3",op,"4",op,"5",op,"6",{")",""}},List];
d=Select[StringJoin /@ d,SyntaxQ];
d=Select[d,Not[notValidQ[Characters[#]]]&];
Select[d,(ToExpression[#]==0)&]

The reason we stopped at number 6 is to get a small representative solution and to warn about the time it will take to compute all solutions were we stopping at 9. We would then have to search 2 (8^8)2=67108864 posibilities, a task that would be extremely time consuming.

There is a second reason why we did not include the division operation. In testing that a pattern is indeed a valid expression, we rely only in the test SyntaxQ which, once it is validated, is followed by a direct evaluation of the pattern using ToExpression, which might involve a division by zero. Our problem is then to find out how, given a string representing a valid expression, to know whether there is a division by zero somewhere without actually attempting to evaluate it. Function divByZeroQ serves this purpose.

divByZeroQ[{___,"/","(",e__,")",___}]:=True /; SyntaxQ[StringJoin[e]] &&((ToExpression[StringJoin[e]]==0)||divByZeroQ[{e}])
divByZeroQ[_]:=False

Note that it is not as straightforward as just checking for a zero-value expression in the denominator of a division. For example, the expression below contains a conspicuously dangerous zero division, despite the fact that the value of the whole expression is zero, fact that, although  it is properly handled by Mathematica, generates an unwanted warning.

divByZeroQ[Characters["2/(5/(3-(7-4)))"]]

2/(5/(3-(7-4)))

SyntaxQ["2/(5/(3-(7-4)))"]

Note that in testing the syntactical correctness of a string, Mathematica makes no attempt at evaluating it.

We are now ready to include the division operation. The fact that we are exploring a space of possibilities of size 2 (10^6) 2=4000000, along with the use of the former test, slows down the process noticeably and produces a fascinating output.

op={"+","-","*","/","","-(",")*","*(",")/","/("};d=Distribute[{{"(",""},"1",op,"2",op,"3",op,"4",op,"5",op,"6",{")",""}},List];
d=Select[StringJoin /@ d,SyntaxQ];
d=Select[d,Not[notValidQ[Characters[#]]]&];
d=Select[d,Not[divByZeroQ[Characters[#]]]&];
d=Select[d,(ToExpression[#]==0)&]

Can the output be formatted so that it uses an horizontal line to indicate division instead of a slash?. Using Mathematica's formatting options we easily solve this problem which would otherwise be somewhat difficult to implement from scratch. As we can see in the output below, even unnecesary parenthesis are removed! - although the multiplication sign disappeared and the order is not apparent any more, which is but a small price to pay for this convenience.

pretty[s_String]:=DisplayForm[ToBoxes[ToExpression[s,StandardForm,HoldForm]]]

pretty /@ d

pretty["1+1/(2+1/(3+1/(4+1/(5+6))))"]

Inserting Operations

In going over the results of the previous section we realize that not all valid expressions are generated by function Distribute. For instance, while it is easy to see why the pandiagonal expression 1*(2-(3+(4-5))) is not generated,  the expression 1*(2-3-(4-5)) is a valid one which our ending condition (and similarly the beginning one) is preventing from being generated. The modifications needed are a bit awkward to code as we do not know in advance with how many brackets a valid pandigital expression begins or ends and to consider all the possibilities could make the computing cumbersome, so in this section we resort to another idea.

Consider function h[s, f] generating all possible ways of bracketing the list Range[s, f].

Clear[u,h]
u[x_,y_]:="("<>ToString[x]<>ToString[y]<>")"

h[m_,m_]:={m}
h[s_,f_]:=h[s,f]=Flatten[Table[Outer[u,h[s,i],h[i+1,f]],{i,s,f-1}]]

b=h[1,6]

We proceed to eliminate the outermost bracket from each one of the above expressions

b=StringTake[#,{2,StringLength[#]-1}]&/@b

and then insert operations

In the code below, symbols p and o stand for operation symbols, preventing and allowing concatenation respectively.

t={{$x___,")","(",$y___}->{$x,")","p","(",$y},{$x___,")",$d_?DigitQ,$y___}->{$x,")","p",$d,$y},
{$x___,$d_?DigitQ,"(",$y___}->{$x,$d,"p","(",$y},{$x___,$d_?DigitQ,$y_ /;Not[MemberQ[{"o","p",")"},$y]],$z___}->{$x,$d,"o",$y,$z} };

c=StringJoin /@ ((Characters[#]//.t)& /@ b)

Note that the names of the variables appearing in the patterns are chosen so as not to coincide with any already used.

op="{\"+\",\"-\",\"\"}";
opb="{\"+\",\"-\"}";
u=("{\""<>StringReplace[#,{"o"->"\","<>op<>",\"","p"->"\","<>opb<>",\""}]<>"\"}")&/@c;
ans={};
Map[
(d=Distribute[ToExpression[#],List];
AppendTo[ans,Select[StringJoin/@d,(ToExpression[#]==0)&]])&,u];
Flatten[ans]

While this idea allows us to have more control on the number of brackets appearing in an expression, and let us review many important strategies, it suffers from some disadvantages. Numbers are enclosed in brackets, zero divisions have to be filtered out and the use of Distribute is inconvenient as it produces an unwieldy number of cases to be tested.

Using backtrack

The previous results show that the number of solutions is negligible compared to the space of combinations computed by the Distribute task, in a manner that recalls our experience with the solution found for the problem with the prefixing primes. Our solution comprised an exhaustive search sweeping the whole space in a goal-oriented manner. Backtrack is a typical method called for whenever we want to exhaustively look for solutions as in our case. The idea is to construct expressions built from left to right, choosing the next symbol from those complying with a series of rules. These rules are such that at each stage in "growing" the solution by appending a character we have to decide whether to choose a number, an operation sign or a bracket and follow the idea of what we consider to be a permissible expression. The rules are:

In choosing to place a number:

In choosing an operation sign:

In choosing a "(" sign:

In choosing a ")" sign:

(Note that this last fourth rule contains in turn the rule: never place it next to an operation sign or a "(" )

By analogy with what we did for the problem of the prefix primes we call this function grow. It takes a current expression (which the user will choose to be the empty string initially) and a set of numbers and recursively attempts to augment it using all possible candidates.

Clear[divByZeroQ,notValidQ,candidates,grow]

divByZeroQ[{___,"/","(",e__}]:=True /; SyntaxQ[StringJoin[e]] &&((ToExpression[StringJoin[e]]==0)|divByZeroQ[{e}])
divByZeroQ[_]:=False

notValidQ[{___,"(","(",e__,")"}]:=True /;SyntaxQ[StringJoin[e]] 
notValidQ[{___,"(",e__}]:=True /; (SyntaxQ[StringJoin[e]] && Not[MemberQ[{e},"+"]]&& Not[MemberQ[{e},"-"]])
notValidQ[_]:=False

candidates[exprSoFar_,numbers_]:=Module[{e=Characters[exprSoFar],choices={},n,s,i},
If[e=={},AppendTo[choices,First[numbers]],
If[Last[e]≠")",
n=Length[Select[e,DigitQ]];
If[n==0,AppendTo[choices,First[numbers]],
s=0; i=1;
While[s<n,s=s+StringLength[numbers[[i]]];i=i+1];
If[i≤Length[numbers],AppendTo[choices,numbers[[i]]]]]]];

If[(e≠{})&&Not[MemberQ[{"+","-","*","/","("},Last[e]]]&&(Select[Characters[exprSoFar],DigitQ]≠Characters[StringJoin[numbers]]),
AppendTo[choices,{"*","/"}];
If[Last[e]≠")",AppendTo[choices,{"+","/"}]]];

If[e=={},AppendTo[choices,"("],
If[(Length[Cases[e,"("]]<Length[numbers]-1)&&Not[MemberQ[Join[CharacterRange["0","9"],{"+","-"}],Last[e]]]&&(Length[Select[e,DigitQ]]<Length[numbers]),AppendTo[choices,"("]]];

If[(e≠{})&&Not[MemberQ[{"+","-","*","/","("},Last[e]]],
n=Length[Cases[e,"("]];
m=Length[Cases[e,")"]];
If[(n-m>0)&&Not[divByZeroQ[e]]&&Not[notValidQ[e]],AppendTo[choices,")"]]];

Flatten[choices]]

grow[exprSoFar_,numbers_]:=exprSoFar /;(Select[Characters[exprSoFar],DigitQ]==Characters[StringJoin[numbers]])&&SyntaxQ[exprSoFar]&&(ToExpression[exprSoFar]==0)

grow[exprSoFar_,numbers_]:=Module[{u,v},
u=candidates[exprSoFar,numbers]; 
If[u=={},{},
v=Flatten[StringJoin[exprSoFar,#]&/@u]; 
Flatten[grow[#,numbers]&/@v]]]

Note how the next candidate number is selected in function candidates above. First we compute how many digits have appeared so far; we know these digits must appear in exactly the same order in list numbers so, through examining the accumulated length we arrive at the last number placed. We have to do it this way because we want to attack the problem preventing future generalizations including arbitrary (possibly repeated) multi-digit elements in the given list of numbers.

Note that the limit on the "(" sign is crucial for the recursion to end as all the others signs already follow certain restrictions in their numbers. Also, the requirement of an expression being not of the form (__) cannot be enforced within function grow due to this function's recursive nature. The following is timed on a 2 Ghz personal computer.

Select[grow["",CharacterRange["1","5"]],Not[StringMatchQ[#,"(*)"]]&]//Timing

Even though we have set a very restrictive list of requirements, the last computation was very time-consuming. There might be some other extra criteria to speed up the process. For instance, we might not admit brackets surrounding operations that evaluate to zero, thus avoiding long chains of "trivial" solutions that exploit this occurrence and that have already occurred as solutions to smaller pandiagonal problems. With this criteria, there is no need to check for zero division, or, alternatively, we can change the definition of divisionByZero function to:

Clear[divByZeroQ]
divByZeroQ[{___,"(",e__}]:=True /; SyntaxQ[StringJoin[e]] &&(ToExpression[StringJoin[e]]==0)
divByZeroQ[_]:=False

Select[grow["",CharacterRange["1","5"]],Not[StringMatchQ[#,"(*)"]]&]//Timing

The reader might find interesting to discover the reason the last computation took longer than the previous one.

Is there a way of assessing the amount of work done by function grow?. Let us include instruction

AppendTo[ans,StringLength[exprSoFar]];

inside the body of function grow, just before the If instruction. It updates a global variable ans which will give an idea of how deep the calls to function grow are. For example, the tree of calls corresponding to the (unsuccessful) case of numbers={1, 2} is shown below. There are 13 leaves (most promising or successful patterns) and 17 inner nodes, making a total of 30 nodes visited. For the case of numbers=Range[5], there are 134080 nodes visited, instead of the 2 (4^4) 2 =40000 (not counting those that start or end with more than one bracket).

Using partitions

Let us now consider unordered pandigital expressions. Because of the amount of solutions, we will structure them to fit a suitable scheme. Instead of a single list of numbers we have now a factorial-sized list of lists. For our original problem this means 9!=362880 individual pandigital problems. The idea we will now follow is: given a list of integers, we proceed to compute all partitions of this list considered as a multiset. This partitions will form classes separating the numbers from the operations in a similar way as we did before using the symbol x. We then proceed to append all possible operations in the gaps and select those that are pandigital expressions.

Function partit[s, n]computes all partitions of the list s having n parts. Function partit[s] computes all partitions of the list s. The functions numPartit[m, n] and numPartit[m] count the size of the sets generated by their counterparts applied to s=Range[m]. Function showPartit displays them in lexicographic order.

partit[s_,n_]:={} /; n>Length[s]
partit[s_,1]:={{s}}
partit[s_,n_]:={{#}& /@ s} /; n==Length[s]

partit[{a_,b___},n_]:=Module[{ans={},i,u},
Map[
Do[u=#;
u[[i]]=Append[u[[i]],a];
AppendTo[ans,u],{i,n}]&,partit[{b},n]];
AppendTo[ans,Append[#,{a}]]&/@partit[{b},n-1];
ans]

partit[s_]:=Flatten[Map[partit[s,#]&, Range[Length[s]]],1]

numPartit[m_,n_]:=0/; n>m
numPartit[_,1]:=1
numPartit[n_,n_]:=1 
numPartit[m_,n_]:=numPartit[m,n]=n numPartit[m-1,n]+numPartit[m-1,n-1]

numPartit[m_]:=(∑_(i=1)^m)numPartit[m,i]

showPartit[p_]:=DisplayForm[Map[OverscriptBox[StringJoin[ToString/@#],StringJoin[Table["_",{Length[#]}]]]&,Sort[Sort /@ p,(First[#1]<First[#2])&]]]

showPartit /@partit[Range[4],3]
numPartit[4,3]

showPartit /@ partit[Range[4]]

numPartit[4]

Table[numPartit[i,j],{i,10},{j,10}] // MatrixForm

To obtain the total amount of partitions we sum the elements in each row:

Table[numPartit[n],{n,10}]

Function partit2[n] enumerates all partitions of a set of size n according to their types, thus providing a more descriptive way of generating partitions. Given n, partit2 will compute a list of pairs of the form {i, m}, each one meaning there are i partitions of n in which their number of elements are coded by list m, describing an ordered partition of the number n. This links together the concepts of partitions of sets and partitions of numbers. Function showPartit2 displays partitions in their canonical notation.

partit2[1]:={{1,{1}}}
partit2[n_]:=Module[{ans={},p=partit2[n-1],q,i,j,k},
Map[({i,j}=#;
Table[q=j;
q[[k]]=q[[k]]+1;
AppendTo[ans,{i,Sort[q]}],{k,Length[j]}])&,p];
Map[({i,j}=#;
AppendTo[ans,{i,Sort[Append[j,1]]}])&,p];
ans //. {a___,{i_,j_},b___,{k_,j_},c___}-> {a,{i+k,j},b,c}]

joinDigits[d_]:=StringJoin[ToString /@ d]

showPartit2[p_]:=DisplayForm[Map[SuperscriptBox[joinDigits[Last[#]],First[#]]&,p]]

Clear[a,b,c,i,j,k]
Do[
Print[showPartit2[partit2[n]]],{n,4}]

The last line establishes that the partitions of a set of four elements can be divided into five classes according to their cardinalities. There is only one partition with a set of four elements (see the previous output corresponding to partit[Range[4]]), 3 partitions with sets of two elements each, 4 partitions with sets of 1 and 3 elements, 6 partitions with three sets of 1, 1 and 2 elements each, and 1 partition with sets of size 1, 1, 1 and 1. The following verifies the number of partitions as produced previously.

Table[Plus @@ First /@ partit2[n],{n,10}]

Consider partition u below. The following segment lists all combinations of the internal permutations of each block.

u={{1,2,5},{3,4},{6},{7,8}};
v=Map[Permutations[#]&,u];
w=Distribute[v,List];
Map[(FromDigits /@ #)&,w]

Function numbers encapsulates the above procedure and function numNumbers counts the size of the resulting list.

numbers[s_]:=Module[{p=Rest[partit[s]],u,v,w},
Flatten[Map[(u=#; 
v=Map[Permutations[#]&,u];
w=Distribute[v,List];
Map[(joinDigits /@ #)&,w])&,p],1]]

numNumbers[n_]:=Plus @@ Map[First[#] Times @@ (Last[#]!)&,Rest[partit2[n]]]

numbers[Range[4]]
numNumbers[4]

This list grows quite rapidly:

Table[numNumbers[n],{n,9}]

We are now ready to insert operations between the blocks of each partition. Let us illustrate the general procedure with partition {(OverBar[321]), (OverBar[4]), (OverBar[5])} of  Range[5].

op={"+","-"};
Drop[Flatten[{#,x}& /@ {321,4,5}] /. x-> op,{-1}]
Distribute[%,List]

Function numResults[n, m] computes the number of expressions considered as candidates from a set of n elements allowing up to m operations.

results[s_,op_]:=Module[{r=numbers[s],v,t,x,y,q},
q=Map[
(u=#;
t=Drop[Flatten[{#,x}& /@ u] /. x->op,{-1}];
t=Distribute[t,List];
v=Map[{#,ToExpression[StringJoin[#],StandardForm]}&,t]; 
Select[v,Last[#]==0&])&,r];
StringJoin /@ First /@ Flatten[q,1]]

numResults[n_,m_]:=Plus @@ Map[(m^(Length[Last[#]]-1))First[#] Times @@ (Last[#]!)&,Rest[partit2[n]]]

Length[numbers[Range[4]]]
results[Range[4],{"+","-"}]
numResults[4,2]
results[Range[4],{"+","-","*"}]
numResults[4,3]
results[Range[4],{"+","-","*","/"}]
numResults[4,4]

From 49 permutations of the partitions of the list {1, 2, 3, 4}, 128 expressions inserting plus/minus signs were calculated, finding only one pandigital solution.There were 243 expressions inserting +, - and * operations and 2 solutions were found. There were 400 expressions inserting +, -, * and / operations, out of which only 3 solutions were found.

Do[
Print[Timing[results[Range[n],{"+","-"}]]],{n,8}]

Do[Print[Union[results[Table[1,{n}],{"+","-","*","/"}]]],{n,4}]

results[{1,2,3,10,8,7},{"+","-","*","/"}]

results[{110,2,3,8,7},{"+","-","*","/"}]

New Operations

Finally, consider the search for pandigital expressions using user-defined operations. In entering their definitions we need the appropriate package.

<< Notation`;

Let us define, for instance, the function corresponding to the commutative non-associative operation xor.

Notation[x_ ⊕ y_  ⟺  xorF[x_,y_]];

xorF[a_,b_]:=a b-a-b

2⊕3

(2⊕3)⊕4
2⊕(3⊕4)

results[Range[5],{"+","-","*","/","⊕"}]

An operation table of function ⊕ is obtained as:

r=Range[5];
t=TableForm[Outer[(#1 ⊕#2)&,r,r],TableHeadings->{r,r}]

Consider now the operation "inverted division"

Notation[x_ ⊗ y_  ⟺  invDiv[x_,y_]];

invDiv[a_,b_]:=b/a

4⊗2

(a/b)/(b⊗a)

results[Range[5],{"+","-","*","/","⊕","⊗"}]

In evaluating the expression 1⊕2⊗3-4+5, Mathematica parses it to

FullForm[Hold[1⊕2⊗3-4+5]]

Finally, we generate the following remarkable output

results[Range[6],{"+","-","*","/","⊕","⊗"}]

This work was finished at Wolfram Research Inc., in Champaign IL, USA, while the first author was invited as a Visiting Scholar. Their assistance and enthusiastic support is gratefully acknowledged. Our thanks are also given for the continuous support received from the University of Queretaro in Mexico.

Mathematica  Pearls: Problems and Solutions. ed. by Donald T. Piele
Mathematica in Education and Research
volume 3 number 3, summer 1994, p. 55-57

Answer to problem 17 Section cowculations by Dr. Mu
Quantum Magazine, vol 10, number 1 September/October 1999, p. 55-57

In and Out, edited by Paul Abbott
The Mathematica Journal vol. 7, Issue 3, 1999

Solving Puzzles with Mathematica. Michael Trott
The Mathematica Journal vol. 7, Issue 3, 1999

"Pandigital Olympic Circles Puzzle" from The Wolfram Demonstrations Project
http://demonstrations.wolfram.com/PandigitalOlympicCirclesPuzzle/

Weisstein, Eric W. "Pandigital Number." From MathWorld--A Wolfram Web Resource. 
http://mathworld.wolfram.com/PandigitalNumber.html