Frase Célebre de Joi Ito

La educación es lo que otros hacen para ti, 
y el aprendizaje es lo que haces tú mismo para ti.

Joi Ito

Juego del Caos cambiando el dado al orden del Genoma

Descargar como Notebook

En la publicación del Juego del Caos del 24 de abril del 2018 había mencionado el procedimiento dado por Michael Bransley para la generación de Fractales que también denominó Ping Pong Fractal, el procedimiento consistía en:

Se parte de tres puntos en una hoja A, B y C (que llamaremos vértices) no colineales, sobre la misma recta,  y otro punto P (que llamaremos punto de partida), se toma un dado y se lanza si el resultado es 1 o 2 nos dirigimos desde P hasta A pero nos quedamos a mitad de camino, si es 3 o 4 lo mismo pero dirigiéndonos a B y si es 5 o 6 dirigiéndonos a C, marcamos el punto sobre la hoja y volvemos a repetir el procedimiento desde el punto que nos habíamos quedado.

Al realizar este proceso se encuentra el triángulo de Sierpinski. Lo que vamos a ver ahora es que al aumentar el número de puntos (vértices) se encuentra un comportamiento fractal excepto para cuatro vértices.

Triángulo

puntos = 3;
vertices = 
  Table[0.5 {Cos[2 \[Pi] n/puntos] + 1, 
     Sin[2 \[Pi] n/puntos] + 1}, {n, 0, puntos - 1, 1}];
inicio = {0, 0};
ran := RandomChoice[Table[1./puntos, {n, puntos}] -> Range[puntos], 
   1][[1]]
siguiente[punto_] := (vertices[[ran]] + punto)/2.
ListPlot[NestList[siguiente, inicio, 100000], 
 PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
 Axes -> False, PlotStyle -> PointSize[0.001]]

Cuadrado

puntos = 4;
vertices = 
  Table[0.5 {Cos[2 \[Pi] n/puntos] + 1, 
     Sin[2 \[Pi] n/puntos] + 1}, {n, 0, puntos - 1, 1}];
inicio = {0, 0};
ran := RandomChoice[Table[1./puntos, {n, puntos}] -> Range[puntos], 
   1][[1]]
siguiente[punto_] := (vertices[[ran]] + punto)/2.
ListPlot[NestList[siguiente, inicio, 100000], 
 PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
 Axes -> False, PlotStyle -> PointSize[0.001]]

Y así sucesivamente obtenemos:

Pentágono

Hexágono

Heptágono

Octágono

Cambiando el Dado

El dado para las anteriores presentaciones lo hemos simulado con el comando RandomChoice que nos permite elegir el número de posibilidades (caras del dado) y la probabilidad de cada uno, en todos hemos tomado un dado homogéneo (igual probabilidad para todos los resultados).

Vamos a centrar nuestro trabajo en el cuadrado, que fue la única estructura que no formó un fractal.

Aquí viene la gran curiosidad, Mathematica tiene incorporada en su base de datos  los resultados del Genoma Humano en el comando GenomaData, donde podemos encontrar de casi 40000 genes su secuencia de ADN:

GenomeData[]

Para cada gen su secuencia corresponde a un listado de A: adenina, T: timina, C: citosina y G: guanina. Esta secuencia no es aleatoria pero para el no experto así lo parece, pues para mí lo es y la tomaré como los resultados del dado para seguir el Juego del Caos. To memos un gen cualquiera, tal parece que es indiferente de la elección, por ejemplo "7A5" y etiquetemos los vértices del cuadrado con A, T, C y G.

gen7A5 = Characters@GenomeData["7A5"]

lista = gen7A5;
long = Length[lista];
rango[n_] := 
 Which[lista[[n]] == "A", 1, lista[[n]] == "C", 2, lista[[n]] == "G", 
  3, lista[[n]] == "T", 4]
dado = Table[rango[n], {n, Length[lista]}];
vertices = {{0, 0}, {1, 0}, {0, 1}, {1, 1}};

