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

Question

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_} :> 
   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.

Answer 1

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