Crear una tabla con profundidad variable y límites interdependientes
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é Nest
pero no llegué muy lejos. Y no quiero usar una función como FactorInteger
y luego Select
las buenas. Estoy buscando una solución que combine la profundidad de Table
y una función (quizás) recursiva de los límites.
Respuestas
Quizás esté buscando números suaves . La función pSmoothOuter
es bastante rápida, pero requiere memoria a medida que el límite superior m
crece. La entrada pmax
es 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}
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.