siguiente[punto_] := 
 Module[{num}, num = First[dado]; 
  dado = Rest[dado]; (vertices[[num]] + punto)/2.]
Show[ListPlot[NestList[siguiente, {0, 0}, Length[lista] - 1], 
  PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
  Axes -> False, PlotStyle -> PointSize[0.001]], 
 Graphics[{Text["A", {-0.1, -0.1}], Text["C", {1.1, -0.1}], 
   Text["T", {1.1, 1.1}], Text["G", {-0.1, 1.1}]}]]

La figura obtenida tiene un claro comportamiento fractal.

Cambiando el orden de las letras

Al cambiar el orden de los vértices se obtiene una figura diferente.

lista = gen7A5;
long = Length[lista];
rango[n_] := 
 Which[lista[[n]] == "A", 1, lista[[n]] == "C", 2, lista[[n]] == "G", 
  3, lista[[n]] == "T", 4]
dado = Table[rango[n], {n, Length[lista]}];
vertices = {{0, 0}, {1, 0}, {1, 1}, {0, 1}};

siguiente[punto_] := 
 Module[{num}, num = First[dado]; 
  dado = Rest[dado]; (vertices[[num]] + punto)/2.]
Show[ListPlot[NestList[siguiente, {0, 0}, Length[lista] - 1], 
  PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
  Axes -> False, PlotStyle -> PointSize[0.001]], 
 Graphics[{Text["A", {-0.1, -0.1}], Text["C", {1.1, -0.1}], 
   Text["G", {1.1, 1.1}], Text["T", {-0.1, 1.1}]}]]

Manteniendo las mismas probabilidades

Considerando como probabilidades del dado en el comando RandomChoice la frecuencia de cada una de las letras en el Gen.

Tally[gen7A5]
{{"A", 25868}, {"T", 26721}, {"G", 15652}, {"C", 14495}}

Length[gen7A5]
82736

vertices = {{0, 0}, {1, 0}, {0, 1}, {1, 1}};
inicio = {1, 1};
ran := RandomChoice[{0.312657, 0.175196, 0.18918, 0.322967} -> {1, 2, 
     3, 4}, 1][[1]]
siguiente[punto_] := (vertices[[ran]] + punto)/2
ListPlot[NestList[siguiente, inicio, 100000], 
 PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
 Axes -> False, PlotStyle -> PointSize[0.001]]

Otro Gen

Ahora, por ejemplo al realizar el mismo proceso con el Gen "ZZZ3", se sigue manteniendo el mismo resultado.

lista = genZZZ3;
long = Length[lista];
rango[n_] := 
 Which[lista[[n]] == "A", 1, lista[[n]] == "C", 2, lista[[n]] == "G", 
  3, lista[[n]] == "T", 4]
dado = Table[rango[n], {n, Length[lista]}];
vertices = {{0, 0}, {1, 0}, {0, 1}, {1, 1}};

siguiente[punto_] := 
 Module[{num}, num = First[dado]; 
  dado = Rest[dado]; (vertices[[num]] + punto)/2]
ListPlot[NestList[siguiente, {0, 0}, Length[lista] - 1], 
 PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
 Axes -> False, PlotStyle -> PointSize[0.001]]

Tal parece que este comportamiento fractal se encuentra con cualquier Gen y en cursos de Genética computacional este es un tema de estudio.


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 Leonard Euler

Mejor que de nuestro juicio, 
debemos fiarnos del cálculo algebraico.

Leonard Euler

Espirales Complejas

Descargar como Notebook

Para un número complejo z cercano a la circunferencia unitaria, de radio uno y centrada en el origen, calculamos sus primeras cien potencias y las juntamos por medio de rectas o curvas.

Obtenemos figuras muy bellas sobre todo en la parte real negativa, parte izquierda de la circunferencia.

it[z_] := 
 Module[{aa, r, i}, aa = Table[z^n, {n, 1, 100, 1}]; r = Re[aa]; 
  i = Im[aa]; Transpose[{r, i}]]
