Skip to main content
added 438 characters in body
Source Link
ubpdqn
  • 64.9k
  • 3
  • 65
  • 154

Just to explore those incomplete sets of permutations of digits:

cand = With[{l = PrimePi[100],
    u = PrimePi[10000]},
   GatherBy[Prime /@ Range[l + 1, u - 1], Sort[IntegerDigits@#] &]];
fun[n_] := Multinomial @@ Tally[IntegerDigits@n][[All, 2]]
res = SortBy[Select[cand, Length@# > 1 &], Length];
all = GatherBy[
   If[fun[#[[1]]] == Length@#, Style[#, Red, Bold] & /@ #, #] & /@ 
    res, Length];
Column@With[{s = Ceiling[Sqrt@#] & /@ Length /@ all},
  MapThread[
   Length[#1[[1]]] -> 
     Grid[Partition[PadRight[#1, #2^2, ""], #2], 
      Frame -> True] &, {all, s}]]

enter image description here

To achieve the aim this is relatively quick:

ans = Module[{l = PrimePi[100], u = PrimePi[10000], cand}, 
  cand = GatherBy[Prime /@ Range[l + 1, u - 1], 
    Sort[IntegerDigits@#] &];
  Pick[cand, 
   Multinomial @@ (Tally[IntegerDigits@#[[1]]][[All, 2]]) == 
      Length@# & /@ cand]
  ]

yielding: {{113, 131, 311}, {199, 919, 991}, {337, 373, 733}}

This avoids repeat testing of permutations.

Just to explore those incomplete sets of permutations of digits:

cand = With[{l = PrimePi[100],
    u = PrimePi[10000]},
   GatherBy[Prime /@ Range[l + 1, u - 1], Sort[IntegerDigits@#] &]];
fun[n_] := Multinomial @@ Tally[IntegerDigits@n][[All, 2]]
res = SortBy[Select[cand, Length@# > 1 &], Length];
all = GatherBy[
   If[fun[#[[1]]] == Length@#, Style[#, Red, Bold] & /@ #, #] & /@ 
    res, Length];
Column@With[{s = Ceiling[Sqrt@#] & /@ Length /@ all},
  MapThread[
   Length[#1[[1]]] -> 
     Grid[Partition[PadRight[#1, #2^2, ""], #2], 
      Frame -> True] &, {all, s}]]

enter image description here

Just to explore those incomplete sets of permutations of digits:

cand = With[{l = PrimePi[100],
    u = PrimePi[10000]},
   GatherBy[Prime /@ Range[l + 1, u - 1], Sort[IntegerDigits@#] &]];
fun[n_] := Multinomial @@ Tally[IntegerDigits@n][[All, 2]]
res = SortBy[Select[cand, Length@# > 1 &], Length];
all = GatherBy[
   If[fun[#[[1]]] == Length@#, Style[#, Red, Bold] & /@ #, #] & /@ 
    res, Length];
Column@With[{s = Ceiling[Sqrt@#] & /@ Length /@ all},
  MapThread[
   Length[#1[[1]]] -> 
     Grid[Partition[PadRight[#1, #2^2, ""], #2], 
      Frame -> True] &, {all, s}]]

enter image description here

To achieve the aim this is relatively quick:

ans = Module[{l = PrimePi[100], u = PrimePi[10000], cand}, 
  cand = GatherBy[Prime /@ Range[l + 1, u - 1], 
    Sort[IntegerDigits@#] &];
  Pick[cand, 
   Multinomial @@ (Tally[IntegerDigits@#[[1]]][[All, 2]]) == 
      Length@# & /@ cand]
  ]

yielding: {{113, 131, 311}, {199, 919, 991}, {337, 373, 733}}

This avoids repeat testing of permutations.

Source Link
ubpdqn
  • 64.9k
  • 3
  • 65
  • 154

Just to explore those incomplete sets of permutations of digits:

cand = With[{l = PrimePi[100],
    u = PrimePi[10000]},
   GatherBy[Prime /@ Range[l + 1, u - 1], Sort[IntegerDigits@#] &]];
fun[n_] := Multinomial @@ Tally[IntegerDigits@n][[All, 2]]
res = SortBy[Select[cand, Length@# > 1 &], Length];
all = GatherBy[
   If[fun[#[[1]]] == Length@#, Style[#, Red, Bold] & /@ #, #] & /@ 
    res, Length];
Column@With[{s = Ceiling[Sqrt@#] & /@ Length /@ all},
  MapThread[
   Length[#1[[1]]] -> 
     Grid[Partition[PadRight[#1, #2^2, ""], #2], 
      Frame -> True] &, {all, s}]]

enter image description here