Entrada destacada

Distancia media de dos puntos en un cuadrado unitario

viernes, 28 de diciembre de 2018

Frase Célebre de Lise Meitner

La ciencia hace a la gente tratar de luchar 
desinteresadamente para llegar 
a la verdad y la objetividad.
Enseña a la gente a aceptar la realidad, 
con asombro y admiración.

Lise Meitner

martes, 25 de diciembre de 2018

Calendario 2019 en forma de Dodecaedro






En la página https://folk.uib.no/nmioa/kalender/ puede descargar los calendarios correspondientes a cada año, sólo tenga presente:

1. Imprimirlo en papel de alto gramaje (aconsejo Opalina)
2. Marcar los festivos correspondientes a su país y los días que quiera resaltar.
3. Recortar por las líneas continuas las punteadas corresponden a dobleces.
4. Lo último que arma son las pestañas grandes.

Y manos a la obra.


martes, 18 de diciembre de 2018

Número de Hardy-Ramanujan: 1729



En una visita del matemático inglés Godfrey H. Hardy al matemático indio Srinivasa A. Ramanujan, cuando este último se encontraba hospitalizado, le comentó que había tomado un taxi con un número poco interesante: 1729, a lo cual Ramanujan objetó diciendo que es un número muy interesante pues es el más pequeño entero positivo que se puede expresar como suma de dos cubos de dos formas diferentes.

1729 = 1³ + 12³= 9³ + 10³.

Comprobemos que es el más pequeño que se puede escribir mínimo de dos formas diferentes:

Select[Tally@Flatten@Table[n^3 + m^3, {n, 45}, {m, n}], #[[2]] != 1 &]

{{1729, 2}, {4104, 2}, {13832, 2}, {20683, 2}, {32832, 2}, {46683, 
  2}, {39312, 2}, {40033, 2}, {65728, 2}, {64232, 2}}

Vemos que 1729 es el más pequeño entero positivo que se puede escribir como la suma de dos cubos de al menos dos formas diferentes.

En el árbol de la figura se construyen números primos palíndromos a partir del 1729 y su capicúa 9271 en el tronco central.




viernes, 14 de diciembre de 2018

Frase Célebre de Neil DeGrasse Tyson

El estudiante que sigue aprendiendo por su cuenta...
Eso es lo que separa a los triunfadores 
de los que sólo hacen la tarea.

 Neil DeGrasse Tyson

viernes, 7 de diciembre de 2018

Frase Célebre de Jules Henri Poincaré

. . . el principio de conservación de la energía significa simplemente que hay algo que permanece constante. 
De hecho, sin importar las nuevas nociones que las experiencias futuras nos den del mundo, estamos seguros de antemano que habrá algo que permanecerá constante, y a lo que podremos llamar energía.


Jules Henri Poincaré

martes, 4 de diciembre de 2018

Sucesión de Kolakoski



Se debe al artista norteamericano William Kolakoski (1944-1997) quien tenía como pasatiempo la matemática recreativa, la publicó en la revista American Mathematical Monthly en 1965, aunque ya en 1939 el matemático Rufus Oldenburger había hecho mención de ella.

La Sucesión de Kolakoski tiene como primeros términos:

1 2 2 1 1 2 1 2 2 1 2 2 1 1 2 1 1 2 2 1 2 1 1 2 1 2 2 1 1 2 1 1 2 1 2 2 1 2 2 1 1 . . .

Para entender como se construye primero debemos hablar de la sucesión contadora de otra sucesión dada (sobre la cual publiqué el 20 de Noviembre de 2018 aquí), que es la sucesión formada por los enteros positivos que indican el número de bloques de símbolos consecutivos iguales en la sucesión. Por ejemplo, la sucesión contadora de la sucesión:

a b b a a b b b a b a a b b . . .

es la sucesión:

1 2 2 3 1 1 2 2 . . .

pues empieza con 1 letra a, luego 2 letras b, 2 letras a, 3 letras b y así sucesivamente.

Ahora sí, la principal característica de la Sucesión de Kolakoski es que ella es su propia sucesión contadora.

En Mathematica

ko = {1, 2, 2};
Do[Which[ko[[n]] == 1 && Last[ko] == 1, AppendTo[ko, 2], 
  ko[[n]] == 1 && Last[ko] == 2, AppendTo[ko, 1], 
  ko[[n]] == 2 && Last[ko] == 1, AppendTo[ko, {2, 2}]; 
  ko = Flatten[ko], ko[[n]] == 2 && Last[ko] == 2, 
  AppendTo[ko, {1, 1}]; ko = Flatten[ko]], {n, 3, 20}]
ko

{1, 2, 2, 1, 1, 2, 1, 2, 2, 1, 2, 2, 1, 1, 2, 1, 1, 2, 2, 1, 2, 1, 1, 2, 1, 2, 2, 1, 1, 2}

Función contadora

La podemos calcular por medio de:

contadora[list_List] := Module[{j = 1,
   con = {}, len = Length[list]}, lis = Map[ToString, list];
  Do[Which[n == len - 1 && lis[[n]] == lis[[n + 1]], j++; 
    AppendTo[con, j], n == len - 1 && lis[[n]] != lis[[n + 1]], 
    AppendTo[con, {j, 1}], lis[[n]] == lis[[n + 1]], j++, 
    lis[[n]] != lis[[n + 1]], AppendTo[con, j]; j = 1], {n, len - 1}];
   Flatten[con]]

La función contadora[ ] aplicada a la salida de la Sucesión de Kolakoski nos da una sub lista de la Sucesión de Kolakoski compuesta por 20 términos, el número que habíamos puesto para calcularla.

contadora[ko]
{1, 2, 2, 1, 1, 2, 1, 2, 2, 1, 2, 2, 1, 1, 2, 1, 1, 2, 2, 1}

Length[%]
20

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

viernes, 30 de noviembre de 2018

martes, 27 de noviembre de 2018

Curva o Ventana de Viviani


Corresponde a la curva que se genera como la intersección de una esfera y un cilindro de radio la mitad de la esfera, y que pasa por el centro de la esfera. Fue propuesta por el matemático italiano Vincenzo Viviani en 1692.

Show[ContourPlot3D[x^2 + y^2 == y, {x, -1, 1}, {y, -1, 1}, {z, -1, 1},ContourStyle -> {Yellow, Opacity[0.8]}, Mesh -> None], 
 Graphics3D[{Opacity[0.5], Sphere[]}]]



El problema consiste en resolver el sistema de ecuaciones:



de donde z²=R²-R y,  como sabemos que la circunferencia en el plano xy en polares tiene por ecuación r=R Sen(θ), y en polares: x=r Cos(θ) y y=r Sen(θ), así:



Por tanto, para R = 1 tenemos :

ParametricPlot3D[{Sin[θ] Cos[θ], Sin[θ]^2, 
  Cos[θ]}, {θ, 0, 2 Pi}, PlotStyle -> Red]



Con todas las figuras :

Manipulate[
 Show[Graphics3D[{Opacity[0.5], Sphere[]}], 
  ParametricPlot3D[{Sin[θ] Cos[θ], Sin[θ]^2, 
    Cos[θ]}, {θ, 0, a}, 
   PlotStyle -> {Red, Thickness[0.01]}], 
  ContourPlot3D[x^2 + y^2 == y, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}, 
   ContourStyle -> {Yellow, Opacity[0.8]}, Mesh -> None], 
  ViewPoint -> {1, 1, 1}], {a, 0.001, 2 Pi, Trigger}]


