Circunferencia de Feuerbach

Descargar como Notebook

Dado un triángulo cualquiera trazamos el punto medio de cada uno de sus lados, y también trazamos las tres alturas del triangulo y tomamos los tres puntos donde corta el lado de forma perpendicular o su extensión, la Circunferencia de Feuerbach es la circunferencia que pasa por los estos seis puntos.

Es decir, como tres puntos no colineales determinan una circunferencia pues lo importante es que la circunferencia que es determinada por los tres puntos de corte de la altura con el lado  o su extensión y la circunferencia que pasa por centros de cada lado son la misma.

Ahora, el punto donde se cortan las alturas se llama Ortocentro, si determinamos el punto medio del ortocentro con el vértice correspondiente a cada altura, estos tres puntos también se encuentran sobre la Circunferencia de Feuerbach.

En Mathematica

linea[{a_, b_}] := 
  ParametricPlot[a (1 - t) + b t, {t, -4, 5}, 
   PlotStyle -> {Green, Dashed}];
linea[a_, b_] := 
  ParametricPlot[a (1 - t) + b t, {t, -4, 5}, 
   PlotStyle -> {Red, Dashed}];
Manipulate[
 centro = TriangleCenter[{(p + q)/2, (p + r)/2, (q + r)/2}, 
   "Circumcenter"]; radio = EuclideanDistance[centro, (p + q)/2]; 
 orto = TriangleConstruct[{p, q, r}, "Orthocenter"][[1]]; 
 altup = TriangleConstruct[{q, p, r}, "Altitude"]; 
 altuq = TriangleConstruct[{p, q, r}, "Altitude"]; 
 altur = TriangleConstruct[{q, r, p}, "Altitude"]; 
 Show[Graphics[{{Red, PointSize[0.02], Point[(orto + p)/2], 
     Point[(orto + q)/2], Point[(orto + r)/2]}, {Black, 
     PointSize[0.02], Point[(p + q)/2], Point[(p + r)/2], 
     Point[(q + r)/2]}, {Blue, PointSize[0.02], Point[altuq[[1, 2]]], 
     Point[altur[[1, 2]]], Point[altup[[1, 2]]]}, {Green, 
     Circle[centro, radio]}, {Yellow, Opacity[0.5], 
     Triangle[{p, q, r}]}}, PlotRange -> 3], linea[p, q], linea[p, r],
   linea[q, r], Apply[linea, altur], Apply[linea, altup], 
  Apply[linea, altuq]], {{p, {1, -1}}, Locator}, {{q, {-1, -1}}, 
  Locator}, {{r, {-1, 1}}, Locator}]

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 Edward Frenkel

Si somos unos ignorantes de las matemáticas no podemos ser libres,
porque estamos dando el poder a una pequeña élite,
que es la que las conoce y utiliza.

Edward Frenkel

Juego de la Vida: Tercera Parte - Creación de Motivos

Descargar como Notebook

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

Frase Célebre de Srinivasa Ramanujan

Cada entero positivo es uno de mis amigos personales.

Srinivasa Ramanujan