gra1 = ContourPlot[x^2 + y^2 == 1, {x, -5, 5}, {y, -5, 5}, 
   ContourStyle -> {Dashed, Red}, Frame -> False];

Manipulate[z := w[[1]] + I w[[2]]; 
 If[Abs[z] < 1, Show[gra1, ListPlot[it[z], Joined -> join]], 
  Show[gra1, 
   ListPlot[it[z], Joined -> join, 
    InterpolationOrder -> by]]], {{w, {1, 0}}, {-2, -2}, {2, 2}, 
  Locator}, {join, {False, True}}, {{by, 1}, {1 -> "lines", 
   2 -> "curves"}}, SaveDefinitions -> True]

Veamos algunos ejemplos:

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 Pierre Simon Laplace

En el fondo la teoría de probabilidades 
es sólo sentido común expresado con números.

Pierre Simon Laplace

Insertar una Imagen en un Manipulate

Descargar como Notebook

Tomamos como imagen la de un carro que hemos encontrado en Google Imágenes, la incorporamos dentro de un entorno Graphics con el comando Inset[ ].

Manipulate[
 Show[Graphics[{Inset[carro, {a, b}], Arrow[{{0, 0}, {a, b}}]}, 
   Axes -> True], PlotRange -> 5], {a, -4, 4}, {b, -4, 4}]

Podemos también, modificar su posición y orientación de tal forma que de la apariencia de recorrer un camino montañoso simulado por la función seno. Su orientación la modificamos con la derivada.

Manipulate[
 Show[Plot[Sin[x], {x, 0, 2 Pi}, PlotRange -> {-2, 2}], 
  Graphics[Inset[carro, {a, Sin[a]}, Center, 1, {1, Cos[a]}]]], {a, 0, 2 Pi}]

Creación de los Gifs de cada Manipulate

Export[NotebookDirectory[] <> "carro1.gif", 
 Manipulate[
  Show[Graphics[{Inset[carro, {a, b}], Arrow[{{0, 0}, {a, b}}]}, 
    Axes -> True], PlotRange -> 5], {a, -4, 4}, {b, -4, 4}], 
 "AnimationRepetitions" -> Infinity]

Export[NotebookDirectory[] <> "carro2.gif", 
 Manipulate[
  Show[Plot[Sin[x], {x, 0, 2 Pi}, PlotRange -> {-2, 2}], 
   Graphics[Inset[carro, {a, Sin[a]}, Center, 1, {1, Cos[a]}]]], {a, 
   0, 2 Pi}], "AnimationRepetitions" -> Infinity]


Recuerde que los Gif los guarda en la misma carpeta donde se encuentra en Notebook desde el que los genera.


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 Proclo

La matemática: 
te recuerda la forma invisible del alma;
da luz a sus propios descubrimientos;
despierta la mente y purifica el intelecto;
ilumina nuestras ideas intrínsecas;
elimina el olvido y la ignorancia que nace con nosotros.

Proclo

Números Inversos de Fibonacci

Descargar como Notebook

Son los números enteros positivos que al calcularle su inverso multiplicativo tienen en sus cifras decimales no nulas los primeros términos de la sucesión de Fibonacci, de la cual hablamos en la entrada de Sucesiones Recurrentes.

Consideremos el número 9999999999999999999899999999999999999999 formado por 19 nueves, un ocho y veinte nueves, es decir en total tiene 40 cifras todas nueves excepto la número 20 que es un ocho. Determinemos las primeras 1000 cifras de su inverso multiplicativo:

N[1/9999999999999999999899999999999999999999, 1000]
1.0000000000000000000100000000000000000002000000000000000000030000000000000000000500000000000000000008000000000000000000130000000000000000002100000000000000000034000000000000000000550000000000000000008900000000000000000144000000000000000002330000000000000000037700000000000000000610000000000000000009870000000000000000159700000000000000002584000000000000000041810000000000000000676500000000000000010946000000000000000177110000000000000002865700000000000000046368000000000000000750250000000000000012139300000000000000196418000000000000003178110000000000000051422900000000000000832040000000000000013462690000000000000217830900000000000003524578000000000000057028870000000000000922746500000000000014930352000000000000241578170000000000003908816900000000000063245986000000000001023341550000000000016558014100000000000267914296000000000004334944370000000000070140873300000000001134903170000000000018363119030000000000297121507300000000004807526976000000000077787420490000000001258626902500000000020365011074*10^-40