Creación del GIF

Export[NotebookDirectory[] <> "viviani1.gif", 
 Manipulate[
  Show[Graphics3D[{Opacity[0.5], Sphere[]}], 
   ParametricPlot3D[{Sin[θ] Cos[θ], Sin[θ]^2, 
     Cos[θ]}, {θ, 0, a}, 
    PlotStyle -> {Red, Thickness[0.01]}], 
   ContourPlot3D[x^2 + y^2 == y, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}, 
    ContourStyle -> {Yellow, Opacity[0.8]}, Mesh -> None], 
   ViewPoint -> {1, 1, 1}], {a, 0.001, 2 Pi, Trigger}], 
 "AnimationRepetitions" -> Infinity]



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

viernes, 23 de noviembre de 2018

Frase Célebre de Carl Sagan

Vivimos en una sociedad profundamente dependiente de la ciencia y la tecnología en la que nadie sabe nada de estos temas. 
Esta mezcla combustible de ignorancia y poder, tarde o temprano,
va a terminar explotando en nuestras caras.

Carl Sagan

martes, 20 de noviembre de 2018

Sucesión Contadora


Dada una sucesión definimos la Sucesión Contadora como la sucesión formada por los enteros positivos que indican el número de bloques de símbolos consecutivos iguales en la sucesión inicial.
Por ejemplo, la sucesión contadora de la sucesión :
  a b b a a b b b a b a a b b . . .
    es la sucesión :
  1 2 2 3 1 1 2 2 . . .
    pues empieza con 1 letra a, luego 2 letras b, 2 letras a, 3 letras b y así sucesivamente.
 
    tiene la propiedad que la suma de todos sus términos es la longitud de la lista inicial.

En Mathematica

Definimos la función contadora[ ], que se aplica sobre una lista de números como:

contadora[lis_List] := Module[{j = 1,
   con = {}, len = Length[lis]},
  Do[Which[n == len - 1 && lis[[n]] == lis[[n + 1]], j++; 
    AppendTo[con, j], n == len - 1 && lis[[n]] != lis[[n + 1]], 
    AppendTo[con, {j, 1}], lis[[n]] == lis[[n + 1]], j++, 
    lis[[n]] != lis[[n + 1]], AppendTo[con, j]; j = 1], {n, len - 1}];
   Flatten[con]]

Por ejemplo, dada la sucesión:

lista = {1, 1, 1, 3, 3, 4, 2, 2, 1, 1, 4, 4, 4, 5, 5, 6};

Al aplicarle la función contadora[ ] obtenemos :

contadora[lista]
{3, 2, 1, 2, 2, 3, 2, 1}

que nos indica que lista tiene: 3 elementos iguales al comienzo (en este caso 3 unos), luego un bloque de dos iguales (2 tres), un bloque de uno solo (1 cuatro), y así sucesivamente.

Otro ejemplo, dada la sucesión lista2 formada por combinación de letras y posiblemente también números:

Clear[a, b, c, d]
lista2 = {a, b, b, c, a, a, a, a, 2, d, c, c, c, a};

al aplicarle contadora[ ], obtenemos:

contadora[lista2]
{ }

El problema ocurre pues :

a == a
True

a==b
a==b

Mathematica no establece un valor de verdad para a==b, no decide si es verdadero (true) o falso (False), que es indispensable para poder utilizar el comando Which[ ], pero si los tomamos como caracteres tenemos:

"a" == "a"
True

"a" == "b"
False

por tanto, mejoramos nuestra función contar[ ], haciendo que previamente convierta la lista en una cadena de caracteres y esto lo logramos con el comando ToString aplicado a cada elemento de la lista mediante el comando Map[ ].

contadora[list_List] := Module[{j = 1,
   con = {}, len = Length[list]}, lis = Map[ToString, list];
  Do[Which[n == len - 1 && lis[[n]] == lis[[n + 1]], j++; 
    AppendTo[con, j], n == len - 1 && lis[[n]] != lis[[n + 1]], 
    AppendTo[con, {j, 1}], lis[[n]] == lis[[n + 1]], j++, 
    lis[[n]] != lis[[n + 1]], AppendTo[con, j]; j = 1], {n, len - 1}];
   Flatten[con]]

contadora[lista2]
{1, 2, 1, 4, 1, 1, 3, 1}

Y aún opera bien sobre listas numéricas :

contadora[lista]
{3, 2, 1, 2, 2, 3, 2, 1}


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

viernes, 16 de noviembre de 2018

Frase Célebre de Lipman Bers

La del matemático es una profesión extremadamente cruel.
Si alguien tiene, digamos, una licenciatura en Química, 
se describirá a sí mismo como un químico.
Sin embargo, si alguien lleva siendo profesor de matemáticas durante diez años y le preguntas: 
"¿Es usted un matemático?",
te contestará 
"¡Estoy intentando serlo!"

Lipman Bers

martes, 13 de noviembre de 2018

Series de Taylor



Dada una función f (x) continuamente derivable en un punto "a", su Serie de Taylor corresponde a:





válido en un intervalo (a - R, a + R), donde R es el radio de convergencia de la serie de Taylor. Así, se puede representar la función f(x) mediante un polinomio infinito, o aproximarla por medio de un polinomio tomando un número suficiente de términos.

Se construye un aplicativo que nos muestra como estos polinomios van aproximando a diferentes funciones, vemos que entre mayor sea el número de términos que consideremos en el polinomio mejor es la aproximación y mayor es el radio de convergencia.

Mathematica cuenta con el comando Series[ ] que nos calcula el polinomio de Taylor. Por ejemplo la función seno centrada en cero y con 10 términos.

Series[Sin[x], {x, 0, 10}]





El término final corresponde al error cometido por solo considerar el polinomio hasta el grado 10, esto lo podemos omitir mediante el comando Normal.

Normal@Series[Sin[x], {x, 0, 10}]





pero, este resultado no lo podemos calcular pues la variable x la considera como variable interna del comando Series[ ], así que se tiene que sustituir:

Normal@Series[Sin[a], {a, 0, 10}] /. a -> x

Ahora sí, podemos graficar la función seno y el polinomio de Taylor que la aproxima centrada en cero considerando sus primeros diez términos. Vemos que la convergencia aproximadamente es de radio 4, en un intervalo centrado en cero es decir ( - 4, 4 ).

Plot[{Sin[x], Normal@Series[Sin[a], {a, 0, 10}] /. a -> x}, {x, -2 Pi, 2 Pi}]



Construyamos el polinomio de aproximación p(x) término a término.

Manipulate[
 Grid[{{Plot[{Sin[x], 
      Normal@Series[Sin[a], {a, 0, n}] /. a -> x}, {x, -2 Pi, 2 Pi}, 
     PlotRange -> {{-7, 7}, {-1.5, 1.5}}, 
     ImageSize -> {500, 400}]}, {"p(x)=" Normal@
       Series[Sin[a], {a, 0, n}] /. a -> x}}], {n, 1, 15, 1}]




Para coseno.

Manipulate[
 Grid[{{Plot[{Cos[x], 
      Normal@Series[Cos[a], {a, 0, n}] /. a -> x}, {x, -2 Pi, 2 Pi}, 
     PlotRange -> {{-7, 7}, {-1.5, 1.5}}, 
     ImageSize -> {450, 400}]}, {"p(x)=" Normal@
       Series[Cos[a], {a, 0, n}] /. a -> x}}], {n, 1, 15, 1}]



Para tangente debemos recordar que ella tiene discontinuidades en -Pi/2 y Pi/2, y un polinomio siempre es continuo, por tanto si hacemos centro en cero sólo tendremos una aproximación para el intervalo (-Pi/2,Pi/2).

Manipulate[
 Grid[{{Plot[{Tan[x], 
      Normal@Series[Tan[a], {a, 0, n}] /. a -> x}, {x, -2 Pi, 2 Pi}, 
     PlotRange -> {{-2, 2}, {-15, 15}}, 
     ImageSize -> {450, 400}]}, {"p(x)=" Normal@
       Series[Tan[a], {a, 0, n}] /. a -> x}}], {n, 1, 15, 1}]



Para las tres funciones :

Manipulate[
 intervalo = 
  If[f === Tan, {{-2, 2}, {-15, 15}}, {{-7, 7}, {-1.5, 1.5}}]; 
 Grid[{{Plot[{f[x], 
      Normal@Series[f[a], {a, 0, n}] /. a -> x}, {x, -2 Pi, 2 Pi}, 
     PlotRange -> intervalo, 
     ImageSize -> {500, 400}]}, {"p(x)=" Normal@
       Series[f[a], {a, 0, n}] /. a -> x}}], {n, 1, 15, 
  1}, {f, {Sin, Cos, Tan}}]



Ejercicio

Realizar la serie de Taylor y graficar el polinomio y la función para cada una de las funciones dadas, centradas en el respectivo punto:
1. exponencial centrada en cero.
2. logaritmo centrada en uno.
3. tangente centrada en Pi.

Creación del último GIF

Export[NotebookDirectory[] <> "taylortres.gif", 
 Manipulate[
  intervalo = 
   If[f === Tan, {{-2, 2}, {-15, 15}}, {{-7, 7}, {-1.5, 1.5}}]; 
  Grid[{{Plot[{f[x], 
       Normal@Series[f[a], {a, 0, n}] /. a -> x}, {x, -2 Pi, 2 Pi}, 
      PlotRange -> intervalo, 
      ImageSize -> {500, 400}]}, {"p(x)=" Normal@
        Series[f[a], {a, 0, n}] /. a -> x}}], {n, 1, 15, 
   1}, {f, {Sin, Cos, Tan}}], "AnimationRepetitions" -> Infinity]


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

viernes, 9 de noviembre de 2018

martes, 6 de noviembre de 2018

Comparación entre las diferentes medias





Vamos a considerar dos números reales positivos a y b, se ejemplificará sobre media circunferencia, de diámetro a + b, la relación existente entre:










