Adelanto mi habitual publicación de los martes como homenaje al matemático John Horton Conway, quien muere el día de ayer 11 de abril víctima del coronavirus. Publico la última entrega del Juego de Vida, diseñado por Conway en 1970.
Vamos, ahora a permitir desde el mismo aplicativo que el usuario cree, guarde y evolucione motivos.
Generamos una rejilla que permita señalar cada celda.
lis = {};
ClickPane[
Dynamic@Framed@
Graphics[{Orange, Map[Rectangle, lis]},
GridLines -> {Range[cuadro], Range[cuadro]},
PlotRange -> {{1, cuadro}, {1, cuadro}}],
AppendTo[lis, Floor[#]] &]
cre := ReplacePart[cero, lis -> 1]
Definimos la función vecino[ , ] que cuenta la cantidad de células vivas alrededor de una célula. Aquí, la dificultad es la definición de los vecinos de una célula en el borde de la rejilla que se toma.
Clear[ca];
vecino[i_, j_] :=
Piecewise[{{Sum[bb[[i + k, j + l]], {k, 0, 1}, {l, 0, 1}],
i == 1 && j == 1}, {Sum[
bb[[i + k, j + l]], {k, -1, 0}, {l, -1, 0}],
i == cuadro && j == cuadro},
{Sum[bb[[i + k, j + l]], {k, 0, 1}, {l, -1, 0}],
i == 1 && j == cuadro},
{Sum[bb[[i + k, j + l]], {k, -1, 0}, {l, 0, 1}],
i == cuadro && j == 1}, {Sum[
bb[[i + k, j + l]], {k, 0, 1}, {l, -1, 1}],
i == 1}, {Sum[bb[[i + k, j + l]], {k, -1, 0}, {l, -1, 1}],
i == cuadro}, {Sum[bb[[i + k, j + l]], {k, -1, 1}, {l, 0, 1}],
j == 1}, {Sum[bb[[i + k, j + l]], {k, -1, 1}, {l, -1, 0}],
j == cuadro}}, Sum[bb[[i + k, j + l]], {k, -1, 1}, {l, -1, 1}]] - bb[[i, j]]
Ahora, definimos la función ca[ , ], la cual aplica las reglas de evolución del juego.
ca[i_, j_] :=
Module[{vec = 0}, vec = vecino[i, j];
Piecewise[{{1, (bb[[i, j]] == 0 &&
vec == 3) || (bb[[i, j]] == 1 && (vec == 2 || vec == 3))}, {0,bb[[i, j]] == 1 && (vec == 0 || vec == 1 || vec > 3)}, {0, (bb[[i, j]] == 0 && vec != 3)}}]]
Definimos cuadro como el tamaño de la rejilla cuadrada, y las formas iniciales de cada patrón.
cuadro = 40;
n = 1;
cero = Table[0, {i, cuadro}, {j, cuadro}];
bb1 = ReplacePart[
cero, {{2, 2}, {3, 3}, {4, 1}, {4, 2}, {4, 3}, {12, 3}, {14, 3}, {15, 4}, {15, 5}, {15, 6}, {15, 7}, {14, 7}, {13, 7}, {12, 6}, {21,2}, {22, 3}, {22, 4}, {22, 5}, {22, 6}, {22, 7}, {21, 7}, {20,7}, {19, 6}, {19, 2}, {18, 4}} -> 1];
bb2 = ReplacePart[
cero, {{3, 3}, {2, 4}, {2, 5}, {3, 6}, {4, 4}, {4, 5}, {3, 10}, {3,11}, {4, 10}, {4, 11}, {8, 11}, {9, 11}, {10, 12}, {10, 13}, {7,12}, {8, 13}, {9, 14}, {9, 3}, {8, 4}, {8, 5}, {9, 6}, {10, 3}, {10, 6}, {11, 4}, {11, 5}, {18, 11}, {18, 12}, {17,11}, {16, 12}, {16, 13}, {17, 13}} -> 1];
bb3 = ReplacePart[
cero, {{4, 4}, {4, 5}, {4, 6}, {5, 5}, {5, 6}, {5, 7}, {4, 12}, {4,13}, {4, 14}} -> 1];
bb4 = ReplacePart[
cero, {{20, 20}, {20, 21}, {18, 21}, {19, 23}, {20, 24}, {20,25}, {20, 26}} -> 1];
bb5 = ReplacePart[
cero, {{20, 20}, {20, 21}, {21, 21}, {21, 25}, {21, 26}, {21,27}, {19, 26}} -> 1];
bb6 = ReplacePart[
cero, {{6, 1}, {6, 2}, {7, 1}, {7, 2}, {6, 11}, {7, 11}, {8, 11}, {5, 12}, {4, 13}, {4, 14}, {9, 12}, {9, 16}, {10, 13}, {10,14}, {5,16}, {6, 17}, {7, 17}, {8, 17}, {7, 15}, {7, 18}, {4, 21}, {5, 21}, {6, 21}, {4, 22}, {5, 22}, {6, 22}, {3, 23}, {7, 23}, {2, 25}, {3, 25}, {7, 25}, {8, 25}, {5, 35}, {5, 36}, {4, 35}, {4, 36}} -> 1];
bb7 = Mod[Array[Binomial, {cuadro, cuadro}, 0], 2];
Generamos el Manipulate que corre el juego:
gg = False; lis = {}; creacion = False;
Manipulate[
cal[i_, j_] :=
Module[{vec = 0}, vec = vecino[i, j];
Piecewise[{{1, (bb[[i, j]] == 0 &&
MemberQ[na, vec]) || (bb[[i, j]] == 1 &&
MemberQ[so, vec])}, {0,
bb[[i, j]] == 1 &&
FreeQ[so, vec]}, {0, (bb[[i, j]] == 0 && FreeQ[na, vec])}}]];
If[n == 1, bb = aa]; m = Total[bb, 2]; If[m == 0, gg = False];
If[gg, t = True; n++];
If[t == True, bb = Table[cal[i, j], {i, cuadro}, {j, cuadro}];
t = False;
MatrixPlot[bb, Mesh -> True,
MeshStyle -> Directive[Gray, Thickness[0.001]], Frame -> False],
If[creacion == False,
MatrixPlot[bb, Mesh -> True,
MeshStyle -> Directive[Gray, Thickness[0.001]], Frame -> False],
bb = Reverse@Transpose@ReplacePart[cero, lis -> 1];
ClickPane[
Dynamic@Graphics[{Orange, Map[Rectangle, lis]},
GridLines -> {Range[cuadro], Range[cuadro]},
PlotRange -> {{1, cuadro}, {1, cuadro}}, ImageMargins -> 6,
ImageSize -> 347], AppendTo[lis, Floor[#]] &]]], Text["Reglas según el número de Vecinos"],
Control[{{so, {2, 3}, "Sobrevive"}, Range[8], TogglerBar}],
Control[{{na, {3}, "Nace"}, Range[8], TogglerBar}], Text[""],
Text["Configuración Inicial"], {{aa, bb1,
"Motivo"}, {bb1 -> "Naves", bb2 -> "Estable", bb3 -> "Oscilador",
bb4 -> "Larga Vida 1", bb5 -> "Larga Vida 2", bb6 -> "Cañón"},
ControlType -> SetterBar},
Button["Creación", n = 1; creacion = True, ImageSize -> 100],
Text["Haciendo Click con el mouse sobre la cuadrícula"],
Button["Salvar",
Print[Transpose[{Transpose[lis][[1]],
cuadro - Transpose[lis][[2]]}]], ImageSize -> 100],
Text["Salva el motivo hecho en creación"], Text[""], Text["Desarrollo del Juego"],
Button["Evolución", n++; gg = True; t = True, ImageSize -> 100],
Button["Parar", creacion = False; gg = False,
ImageSize -> 100], {{n, 1, "Número de Vida:"},
Appearance -> Open}, {{m, 0, "Población:"}, Appearance -> Open},
Button["Limpiar", n = 1; t = False; creacion = False; lis = {};
gg = False; aa = cero, ImageSize -> 100]]
Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas
No hay comentarios.:
Publicar un comentario