Entrada destacada

Distancia media de dos puntos en un cuadrado unitario

martes, 15 de diciembre de 2020

martes, 8 de diciembre de 2020

Teorema de Zeckendorf


Enunciado y demostrado por el matemático belga Edouard Zeckendorf (1901 - 1983), conocido por su trabajo sobre la sucesión de Fibonacci y en especial por el Teorema que lleva su nombre, que dice:

Todo entero positivo se escribe, de manera única, 
como suma de números de Fibonacci no consecutivos.

Los números de Fibonacci corresponden a la sucesión recursiva definida por:

f (1) = 1; f (2) = 1     y     f (n + 2) = f (n + 1) + f (n) para n > 0.

los primeros treinta números son :

Table[Fibonacci[n], {n, 30}] 

{1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987, 1597, 
2584, 4181, 6765, 10946, 17711, 28657, 46368, 75025, 121393, 196418, 
317811, 514229, 832040}

El procedimiento para determinar los números de la sucesión de Fibonacci que logran la representación del Teorema de Zeckendorf es: dado el entero positivo n se determina el mayor número de Fibonacci que es menor que n, se realiza la resta y se repite el proceso hasta obtener un número de Fibonacci donde el proceso se detiene.

En Mathematica

Se crea la función ff[n] que nos genera el mayor número de Fibonacci que es menor que n,