Manipulate[ra = Sqrt[1 - a^2]; ang = Arg[a + I ra]; 
 Grid[{{Show[
     Graphics[{{If[0.1 < Abs[a] < 0.9, 
         Text["90º", {a^3 + 0.15 Sign[a], 
           a^2 ra}]]}, {Arrowheads[{-0.02, 0.02}], 
        Arrow[{{-1, -0.2}, {a, -0.2}}], 
        Arrow[{{a, -0.2}, {1, -0.2}}]}, {Text["a", {(a - 1)/2, -0.1}],
         Text["b", {(a + 1)/2, -0.1}]}, {Circle[{a^3, a^2 ra}, 
         0.1, {ang, ang - Sign[a] Pi/2}]}, {Red, Thickness[0.01], 
        Line[{{-1, 0}, {a, 0}}]}, {Blue, Thickness[0.01], 
        Line[{{1, 0}, {a, 0}}]}, {Green, Thickness[0.02], 
        Line[{{0, 0}, {0, 1}}]}, {Orange, Thickness[0.02], 
        Line[{{a, ra}, {a, 0}}]}, {Line[{{0, 0}, {a, 
           ra}}]}, {Line[{{a, 0}, {a^3, a^2 ra}}]}, {Cyan, 
        Thickness[0.02], Line[{{a^3, a^2 ra}, {a, ra}}]}, {Yellow, 
        Thickness[0.02], Line[{{a, 0}, {0, 1}}]}}, 
      ImageSize -> {450, 400}], 
     Plot[Sqrt[1 - x^2], {x, -1, 1}, AspectRatio -> 1/2, 
      Ticks -> None]], 
    Graphics[{{Text["b", {-0.1, 0.8}]}, {Blue, Thickness[0.01], 
       Line[{{0, 0.8}, {1 - a, 0.8}}]}, {Text["a", {-0.1, 1}]}, {Red, 
       Thickness[0.01], 
       Line[{{0, 1}, {1 + a, 1}}]}, {Text[
        "Aritmética", {-0.25, 0.6}]}, {Green, Thickness[0.02], 
       Line[{{0, 0.6}, {1, 0.6}}]}, {Text[
        "Geométrica", {-0.26, 0.4}]}, {Orange, Thickness[0.02], 
       Line[{{0, 0.4}, {ra, 0.4}}]}, {Text[
        "Armónica", {-0.25, 0.2}]}, {Cyan, Thickness[0.02], 
       Line[{{0, 0.2}, {1 - a^2, 0.2}}]}, {Text[
        "Cuadrática", {-0.26, 0}]}, {Yellow, Thickness[0.02], 
       Line[{{0, 0}, {Sqrt[1 + a^2], 0}}]}, {Text["a", {-0.1, 1}]}}, 
     PlotRange -> {{-0.95, 2}, {-0.1, 1.1}}, 
     ImageSize -> {450, 400}]}}], {{a, -0.8, 
   "Relación entre a y b"}, -0.95, 0.95}, ContentSize -> {1000, 400}]


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

viernes, 2 de noviembre de 2018

Frase Célebre de Marcus du Sautoy

Las matemáticas son un lugar 
donde puedes hacer cosas 
que no puedes hacer en el mundo real.

Marcus du Sautoy

martes, 30 de octubre de 2018

Juego del Caos : Cambiando el dado en el caso del cuadrado



Volviendo al Juego del Caos del cual ya lo había mencionado en las publicaciones del 24 de abril del 2018, mostrando la obtención del Triángulo de Sierpinski, y en la publicación del 28 de agosto de 2018, donde se extendía el procedimiento del Juego del Caos para dados de más de tres opciones. Observábamos que, excepto para cuatro, se obtenían figuras con cierto comportamiento de índole fractal, para cuatro obteníamos la primera figura, sin ninguna estructura particular.

Como se explicó en la publicación del 28 de agosto de 2018, cambiando el dado para cuatro siguiendo la secuencia de un gen del genoma humano se obtenía una figura que claramente tenía un comportamiento fractal, segunda y tercera que difieren del orden de las letras en los vértices.















Voy a seguir cambiando el dado buscando algún tipo de comportamiento en la gráfica al tomar un dado con cuatro opciones, pero con un comportamiento no necesariamente regido por el azar.

  Primero, defino la función cuadrado[ ] que dada una lista (dado) de secuencias de los dígitos
{1, 2, 3, 4} la gráfica según las reglas del Juego del Caos.

cuadrado[lista_List] := Module[{long = Length[lista],
   dado = Table[lista[[n]], {n, Length[lista]}],
   vertices = {{0, 0}, {0, 1}, {1, 0}, {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.1, 1.1}, {-0.1, 1.1}}, AspectRatio -> 1, 
   Axes -> False, PlotStyle -> PointSize[0.001]]]

Diferentes Dados

Generamos listas con los dígitos {1,2,3,4} siguiendo diferentes criterios para su obtención.

Primos módulo 5

A la lista de los números primos mayores que 5 les calculamos su módulo con respecto a 5, residuo que se obtiene al dividir el número por 5.

lista1 = Table[Mod[Prime[n], 5], {n, 4, 200000}];
Tally[%]

{{2, 50071}, {1, 49964}, {3, 50020}, {4, 49942}}

Vemos que el dado no está "cargado" hacia algún resultado,

cuadrado[lista1]



la figura obtenida muestra una estructura fractal.

Distancia entre primos

Ahora, como dado tomaré la distancia entre primos consecutivos dividida por 2 y tomando módulo 4.

lista2 = Table[
   Mod[(Prime[n + 1] - Prime[n])/2, 4] + 1, {n, 2, 200000}];
Tally[%]

{{2, 57160}, {3, 53349}, {4, 56687}, {1, 32803}}

cuadrado[lista2]


Se obtiene una estructura fractal similar a la que se obtuvo con el genoma.

Números Normales

En la publicación del 4 de julio del 2017 expresaba sobre los Números Normales que:

Un número real es un Número Normal en base b si en su expansión decimal en base b los dígitos se distribuyen de una forma uniforme. Es decir, los números de una cifra aparecen en la misma proporción, los de dos cifras, los de tres cifras, etc.

Tomaré las cifras decimales de algunos números que hasta el momento se conjetura que son normales: Pi, Euler y la constante Aurea, para que el dado no esté cargado eliminaré los 8 y 9 y ahí sí tomaré módulo 4.

lista3 = Mod[
    Select[RealDigits[N[GoldenRatio, 100000]][[1]], 
     And[# != 8, # != 9] &], 4] + 1;
Tally[%]

{{2, 19980}, {3, 19924}, {1, 20027}, {4, 20067}}

cuadrado[lista3]

En todos se obtiene un gráfico sin ninguna estructura del tipo la primera que se mostraba cuando el dado era totalmente al azar. Lo que también ocurre al tomar Módulo 5 y eliminar alguno de los dígitos, para que el dado tenga cuatro resultados.

lista4 = Select[Mod[RealDigits[N[Pi, 100000]][[1]], 5], # != 0 &];
Tally[%]

{{3, 20004}, {1, 20165}, {4, 19873}, {2, 19933}}

cuadrado[lista4]


Números no normales

Número de Champernowne

Tomando como dado las cifras del número de Champernowne generado concatenando los números enteros positivos como sus cifras decimales, Mathematica lo genera con el comando ChampernowneNumber[10].

lista5 = Mod[
    Select[RealDigits[N[ChampernowneNumber[10], 1000000]][[1]], 
     And[# != 8, # != 9] &], 4] + 1;
Tally[%]

{{2, 273533}, {3, 188077}, {4, 188077}, {1, 178067}}

cuadrado[lista5]


Aunque no veo una estructura fractal, si tiene un comportamiento en su ordenamiento.

Número de Copeland - Erdös

Es el número decimal entre cero y uno cuyas cifras decimales se obtienen concatenando los números primos. El cual lo podemos construir en Mathematica, en sus primeras cifras, como:

cop = Flatten[Prepend[IntegerDigits[Table[Prime[n], {n, 20}]], 0]];
N[FromDigits[{cop, 1}], Length[cop] - 1]

0.235711131719232931374143475359616771

Así, determinamos la lista de los números primos y determinamos sus dígitos, eliminamos 8 y 9 y tomamos módulo 4.

lista6 = Mod[
    Select[Flatten@IntegerDigits[Table[Prime[n], {n, 100000}]], 
     And[# != 8, # != 9] &], 4] + 1;
Tally[%]

{{3, 102482}, {4, 145036}, {2, 149895}, {1, 93835}}

cuadrado[lista6]


Ahora, sin eliminar 8 y 9.


lista7 = Mod[Flatten@IntegerDigits[Table[Prime[n], {n, 100000}]], 
    4] + 1;
Tally[%]

{{3, 102482}, {4, 145036}, {2, 221957}, {1, 141009}}

cuadrado[lista7]



Ejercicio

1. Determinar otros tipos de dados, con cuatro resultados, que generen algún tipo de estructura.
2. ¿Qué pasa al tomar dados con 3,5,6,7,... número de resultados posibles para generar polígonos regulares de 3,5,6,7,... lados respectivamente.?


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

viernes, 26 de octubre de 2018

martes, 23 de octubre de 2018

Gráficas en Coordenadas Polares


El comando básico es PolarPlot







PolarPlot[2, {t, 0, 2 Pi}]




PolarPlot[t, {t, 0, 2 Pi}]



PolarPlot[{Sin[t], Cos[t]}, {t, 0, Pi}]




Opciones sobre los ejes

Manipulate[
 PolarPlot[Sin[3 t], {t, 0, Pi}, PolarGridLines -> lines, 
  PolarAxes -> axes], {{lines, True, "Líneas"}, {True, False, 
   Automatic}}, {{axes, True, "Eje"}, {True, False, Automatic}}]




Construcciones

Principales gráficas en polares

Manipulate[
 PolarPlot[{r, 2}, {t, 0, a}, PolarAxes -> True, PlotRange -> 4, 
  PolarGridLines -> {True, {1, 2, 3}}, 
  PolarTicks -> {Table[n Pi/6, {n, 0, 12}], {1, 2}}, 
  PlotStyle -> {Red, LightGray}], {{a, 2 \[Pi]}, 0.00001, 
  2 \[Pi]}, {{r, 3 Sin[t], "Función r"}, {3 Sin[t] -> "3 Sen(t)", 
   3 Cos[t] -> "3 Cos(t)", 1.5 - 1.5 Sin[t] -> "3/2(1-Sen(t))", 
   1.5 + 1.5 Sin[t] -> "3/2(1+Sen(t))", 
   1.5 - 1.5 Cos[t] -> "3/2(1-Cos(t))", 
   1.5 + 1.5 Cos[t] -> "3/2(1+Cos(t))", 1 + 2 Sin[t] -> "1+2Sen(t)", 
   3 Sin[2 t] -> "3 Sen(2t)", 3 Cos[3 t] -> "3 Cos(3t)"}}]



Rosas

Manipulate[
 PolarPlot[Sin[n t], {t, 0, a}, PolarGridLines -> Automatic, 
  PolarAxes -> True, PlotRange -> 2, PlotStyle -> Red], {{a, Pi}, 
  Pi/2, 2 \[Pi]}, {n, 1, 12, 1}]



Otros gráficos

ListPolarPlot[Table[Sin[2 t] Cos[2 t], {t, 0, 2 Pi, 0.01}], 
 PolarAxes -> Automatic, 
 PolarGridLines -> {{{Pi/6, Blue}, {Pi/3, Red}, 
    3 Pi/2, {Pi, Dashed}}, {{0.2, Red}, {0.4, Cyan}, {0.6, Red}, 
    0.8}}, PolarTicks -> {"Degrees", Automatic}]





PolarPlot[Sin[3 t] Cos[5 t], {t, 0, 2 Pi}, 
 PolarGridLines -> Automatic, PolarAxes -> True, 
 GridLinesStyle -> Directive[Dotted, Orange], PlotRange -> 1.5]



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

viernes, 19 de octubre de 2018

Frase Célebre de Brian Greene

Cuando los niños miren a los grandes científicos 
como miran a los grandes músicos y actores, 
la civilización saltará al próximo nivel.

Brian Greene

martes, 16 de octubre de 2018

Integración Numérica


Vamos a realizar una tabla para comparar los resultados de integrales numéricas por los métodos de : punto medio, sumas a izquierda, sumas a derecha, trapecio y Simpson 1/3.

En la tabla podremos modificar los intervalos, el número de divisiones y las funciones a integrar.

Clear[h, f1, f2, f3]
f1[x_] := Sin[x]
f2[x_] := Log[x + 2]
f3[x_] := Exp[x]
Manipulate[h = (b - a)/n; 
 Grid[{{"Método", "Valor"}, {"Sumas a Derecha", 
    h Sum[f[a + i h], {i, 1, n}] // N}, {"Sumas a Izquierda", 
    h Sum[f[a + (i - 1) h] , {i, 1, n}] // N}, {"Punto Medio", 
    h Sum[f[a + (i - 1/2) h], {i, 1, n}] // N}, {"Trapecio", 
    h/2 (f[ a] + f[b] + 2 Sum[f[a + i h], {i, 1, n - 1}] ) // 
     N}, {"Simpson", 
    h/3 (f[ a] + f[b] + 2 Sum[f[a + 2 i h], {i, 1, n/2 - 1}] + 
        4 Sum[f[a + (2 i - 1) h], {i, 1, n/2}]) // N}, {"Exacta", 
    NIntegrate[f[x], {x, a, b}]}}, Frame -> All], {a, 0, 5} , {{b, 2},
   a, 10} , {n, 2, 10, 
  2}, {{f, f1, "Funciones"}, {f1 -> "Sen(x)", f2 -> "Ln(x+2)", 
   f3 -> "Exp(x)"}}]





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


viernes, 12 de octubre de 2018

Frase Célebre de André Weil

Todo matemático digno de este nombre ha conocido,
puede que sólo en momentos excepcionales,
esos estados de exaltación lúcida 
en que los pensamientos se encadenan de forma milagrosa 
y en que el inconsciente 
(sea cual sea el significado que se le atribuya a esta palabra) también parece tomar parte.

André Weil

martes, 9 de octubre de 2018

Cortezas Cilíndricas


Colaboración del Profesor Nicolás Marciales

Se hace rotar la región encerrada por la función y = Sen(x) con 0<x<Pi y el eje x, con respecto al eje y. Posteriormente se simulan por medio de bandas las cortezas cilíndricas que aproximan el sólido generado.

Clear[n]; Manipulate[
 Show[ContourPlot3D[
   z == Sin[Sqrt[x^2 + y^2]], {x, -Pi, Pi}, {y, -Pi, Pi}, {z, -2, 2}, 
   RegionFunction -> Function[{x, y, z}, 0 < x^2 + y^2 < Pi^2], 
   Mesh -> None, ContourStyle -> Opacity[0.3]], 
  ContourPlot3D[
   Evaluate@Table[x^2 + y^2 == k^2, {k, 0, 3, 3/n}], {x, -Pi, 
    Pi}, {y, -Pi, Pi}, {z, -2, 2}, 
   ContourStyle -> {Opacity[0.1], Red}, Mesh -> 1, 
   RegionFunction -> 
    Function[{x, y, z}, 0 < z <= Sin[Sqrt[x^2 + y^2]]]], 
  AxesOrigin -> {0, 0, 0}], {{n, 1}, 1, 20, 1}]





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

viernes, 5 de octubre de 2018

Frase Célebre de Hipatia de Alejandría

Defiende tu derecho a pensar, 
porque incluso pensar de forma errónea 
es mejor que no pensar.

Hipatia de Alejandría

martes, 2 de octubre de 2018

La Hipótesis de Riemann


Esta conjetura fue enunciada en el año de 1859 por el matemático alemán Bernard Riemann en su tesis doctoral, en esencia plantea que:

para la función Zeta de Riemann definida en los números complejos por:



todos sus ceros no triviales tienen parte real igual a 1/2.

Una de las grandes importancias de la función Zeta de Riemann es que el matemático suizo Leonard Euler había previamente probado la siguiente relación:



Así, los ceros de la función Zeta de Riemann tienen relación con la distribución de los números primos, de aquí su importancia.

El problema ha tomado relevancia a nivel popular pues el pasado Lunes 24 de Septiembre el matemático Michael Atiyah, laureado con la medalla Fields en 1966, ha realizado una posible demostración (aún no es aceptada por la comunidad matemática en general).


En Mathematica

Mathematica incorpora el comando Zeta[ ] para el cálculo de la función Zeta de Riemann.

Al pedirle a Mathematica que nos muestre los ceros de la función Zeta con parte real igual a 1/2, obtenemos:

Reduce[Zeta[z] == 0, z]






es decir, realiza el calculo asumiendo como cierta la hipótesis de Riemann.

Es imposible realizar un gráfico de la función Zeta de Riemann pues es una función de los complejos en los complejos, si asumimos los complejos como una representación del plano, tendríamos que la gráfica se debe realizar en cuatro dimensiones. Por tanto representaremos la parte real de la función Zeta de Riemann con un plano horizontal en cero y uno vertical en 1/2.

Show[Plot3D[{Re[Zeta[s + I t]], 0}, {s, 0, 1}, {t, 0, 50}, 
  BoxRatios -> {1, 5, 1.5}], 
 ContourPlot3D[s == 1/2, {s, 0, 1}, {t, 0, 50}, {u, -2, 3}, 
  Mesh -> None, ContourStyle -> Opacity[0.5]]]




Al graficar en un mismo plano tanto la parte real como la parte imaginaria de la función Zeta de Riemann para valores complejos de parte real igual a 1/2 vemos sus ceros (para la parte imaginaria entre 10 y 50) donde ambas funciones cortan el eje X.

Plot[{Re@Zeta[1/2 + I x], Im@Zeta[1/2 + I x]}, {x, 10, 50}, 
 PlotStyle -> {Red, Green}, PlotLegends -> "Expressions"]



Realizamos un Manipulate para valores de la parte imaginaria entre 10 y 50, representando la parte real y la parte imaginaria de la función Zeta de Riemann para valores de la parte real entre -1 y 10.

Manipulate[
 Plot[{Re@Zeta[c + I x], Im@Zeta[c + I x]}, {x, 10, 50}, 
  PlotRange -> 5, PlotStyle -> {Red, Green}, 
  PlotLegends -> {"Parte Real", "Parte Imaginaria"}], {{c, 1/2, 
   "Parte Real del Dominio"}, -1, 10}]




Vemos como la parte imaginaria se estabiliza en cero y la parte real en uno, lo cual no da posibilidad de la aparición de otros ceros de la función.


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