Sucesión Fractal o de Levine

Descargar como Notebook

El matemático Lionel Levine de la Universidad de California la introduce en un articulo titulado : Fractal Sequences and Restricted Nim.

Se define como la sucesión que en sus posiciones impares corresponde a la sucesión de los números naturales (comenzando en cero) y en sus posiciones pares es la sucesión original, ella misma.

Para generarla definimos la función s[n],

utilizando el comando Piecewise[ ]:

s[n_] := Piecewise[{{(n - 1)/2, OddQ[n]}, {lista[[n/2]], EvenQ[n]}}]

La cual en las posiciones impares n asigna el valor (n-1)/2, y en las posiciones pares n el elemento que se encuentra en la posición n/2. Calculando los primeros cien elementos de la lista tenemos: en verde los números naturales desde cero y en rojo los primeros elementos de la sucesión, es decir ella se contiene a sí misma por eso se le llama sucesión fractal.

cantidad = 100;
lista = {};
Do[AppendTo[lista, s[n]], {n, cantidad}]
Table[If[EvenQ[n], Text[Style[lista[[n]], Red]], 
  Text[Style[lista[[n]], Green]]], {n, cantidad}]

Determinando la posición en la que encontramos cada elemento, obtenemos:

Table[{n,Row[{Flatten@Position[lista,n]}]},{n, 0, 10}]//TableForm

Observamos, que el número n aparece en la lista en las posiciones:

para valores de k desde 1 en adelante.

Así, también podemos generar la sucesión ubicando en la posición (2 n + 1) 2^(k-1) el valor n para valores de k desde 1 en adelante:

lis = Table[a, {p, 100}];
Do[lis1 = ReplacePart[lis, (2 n + 1) 2^(k - 1) -> n]; 
 lis = lis1, {k, 7}, {n, 0, 49}]
lis1

{0, 0, 1, 0, 2, 1, 3, 0, 4, 2, 5, 1, 6, 3, 7, 0, 8, 4, 9, 2, 10, 5, 11, 1, 12, 6, 13, 3, 14, 7, 15, 0, 16, 8, 17, 4, 18, 9, 19, 2, 20,
10, 21, 5, 22, 11, 23, 1, 24, 12, 25, 6, 26, 13, 27, 3, 28, 14, 29, 7, 30, 15, 31, 0, 32, 16, 33, 8, 34, 17, 35, 4, 36, 18, 37, 9, 38,
19, 39, 2, 40, 20, 41, 10, 42, 21, 43, 5, 44, 22, 45, 11, 46, 23, 47, 1, 48, 24, 49, 12}

Podemos generalizar la anterior sucesión utilizando no necesariamente la sucesión de los números naturales sino cualquier otra sucesión, por ejemplo i[n]:


a[n_]:= Piecewise[{{i[(n - 1)/2],OddQ[n]},{list[[n/2]],EvenQ[n]}}]

cantidad = 100;
list = {};
Do[AppendTo[list, a[n]], {n, cantidad}]
Table[If[EvenQ[n], Text[Style[list[[n]], Red]], 
  Text[Style[list[[n]], Green]]], {n, cantidad}]

Donde también, cada elemento i[n] de la sucesión aparece en la posición (2 n + 1) 2^(k-1) para valores de k desde 1 en adelante.

Table[{i[n],Row[{Flatten@Position[list,i[n]]}]},{n,0,10}]//TableForm

Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas

Frase Célebre de Sofia Kovalevski

Muchas personas que no han estudiado matemáticas
las confunden con la aritmética
y la consideran una ciencia seca y árida.
Lo cierto es que esta ciencia requiere mucha imaginación.

Sofia Kovalevski

Circunferencia de Conway

Descargar como Notebook

Resultado dado a conocer en forma de problema por el matemático John Horton Conway.

Dado un triángulo cualquiera, prolongamos las líneas que forman cada vértice una longitud igual a la longitud del lado opuesto del vértice, y así para los tres vértices del triángulo, obteniendo seis puntos al final de dichas prolongaciones. Obtenemos el siguiente resultado:

Teorema de Conway

 Los seis puntos obtenidos al final de las seis prolongaciones de los segmentos descritas anteriormente desde los tres vértices del triángulo están en una misma circunferencia.

 Esta circunferencia se conoce como la Circunferencia de Conway.

 En el siguiente aplicativo nos ilustra el resultado, tenemos un triángulo de vértices A, B y C con lados opuestos a cada vértice nombrados a, b y c, en el vértice A prolongamos las líneas que lo forman una longitud igual al lado contrario a, y así con los vértices B y C, encontrando seis puntos (dibujados en rojo) por ellos pasa una única circunferencia que corresponde a la Circunferencia de Conway.

Manipulate[dab = EuclideanDistance[a, b]; 
 dac = EuclideanDistance[a, c]; dbc = EuclideanDistance[c, b];
 Show[Graphics[{Text["A", a + 0.2 Sign[a[[1]]]], 
    Text["B", b + 0.2 Sign[b[[1]]]], Text["C", c + 0.2 Sign[c[[1]]]], 
    Text["a", (b + c)/2 + 0.1], Text["b", (a + c)/2 + 0.1], 
    Text["c", (b + a)/2 + 0.1],
    Text["b", b + dac/dab (b - a) 0.5 + 0.1], 
    Text["c", c + dab/dbc (c - b) 0.5 + 0.1], 
    Text["c", c + dab/dac (c - a) 0.5 + 0.1], 
    Text["a", a + dbc/dab (a - b) 0.5 + 0.1], 
    Text["a", a + dbc/dac (a - c) 0.5 + 0.1], 
    Text["b", b + dac/dbc (b - c) 0.5 + 0.1], {Pink, Opacity[0.2], 
     EdgeForm[Directive[Thick, Red]], Triangle[{a, b, c}]}, 
    If[circ, 
     Circumsphere[{b + dac/dab (b - a), c + dab/dbc (c - b), 
      c + dab/dac (c - a)}], Point[a]], {Red, PointSize[Large], 
     Point[{b + dac/dab (b - a), c + dab/dbc (c - b), 
      c + dab/dac (c - a), a + dbc/dab (a - b), b + dac/dbc (b - c), 
       a + dbc/dac (a - c)}]}}, PlotRange -> 4], 
  ParametricPlot[a (1 - t) + b t, {t, -dbc/dab, 1 + dac/dab}, 
   PlotStyle -> Dashed], 
  ParametricPlot[a (1 - t) + c t, {t, -dbc/dac, 1 + dab/dac}, 
   PlotStyle -> Dashed], 
  ParametricPlot[b (1 - t) + c t, {t, -dac/dbc, 1 + dab/dbc}, 
   PlotStyle -> Dashed]], {{a, {1, 1}}, Locator}, {{b, {-1, 1}}, 
  Locator}, {{c, {1, 0}}, 
  Locator}, {{circ, False, "Circunferencia de Conway"}, {False, 
   True}}]

Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas

Frase Célebre de John von Neumann

Si la gente no  cree que las matemáticas son sencillas,
es solo que no se da cuenta de lo complicada que es la vida.

John von Neumann

Teorema de Moessner

Descargar como Notebook

Propuesto por el matemático Alfred Moessner en 1951, pero demostrado al año siguiente por Oskar Perrone.

Es un método de constructivo que partiendo de la sucesión de los números enteros positivos {1,2,3,4,5,6,7,8,9,10,11,...}, consigue la sucesión de las potencias cuadradas {1,4,9,16,...}, cúbicas {1,8,27,64,...} , cuartas {1,16,81,256,..}, etc. de los números enteros positivos.

Teorema de Moessner

