6
$\begingroup$

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:

Each one of these has the digits from 0-9

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_} :> 
   TraditionalForm[a\[Cross]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 Combinatorica`TransitiveReduction).

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

$\endgroup$
  • $\begingroup$ ! SameQ[#[[1]], "0"] in uniqueTerms[alphabet, 3, ! SameQ[#[[1]], "0"]. $\endgroup$ – Schopenhauer Feb 9 '16 at 6:32
  • $\begingroup$ 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. $\endgroup$ – Schopenhauer Feb 9 '16 at 6:36
  • $\begingroup$ 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. $\endgroup$ – Schopenhauer Feb 9 '16 at 6:44
  • $\begingroup$ 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. $\endgroup$ – Schopenhauer Feb 9 '16 at 7:09
5
$\begingroup$

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

enter image description here

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

$\endgroup$
  • 1
    $\begingroup$ @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. $\endgroup$ – garej Feb 10 '16 at 22:44

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.