Ecuaciones diferenciales de una Pandemia

Descargar como Notebook

Vamos a realizar una partición entre la población de un cierto lugar, es decir, cada habitante pertenece a uno de los siguientes grupos: Infectado (I), Recuperado (R) o Susceptible de contagio (S). La población total la consideraremos en porcentaje donde 1 es el total, y los valores iniciales en la población son: R(0)=0, I(0)=0.01 y S(0)=1-I=1-0.01=0.99. 

Vamos a considerar dos parámetros tr el índice de transmisión del virus y re el índice de recuperación de los infectados.

Las ecuaciones diferenciales que gobiernan el comportamiento entre estos tres conjuntos son: 

La tasa de cambio del conjunto S es igual a menos el índice de transmisión tr por el producto de S por I, que es el número de interacciones entre Susceptibles e Infectados.

La tasa de cambio de los recuperados R es igual al producto del índice de recuperación por el número de infectados I.

La tasa de cambio de los Infectados es igual a la diferencia entre el aumento de infectados y el número de recuperados.

Al resolver el sistema de ecuaciones diferenciales y graficarlo, obtenemos el siguiente aplicativo, donde podemos cambiar los índices de transmisión y recuperación.

Manipulate[
 eqs = NDSolve[{s'[t] == -tr s[t] i[t], 
    i'[t] == tr s[t] i[t] - re i[t], r'[t] == re i[t], i[0] == 0.01, 
    s[0] == 0.99, r[0] == 0}, {r[t], s[t], i[t]}, {t, 0, 20}]; 
 Plot[Evaluate[{r[t], i[t], s[t]} /. eqs], {t, 0, 20}, 
  PlotStyle -> Automatic, 
  PlotRange -> {0, 1}], {{re, 0.1, "Indice de Recuperación"}, 0, 
  1}, {{tr, 1, "Indice de transmisión"}, 0, 3.5}]

La gráfica verde es la de Susceptibles, la roja los Infectados y la azul la de los Recuperados. Vea el comportamiento cuando aumenta el índice de transmisión y disminuye el de recuperación, y lo contrario.

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 Jules Henri Poincaré

Probamos por medio de la lógica
pero descubrimos por medio de la intuición.

Jules Henri Poincaré

Números Autobiográficos

Descargar como Notebook

Son los números naturales tales que su primera cifra dice el número de ceros que él tiene, la segunda cifra el número de unos, y así sucesivamente.

Estos números cumplen que la suma de sus dígitos es igual a su longitud, pues cada dígito cuenta las apariciones de cada número. La anterior propiedad la utilizaremos para agilizar el algoritmo para la búsqueda.

auto = {};
Do[digitos = IntegerDigits[num]; lon = Length[digitos];
 If[lon == Total[digitos], 
  If[BinCounts[digitos, {0, lon, 1}] == digitos, 
   AppendTo[auto, num]]], {num, 10^15}]
auto

{1210, 2020, 21200, 3211000, 42101000, 521001000, 6210001000, 72100001000, 821000001000, 9210000001000}

Observe que desde el número 3211000 los siguientes se generan aumentando las unidades, el número de ceros, y agregando una unidad en la respectiva posición que corresponde al primer dígito.


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 Albert Einstein

Nunca dejará de asombrarme que las matemáticas,
un producto de la libre imaginación humana,
se corresponda tan exactamente con la realidad.

Albert Einstein

Juego de la Vida: Segunda Parte - Variantes

Descargar como Notebook

Desde la creación del juego se han desarrollado nuevas reglas. El juego estándar, en que nace una célula si tiene 3 células vecinas vivas, sigue viva si tiene 2 o 3 células vecinas vivas y muere en otro caso, se simboliza como "23/3". El primer número o lista de números es lo que requiere una célula para que siga viva, y el segundo es el requisito para su nacimiento. Así, "16/6" significa que "una célula nace si tiene 6 vecinas y vive siempre que haya 1 o 6 vecinas". HighLife ("Alta Vida") es 23/36, porque es similar al juego original 23/3 solo que también nace una célula si tiene 6 vecinas vivas. HighLife es conocida sobre todo por sus replicantes, formas que crean copias de ellas mismas. Se conocen muchas variaciones del juego de la vida, aunque casi todas son demasiado caóticas o demasiado desoladas. 

⨷  /3 (estable) casi todo es una chispa
⨷ 5678/35678 (caótico) diamantes, catástrofes
⨷ 1357/1357 (crece) todo son replicantes
⨷ 1358/357 (caótico) un reino equilibrado de amebas
⨷ 23/3 (complejo) "Juego de la Vida de Conway"
⨷ 23/36 (caótico) "HighLife" (tiene replicante)
⨷ 2/7 (caótico) "Diffusion Rule"
⨷ 235678/3678 (estable) mancha de tinta que se seca rápidamente
⨷ 245/368 (estable) muerte, locomotoras y naves
⨷ 34/34 (crece) "Vida 34"
⨷ 4/2 (crece) generador de patrones de alfombras
⨷ 51/346 (estable) "Larga vida" casi todo son osciladores

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 la posibilidad de cambiar las reglas de sobre vivencia y muerte según el número de vecinos de cada celda.

gg = 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 -> False, Frame -> False],
  MatrixPlot[bb, Mesh -> False, Frame -> False]], 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}, Text[""], Text["Desarrollo del Juego"],
 Button["Evolución", n++; gg = True; t = True, ImageSize -> 100],
 Button["Parar", gg = False,
  ImageSize -> 100], {{n, 1, "Número de Vida:"},
  Appearance -> Open}, {{m, 0, "Población:"}, Appearance -> Open},
 Button["Limpiar", n = 1; t = False; gg = False; aa = cero,
  ImageSize -> 100]]

Se han desarrollado variantes adicionales mediante la modificación de otros elementos del universo. Las variantes anteriores son para un universo bi dimensional formado por cuadrados, pero también se han desarrollado variantes unidimensionales y tridimensionales, así como variantes 2 - D donde la malla es hexagonal o triangular en lugar de cuadrada.

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