dado un número n, mayor que 1, se genera una primera sucesión al tachar de n en n elementos en la sucesión de los números enteros positivos 1, 2, 3, 4, 5, 6, . . . Para generar la segunda sucesión se realizan las sumas acumulativas de los números no tachados, y entonces se tacha de (n - 1) en (n - 1) elementos de la sucesión. Y se continúa así hasta que se tache uno de cada dos elementos de la correspondiente sucesión. Entonces, la sucesión de las sumas acumulativas de los números no tachados de la última sucesión que ha quedado, es precisamente la sucesión de las potencias enésimas de los números naturales, es decir, 1ⁿ, 2ⁿ, 3ⁿ, 4ⁿ, etc.

Cuadrados

Partiendo de la lista de los 20 primeros enteros positivos,

Range[20]

{1,2,3,4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20}

Eliminamos de ella los números de dos en dos, es decir en este caso los pares,

Drop[Range[20], {2, 20, 2}]

{1, 3, 5, 7, 9, 11, 13, 15, 17, 19}

Realizamos las sumas acumuladas en cada posición,

Accumulate@Drop[Range[20], {2, 20, 2}]

{1, 4, 9, 16, 25, 36, 49, 64, 81, 100}

Obteniendo los cuadrados de los enteros positivos.

Range[10]^2

{1, 4, 9, 16, 25, 36, 49, 64, 81, 100}

Cubos

Nuevamente partiendo de la lista de los primeros 20 números enteros positivos, ahora vamos a eliminar de tres en tres :

Range[20]

{1,2,3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,20}

Drop[Range[20], {3, 20, 3}]

{1, 2, 4, 5, 7, 8, 10, 11, 13, 14, 16, 17, 19, 20}

Realizamos sus sumas parciales

Accumulate@Drop[Range[20], {3, 20, 3}]

{1, 3, 7, 12, 19, 27, 37, 48, 61, 75, 91, 108, 127, 147}

Eliminamos de dos en dos y volvemos a sumar,

Accumulate@Drop[Accumulate@Drop[Range[20], {3, 20, 3}], {2, 14, 2}]

{1, 8, 27, 64, 125, 216, 343}

Obtenemos los cubos, potencias terceras, de los enteros positivos.

Range[7]^3

{1, 8, 27, 64, 125, 216, 343}

Generalización del Método

Definimos la función moessner[n,m], donde n representa el orden de potencia que deseamos y m la longitud de la lista de potencias deseada.

moessner[n_Integer, m_Integer] := 

 Module[{p, q}, p[0] = Range[n m]; 

  Print[Column[{Row[{"De la lista de los primeros ", n m, 

       " enteros positivos, marcamos los multiplos de " , n, 

       " que se van a eliminar:"}], 

     Table[If[Mod[k, n] == 0, Text[p[0][[k]], Background -> Yellow], 

       p[0][[k]]], {k, n m}]}]]; i = 1; 

  While[i < n, 

   q[i] = Drop[p[i - 1], {n - i + 1, Length[p[i - 1]], n - i + 1}]; 

   p[i] = Accumulate[q[i]]; 

   Print[Column[{"Lista resultante después de la eliminación de los términos antes señalados:", q[i]}]];

   

   If[i < n - 1, 

    Print[Column[{Row[{"Sumas acumuladas de la lista anterior, marcando de ", n - i, " en ", n - i, " los próximos a eliminar:"}], 

       Table[If[Mod[k, n - i] == 0, 

         Text[p[i][[k]], Background -> Yellow], p[i][[k]]], {k, 

         Length[p[i]]}]}]], 

    Print[Column[{"Al realizar las sumas acumuladas obtenemos las potencias deseadas:", p[i]}]]]; i++]]

La función moessner así definida, nos va "narrando" el proceso que se sigue durante la construcción dada en el Teorema de Moessner. 

Por ejemplo,  determinaremos las potencias sextas de los primeros 10 enteros positivos. 

Comprobemos la respuesta que hemos obtenido:

Range[10]^6
{1, 64, 729, 4096, 15625, 46656, 117649, 262144, 531441, 1000000}

que corresponde a la última salida de la función moessner.


Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas