Frase Célebre de Jesús Mosterín

La matemática es la más grande aventura del pensamiento humano. 

Jesús Mosterín 

Curva o Ventana de Viviani

Descargar como Notebook

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

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

Sucesión Contadora

Descargar como Notebook

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

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

Series de Taylor

Descargar como Notebook

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

Frase Célebre de John Dewey

Si enseñas a los niños de hoy como enseñamos ayer, 
les estamos robando el mañana.

John Dewey

Comparación entre las diferentes medias

Descargar como Notebook

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

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