Después de de esta prolongada recopilación de datos dimos con la solución esta problema que tienen muchos de nuestros lectores. Te brindamos la respuesta y deseamos resultarte de mucha apoyo.
Solución:
Función recursiva
Comencemos con la función recursiva simple proporcionada por @ corey979:
ClearAll[fRecursive]
fRecursive[1] = 2;
fRecursive[n_] := fRecursive[n] =
Count[Table[fRecursive[k], k, 1, n-2], fRecursive[n - 1]]
Funciona como se esperaba:
Array[fRecursive, 15]
(* 2, 0, 0, 1, 0, 2, 1, 1, 2, 2, 3, 0, 3, 1, 3 *)
pero es un poco lento:
Table[fRecursive[i], i, 10^4] // MaxMemoryUsed // AbsoluteTiming
(* 23.9591, 2043888 *)
Función no recursiva
General
Para escribir una versión más rápida, pensemos qué conocimiento, sobre los elementos anteriores, necesitamos para calcular el siguiente elemento.
En fRecursive, en cada n-th paso, creamos una lista de todos los elementos hasta n-2 (dado que se usa la memorización, no los recalculamos) y contamos el número de apariciones de n-1 elemento en esa lista. Si n-1 El elemento está en la lista, significa que en algún paso anterior ya teníamos que calcular el número de sus apariciones en una sublista de la lista utilizada actualmente, por lo que si lleváramos información sobre recuentos anteriores, entre iteraciones, posiblemente podríamos acelerar los cálculos.
Como “contador”, necesitamos un mapeo de enteros no negativos, que representan elementos de secuencia que queremos generar, a enteros no negativos que representan el número de apariciones de esos elementos en secuencia generados hasta ahora. Dado que los elementos de secuencia son recuentos de algunos elementos en una secuencia ya generada, no pueden ser mayores que el número total de elementos de secuencia que queremos generar (excepto el primer elemento que puede ser arbitrariamente grande), por lo que nuestro mapeo se puede implementar como una matriz de enteros con una longitud igual al índice máximo del elemento que queremos generar.
Inicialmente no hay elementos en secuencia, así que comenzamos con una matriz de ceros “contador”. En cada paso tomamos el elemento “actual” de la secuencia, ya que aparece en secuencia, incrementamos el valor del “contador” asociado con el elemento actual y tomamos el resultado como un nuevo elemento “actual” para la siguiente iteración. Nuestra secuencia esperada es una lista de valores “actuales” consecutivos.
El algoritmo anterior se implementa en la siguiente función, que proporciona elementos con índices de min para max de la secuencia que comienza con n0 valor:
ClearAll[fGeneral]
fGeneral = Compile[n0, _Integer, min, _Integer, max, _Integer,
Module[current = -1, counter = Table[0, max + 2],
counter[[1]] = n0;
Do[current = counter[[current + 2]]++, min - 1];
Table[current = counter[[current + 2]]++, max - min + 1]
],
RuntimeOptions -> "Speed", CompilationTarget -> "C"
];
Obtenemos los resultados esperados:
fGeneral[2, 1, 15]
(* 2, 0, 0, 1, 0, 2, 1, 1, 2, 2, 3, 0, 3, 1, 3 *)
fGeneral[2, 10, 15]
(* 2, 3, 0, 3, 1, 3 *)
lo mismo que con la función recursiva:
fGeneral[2, 1, 10^3] === Array[fRecursive, 10^3]
(* True *)
pero mucho más rápido y usando mucha menos memoria:
fGeneral[2, 1, 10^4] // MaxMemoryUsed // AbsoluteTiming
(* 0.00008, 320560 *)
Tenga en cuenta que desde nuestro counter puede manejar como máximo max valores, la función anterior dará un error si n0 el valor es mayor que max. Nos ocuparemos de este caso especial más tarde.
Buscando un patrón
Ahora, para encontrar más optimizaciones, veamos la tabla de valores de nuestra secuencia como en la respuesta de @m_goldberg y la respuesta de @ubpdqn.
Table[
Module[max = 100, list, n0SecondPos, n0PlusOnePos,
list = fGeneral[n0, 1, max];
n0SecondPos = Position[list, n0, 1, 2][[2, 1]];
n0PlusOnePos =
Replace[Position[list, n0 + 1, 1, 1], i_ :> i, -> max + 1];
Join[
Take[list, 1],
Style[#, Red] & /@ Take[list, 2, n0SecondPos],
Take[list, n0SecondPos + 1, n0PlusOnePos - 1],
Style[#, Blue] & /@ Take[list, n0PlusOnePos, -1]
]
],
n0, 0, 10
] // TableForm
(Has click en la imagen para agrandarla)
Pequeños elementos
Podemos ver que hasta la segunda aparición del primer elemento de secuencia, siempre hay enteros consecutivos, comenzando desde cero, entrelazados con ceros (elementos rojos).
Así que elementos hasta 2 n0 + 2 se puede generar utilizando la siguiente función, aprovechando las operaciones vectorizadas rápidas e integradas:
ClearAll[fSmall]
fSmall = Function[n0, min, max,
Module[result = Quotient[Range[min - 2, max - 2], 2],
result[[(2 - Mod[min, 2]) ;; ;; 2]] = 0;
If[min === 1, result[[1]] = n0];
result
]
];
Obtenemos los resultados esperados:
fSmall[2, 1, 2 2 + 2]
(* 2, 0, 0, 1, 0, 2 *)
lo mismo que con fGeneral función:
fSmall[2, 1, 2 2 + 2] === fGeneral[2, 1, 2 2 + 2]
(* True *)
fSmall[10^7, 1, 2 10^7 + 2] === fGeneral[10^7, 1, 2 10^7 + 2]
(* True *)
pero más rápido y con menos memoria:
fSmall[10^7, 1, 2 10^7 + 2] // MaxMemoryUsed // AbsoluteTiming
(* 0.269374, 320001984 *)
fGeneral[10^7, 1, 2 10^7 + 2] // MaxMemoryUsed // AbsoluteTiming
(* 0.424444, 640000640 *)
Usaremos fSmall para generar secuencias “relativamente pequeñas”, es decir, aquellas con max <= 2 n0 + 2. Tenga en cuenta que esto se encargará automáticamente de los casos especiales para los que fGeneral no funciona, es decir, aquellos con max < n0
Elementos grandes
La segunda observación relevante es la generalización del descubrimiento hecha por @Watson y @m_goldberg. A partir de la primera aparición de n0+1 valor, podemos ver un patrón simple (elementos azules).
Dependencia de la posición del primero n0+1 valor en n0 puede ser encontrado por Mathematica:
Table[Position[fGeneral[n0, 1, 10^3], n0 + 1, 1, 1][[1, 1]], n0, 30] //
FindSequenceFunction
(* 3 + 2 #1 + #1^2 & *)
Para elementos a partir de n0^2 + 2 n0 + 3 podemos ver el patrón descrito por m_goldberg y Watson.
partitionedTable = Module[min = #^2 + 2 # + 3, k = 2 # + 2,
Partition[fGeneral[#, min, min + 10 k], k] // TableForm
] &;
[email protected]
$ begin array cccccc 3 & 0 & 3 & 1 & 3 & 2 \ 4 & 0 & 4 & 1 & 4 & 2 \ 5 & 0 & 5 & 1 & 5 & 2 \ 6 & 0 & 6 & 1 & 6 & 2 \ 7 & 0 & 7 & 1 & 7 & 2 \ 8 & 0 & 8 & 1 & 8 & 2 \ 9 & 0 & 9 & 1 & 9 & 2 \ 10 & 0 & 10 & 1 & 10 & 2 \ 11 & 0 & 11 & 1 & 11 & 2 \ 12 & 0 & 12 & 1 & 12 & 2 \ end array $
[email protected]$ begin array cccccccccccc 6 & 0 & 6 & 1 & 6 & 2 & 6 & 3 & 6 & 4 & 6 & 5 \ 7 & 0 & 7 & 1 & 7 & 2 & 7 & 3 & 7 & 4 & 7 & 5 \ 8 & 0 & 8 & 1 & 8 & 2 & 8 & 3 & 8 & 4 & 8 & 5 \ 9 & 0 & 9 & 1 & 9 & 2 & 9 & 3 & 9 y 4 y 9 y 5 \ 10 y 0 y 10 y 1 y 10 y 2 y 10 y 3 y 10 y 4 y 10 y 5 \ 11 y 0 y 11 y 1 y 11 y 2 y 11 y 3 y 11 y 4 y 11 y 5 \ 12 y 0 y 12 y 1 y 12 y 2 y 12 y 3 y 12 y 4 y 12 y 5 \ 13 y 0 y 13 y 1 y 13 y 2 y 13 y 3 y 13 y 4 y 13 y 5 \ 14 y 0 y 14 y 1 y 14 y 2 y 14 y 3 y 14 y 4 y 14 y 5 \ 15 y 0 y 15 y 1 y 15 y 2 y 15 y 3 y 15 y 4 y 15 y 5 \ end array $
[email protected]$ begin array cccccccccccccccccccc 10 & 0 & 10 & 10 & 2 & 10 & 3 & 10 & 4 & 10 & 5 & 10 & 6 & 10 & 7 & 10 & 8 & 10 & 9 \ 11 y 0 y 11 y 1 y 11 y 2 y 11 y 3 y 11 y 4 y 11 y 5 y 11 y 6 y 11 y 7 y 11 y 8 y 11 y 9 \ 12 y 0 y 12 y 1 y 12 & 2 & 12 & 3 & 12 & 4 & 12 & 5 & 12 & 6 & 12 & 7 & 12 & 8 & 12 & 9 \ 13 & 0 & 13 & 1 & 13 & 2 & 13 & 3 & 13 & 4 & 13 & 5 & 13 & 6 & 13 & 7 & 13 & 8 & 13 & 9 \ 14 & 0 & 14 & 1 & 14 & 2 & 14 & 3 & 14 & 4 & 14 & 5 & 14 & 6 & 14 & 7 & 14 & 8 & 14 & 9 \ 15 & 0 & 15 & 1 & 15 & 2 & 15 & 3 & 15 & 4 & 15 & 5 & 15 & 6 & 15 & 7 & 15 & 8 & 15 y 9 \ 16 y 0 y 16 y 1 y 16 y 2 y 16 y 3 y 16 y 4 y 16 y 5 y 16 y 6 y 16 y 7 y 16 y 8 y 16 y 9 \ 17 y 0 y 17 y 1 y 17 y 2 y 17 y 3 y 17 y 4 y 17 y 5 y 17 y 6 y 17 y 7 y 17 y 8 y 17 y 9 \ 18 y 0 y 18 y 1 y 18 y 2 y 18 & 3 & 18 & 4 & 18 & 5 & 18 & 6 & 18 & 7 & 18 & 8 & 18 & 9 \ 19 & 0 & 19 & 1 & 19 & 2 & 19 & 3 & 19 & 4 & 19 & 5 y 19 y 6 y 19 y 7 y 19 y 8 y 19 y 9 \ end array $
Las listas con elementos que siguen el patrón anterior se pueden generar usando la siguiente función:
ClearAll[fLarge]
fLarge = Compile[n0, _Integer, min, _Integer, max, _Integer,
Module[shift = n0^2 + 2 n0 + 3,
Table[
If[EvenQ[i],
Quotient[i, 2 n0 + 2] + n0 + 1
(* else *),
Quotient[Mod[i, 2 n0 + 2] - 1, 2]
],
i, min - shift, max - shift
]
],
RuntimeOptions -> "Speed", CompilationTarget -> "C"
];
Da los resultados esperados:
fLarge[2, 2^2 + 2 2 + 3, 15]
(* 3, 0, 3, 1, 3 *)
lo mismo que con fGeneral función:
fLarge[2, 2^2 + 2 2 + 3, 10^7] === fGeneral[2, 2^2 + 2 2 + 3, 10^7]
(* True *)
fLarge[10^2, 10^4 + 2 10^2 + 3, 10^7] === fGeneral[10^2, 10^4 + 2 10^2 + 3, 10^7]
(* True *)
la generación de listas grandes es más lenta que con fGeneral:
fLarge[2, 2^2 + 2 2 + 3, 10^7] // MaxMemoryUsed // AbsoluteTiming
(* 0.556881, 240000192 *)
fGeneral[2, 2^2 + 2 2 + 3, 10^7] // MaxMemoryUsed // AbsoluteTiming
(* 0.11998, 320000320 *)
pero algoritmo utilizado en fLarge, en contraste con fGeneral, no necesita generar todos los elementos anteriores, por lo que es mucho más rápido cuando necesitamos generar una secuencia de elementos con un valor relativamente alto min índice.
Por ejemplo, la generación de un solo elemento es mucho más rápida y casi no usa memoria:
fLarge[2, 10^7, 10^7] // MaxMemoryUsed // AbsoluteTiming
(* 0.000016, 352 *)
fGeneral[2, 10^7, 10^7] // MaxMemoryUsed // AbsoluteTiming
(* 0.059807, 80000480 *)
Empíricamente fLarge se vuelve más rápido, más o menos, cuando min > 9/10 max (al menos en mi computadora):
fLarge[2, 9 10^6, 10^7] // MaxMemoryUsed // AbsoluteTiming
(* 0.056439, 24000472 *)
fGeneral[2, 9 10^6, 10^7] // MaxMemoryUsed // AbsoluteTiming
(* 0.05865, 104000600 *)
Función final
Juntando las tres funciones obtenemos:
ClearAll[fInternal]
fInternal = Function[n0, min, max,
Which[
max <= 2 n0 + 2,
fSmall[n0, min, max],
9 max < 10 min && min >= n0^2 + 2 n0 + 3,
fLarge[n0, min, max],
True,
fGeneral[n0, min, max]
]
];
Nuestra función final con pruebas básicas sobre patrones de argumentos:
ClearAll[f]
f[n0_Integer?NonNegative, min_Integer?Positive, max_Integer?Positive] /; min <= max := fInternal[n0, min, max]
f[n0_Integer?NonNegative, max_Integer?Positive] := fInternal[n0, 1, max]
f[n0_Integer?NonNegative, n_Integer?Positive] := [email protected][n0, n, n]
Primer argumento de f la función es el primer elemento de la secuencia, el segundo argumento es la especificación de secuencia estándar, por lo que n daré n-th elemento de secuencia, min, max dará una lista que contiene elementos de min para max, max dará elementos de 1 a max.
f[2, 15]
(* 2, 0, 0, 1, 0, 2, 1, 1, 2, 2, 3, 0, 3, 1, 3 *)
f[2, 9, 15]
(* 2, 2, 3, 0, 3, 1, 3 *)
f[2, 15]
(* 3 *)
f[1] = 2;
Para calcular $ x_ n + 1 $ desea verificar cuántos $ x_n $ hay en el conjunto $ x_1, ldots, x_ n-1 $, es decir, para f[n] quieres generar un Table de f[1],...,f[n-2]:
Table[f[k], k, 1, n - 2]
y cuenta cuantos f[n-1]están ahí:
f[n_] := Count[Table[f[k], k, 1, n - 2], f[n - 1]]
Alternativamente, puede cambiar el índice en 1 (lo que no afecta la salida de Table):
f[n_] := Count[Table[f[k - 1], k, 2, n - 1], f[n - 1]]
En cualquier caso,
Table[f[i], i, 1, 14]
2, 0, 0, 1, 0, 2, 1, 1, 2, 2, 3, 0, 3, 1
EDITAR: De hecho, en el caso de $ n = 30 $, se necesita una cantidad de tiempo demasiado larga para esperar la salida. Esto se puede resolver con la construcción estándar.
f[n_]:=f[n]=...
Luego,
Table[f[i], i, 1, 1000]; // AbsoluteTiming
0.267906, nulo
Hasta $ n = 200 $:
EDITAR: Una animación interesante de lo anterior (crédito a Lovsovs).
Comportamiento interesante de esta regla:
Ya hay dos respuestas, pero creo que aún podría ser interesante reconsiderar el problema.
Mi idea es escribir un generador s[n] para la secuencia f[1], f[2], ..., f[n] y luego, deberíamos necesitar f, para que siempre podamos definirlo como
f[n_Integer?Positive] := s[n][[-1]]
El generador es bastante simple cuando se expresa como una función recursiva.
s[1] = 2; s[2] = 2, 0;
s[n_] := s[n] =
Module[prev = s[n - 1], prev~Join~Count[s[n - 2], prev[[-1]]]]
Luego
s[14]
2, 0, 0, 1, 0, 2, 1, 1, 2, 2, 3, 0, 3, 1
y
ListPlot[s[200], AspectRatio -> 1/2, ImageSize -> 500]
La regularidad de la trama sugiere que existe una solución simple no recursiva. Deberíamos investigar eso.
Evaluar s[40] da
2, 0, 0, 1, 0, 2, 1, 1, 2, 2, 3, 0, 3, 1, 3, 2, 4, 0, 4, 1, 4, 2, 5, 0, 5, 1, 5, 2, 6, 0, 6, 1, 6, 2, 7, 0, 7, 1, 7, 2
Después de diez enteros algo irregulares, la secuencia se establece en bloques de seis de la forma ..., k, 0, k, 1, k, 3, k + 1, 0, k + 1, 1, k + 1, 2, .... Esto se puede codificar como
Clear[f]
MapThread[
Set[f[#1], #2] &, Range[10], 2, 0, 0, 1, 0, 2, 1, 1, 2, 2];
f[n_Integer /; n > 10] :=
Module[q, r,
q, r = QuotientRemainder[n - 11, 6];
Switch[r,
0 | 2 | 4, 3 + q,
1 | 3 | 5, (r - 1)/2]]
Como prueba:
Table[f[i], i, 40]
que, por supuesto, da el mismo resultado que s[40].
Esta versión de f es bien rapido.
AbsoluteTiming[Do[f[i], i, 10000]]
0.112455, Null
PD: Quizás este sea un ejemplo de lo que Stephen Wolfram llama pensamiento computacional. Es decir, en lugar de hacer matemáticas para obtener el resultado, simplemente jugué con Mathematica.
Recuerda que puedes permitirte reseñar si te fue útil.