si las tomamos en grupos de 20, tenemos:

lista = Partition[
  Rest[RealDigits[
     N[1/9999999999999999999899999999999999999999, 1000]][[1]]], 20]

Que transformándolos en números obtenemos la lista, que corresponde a los números de Fibonacci en las posiciones 2 a la 51:

Map[FromDigits, lista]

{1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987, 1597, 2584, 4181, 6765, 10946, 17711, 28657, 46368, 75025, 121393, 196418, 317811, 514229, 832040, 1346269, 2178309, 3524578, 5702887, 9227465, 14930352, 24157817, 39088169, 63245986, 102334155, 165580141, 267914296, 433494437, 701408733, 1134903170, 1836311903, 2971215073, 4807526976, 7778742049, 12586269025, 20365011074}

Primeros 51 términos de la sucesión de Fibonacci :

Table[Fibonacci[n], {n, 51}]

{1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987, 1597, 2584, 4181, 6765, 10946, 17711, 28657, 46368, 75025, 121393, 196418, 317811, 514229, 832040, 1346269, 2178309, 3524578, 5702887, 9227465, 14930352, 24157817, 39088169, 63245986, 102334155, 165580141, 267914296, 433494437, 701408733, 1134903170, 1836311903, 2971215073, 4807526976, 7778742049, 12586269025, 20365011074}

La razón tiene que ver con lo que ya explicamos en la entrada de Sucesiones Recurrentes, la sucesión de Fibonacci la podemos definir de forma recurrente como:

f (n+2) = f (n +1) + f (n) con f (1) = 1, f (0) = 1

es decir, un término se obtiene como la suma de los dos anteriores, donde los dos primeros son cero y uno. Al calcularle su función generatriz, obtenemos:

RSolve[{f[n + 2] == f[n + 1] + f[n], f[1] == 1, f[2] == 1}, f[n], n]

{{f[n] -> Fibonacci[n]}}

GeneratingFunction[Fibonacci[n], n, x]

Que al ser desarrollada como una serie de potencias, tiene como coeficientes la sucesión de Fibonacci:

Normal@Series[-(x/(-1 + x + x^2)), {x, 0, 20}]

x + x^2 + 2 x^3 + 3 x^4 + 5 x^5 + 8 x^6 + 13 x^7 + 21 x^8 + 34 x^9 + 
 55 x^10 + 89 x^11 + 144 x^12 + 233 x^13 + 377 x^14 + 610 x^15 + 
 987 x^16 + 1597 x^17 + 2584 x^18 + 4181 x^19 + 6765 x^20

Al calcular en la función generatriz, inversos de potencias de 10 obtenemos en el denominador los números inversos de Fibonacci:

g[1/10^20]

y al calcular inversos de las potencias de 10 en la serie se comprende la razón de la formación de la sucesión de Fibonacci en las cifras decimales de los números inversos de Fibonacci.

s[x_] := x + x^2 + 2 x^3 + 3 x^4 + 5 x^5 + 8 x^6 + 13 x^7 + 21 x^8 + 
  34 x^9 + 55 x^10 + 89 x^11 + 144 x^12 + 233 x^13 + 377 x^14 + 
  610 x^15 + 987 x^16 + 1597 x^17 + 2584 x^18 + 4181 x^19 + 6765 x^20

N[s[1/10^10], 200]

1.00000000010000000002000000000300000000050000000008000000001300000000
2100000000340000000055000000008900000001440000000233000000037700000006
1000000009870000001597000000258400000041810000006765000000000*10^-10



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 Raúl Rojas

Las matemáticas son el lenguaje más viejo
e intercultural de la humanidad.

Raúl Rojas