# How to efficiently find all combinations of the letters in an alphabet given a condition

## Problem:

I want to find all unique expressions with n number of terms that contain all the digits (or characters) in alphabet.

Example: Let the variable alphabet be a given a List of digits or characters (for now let us use base 10 or the output of Range[0, 9]). So I need all equations with non repeating digits, as follows:

Note that each one of the multiplications above contains all the digits without repetition from 0 to 9.

For example: 402 * 39 == 15678 contains {4,0,2,3,9,1,5,6,7,8} - all unique elements of alphabet {0,1,2,3,4,5,6,7,8,9}.

## Solution: Draft

alphabet = (  ToString /@ Range[0, 9]  );
Off[Part::partw];
(
uniqueTerms[  alphabet_List: (ToString /@ Range[0, 9] ),
size_Integer: Part[Divisors[alphabet_], 2],
selectionCriteria_: _] :=
(*  Select returns a list of elements that match a given pattern. *)
Select[
DeleteDuplicates /@ Permutations[alphabet, {size}]
, selectionCriteria]

) ;

(  twos = uniqueTerms[ alphabet, 2, ! SameQ[#[[1]], "0"] & ] );
(  threes = uniqueTerms[alphabet, 3, ! SameQ[#[[1]], "0"] & ]   ) ;
(  expressions = Select[ Flatten[  Table[
{  threes[[  i  ]], twos[[  j  ]] ,
DeleteDuplicates[
Flatten[ { threes[[  i  ]], twos[[  j  ]] }  ]  ]  },
{  i, Range[Length@threes]  },
{  j, Range[  Length@twos  ]  }
], 1] , Length[  #[[  3  ]] ] == 5 &  ]  [[
All, {  1, 2  }  ]]  ) ;
(  eqns = (
expressions //. {a_List,
b_List} :> {t1 = FromDigits[ToExpression /@ a],
t2 = FromDigits[ToExpression /@ b], t1*t2} ) ) ;
sol = SortBy[
Select[eqns, (
IntegerDigits[ #[[1]] ] \[Union]
IntegerDigits[ #[[2]] ] \[Union] IntegerDigits[ #[[3]] ] ) ==
Range[0, 9]  & ], Last] /. {a_, b_, c_} :>


This was my solution. I would like to use an alternative to Permutations and Select in cases where alphabet is big enough (maybe using Signature and PartitionQ or CombinatoricaTransitiveReduction).

Any suggestion to generalize or improve my approach is welcomed. Links to similar problems, posts, books and articles are also helpful.

• ! SameQ[#[[1]], "0"] in uniqueTerms[alphabet, 3, ! SameQ[#[[1]], "0"]. Feb 9, 2016 at 6:32
• That is because in uniqueTerms[ alphabet_List: (ToString /@ Range[0, 9] ), size_Integer: Part[Divisors[alphabet_], 2], selectionCriteria_: _] is called as the defalt value of the second argument. It does not affect functionality. Feb 9, 2016 at 6:36
• I saw Select[Permutations[Range[0, 9]], FromDigits[Take[#, 3]]* FromDigits[Take[#, {4, 5}]] == FromDigits[Take[#, -5]]&] and it is interesting but 16 seconds is quiet big. The approach I proposed took 1 second. Feb 9, 2016 at 6:44
• Also because the product have to have at least as many digits as the number of digits in the factors we do not consider 01 * 345 == 1 * 345 -> {1, 3,4,5} because that will give us an answer with less than 5 digits and therefore the expression will not contain all the characters in the alphabet. Remember 402 * 39 == 15678 is True and {4,0,2,3,9,1,5,6,7,8} == {0,1,2,3,4,5,6,7,8,9} is also True. Feb 9, 2016 at 7:09

You draft code gives on my PC 1.11 s. This version is better (the best I've got so far is 0.26 s), though Permutations preserved (I cannot see how to avoid them efficiently):

({p2, p3} = DeleteCases[Permutations[Range[0, 9], {#}], {0, __}] & /@ {2, 3};
list = Flatten[Outer[Join, p3, p2, 1], 1];
tmp2 = (FromDigits[#] & /@ list[[All, 1 ;; 3]])*(FromDigits[#] & /@ list[[All, 4 ;; 5]]);
list2 = IntegerDigits /@ tmp2;
res = Select[DeleteDuplicates /@ MapThread[Join, {list, list2}], Length[#] == 10 &];

(* view *)

tmp3 = Transpose[{FromDigits[#] & /@ res[[All, 1 ;;  3]],
FromDigits[#] & /@ res[[All, 4 ;;  5]],
FromDigits[#] & /@ res[[All, 6 ;; 10]]}];

SortBy[tmp3, Last] /. {a_, b_, c_} :> TraditionalForm[a\[Cross]b == c])
// RepeatedTiming


res= {{2, 9, 7, 5, 4, 1, 6, 0, 3, 8}, {3, 4, 5, 7, 8, 2, 6, 9, 1, 0},
{3, 6, 7, 5, 2, 1, 9, 0, 8, 4}, {3, 9, 6, 4, 5, 1, 7, 8, 2, 0},
{4, 0, 2, 3, 9, 1, 5, 6, 7, 8}, {4, 9, 5, 3, 6, 1, 7, 8, 2, 0},
{5, 9, 4, 2, 7, 1, 6, 0, 3, 8}, {7, 1, 5, 4, 6, 3, 2, 8, 9, 0},
{9, 2, 7, 6, 3, 5, 8, 4, 0, 1}}


Edit With Case instead of Select timing is better - (0.26 s):

res = Cases[Replace[Range[0, 9], _ :> _, {-1}]][ DeleteDuplicates /@ MapThread[Join, {list, list2}]]

• @Schopenhauer, note that your code without ToString inclusions gives 0.84 on RepeatedTiming test. I've also found no way to use PackedArray` in the example provided. Feb 10, 2016 at 22:44