ff[n_] := Fibonacci[NestWhile[(# + 1) &, 1, Fibonacci[#] <= n &] - 1]

por ejemplo:

ff[100]
89

ff[144]
144

Ahora, generamos la rutina que  genera la lista de números de Fibonacci que nos afirma el Teorema de Zeckendorf.

zz[n_] := n - ff[n]
zeck[n_] := 
 Module[{lis}, lis = NestWhileList[zz, n, # != 0 &]; 
  Map[ff, Delete[lis, -1]]]

Algunos ejemplos:

Ejemplo 1:

zeck[33]

{21, 8, 3, 1}

Total[{21, 8, 3, 1}]

33

Ejemplo 2:

zeck[88]

{55, 21, 8, 3, 1}

Total[{55, 21, 8, 3, 1}]

88

Ejemplo 3:

zeck[4180]

{2584, 987, 377, 144, 55, 21, 8, 3, 1}

Total[{2584, 987, 377, 144, 55, 21, 8, 3, 1}]

4180


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

martes, 1 de diciembre de 2020

Frase Célebre de René Descartes


Para saber que sabemos lo que sabemos,
y que no sabemos lo que no sabemos,
hay que tener cierto conocimiento.

René Descartes

martes, 24 de noviembre de 2020

Transformaciones de Funciones



Consiste en los cambios que se pueden obtener sobre una función al pre-componer y pos-componer con respecto a funciones lineales.

Consideraremos la función:


f[x_] := Piecewise[{{x + 2, -1 <= x < 0}, {2, 0 <= x < 2}, {-x + 4, 
    2 <= x < 4}, {x - 4, 4 <= x <= 5}}, None]
Plot[f[x], {x, -5, 5}, GridLines -> All]


Pos - composición : Transformación en Y

Sea g(x) = c x + d, realizaremos la composición (g\[SmallCircle]f)(x) = g(f(x)) = c f(x) + d, que afecta a la función en el eje Y. 

f[x_] := Piecewise[{{x + 2, -1 <= x < 0}, {2, 0 <= x < 2}, {-x + 4, 
    2 <= x < 4}, {x - 4, 4 <= x <= 5}}, None]
Manipulate[g[x_] := c x + d; 
 Show[Plot[{f[x], g[f[x]]}, {x, -6, 6}, 
   PlotLabel -> Row[{c, "f(x)", If[d >= 0, "+", ""], d}], 
   PlotStyle -> {{Dashed, Blue}, {Red, Thickness[0.01]}}, 
   PlotRange -> 8, GridLines -> All, AspectRatio -> 1], 
  Graphics[{Text["f(x)", {2.2, 2.2}]}]], {{c, 1}, -3, 3}, {{d, 0}, -3,
   3}]



Pre - composición : Transformación en X

Sea g(x) = a x + b, realizaremos la composición (f\[SmallCircle]g)(x) = f(g(x)) = f(a x + b), que afecta a la función en el eje X. 

f[x_] := Piecewise[{{x + 2, -1 < x < 0}, {2, 0 < x < 2}, {-x + 4, 
    2 < x < 4}, {x - 4, 4 < x < 5}}, None]
Manipulate[g[x_] := a x + b; 
 Show[Plot[{f[x], f[a x + b]}, {x, -6, 6}, 
   PlotLabel -> Row[{"f(", a, "x", If[b >= 0, "+", ""], b, ")"}], 
   PlotStyle -> {{Dashed, Blue}, {Red, Thickness[0.01]}}, 
   PlotRange -> 8, GridLines -> All, AspectRatio -> 1], 
  Graphics[{Text["f(x)", {2.2, 2.2}]}]], {{a, 1}, -3, 3}, {{b, 0}, -3,
   3}]


Composiciones con g (x) = - x

Clear[f, gf, gfg]
f[x_] := Piecewise[{{x + 2, -1 < x < 0}, {2, 0 < x < 2}, {-x + 4, 
    2 < x < 4}, {x - 4, 4 < x < 5}}, None]
Manipulate[
 Plot[{f[x], 
   Evaluate@Switch[op, fg, f[-x], gf, -f[x], gfg, -f[-x]]}, {x, -5, 
   5}, PlotRange -> 5, 
  PlotStyle -> {{Dashed, Blue}, {Red, Thickness[0.01]}}, 
  GridLines -> All, 
  AspectRatio -> 1], {{op, "", "Composición: Roja"}, {fg -> "f(-x)", 
   gf -> "-f(x)", gfg -> "-f(-x)"}}]







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

martes, 17 de noviembre de 2020

Frase Célebre de George Polyá

Si no puedes resolver un problema,
entonces hay una manera más sencilla de resolverlo:
encuéntrala.

George Polyá

martes, 10 de noviembre de 2020

Funciones Inversas


Definición

La inversa de una función f(x) corresponde a una función g(x) tal que:

( f ∘ g ) ( x ) = x        y       ( g ∘ f ) ( x ) = x

En la práctica, la gráfica de la inversa de una función corresponde a su simétrica con respecto a la función idéntica 
Id( x ) = x.
Para que la inversa sea función es necesario que la función inicial sea inyectiva, rectas horizontales la cortan en un único punto.

Show[ContourPlot[{y == x^2 + 1, y == x, x == y^2 + 1}, {x, -5, 
   5}, {y, -5, 5}, Axes -> True, GridLines -> Automatic], 
 Graphics[{Text["f(x)", {-1, 3}], 
   Text["\!\(\*SuperscriptBox[\(f\), \(-1\)]\)(x)", {3, -1}], 
   Text["Id", {4, 4.2}], Red, Dashed, Line[{{-2, 4}, {2, 4}}], 
   Line[{{4, -2}, {4, 2}}]}]]


La función f(x), por no ser inyectiva, no tiene inversa pues f^-1(x) NO es una función. Las líneas horizontales en f (para ser inyectiva) se vuelven verticales en f^-1 (para ser función).

Restricciones del Dominio e Inversas

Seno

gra = Graphics[{Point[{0, 0}]}];
Manipulate[
 Show[Plot[{If[id, x, Sin[x]], Sin[x]}, {x, -Pi, Pi}, 
   PlotRange -> {{-Pi, Pi}, {-Pi, Pi}}, AspectRatio -> Automatic], 
  If[re, Plot[Sin[x], {x, -Pi/2, Pi/2}, PlotStyle -> {Red, Dashed}], 
   gra], If[inv, 
   Plot[ArcSin[x], {x, -Pi, Pi}, PlotStyle -> {Green, Dashed}], 
   gra]], {{id, False, "Idéntica"}, {False, True}}, {{re, False, 
   "Restricción"}, {False, True}}, {{inv, False, "Inversa"}, {False, 
   True}}]


Coseno

gra = Graphics[{Point[{0, 0}]}];
Manipulate[
 Show[Plot[{If[id, x, Cos[x]], Cos[x]}, {x, -Pi, Pi}, 
   PlotRange -> {{-Pi, Pi}, {-Pi, Pi}}, AspectRatio -> Automatic], 
  If[re, Plot[Cos[x], {x, 0, Pi}, PlotStyle -> {Red, Dashed}], gra], 
  If[inv, Plot[ArcCos[x], {x, -Pi, Pi}, PlotStyle -> {Green, Dashed}],
    gra]], {{id, False, "Idéntica"}, {False, True}}, {{re, False, 
   "Restricción"}, {False, True}}, {{inv, False, "Inversa"}, {False, 
   True}}]



Tangente

gra = Graphics[{Point[{0, 0}]}];
Manipulate[
 Show[Plot[{If[id, x, Tan[x]], Tan[x]}, {x, -Pi, Pi}, 
   PlotRange -> {{-Pi, Pi}, {-Pi, Pi}}, AspectRatio -> Automatic], 
  If[re, Plot[Tan[x], {x, -Pi/2, Pi/2}, PlotStyle -> {Red, Dashed}], 
   gra], If[inv, 
   Plot[ArcTan[x], {x, -Pi, Pi}, PlotStyle -> {Green, Dashed}], 
   gra]], {{id, False, "Idéntica"}, {False, True}}, {{re, False, 
   "Restricción"}, {False, True}}, {{inv, False, "Inversa"}, {False, 
   True}}]


Todas en un Aplicativo

gra = Graphics[{Point[{0, 0}]}]; RefLink[
 Off,paclet : ref/Off][message];
f1[x_] := x^2
Manipulate[
 Switch[fun, Sin, aa = -Pi/2; bb = Pi/2; s = 1, Cos, aa = 0; bb = Pi; 
  s = 1, Tan, aa = -Pi/2; bb = Pi/2; s = 1, f1, aa = 0; bb = Pi; 
  s = -1]; Show[
  Plot[{If[id, x, fun[x]], fun[x]}, {x, -Pi, Pi}, 
   PlotRange -> {{-Pi, Pi}, {-Pi, Pi}}, AspectRatio -> Automatic], 
  If[re, Plot[fun[x], {x, aa, bb}, PlotStyle -> {Red, Dashed}], gra], 
  If[inv, Plot[s InverseFunction[fun][x], {x, -Pi, Pi}, 
    PlotStyle -> {Green, Dashed}], gra]], {{fun, Sin, 
   "Función"}, {Sin -> "Seno", Cos -> "Coseno", Tan -> "Tangente", 
   f1 -> " Á\[Divide]É\[Divide]È\[Divide]SuperscriptBox[É\[Divide]xÀ\
\[Divide], É\[Divide]2À\[Divide]]À\[Divide] "}}, {{id, False, 
   "Idéntica"}, {False, True}}, {{re, False, "Restricción"}, {False, 
   True}}, {{inv, False, "Inversa"}, {False, True}}]


Inversas sin Restricción del Dominio

gra = Graphics[{Point[{0, 0}]}];
f1[x_] := x^2
f2[x_] := x^3
Manipulate[aa = -Pi; bb = Pi; 
 Switch[fun, f2, inversa = CubeRoot, Exp, inversa = Log, Log, 
  inversa = Exp, Sqrt, inversa = f1; aa = 0; bb = Pi]; 
 Show[Plot[{If[id, x, fun[x]], fun[x]}, {x, -Pi, Pi}, 
   PlotRange -> {{-Pi, Pi}, {-Pi, Pi}}, AspectRatio -> Automatic], 
  If[inv, Plot[inversa[x], {x, aa, bb}, PlotStyle -> {Green, Dashed}],
    gra]], {{fun, "", "Función"}, {Exp -> "Exponencial", 
   Log -> "Logarítmo", Sqrt -> "Raíz Cuadrada", 
   f2 -> " \!\(\*SuperscriptBox[\(x\), \(3\)]\) "}}, {{id, False, 
   "Idéntica"}, {False, True}}, {{inv, False, "Inversa"}, {False, 
   True}}]





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

martes, 3 de noviembre de 2020

martes, 27 de octubre de 2020

El Juego del Caos como un Sistema Iterado de Funciones SIF



Volvemos a hablar sobre el Juego del Caos, el cual ya lo mencionamos en publicaciones anteriores, su importancia radica en que su generalización nos permitirá la construcción de fractales mediante Sistemas Iterados de Funciones SIF o IFS por sus siglas en inglés.

Recordemos en que consistía: Se parte de tres puntos en una hoja A, B y C (que llamaremos vértices) no colineales, es decir no sobre la misma recta,  y otro punto P (que llamaremos punto de partida), se toma un dado de seis lados y se lanza si el resultado es 1 o 2 nos dirigimos desde P hasta A pero nos quedamos a mitad de camino, si es 3 o 4 lo mismo pero dirigiéndonos a B y si es 5 o 6 dirigiéndonos a C, marcamos el punto sobre la hoja y volvemos a repetir el procedimiento desde el punto que nos habíamos quedado.

Al realizar este proceso se encuentra el triángulo de Sierpinski. aquí un ejemplo para los vértices A(2,1), B(3,0) y C(4,0), y repitiendo el proceso cien mil veces.

vertices = {{2, 1}, {3, 0}, {4, 0}};
inicio = {0, 0};
ran := RandomChoice[Table[1./3, {n, 3}] -> Range[3], 1][[1]]
siguiente[punto_] := (vertices[[ran]] + punto)/2.
ListPlot[NestList[siguiente, inicio, 100000], AspectRatio -> 1, 
 Axes -> True, PlotStyle -> PointSize[0.001]]



El proceso del Juego del Caos lo podemos ver como una transformación afín del plano en el plano, es decir una transformación lineal sobre el plano (multiplicar por una matriz dos por dos) más una traslación (sumar un par de coordenadas).

Estas transformaciones afines las podemos ver como:





Consideraremos las reglas:
R1: Mover hasta el punto medio entre el actual y A(2,1).
R2: Mover hasta el punto medio entre el actual y B(3,0).
R3: Mover hasta el punto medio entre el actual y C(4,0).
Todas aplicadas con igual probabilidad.

Para la regla R1, partiendo del punto (x,y) y llegando al punto medio a A(2,1) obtenemos la función:





Para la regla R2, partiendo del punto (x, y) y llegando al punto medio a B (3,0) obtenemos la función:





Para la regla R3, partiendo del punto (x, y) y llegando al punto medio a C (4, 0) obtenemos la función:





Generalizamos estas tres funciones en la función definida por:

f[n_, {x_, y_}] := {a[[n]] x + b[[n]] y + c[[n]], 
  d[[n]] x + e[[n]] y + k[[n]]}

donde n corresponde al número de la regla, y los coeficientes vienen dados en las listas:

a = {1/2, 1/2, 1/2};
b = {0, 0, 0};
c = {1, 3/2, 2};
d = {0, 0, 0};
e = {1/2, 1/2, 1/2};
k = {1/2, 0, 0};

Como todas las funciones se aplican con igual probabilidad de 1/3, definimos el dado de tres resultados posibles {1,2,3} e igual probabilidad {0.33,0.33,0.33}:

prob = {0.33, 0.33, 0.33};
ran := RandomChoice[prob -> {1, 2, 3}, 1][[1]]

Ahora, definimos la función siguiente [ ], que nos va a permitir iterar el punto, aplicando la función f1, f2 o f3, dependiendo del resultado del dado que está dado por el valor ran:

siguiente[punto_] := f[ran, punto]

La lista de todas las iteraciones la obtenemos mediante el comando NestList[ ] que tiene tres argumentos: la función a iterar, el punto de partida y el número de iteraciones que se van a realizar. Aquí, la función a iterar es siguiente, partiendo del punto (0,0) y el proceso se realizará 10 veces.

NestList[siguiente, {0, 0}, 10]
{{0, 0}, {1., 0.5}, {1.5, 0.75}, {1.75, 0.875}, {2.375, 
  0.4375}, {3.1875, 0.21875}, {3.09375, 0.109375}, {3.04688, 
  0.0546875}, {2.52344, 0.527344}, {3.26172, 0.263672}, {3.13086, 
  0.131836}}

Para graficar la lista obtenida lo hacemos mediante el comando ListPlot[ ],

ListPlot[%]


Resumiendo todo en una única entrada y realizando la iteración para cien mil puntos, obtenemos:

a = {1/2, 1/2, 1/2};
b = {0, 0, 0};
c = {1, 3/2, 2};
d = {0, 0, 0};
e = {1/2, 1/2, 1/2};
k = {1/2, 0, 0};
prob = {0.33, 0.33, 0.34};
ran := RandomChoice[prob -> {1, 2, 3}, 1][[1]]
siguiente[punto_] := N[f[ran, punto]]
ListPlot[NestList[siguiente, {0, 0}, 100000], 
 PlotStyle -> PointSize[Tiny], Axes -> True]


Variación sobre las reglas

Vamos a considerar los mismos vértices anteriores A(2,1), B(3,0) y C(4,0), pero consideraremos dos reglas adicionales R4 y R5, y más importante la forma de decidir la regla que se aplicará en cada caso, aunque el dado sigue siendo el mismo:
  R1 : Mover hasta el punto medio entre el actual y A (2, 1).
  R2 : Mover hasta el punto medio entre el actual y B (3, 0).
  R3 : Mover hasta el punto medio entre el actual y C (4, 0).
  R4: Cambiamos por el punto 2(B-C).
  R5: Rotar 180º alrededor del punto (A+5B-4C)/2.
    Las probabilidades del dado son iguales, pero ahora, se tiene memoria del resultado anterior del dado para determinar que regla se aplica:



  La regla R4, la definimos por la función constante :

f4 (x, y) = 2 (B - C) = 2 ((3, 0) - (4, 0)) = (-2, 0)

La regla R5, partiendo del punto (x,y) buscamos el punto (m,n) que deje como punto medio al punto (A+5B-4C)/2=(1/2,1/2),


así,

f5(x,y)=( - x + 1 , - y + 1).

Y los coeficientes de las cinco funciones los resumimos en las siguientes listas:

a = {1/2, 1/2, 1/2, 0, -1};
b = {0, 0, 0, 0, 0};
c = {1, 3/2, 2, -2, 1};
d = {0, 0, 0, 0, 0};
e = {1, 1, 1, 0, -1};
k = {1, 0, 0, 0, 1};

El dado y la forma de seleccionar la función están dados por:

prob = {0.33, 0.33, 0.34};
ran := Module[{dado = 1, da}, da = dado; 
  dado = RandomChoice[prob -> {1, 2, 3}, 1][[1]]; 
  Which[(da == 1 || da == 2) && dado == 1, 
   1, (da == 1 || da == 2) && dado == 2, 
   2, (da == 1 || da == 2) && dado == 3, 4, 
   da == 3 && (dado == 1 || dado == 2), 5, da == 3 && dado == 3, 3]]

Resumiendo en una única entrada, tenemos :

a = {1/2, 1/2, 1/2, 0, -1};
b = {0, 0, 0, 0, 0};
c = {1, 3/2, 2, -2, 1};
d = {0, 0, 0, 0, 0};
e = {1, 1, 1, 0, -1};
k = {1, 0, 0, 0, 1};
prob = {0.33, 0.33, 0.34};
ran := Module[{dado = 1, da}, da = dado; 
  dado = RandomChoice[prob -> {1, 2, 3}, 1][[1]]; 
  Which[(da == 1 || da == 2) && dado == 1, 
   1, (da == 1 || da == 2) && dado == 2, 
   2, (da == 1 || da == 2) && dado == 3, 4, 
   da == 3 && (dado == 1 || dado == 2), 5, da == 3 && dado == 3, 3]]
siguiente[punto_] := f[ran, punto]
ListPlot[NestList[siguiente, {0, 0}, 100000], 
 PlotStyle -> PointSize[Tiny], Axes -> True]


Curiosamente el resultado obtenido es el Triángulo de Sierpinski con vértices en los puntos (0,0), (1/2,1) y (1,0).


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

martes, 20 de octubre de 2020

Frase Célebre de Nikolai Lobachevsky

No hay rama de las matemáticas,
por más abstracta que sea,
que quizás no se aplique algún día 
a los fenómenos del mundo real.

Nikolai Lobachevsky

martes, 13 de octubre de 2020

Función Exponencial


Son las funciones de la forma :



Manipulate[
 Show[Plot[{a^x, Log[a] x + 1}, {x, -5, 5}, 
   PlotRange -> {{-5.5, 5.5}, {-0.5, 10.5}}, GridLines -> All, 
   AspectRatio -> 1, 
   PlotLabel -> Row[{"f(x) = ", Defer[ Dynamic[a]^x ]}]], 
  Graphics[{Text[Row[{"m = ", N@Log[a]}], Sign[Log[a]] {4, 4 Log[a]}],
     Red, PointSize[0.01], Point[{0, 1}]}]], {{a, 2, "a"}, 0.08, 4}]



Gráficas de las funciones exponenciales, con su recta tangente en el punto (0,1) y su pendiente.
Se observa que la pendiente 1 corresponde al valor de la constante de Euler.

Comportamiento de y = aˣ con y = a⁻ˣ


Show[Plot[{a^x, a^(-x)}, {x, -5, 5}, 
   PlotRange -> {{-5.5, 5.5}, {-0.5, 10.5}}, GridLines -> All, 
   AspectRatio -> 1, PlotLabel -> Row[{"a = ", Defer[ Dynamic[a] ]}]],
   Graphics[{Text[
     "f(x) = \!\(\*SuperscriptBox[\(a\), \(x\)]\)", {Sign[Log[a]] 3, 
      a^(2 Sign[Log[a]])}], 
    Text["f(x) = \!\(\*SuperscriptBox[\(a\), \(-x\)]\)", {Sign[-Log[
          a]] 3, a^(2 Sign[Log[a]])}], Red, PointSize[0.01], 
    Point[{0, 1}]}]], {{a, 2, "a"}, 0.08, 4}]




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

martes, 6 de octubre de 2020

martes, 29 de septiembre de 2020

Funciones Trigonométricas



Definición de las funciones Trigonométricas 

Definición de las funciones trigonométricas sobre el circulo unitario.

g1 = ContourPlot[{x^2 + y^2 == 1}, {x, -2, 2}, {y, -2, 2}, Axes -> True]; s = 2; Manipulate[ Show[g1, Graphics[{Text["\[Theta]", 0.3 {Cos[a/2], Sin[a/2]}], Line[{{0, 0}, s Sign[Cos[a]] {1, Tan[a]}}], {Dashed, Circle[{0, 0}, 0.2, {0, a}], Line[{{0, 0}, -s Sign[Cos[a]] {1, Tan[a]}}], Switch[fun, seno, Line[{{Cos[a], 0}, {0, 0}}], coseno, Line[{{Cos[a], 0}, {Cos[a], Sin[a]}}], tangente, Line[{{1, -2}, {1, 2}}], cotangente, Line[{{-2, 1}, {2, 1}}], secante, Line[{{1, -2}, {1, 2}}], cosecante, Line[{{-2, 1}, {2, 1}}]]}, Red, Point[{Cos[a], Sin[a]}], Thickness[0.01], Switch[fun, seno, Line[{{Cos[a], 0}, {Cos[a], Sin[a]}}], coseno, Line[{{Cos[a], 0}, {0, 0}}], tangente, Line[{{1, 0}, {1, Tan[a]}}], cotangente, Line[{{0, 1}, {Cot[a], 1}}], secante, Line[{{0, 0}, {1, Tan[a]}}], cosecante, Line[{{0, 0}, {Cot[a], 1}}]]}]], {{a, Pi/4, "θ"}, 0, 2 Pi}, {{fun, seno, "Función"}, {seno, coseno, tangente, cotangente, secante, cosecante}, ControlType -> Setter}]


Construcción de las Gráficas

g1 = ContourPlot[{x^2 + y^2 == 1}, {x, -2, 2}, {y, -2, 2}, Axes -> True]; s = 1.9; Manipulate[ Switch[fun, seno, ff = Sin, coseno, ff = Cos, tangente, ff = Tan, cotangente, ff = Cot, secante, ff = Sec, cosecante, ff = Csc]; linea[ff_] := Line[{{a + 2, 0}, {a + 2, ff[a]}}]; Show[Plot[ff[x - 2], {x, 2, 2.00001 + a}, PlotRange -> {{-2.1, 9}, {-4.5, 4.5}}, Ticks -> {{{2 + Pi/2, Pi/2}, {2 + Pi, Pi}, {2 + 3 Pi/2, 3 Pi/2}, {2 + 2 Pi, 2 Pi}}, {-1, 1}}, AspectRatio -> 1], g1, Graphics[{Arrow[{{2, -4}, {2, 4}}], Arrow[{{1.5, 0}, {9, 0}}], Text["\[Theta]", {8.8, 0.2}], Text["\[Theta]", 0.3 {Cos[a/2], Sin[a/2]}], {Green, PointSize[0.02], Point[{Cos[a], Sin[a]}], Point[{a + 2, 0}]}, Line[{{0, 0}, s Sign[Cos[a]] {1, Tan[a]}}], {Dashed, Circle[{0, 0}, 0.2, {0, a}], Line[{{0, 0}, -s Sign[Cos[a]] {1, Tan[a]}}], Switch[fun, seno, Line[{{Cos[a], 0}, {0, 0}}], coseno, Line[{{Cos[a], 0}, {Cos[a], Sin[a]}}], tangente, Line[{{1, -2}, {1, 2}}], cotangente, Line[{{-2, 1}, {2, 1}}], secante, Line[{{1, -2}, {1, 2}}], cosecante, Line[{{-2, 1}, {2, 1}}]]}, Red, Thickness[0.01], linea[ff], Switch[fun, seno, Line[{{Cos[a], 0}, {Cos[a], Sin[a]}}], coseno, Line[{{Cos[a], 0}, {0, 0}}], tangente, Line[{{1, 0}, {1, Tan[a]}}], cotangente, Line[{{0, 1}, {Min[Cot[a], 4.5], 1}}], secante, Line[{{0, 0}, {1, Tan[a]}}], cosecante, Line[{{0, 0}, {Cot[a], 1}}]]}], AspectRatio -> Automatic], {{a, Pi/4, "θ"}, 0.000001, 2 Pi}, {{fun, seno, "Función"}, {seno, coseno, tangente, cotangente, secante, cosecante}, ControlType -> Setter}, ContentSize -> {400, 500}]


Representación de las funciones trigonométricas

Manipulate[ Show[Plot[f[x], {x, -2 Pi, 2 Pi}, PlotRange -> 3, Ticks -> {{-2 Pi, -3 Pi/2, -Pi, -Pi/2, Pi/2, Pi, 3 Pi/2, 2 Pi}, {-1, 1}}], ContourPlot[{y == 1, y == -1, x == 0, x == -Pi/2, x == Pi/2, x == -Pi, x == Pi, x == -3 Pi/2, x == 3 Pi/2}, {x, -2 Pi, 2 Pi}, {y, -3, 3}, ContourStyle -> {{Dashed, LightRed}}]], {f, {Sin, Cos, Tan, Cot, Sec, Csc}, ControlType -> Setter}]


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

martes, 22 de septiembre de 2020

martes, 15 de septiembre de 2020

Juego del Caos - Triángulo de Sierpinski



El matemático Británico Michael Barnsley en 1988 dio a conocer el siguiente proceso. Se parte de tres puntos en una hoja P, Q y R no colineales, no sobre la misma recta, (que llamaremos vértices) y otro punto X (que llamaremos punto de partida), se considera un dado que tiene tres resultados igualmente posibles: P, Q y R. Si el resultado es P nos dirigimos desde X hasta P pero nos quedamos a mitad de camino y allí marcamos punto, si es Q del punto que acabamos de marcar inmediatamente nos dirigimos a Q y también nos quedamos a mitad de camino y allí marcamos punto, y si es R dirigiéndonos a R desde el último punto marcamos a mitad de camino, y así sucesivamente. El resultado que se obtiene al realizar un número considerable de veces este proceso es sorprendente, es el Triángulo de Sierpinski.

A diferencia de otras publicaciones ya realizadas donde se mencionaba este procedimiento, vamos a realizar el procedimiento paso a paso. Primero lanzando el dado y dibujando el punto correspondiente, volviendo a lanzar el dado y así permitiendo realizar el proceso punto a punto, pero también se da la posibilidad de realizarlo de cien en cien puntos.

En Mathematica

lista = {}; n = 1; aa = "P";
Manipulate[If[n == 1, AppendTo[lista, s]]; vertices = {p, q, r}; 
 siguiente[punto_] := (vertices[[cc]] + punto)/2; 
 ran := RandomChoice[{0.33, 0.33, 0.34} -> {1, 2, 3}, 1][[1]];
 sig[punto_] := (vertices[[ran]] + punto)/2; 
 Show[Graphics[{Text["P", p + {0.1, 0.1}], Text["Q", q + {0.1, 0.1}], 
    Text["R", r + {0.1, 0.1}]}, PlotRange -> 2], 
  ListPlot[lista, PlotStyle -> {Red, PointSize[0.005]}]], 
 Text["Dado"], 
 Button[Dynamic[aa], cc = ran; 
  aa = Switch[cc, 1, "P", 2, "Q", 3, "R"]], 
 Text["Generación de Puntos"], Text["Uno por Uno"], 
 Button["Acción", n++; 
  AppendTo[lista, Nest[siguiente, Last[lista], 1]]; n++], 
 Text["Cien en Cien"], 
 Button["Continua", pp = NestList[sig, p, 100]; 
  lista = Join[lista, pp]], {{p, {1, 1}}, Locator}, {{q, {-1, 1}}, 
  Locator}, {{r, {-1, -1}}, Locator}, {{s, {2, 2}}, Locator, 
  Appearance -> "X"}]

Primeros pasos, se lanza el dado y luego se genera la acción


Algunos pasos más



Generando puntos de cien en cien




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


martes, 8 de septiembre de 2020

Frase Célebre de Isaac Asimov

El aspecto más triste de la vida actual
es que la ciencia gana en conocimiento
más rápidamente que la sociedad en sabiduría.

Isaac Asimov

martes, 1 de septiembre de 2020

Integración Tabular



Las integrales que son de la forma : Un polinomio por una función que sea integrable tantas veces como el grado del polinomio, se pueden resolver aplicando reiteradamente el método de Integración por Partes eligiendo al polinomio como la función a derivar, esto se denomina Integración Tabular.

En el siguiente código definimos la función con tres argumentos: ParT[polinomio,función,variable] para realizar el método de integración tabular:

flecha[p_, q_] := {Red, Opacity[0.5], Arrowheads[{{0, 0}, {.05, 1}}], 
  Arrow[{p, q}]}
ParT[po_, fu_, var_] := 
 Module[{n, pp, pol, fun}, 
  If[PolynomialQ[po, 
    var], {pol, fun} = {po, fu}, {pol, fun} = {fu, po}]; 
  n = Exponent[pol, var] + 1; int[func_] := Integrate[func, var]; 
  pp = NestList[int, fun, n];
  Column[{Graphics[{Table[
       flecha[{3, 0.5 - k}, {5, -0.5 - k}], {k, n}], 
      Table[Text[D[pol, {var, k}], {2, -0.5 - k}], {k, 0, n}], 
      Table[Text[pp[[k]], {6, 0.5 - k}], {k, n + 1}], {Text[
        "Polinomio a Derivar", {2, 0.5}], 
       Text["Función a Integrar", {6, 0.5}]}, 
      Table[Line[{{4 i, 1}, {4 i, -(n + 1)}}], {i, 0, 2}], 
      Table[Line[{{0, 1 - i}, {8, 1 - i}}], {i, 0, n + 2}], 
      Table[Text[
        Style[If[OddQ[k], "-", "+"], Large, 
         Green], {3.8, -0.6 - k}], {k, 0, n - 1}]}, 
     PlotRange -> {{0, 8.1}, {-(n + 2), 1}}, ImageSize -> Medium], 
    "de donde:", "",
    Row[{Defer[TraditionalForm[\[Integral]po fu \[DifferentialD]var]],
       " = ", 
      Row@Table[
        Row[{Style[Text[If[OddQ[k], "-", "+"]], Green], "(", 
          D[pol, {var, k}], ")", "(", pp[[k + 2]], ")"}], {k, 0, 
         n - 1}]}]
    , "", "Simplificando:", "", 
    Row[{Defer@TraditionalForm[\[Integral]po fu \[DifferentialD]var], 
      " = ", Integrate[pol fun, x]}]}]]

Ejemplo

Calcular  ∫ ( x⁸+x³ ) Sen(x) dx


Operamos:

ParT[x^8 + x^3, Sin[x], x]




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

martes, 25 de agosto de 2020

Frase Célebre de Claudi Alsina

La matemática rigurosa se hace con la mente,
la matemática hermosa se enseña con el corazón.

Claudi Alsina

martes, 18 de agosto de 2020

Función Lineal


Pendiente


Muestra que la pendiente de una recta es independiente de la elección de los puntos sobre la recta que se tomen.

a = 1; c = 3;
Manipulate[p = m (c - a); q = (c - a); 
 Show[Plot[m x + b, {x, -5, 5}, PlotRange -> {{-5, 5}, {-5, 5}}, 
   GridLines -> All, AspectRatio -> 1, 
   PlotLabel -> 
    Row[{"m =∆y/∆x = ", Defer[ Dynamic[p] /Dynamic[q]], 
      " = ", m }]], 
  Graphics[{Locator[Dynamic[{a, m a + b}]], 
    Locator[Dynamic[{c, m c + b}]], Point[{0, b}], Red, 
    Text[Row[{"b =", b}], {-0.7, b}], Dashed, 
    Line[{{a, m a + b}, {c, m a + b}, {c, m c + b}}], Blue, 
    Text[Row[{"y = ", p}], {c + 0.5, 
      m (c - a)/2 + m a + b}], 
    Text[Row[{"x = ", q}], {(c - a)/2 + a, 
      m a + b - 0.5}]}]], {{m, 1, "Pendiente: m"}, -3, 3, 
  Appearance -> "Open"}, {{b, 0, "Y-Intercepto: b"}, -3, 3}]



Forma pendiente (m) con y - Intercepto (b).


Ecuación de la recta en su forma pendiente (m) e intercepto con el eje y (b).

Manipulate[
 Show[Plot[m x + b, {x, -5, 5}, PlotRange -> {{-5, 5}, {-5, 5}}, 
   GridLines -> All, AspectRatio -> 1, 
   PlotLabel -> Row[{"y = ", TraditionalForm[m x + b] }]], 
  Graphics[{Point[{0, b}], Red, Text[Row[{"b =", b}], {-0.7, b}], 
    Dashed, Line[{{0, b}, {1, b}, {1, m + b}}], 
    Text[Row[{"m=", m}], {1.65, b + m/2}], 
    Text["1", {0.5, b - Sign[m] 0.25}]}]], {{m, 1, 
   "Pendiente: m"}, -3, 3, 0.5}, {{b, 0, "Y-Intercepto: b"}, -3, 3, 
  0.5}]


Forma pendiente (m) y un punto de la recta(x₀,y₀)


La ecuación general de la recta dada la pendiente (m) y un punto de la recta (x₀,y₀) es:

y - y₀ = m (x - x₀)



o, de forma equivalente :

m=(y-y₀)/(x-x₀)


Manipulate[b = -m p[[1]] + p[[2]]; 
 Show[Plot[m (x - p[[1]]) + p[[2]], {x, -5, 5}, 
   PlotRange -> {{-5, 5}, {-5, 5}}, GridLines -> All, 
   AspectRatio -> 1, 
   PlotLabel -> 
    Column[{Row[{"m = ", Defer[ Dynamic[m] /Dynamic[1]], " = ", m}], 
      Row[{"y  = ", 
        TraditionalForm[Expand[m (x - p[[1]]) + p[[2]]]] }]}]], 
  Graphics[{Red, Dashed, 
    Line[{{0, b}, {p[[1]], b}, {p[[1]], m p[[1]] + b}}], 
    Text[m p[[1]], {p[[1]] + 0.5, 0.5 m p[[1]] + b}], 
    Text[p[[1]], {0.5 p[[1]], b - Sign[m] 0.25}]}]], {{m, 1, 
   "Pendiente: m"}, -3, 3, 0.5}, {{p, {1, 1}}, Locator}]


La pendiente se puede interpretar como en cambio en y cuando en x el cambio es de una unidad.




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

martes, 4 de agosto de 2020

Multiplicación mediante una parábola


Representamos la parábola y = - x² y ubicamos sobre ella los puntos (a,-a²) y (b,-b²), el corte de la recta que pasa por ellos con el eje Y corresponde al punto (0,a b), es decir su altura es el producto de a y b. 

Manipulate[
 Show[Plot[{-x^2, -(a + b) x + a b}, {x, -10, 10}, PlotRange -> 105], Graphics[{{Blue, Point[{a, 0}], Point[{b, 0}]}, 
    Text["y = x²", {-8, -85}],{Green, Text[a, {a, 8}], Blue, 
   Text[b, {b, If[Abs[a - b] > 1, 8, -8]}]}, {Red, Point[{a, -a^2}],
   Point[{b, -b^2}], Point[{0, a b}], Text[a b, {1.5, a b}]}, {Pink, Dashed, Line[{{a, 0}, {a, -a^2}}],Line[{{b, 0}, {b, -b^2}}]}}]], {{a, 10, "Número: a"}, -10, 10}, {{b, 5, "Número: b"}, -10, 10}]




La razón  es simple, la ecuación de la recta que pasa por (a,-a²) y (b,-b²), es:

Y = -(a + b) X + a b,

de donde cuando X = 0, corte con el eje Y, tenemos Y = a b.

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


martes, 28 de julio de 2020

Frase Célebre de David Gelernter

La belleza es más importante en informática 
que en cualquier otro lugar en tecnología
porque la computación es muy complicada.
La belleza es la mejor defensa contra la complejidad.

David Gelernter

martes, 21 de julio de 2020

Proyecciones de un punto en el circulo unitario sobre sus diámetros



Tenemos el circulo unitario, centrado en el origen y de radio una unidad, y un punto que se mueve sobre él.
La proyección perpendicular de éste punto sobre los diámetros del circulo que están sobre los ejes coordenados x y y corresponden respectivamente a los valores de coseno y seno (puntos de color naranja y verde).

El segmento de recta que une a los puntos (naranja y verde) siempre tiene longitud de una unidad, su punto medio se encuentra en el corte del segmento con el radio correspondiente del punto sobre la circunferencia unitaria y todos estos puntos medios forman una circunferencia centrada en el origen y de radio media unidad.

gra1 = ContourPlot[x^2 + y^2 == 1, {x, -2, 2}, {y, -2, 2}, 
   Axes -> True];
gra2 = Point[{0, 0}];
Manipulate[
 Show[gra1, 
  If[circulo, ParametricPlot[0.5 {Cos[u], Sin[u]}, {u, 0, t}], gra1], 
  Graphics[{Blue, Line[{{-1, 0}, {1, 0}}], Line[{{0, -1}, {0, 1}}], 
    Green, If[radio, Line[{{0, 0}, {Cos[t], Sin[t]}}], gra2], Black, 
    If[linea, Line[{{0, Sin[t]}, {Cos[t], 0}}], gra2], Red, Dashed, 
    If[proy, Line[{{Cos[t], 0}, {Cos[t], Sin[t]}, {0, Sin[t]}}], 
     gra2], PointSize[0.02], Point[{Cos[t], Sin[t]}], Green, 
    Point[{0, Sin[t]}], Orange, Point[{Cos[t], 0}], Pink, 
    If[puntomedio, Point[0.5 {Cos[t], Sin[t]}], gra2]}]], {{t, 0, 
   "Punto"}, 0.00001, 6 Pi}, {{proy, False, "Proyección"}, {False, True}}, {linea, {False, True}}, {radio, {False, True}}, {puntomedio, {False, True}}, {circulo, {False, True}}]




Ahora, vamos a considerar la proyección de un punto en el circulo unitario sobre cualquier diámetro del mismo.

gra1 = ContourPlot[x^2 + y^2 == 1, {x, -2, 2}, {y, -2, 2}, 
   Axes -> True];
gra2 = Point[{0, 0}];
Manipulate[
 Show[gra1, ParametricPlot[{a, Tan[u] a}, {a, -Cos[u], Cos[u]}], 
  Graphics[{Point[{(Cos[t] + Tan[u] Sin[t])/(Tan[u]^2 + 
         1), (Tan[u] Cos[t] + Tan[u]^2 Sin[t])/(Tan[u]^2 + 1)}], Red, Dashed, Line[{{Cos[t], Sin[t]}, {(Cos[t] + Tan[u] Sin[t])/(Tan[u]^2 + 1), (Tan[u] Cos[t] + Tan[u]^2 Sin[t])/(Tan[u]^2 + 1)}}], PointSize[0.02], Point[{Cos[t], Sin[t]}]}]], {{t, 0, "Punto"}, 0, 2 Pi}, {{u, Pi/4, "Diamétro"}, -Pi, Pi/2}]



Para un punto fijo sobre el circulo unitario, las proyecciones ortogonales sobre los diámetros del circulo forman una circunferencia de radio media unidad y centro en el punto medio del radio del circulo en el punto fijo inicial.

gra1 = ContourPlot[x^2 + y^2 == 1, {x, -2, 2}, {y, -2, 2}, 
   Axes -> True];
gra2 = {PointSize[0.01], Point[{0, 0}]};
Manipulate[
 Show[gra1,Table[ParametricPlot[{a, Tan[u] a}, {a, -Cos[u],Cos[u]}], {u, -Pi/2, Pi/2, Pi/24.}], Graphics[{Point@Table[{(Cos[t] + Tan[u] Sin[t])/(Tan[u]^2 + 1), (Tan[u] Cos[t] + Tan[u]^2 Sin[t])/(Tan[u]^2 + 1)}, {u, -Pi/2, Pi/2, Pi/24.}],Red, PointSize[0.02],Point[{Cos[t], Sin[t]}], If[circulo, Circle[0.5 {Cos[t], Sin[t]}, 0.5], gra2]}]], {{t, 0, "Punto"}, 0, 2 Pi}, {circulo, {False, True}}]




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


martes, 7 de julio de 2020

Curva Contrapodaria



En una publicación anterior, hablamos de la Curva Podaria, que correspondía a dada una curva C y un punto fijo P al lugar geométrico de las proyecciones ortogonales de P sobre las tangentes de la curva C. La ContraPodaria corresponde a las proyecciones ortogonales de P sobre la recta normal a cada punto de la curva C.

En el siguiente ejemplo el punto R pertenece a la Podaria de la curva C con respecto al punto P y Q la contraPodaria de la curva C con respecto al punto P.

Show[ContourPlot[{x^2 + x y == y, y == 0, x == 0, y == -1,
   x == -1}, {x, -3, 3}, {y, -3, 3}],
 Graphics[{Point[{-1, -1}], Text["P", {-1.1, -1.1}],
   Text["C", {0.9, 1}], Red, Point[{-1, 0}], Point[{0, -1}],
   Text["Podaria - R", {-1.5, 0.1}],
   Text["Q - ContraPodaria", {0.8, -1.1}]}]]



Dada la curva F(t) y un punto P, su recta normal en el punto t = t', tiene por ecuación:

F (t') +  {{0, 1}, {-1, 0}}F' (t') s, con s en los reales.

La recta perpendicular a la normal a C que pasa por el punto P, es paralela a recta tangente a C en el punto t',  tiene por ecuación:

P +F' (t') u, con u en los reales.

El punto de corte entre las rectas anteriores, es:


Vamos a construir un aplicativo para determinar la Podaria de algunas curvas planas:

f1[t_] := {t, t^2}
f2[t_] := {t, t^3 - 3 t^2}
f3[t_] := {Cos[t], 4 Sin[t]}
f4[t_] := {t^3, t^2}
f5[t_] := {4 Cos[t]^3, 5 Sin[t]^3}
Manipulate[m[t_] := f'[t] (Dot[f'[t], p - f[t]]/Norm[f'[t]]^2); 
 g1 = ParametricPlot[f[t], {t, -50, 50}, PlotStyle -> Green]; 
 Show[ParametricPlot[{p + t f'[r], f[r] + t Reverse[f'[r]] {1, -1}, 
    f[r] + t f'[r], p + t Reverse[f'[r]] {1, -1}}, {t, -20, 20}, 
   PlotRange -> 10], 
  ParametricPlot[f[t], {t, -50, 50}, PlotStyle -> Green], 
  If[Podaria, 
   ParametricPlot[{f[t] + m[t]}, {t, -20.00001, r}, 
    PlotStyle -> Pink], g1], 
  If[ContraPodaria, 
   ParametricPlot[{p - m[t]}, {t, -20.00001, r}, PlotStyle -> Red], 
   g1], Graphics[{Point[p], Point[f[r]], 
    Text["P", p + {-0.1, -0.1}]}]], {r, -20, 
  20}, {f, {f1, f2, f3, f4, f5}}, {p, {-5, -5}, {5, 
   5}}, {Podaria, {False, True}}, {ContraPodaria, {True, False}}, 
 ControlPlacement -> Left]




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