Este dilema se puede abordar de diversas maneras, pero en este caso te damos la que para nosotros es la solución más completa.
Solución:
Aquí hay un enfoque funcional:
Narciss[x_] := With[num = IntegerDigits[x], Total[num^Length[num]] == x]
Aquí hay una versión compilada de la función anterior:
NarcissC = Compile[x, _Integer,
With[num = IntegerDigits[x], Total[num^Length[num]] == x],
Parallelization -> True, CompilationTarget -> "C",
RuntimeAttributes -> Listable, RuntimeOptions -> "Speed"]
Ahora puedes hacer algo como
AbsoluteTiming[Position[NarcissC[Range[10000000]], True] // Flatten]
1.003214, 1, 2, 3, 4, 5, 6, 7, 8, 9, 153, 370, 371, 407, 1634, 8208, 9474, 54748, 92727, 93084, 548834, 1741725, 4210818, 7,980 9926315
para obtener todo el metro-Números narcisistas del 1 al 10000000.
Para un aumento adicional en la velocidad como lo sugiere chyaong, aquí está NarcissC2 (Utilizando Sum en vez de Total)
NarcissC2 = Compile[x, _Integer,
With[num = IntegerDigits[x], Sum[i^[email protected], i, num] - x],
CompilationTarget -> "C", RuntimeAttributes -> Listable, RuntimeOptions-> "Speed"];
Ahora puedes hacer:
Pick[#, NarcissC2[#], 0] &@Range[10000000] // AbsoluteTiming
Lo que da:
0.475276, 1, 2, 3, 4, 5, 6, 7, 8, 9, 153, 370, 371, 407, 1634, 8208, 9474, 54748, 92727, 93084, 548834, 1741725, 4210818, 7,980 9926315
EDITAR
Resulta que puedes obtener un bache usando Total y Pick en vez de Position (no tan rápido como Sum):
NarcissC1 = Compile[x, _Integer,
With[num = IntegerDigits[x], Total[num^Length[num]] - x], Parallelization -> True,
CompilationTarget -> "C", RuntimeAttributes -> Listable, RuntimeOptions -> "Speed"]
Entonces
Pick[#, NarcissC1[#], 0] &@Range[10000000] // AbsoluteTiming
da:
0.626322, 1, 2, 3, 4, 5, 6, 7, 8, 9, 153, 370, 371, 407, 1634, 8208,
9474, 54748, 92727, 93084, 548834, 1741725, 4210818, 9800817, 9926315
no es una respuesta per sepero dos aclaraciones (que son demasiado largas para la caja de comentarios):
1) La definición de Wiki a la que se ha vinculado para un número narcisista no es realmente adecuada. La página Wiki en realidad describe la definición de un número de Armstrong, también conocido como invariantes digitales pluscuamperfectos, o metro-Números narcisistas, tales como:
$$407 = 4^3 + 0^3 + 7^3$$
Estos requieren el uso del término de potencia $m$ (el 3 en este ejemplo) por encima de los dígitos del entero $n= 407$. Por el contrario, la referencia correcta y adecuada al término ‘número narcisista’ proviene del artículo de Madachy, JS (1966), Matemáticas de vacacionesThomas Nelson & Sons — p.163 a 175, quien los define como números:
“que son representables, de alguna manera, manipulando matemáticamente los dígitos de los propios números”.
Lo que describe la página Wiki… los números de Armstrong… es bastante diferente… no los ‘números narcisistas’, como afirma la página, sino los metro-Números narcisistas. Pero eso es wiki para ti.
2) Finito a infinito: el conjunto de números narcisistas implica una búsqueda finita (como las soluciones anteriores). El problema se vuelve bastante más complicado si permite el uso de radicales o factoriales… porque el problema de búsqueda ya no es finito… sino que puede tener un anidamiento infinito de símbolos de raíces cuadradas o factoriales.
Uno puede obtener algunos resultados bonitos cuando permite radicales, como decir:
Para obtener más detalles, consulte:
http://www.tri.org.au/numQ/pwn/
o una pequeña pieza divertida que hice titulada:
Números narcisistas radicales, Revista de matemáticas recreativas33(4), 2004-2005, 250-254.
He tenido la intención de poner el código mma para esto también… esto se hizo mucho antes de la era de los multiprocesadores, así que creo que tendré que actualizar el código para núcleos paralelos, lo que marcaría una gran diferencia. aquí.
nar[m_] :=
ToExpression[
"Compile[$,Do[With[n=0" <>
StringJoin[
Table["+1" <> Array["0" &, m - 1 - i, 1, StringJoin] <> "a" <>
ToString[m - 1 - i], i, 0, m - 1]] <> ",n2=0" <>
Table["+a" <> ToString[m - 1 - i] <> "^" <> ToString[m], i, 0,
m - 1] <> ",If[n[Equal]n2,[email protected]];];,a0" <>
StringJoin[Table[",0,9,a" <> ToString[i], i, 1, m - 1]] <>
",9],RuntimeOptions[Rule]"Speed",CompilationTarget[Rule]"C"
]"];
Reap[nar[7][0]][[2, 1]] // AbsoluteTiming
(*1.184733, 9926315, 1741725, 9800817, 4210818*)
Mi computadora es bastante lenta. El código de @RunnyKine tarda 0,901549 segundos en mi computadora.
Eres capaz de favorecer nuestro análisis mostrando un comentario o valorándolo te lo agradecemos.