Volvemos a hablar sobre el Juego del Caos, el cual ya lo mencionamos en publicaciones anteriores, su importancia radica en que su generalización nos permitirá la construcción de fractales mediante Sistemas Iterados de Funciones SIF o IFS por sus siglas en inglés.
Recordemos en que consistía: Se parte de tres puntos en una hoja A, B y C (que llamaremos vértices) no colineales, es decir no sobre la misma recta, y otro punto P (que llamaremos punto de partida), se toma un dado de seis lados 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. aquí un ejemplo para los vértices A(2,1), B(3,0) y C(4,0), y repitiendo el proceso cien mil veces.
vertices = {{2, 1}, {3, 0}, {4, 0}};
inicio = {0, 0};
ran := RandomChoice[Table[1./3, {n, 3}] -> Range[3], 1][[1]]
siguiente[punto_] := (vertices[[ran]] + punto)/2.
ListPlot[NestList[siguiente, inicio, 100000], AspectRatio -> 1,
Axes -> True, PlotStyle -> PointSize[0.001]]
El proceso del Juego del Caos lo podemos ver como una transformación afín del plano en el plano, es decir una transformación lineal sobre el plano (multiplicar por una matriz dos por dos) más una traslación (sumar un par de coordenadas).
Estas transformaciones afines las podemos ver como:
Consideraremos las reglas:
R1: Mover hasta el punto medio entre el actual y A(2,1).
R2: Mover hasta el punto medio entre el actual y B(3,0).
R3: Mover hasta el punto medio entre el actual y C(4,0).
Todas aplicadas con igual probabilidad.
Para la regla R1, partiendo del punto (x,y) y llegando al punto medio a A(2,1) obtenemos la función:
Para la regla R2, partiendo del punto (x, y) y llegando al punto medio a B (3,0) obtenemos la función:
Para la regla R3, partiendo del punto (x, y) y llegando al punto medio a C (4, 0) obtenemos la función:
Generalizamos estas tres funciones en la función definida por:
f[n_, {x_, y_}] := {a[[n]] x + b[[n]] y + c[[n]],
d[[n]] x + e[[n]] y + k[[n]]}
donde n corresponde al número de la regla, y los coeficientes vienen dados en las listas:
a = {1/2, 1/2, 1/2};
b = {0, 0, 0};
c = {1, 3/2, 2};
d = {0, 0, 0};
e = {1/2, 1/2, 1/2};
k = {1/2, 0, 0};
Como todas las funciones se aplican con igual probabilidad de 1/3, definimos el dado de tres resultados posibles {1,2,3} e igual probabilidad {0.33,0.33,0.33}:
prob = {0.33, 0.33, 0.33};
ran := RandomChoice[prob -> {1, 2, 3}, 1][[1]]
Ahora, definimos la función siguiente [ ], que nos va a permitir iterar el punto, aplicando la función f1, f2 o f3, dependiendo del resultado del dado que está dado por el valor ran:
siguiente[punto_] := f[ran, punto]
La lista de todas las iteraciones la obtenemos mediante el comando NestList[ ] que tiene tres argumentos: la función a iterar, el punto de partida y el número de iteraciones que se van a realizar. Aquí, la función a iterar es siguiente, partiendo del punto (0,0) y el proceso se realizará 10 veces.
NestList[siguiente, {0, 0}, 10]
{{0, 0}, {1., 0.5}, {1.5, 0.75}, {1.75, 0.875}, {2.375,
0.4375}, {3.1875, 0.21875}, {3.09375, 0.109375}, {3.04688,
0.0546875}, {2.52344, 0.527344}, {3.26172, 0.263672}, {3.13086,
0.131836}}
Para graficar la lista obtenida lo hacemos mediante el comando ListPlot[ ],
ListPlot[%]
Resumiendo todo en una única entrada y realizando la iteración para cien mil puntos, obtenemos:
a = {1/2, 1/2, 1/2};
b = {0, 0, 0};
c = {1, 3/2, 2};
d = {0, 0, 0};
e = {1/2, 1/2, 1/2};
k = {1/2, 0, 0};
prob = {0.33, 0.33, 0.34};
ran := RandomChoice[prob -> {1, 2, 3}, 1][[1]]
siguiente[punto_] := N[f[ran, punto]]
ListPlot[NestList[siguiente, {0, 0}, 100000],
PlotStyle -> PointSize[Tiny], Axes -> True]
Variación sobre las reglas
Vamos a considerar los mismos vértices anteriores A(2,1), B(3,0) y C(4,0), pero consideraremos dos reglas adicionales R4 y R5, y más importante la forma de decidir la regla que se aplicará en cada caso, aunque el dado sigue siendo el mismo:
R1 : Mover hasta el punto medio entre el actual y A (2, 1).
R2 : Mover hasta el punto medio entre el actual y B (3, 0).
R3 : Mover hasta el punto medio entre el actual y C (4, 0).
R4: Cambiamos por el punto 2(B-C).
R5: Rotar 180º alrededor del punto (A+5B-4C)/2.
Las probabilidades del dado son iguales, pero ahora, se tiene memoria del resultado anterior del dado para determinar que regla se aplica:
La regla R4, la definimos por la función constante :
f4 (x, y) = 2 (B - C) = 2 ((3, 0) - (4, 0)) = (-2, 0)
La regla R5, partiendo del punto (x,y) buscamos el punto (m,n) que deje como punto medio al punto (A+5B-4C)/2=(1/2,1/2),
así,
f5(x,y)=( - x + 1 , - y + 1).
Y los coeficientes de las cinco funciones los resumimos en las siguientes listas:
a = {1/2, 1/2, 1/2, 0, -1};
b = {0, 0, 0, 0, 0};
c = {1, 3/2, 2, -2, 1};
d = {0, 0, 0, 0, 0};
e = {1, 1, 1, 0, -1};
k = {1, 0, 0, 0, 1};
El dado y la forma de seleccionar la función están dados por:
prob = {0.33, 0.33, 0.34};
ran := Module[{dado = 1, da}, da = dado;
dado = RandomChoice[prob -> {1, 2, 3}, 1][[1]];
Which[(da == 1 || da == 2) && dado == 1,
1, (da == 1 || da == 2) && dado == 2,
2, (da == 1 || da == 2) && dado == 3, 4,
da == 3 && (dado == 1 || dado == 2), 5, da == 3 && dado == 3, 3]]
Resumiendo en una única entrada, tenemos :
a = {1/2, 1/2, 1/2, 0, -1};
b = {0, 0, 0, 0, 0};
c = {1, 3/2, 2, -2, 1};
d = {0, 0, 0, 0, 0};
e = {1, 1, 1, 0, -1};
k = {1, 0, 0, 0, 1};
prob = {0.33, 0.33, 0.34};
ran := Module[{dado = 1, da}, da = dado;
dado = RandomChoice[prob -> {1, 2, 3}, 1][[1]];
Which[(da == 1 || da == 2) && dado == 1,
1, (da == 1 || da == 2) && dado == 2,
2, (da == 1 || da == 2) && dado == 3, 4,
da == 3 && (dado == 1 || dado == 2), 5, da == 3 && dado == 3, 3]]
siguiente[punto_] := f[ran, punto]
ListPlot[NestList[siguiente, {0, 0}, 100000],
PlotStyle -> PointSize[Tiny], Axes -> True]
Curiosamente el resultado obtenido es el Triángulo de Sierpinski con vértices en los puntos (0,0), (1/2,1) y (1,0).
Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas
