Resultado curioso con la constante de Euler

 Descargar como Notebook

La constante de Euler aparece de muchas y variadas formas en el cálculo. Pero la siguiente es una que no tengo la explicación del por qué aparece.

Consideramos números aleatorios entre 0 y 1, nos interesa el número necesario para que la suma supere a uno. 

Por ejemplo, consideremos seis números aleatorios entre 0 y 1,

tabla = Table[RandomReal[], {6}]

{0.331578, 0.229754, 0.580864, 0.346653, 0.90035, 0.917802}

La suma acumulada de los tres primeros ya supera la unidad, entonces nos quedamos con el número 3,

Accumulate[tabla]

{0.331578, 0.561332, 1.1422, 1.48885, 2.3892, 3.307}

Esto lo podemos conseguir así :

s = 0; n = 0; int = {};

While[s < 1, s = s + RandomReal[]; n++; AppendTo[int, n]]; Last[int]

Lo sorprendente es que sí realizamos el anterior proceso un gran número de veces y promediamos la cantidad de números necesarios para alcanzar la unidad, el resultado tiende a la Constante de Euler.

Forma 1

Realizando el proceso 100000 veces .

prom = {};

Do[s = 0; n = 0; int = {};

 While[s < 1, s = s + RandomReal[]; n++; AppendTo[int, n]];

 AppendTo[prom, Last[int]], {i, 100000}]

Mean[prom] // N

2.71592

Forma 2

Este código nos da la posibilidad de graficar los promedios.

prom = {}; num = 0;

Do[s = 0; n = 0; int = {};

 While[s < 1, s = s + RandomReal[]; n++; AppendTo[int, n]]; 

 num = num + Last[int];

 AppendTo[prom, num/i], {i, 200000}]

N[Last[prom], 10]

2.716675000

Graficando la aproximación

Show[ListPlot[prom], Plot[E, {x, 0, Length[prom]}, PlotStyle -> Red], 

 PlotRange -> {2.6, 2.8}, AxesOrigin -> {0, 2.6}]

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

Definición de Caos por Edward Lorentz

 Cuando el presente determina el futuro,

pero una aproximación del presente no aproxima el futuro.

Pelota rebotando sobre una Parábola

 Descargar como Notebook

Se deja caer una pelota sobre una parábola bajo la acción únicamente de la fuerza de gravedad, su trayectoria genera la envolvente lineal de una nueva parábola.

Primero se resuelve la Ecuación Diferencial de forma numérica.

Clear["Global`*"]

g = 9.81;

tmax = 15;

rebote = ReflectionTransform[{1, 2 x[t]}][{-x'[t], -y'[t]}];

solucion[x0_, y0_] := 

  NDSolveValue[{y''[t] == -g, x''[t] == 0, x'[0] == 0, y'[0] == 0, 

    x[0] == x0, y[0] == y0, 

    WhenEvent[

     y[t] == x[t]^2, {x'[t], y'[t]} -> Evaluate[rebote]]}, {x, y}, {t,

     0, tmax}];

Se elige el valor inicial desde el cual se deja caer la pelota.

{xf1, yf1} = solucion[0.402, 1.];(*Cambiar el punto inicial*)

graf3 = Plot[x^2, {x, -1, 1}, PlotStyle -> Red, 

   PlotRange -> {{-1, 1}, {-0.1, 1.2}}];

Manipulate[

 max = Max[

   Transpose[

     Select[Table[{xf1[n], yf1[n]}, {n, 0, 15, 0.001}], 

      Abs[#[[1]]] < 0.001 &]][[2]]]; 

 p[a_] := Fit[{{0, max}, {xf1[0], yf1[0]}, {-xf1[0], yf1[0]}}, {1, x, 

     x^2}, x] /. {x -> a}; 

 Show[graf3, 

  If[ttt == tmax, ParametricPlot[{xf1[t], yf1[t]}, {t, 0, ttt}], 

   graf3], If[pp, Plot[p[a], {a, -1, 1}, PlotStyle -> Green], graf3], 

  Graphics[{PointSize[0.03], Blue, Point[{xf1[ttt], yf1[ttt]}]}], 

  Ticks -> None, Background -> Black], {{ttt, 0.00001, "Inicio"}, 

  0.00001, tmax, Trigger, 

  DefaultDuration -> 15}, {{pp, False, "Parábola Interna"}, {False, 

   True}}]

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 Jacob Bronowski

 Es importante que los estudiantes 

traigan cierta desnuda irreverencia a sus estudios;

no están aquí para rendir culto al conocimiento 

sino para ponerlo en tela de juicio.

Jacob Bronowski

Distancia Media de dos puntos sobre la Circunferencia Unitaria

 Descargar como Notebook

Determinar la media (el promedio) de las distancias de dos puntos que se encuentran sobre la circunferencia de radio uno. 

f[t_] := {Cos[t], Sin[t]}

Graphics[{Circle[], 

  Table[{Hue[Cos[i]], 

    Line[{f[RandomReal[2 Pi]], f[RandomReal[2 Pi]]}]}, {i, 100}]}]

Considerando los puntos en coordenadas polares son de radio 1 y únicamente quedan determinados por su ángulo.

La distancia entre los puntos (Cos(t1),Sen(t1)) y (Cos(t2),Sen(t2)) es:

Simplify[Sqrt[(Cos[t1] - Cos[t2])^2 + (Sin[t1] - Sin[t2])^2]]

TrigReduce[%]

Como, t1 y t2 toman valores entre 0 y 2Pi, por la fórmula del valor medio tenemos:

4/π

Comprobándolo por medio de una simulación:

Para 100 líneas:

ss = 0; pro = {}; nn = 100; Do[t1 = RandomReal[2 Pi]; 

 t2 = RandomReal[2 Pi];

 ss = ss + Sqrt[2 - 2 Cos[t1 - t2]]; AppendTo[pro, ss/i], {i, nn}];

Show[Plot[4/Pi, {x, 0, nn}, PlotStyle -> Red, PlotRange -> {0, 1.5}, 

  PlotLabels -> "Expressions"], ListPlot[pro]]

Para 1000 líneas :

Para 100000 líneas :

Que se corresponde con los resultados teóricos.

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