Crear una tabla con profundidad variable y límites interdependientes

Aug 21 2020

Como ejemplo, quiero encontrar todos los enteros hasta un límite dado que solo tengan ciertos factores primos. Puedo hacerlo de manera eficiente para el caso de 2, 3 y 5 por

g = 100;
t1 = Table[{2^x*3^y*5^z}, {z, 0, Log[g]/Log[5]}, {y, 0, Log[g/(5^z)]/Log[3]}, {x, 0, Log[g/(5^z*3^y)]/Log[2]}]
t2 = Sort[Flatten[t1]]

Pero estoy buscando una solución más general donde podría tener un conjunto de k factores diferentes. Lo intenté Nestpero no llegué muy lejos. Y no quiero usar una función como FactorIntegery luego Selectlas buenas. Estoy buscando una solución que combine la profundidad de Tabley una función (quizás) recursiva de los límites.

Respuestas

2 KennyColnago Aug 22 2020 at 03:30

Quizás esté buscando números suaves . La función pSmoothOuteres bastante rápida, pero requiere memoria a medida que el límite superior mcrece. La entrada pmaxes el cebado máximo permitido.

pSmoothOuter[pmax_Integer, m_] :=
   Block[{s},
      s = 2^Range[0, Log[2, m]];
      Do[
         s = Pick[s = Flatten[Outer[Times, s, p^Range[0, Log[p, m]]]], UnitStep[m - s], 1],
         {p, Prime[Reverse[Range[2, PrimePi[pmax]]]]}];
      Sort[s]]

Por ejemplo,

pSmoothOuter[5,10^2]

{1, 2, 3, 4, 5, 6, 8, 9, 10, 12, 15, 16, 18, 20, 24, 25, 27, 30, 32,
36, 40, 45, 48, 50, 54 , 60, 64, 72, 75, 80, 81, 90, 96, 100}

AbsoluteTiming[{Total[#], Length[#]} &[pSmoothOuter[30, 10^8]]]

{0.015348, {2364148327261, 88415}}

La siguiente versión permite una lista de entrada de primos p, no necesariamente contiguos.

pSmoothOuter[p_List, m_] :=
   Block[{s},
      s = Min[p]^Range[0, Log[Min[p], m]];
      Do[
         s = Pick[s=Flatten[Outer[Times, s, q^Range[0, Log[q, m]]]], UnitStep[m - s], 1],
         {q, Most@Reverse[Sort[p]]}];
      Sort[s]]

Por ejemplo,

pSmoothOuter[{5, 13, 11}, 800]

{1, 5, 11, 13, 25, 55, 65, 121, 125, 143, 169, 275, 325, 605, 625, 715}

2 march Aug 21 2020 at 01:23

Esto debería funcionar. La construcción es difícil de manejar y se puede simplificar, pero al menos esto funciona:

makePrimes[numPrimes_, bound_] := Module[
  {powers = (Prime@Range[numPrimes])^Array[x, numPrimes] // Reverse},
  Sort@Flatten@Table[
    Times @@ powers // Evaluate,
    Sequence @@ MapThread[{#1, 0, #2} &,
      {Reverse@Array[x, numPrimes], 
       Log[bound/Prepend[Most@Exp@Accumulate@Log@powers, 1]]/Reverse@Log@Prime@Range[numPrimes]}
    ] // Evaluate
  ]
]

Luego

makePrimes[3, 100]
(* {1, 2, 3, 4, 5, 6, 8, 9, 10, 12, 15, 16, 18, 20, 24, 25, 27, 30, 32, 36, 40, 45, 48, 50, 54, 60, 64, 72, 75, 80, 81, 90, 96, 100} *)

es la misma lista que en el ejemplo del OP.