4
$\begingroup$

I need to generate all integers such that they start with 1, have exactly k distinct digits, and every next digit is at most by 1 larger than the maximum of the preceding ones (10 is replaced with 0). At the moment I am using the following recursive function:

TotalDigits=10;
DistinctDigits=4;
b[n_, m_] := 
  b[n, m] = 
   If[n == 1, {{1}}, 
    Table[Append[#, Mod[i, 10]], {i, 1, Min[Max[#] + 1, m]}] & /@ 
      b[n - 1, m] // Flatten[#, 1] &];
FromDigits /@ 
  Select[b[TotalDigits, DistinctDigits], 
   CountDistinct[#] == DistinctDigits &]

This works when the number of distinct digits is small but becomes very ineffective when it gets larger, as too many unnecessary elements are generated that are later filtered out by the Select function. Can anyone suggest how to optimize this so that I do not need to generate too many elements at the intermediate step? In particular, b[10,10] should return only one element, {1,2,3,4,5,6,7,8,9,0}, but my current code runs out of memory before it can calculate this.

I saw a somewhat related question here: Generating Tuples with restrictions

However, I doubt that the solution proposed there, which uses IntegerPartitions, is of any use in my case, because the sum is not constrained.

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ you could search for dfs $\endgroup$
    – AsukaMinato
    Commented Oct 12 at 8:14
  • $\begingroup$ a ref implement in py, pastebin.com/622JbvWp, I am porting it to mathematica. $\endgroup$
    – AsukaMinato
    Commented Oct 12 at 8:24

2 Answers 2

Reset to default
3
$\begingroup$ 
len = 10;
k = 10;
dfs[number_List] := If[Length[number] == len ,
   If[
       Length[Union[If[# < 10, #, 0] & /@ number]] == k,
       Print[If[# < 10, #, 0] & /@number]
   ],
  Do[
    If[i <= 10,
      dfs[Append[number, i]]
      ],
      {i, {Last[number], Last[number] + 1}}
    ]
  ];

dfs[{1}]

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

Improve this answer
$\endgroup$
7
  • $\begingroup$ Thank you! This is indeed much faster, though I don't quite understand how it works. ;-) $\endgroup$
    – Vosoni
    Commented Oct 12 at 9:10
  • 1
    $\begingroup$ It should be {i, Range[1, Last[number] + 1]} because zero comes at the end, then it works. $\endgroup$
    – Vosoni
    Commented Oct 12 at 9:37
  • 1
    $\begingroup$ Or, rather, {i, Range[1, Last[Union[number]] + 1]} $\endgroup$
    – Vosoni
    Commented Oct 12 at 9:42
  • 1
    $\begingroup$ This is the version of the code in the form of a function: Patterns[len_, k_] := ( Clear[dfs]; ResultingPatterns = {}; dfs[number_List] := If[Length[number] == len, If[Length[Union[If[# < 10, #, 0] & /@ number]] == k, AppendTo[ResultingPatterns, If[# < 10, #, 0] & /@ number]], Do[If[i <= 10, dfs[Append[number, i]]], {i, Range[1, Last[Union[number]] + 1]}] ]; dfs[{1}]; FromDigits /@ ResultingPatterns ); Patterns[11, 10] $\endgroup$
    – Vosoni
    Commented Oct 12 at 9:43
  • 1
    $\begingroup$ Patterns[11, 10] returns 55 results, as it should. Thanks a lot for help. $\endgroup$
    – Vosoni
    Commented Oct 12 at 9:45
0
$\begingroup$

I'll post here a slightly modified code suggested by AsukaMinato which achieves what I wanted:

Patterns[len_, k_] := (Clear[dfs];
ResultingPatterns = {};
dfs[number_List] := If[Length[number] == len,
If[Length[Union[If[# < 10, #, 0] & /@ number]] == k,
AppendTo[ResultingPatterns, If[# < 10, #, 0] & /@ number]],
Do[If[i <= 10, dfs[Append[number, i]]], {i, Range[1, Last[Union[number]] + 1]}]];
dfs[{1}];
FromDigits /@ ResultingPatterns);
Patterns[11, 10]
Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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