Representaciones numéricas de 2018

El número 2018 lo podemos ver como:

Pandigitales

2048 - (9 + 6 + 3) 1 - 5 - 7

2018

8 (3 - 1) + 2 7 (5 + 6 + 0) (4 + 9)

2018

(987 + 65 - 43) 2 1

2018

1 2 (3! + 45 + 67 + 891 + 0)

2018

(9 + 8 + 7 + 6 + 54 + 3 + 2 + 1 + 0 + 1) 23 - 45 - 6 - 7 - 8 - 9

2018

Terna Pitagórica

2018^2 == 1118^2 + 1680^2

True

Suma de cuadrados

dos cuadrados

13^2 + 43^2

2018

tres cuadrados

1^2 + 9^2 + 44^2

2018

3^2 + 28^2 + 35^2

2018

5^2 + 12^2 + 43^2

2018

8^2 + 27^2 + 35^2

2018

9^2 + 16^2 + 41^2

2018

19^2 + 19^2 + 36^2

2018

20^2 + 23^2 + 33^2

2018

Cuatro cuadrados

1^2 + 21^2 + 26^2 + 30^2

2018

15^2 + 28^2 + 28^2 + 15^2

2018

18^2 + 18^2 + 23^2 + 29^2

2018

15^2 + 21^2 + 26^2 + 26^2

2018

2^2 + 5^2 + 30^2 + 33^2

2018

Cinco cuadrados

3^2 + 18^2 + 22^2 + 24^2 + 25^2

2018

19^2 + 24^2 + 12^2 + 24^2 + 19^2

2018

4^2 + 31^2 + 8^2 + 31^2 + 4^2

2018

Suma de cubos

1^3 + 7^3 + 7^3 + 11^3

2018

1^3 + 2^3 + 4^3 + 6^3 + 9^3 + 10^3

2018

1^3 + 7^3 + 7^3 + 11^3

2018

Suma de cuartas potencias

2^4 + 3^4 + 5^4 + 6^4

2018

4^4 + 5^4 + 4^4 + 5^4 + 4^4

2018

2^4 + 3^4 + 5^4 + 6^4

2018

Sumas de potencias diferentes

2^1 + 2^11 - 2^5

2018

3^4 + 1^3 + 44^2

2018

1^4 + 12^3 + 17^2

2018

2^8 + 3^4 + 41^2

2018

3^6 + 10^3 + 17^2

2018

Con una sola cifra

(1111 - 111 + 11 - 1 - 1) (1 + 1)

2018

2 (2^(2^2 + 2^2 + 2) - (2 + 2)^2) + 2

2018

333 (3 + 3) + 3 3 + 3 3 + 3!/3

2018

44 44 + 44 + 44 - 4!/4

2018

5^5 - 555 - 555 + (5 + 5 + 5)/5

2018

(666 + 6) 6 6/(6 + 6) + (6 + 6)/6

2018

7 7 (7 7 - 7 - 7/7) + 7 + (7 + 7)/7

2018

(8 8 8 - 8) 8 8/(8 + 8) + (8 + 8)/8

2018

999 + 999 + 9 + 9 + (9 + 9)/9

2018

Suma de triangulares

t[n_] := n (n + 1)/2

t[25] + t[37] + t[44]

2018

t[27] + t[40] + t[40]

2018

t[28] + t[36] + t[43]

2018

Suma de Pentagonales

p[n_] := n (3 n - 1)/2

p[8] + p[36]
p[4] + p[11] + p[35]
p[6] + p[9] + p[25] + p[25]

2018

Palíndromo

4 4 + 5 5 + 44 44 + 5 5 + 4 4

2018

8 + 2002 + 8

2018

696 + 626 + 696

2018

878 + 262 + 878

2018

797 + 424 + 797

2018

575 + 868 + 575

2018

Árbol Navideño Fractal

Problema Relacionado con la Constante Áurea

Descargar como Notebook

Dados un cuadrado de lado L y media circunferencia con diámetro uno de los lados, determinar la razón entre el lado del cuadrado y la distancia de un vértice del cuadrado, fuera de la circunferencia, y la circunferencia.

Llamemos P a uno de los vértices del cuadrado, fuera de la circunferencia, O al centro de la circunferencia y d la distancia de P a la circunferencia.

gra1 = Graphics[{Line[{{1/2, 0}, {1/2, 1}, {-1/2, 1}, {-1/2, 0}, {1/2,0}}], Line[{{0, 0}, Sqrt[2]/4 {1, 1}}], {Red, Dashed, 
     Line[{{0, 0}, {0.5, 1}}]}, Text["L/2", {1/4, 1/8}], Text["P", {0.47, 0.96}], Text["d", {0.33, 0.7}], {PointSize[Large], 
     Point[{0, 0}], Point[{0.218, 0.449}], Point[{0.5, 1}]}, 
    Text["O", {-0.05, 0.05}], {Arrowheads[{-.05, .05}], Arrow[{{9/16, 0}, {9/16, 1}}],Text["L", {10/16, 1/2}], 
     Arrow[{{-1/2, 17/16}, {1/2, 17/16}}]}, Text["L", {0, 18/16}]}];
Show[ContourPlot[{x^2 + y^2 == 1/4}, {x, -10/16, 10/16}, {y, 0, 10/8},Frame -> None, Axes -> False, AxesLabel -> None, 
  Ticks -> None], gra1]

Como la distancia de P(L/2,L) a O(0,0) es igual a d+L/2, entonces:

Clear[d, L]
Reduce[{EuclideanDistance[{L/2, L}, {0, 0}] == d + L/2, d > 0, 
  L > 0}, {L}, Reals]

Así,

Por tanto, la razón entre el lado del cuadrado y la distancia del vértice a la media circunferencia inscrita es la constante áurea.



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 Charles. G. Darwin

Cualquier nueva serie de descubrimientos es Matemática en forma, ya que no podemos tener otra guía.

Charles. G. Darwin

Construcción de una Elipse por Afinidad

Descargar como Notebook

Partimos de dos circunferencias concéntricas, trazamos un radio de la circunferencia mayor y dibujamos un triangulo rectángulo con hipotenusa el segmento de radio entre las dos circunferencias entonces el vértice que corresponde al ángulo recto corresponde a un punto de la elipse con semiejes menor y mayor los radios de las circunferencia interior y exterior respectivamente.

Al ir haciendo girar el radio con respecto al centro se va construyendo la elipse.

En Mathematica

cir = ContourPlot[{x^2 + y^2 == 1, x^2 + y^2 == 4}, {x, -3, 
    3}, {y, -3, 3}, Axes -> True];
Manipulate[
 Show[cir, 
  Graphics[{{Dashed, 
     Line[{{2 Cos[\[Theta]], Sin[\[Theta]]}, {2 Cos[\[Theta]], 
        2 Sin[\[Theta]]}}], 
     Line[{{2 Cos[\[Theta]], Sin[\[Theta]]}, {Cos[\[Theta]], 
        Sin[\[Theta]]}}]}, 
    Line[{{0, 0}, {2 Cos[\[Theta]], 2 Sin[\[Theta]]}}]}], 
  ParametricPlot[{2 Cos[t], Sin[t]}, {t, 0, \[Theta]}, 
   PlotStyle -> Red]], {\[Theta], 0.00001, 2 Pi}]

Manipulando el radio de las circunferencias, podemos lograr que el semieje mayor esté de forma vertical al intercambiar la circunferencia interior con la exterior.

Manipulate[r = Max[a, b]; 
 Show[ContourPlot[{x^2 + y^2 == a^2, x^2 + y^2 == b^2}, {x, -3, 
    3}, {y, -3, 3}, Axes -> True], 
  Graphics[{{Dashed, 
     Line[{{b Cos[\[Theta]], a Sin[\[Theta]]}, {b Cos[\[Theta]], 
        b Sin[\[Theta]]}}], 
     Line[{{b Cos[\[Theta]], a Sin[\[Theta]]}, {a Cos[\[Theta]], 
        a Sin[\[Theta]]}}]}, 
    Line[{{0, 0}, {r Cos[\[Theta]], r Sin[\[Theta]]}}]}], 
  ParametricPlot[{b Cos[t], a Sin[t]}, {t, 0, \[Theta]}, 
   PlotStyle -> Red]], {{a, 1}, 0.1, 3}, {{b, 2}, 0.1, 3}, {\[Theta], 
  0.00001, 2 Pi}]

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 René Descartes

Daría todo lo que sé por la mitad de lo que ignoro

René Descartes

Estado Magnético en términos de los Espines

Descargar como Notebook

Colaboración con la Física Claudia Milena Bedoya.

Otra de las múltiples aplicaciones que permite Wolfram Mathematica es la visualización del estado magnético de materiales a escala reducida. La gráfica muestra el estado magnético en términos de los espines (propiedad física asociada al movimiento de un electrón sobre su propio eje) en un sistema core/shell, compuesto por un núcleo y una envoltura ambos magnéticos.
Estos sistemas presentan potenciales aplicaciones en el campo de almacenamiento de información.

Tenemos una base de 400 datos Dat.xls (descargar), donde cada entrada tiene cuatro componentes: las dos primeras nos indican la posición en el plano, la tercera la orientación 1-arriba y -1-abajo y la cuarta componente core/shell con los colores verde y rojo respectivamente.

Primero cargamos la base de datos:

datos = Flatten[Import["por Insertar->Ruta de Archivo (buscar el archivo Dat.xls donde lo descargó)"], 1];

Ahora realizamos la representación gráfica :

Graphics[Table[{If[datos[[n, 4]] == "c", Red, Green], 
   Arrowheads[0.03], 
   Arrow[{datos[[n, {1, 2}]], 
     datos[[n, {1, 2}]] + {0, datos[[n, 3]]}}]}, {n, 1, 400}], 
 Axes -> 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 Ludwig Wittgenstein

No hay enigmas. 
Si un problema puede plantearse, 
también puede resolverse.

Ludwig Wittgenstein

Sucesión de Farey

Descargar como Notebook

Dado un número entero positivo n la Sucesión de Farey de orden n, notada F(n), corresponde a la lista ordenada de forma creciente de todas las fracciones irreducibles entre 0 y 1 que tienen denominador menor o igual a n.

Su nombre se debe al geólogo británico Jhon Farey, quien publicó en 1816 en forma de conjetura que: "cada término de la sucesión es la suma de los numeradores de sus vecinos sobre la suma de los denominadores de los mismos".

Construcción

Para la construcción por ejemplo de F (5), se toman todas las fracciones posibles menores o iguales a 1 con denominador 1, 2, 3, 4 y 5:

farey[p_, q_] :=HoldForm[p/q](*es provisional para asegurarnos que                       no simplifique aún las fracciones*)

Flatten[Table[farey[p, q], {q, 1, 5}, {p, 0, q}], 1]

Se simplifican y descartan las repetidas:

DeleteDuplicates@Flatten[Table[p/q, {q, 1, 5}, {p, 0, q}], 1] /. {0 ->  "⁰/₁",  1 -> "¹/₁"}

Se ordenan en forma creciente :

Sort@DeleteDuplicates@Flatten[Table[p/q, {q, 1, 5}, {p, 0, q}], 1] /.{0 ->  "⁰/₁",  1 -> "¹/₁"}

Definimos una función dependiendo de n para generar las Sucesiones de Farey:

farey[n_] := 
 DeleteDuplicates@Sort@Flatten[Table[p/q, {q, 1, n}, {p, 0, q}], 1] /.{0 ->  "⁰/₁",  1 -> "¹/₁"}


farey[1]

farey[2]

farey[3]

Mathematica tiene incorporado el comando FareySequence[ ] :

FareySequence[5]

Propiedades

Longitud de cada Sucesión de Farey

Calculemos la longitud de las primeras 20 Sucesiones de Farey :

Table[Length[farey[n]], {n, 20}]
{2, 3, 5, 7, 11, 13, 19, 23, 29, 33, 43, 47, 59, 65, 73, 81, 97, 103, 121, 129}

Buscamos una fórmula para el término general :

FindSequenceFunction[{2, 3, 5, 7, 11, 13, 19, 23, 29, 33, 43, 47, 59, 65, 73, 81, 97, 103, 121, 129}, n]

Mathematica no la encuentra, pero observemos que: F(n-1) está contenido en F(n) para todo n mayor que 1, y que F(n) contiene fracciones de denominador n y por numerador los números que son coprimos (primos relativos) con n. Por tanto,

Long (F (n)) =
 Long (F (n - 1)) +  φ(n), donde φ(n) la función de Euler

Así,

Long (F (1)) = 2
Long (F (2)) = Long (F (1)) + φ(2) = 2 +  φ (2)
Long (F (3)) = Long (F (2)) + φ(3) = 2 +  φ(2) +  φ(3)

Por tanto,

Como φ (2) = 1 y  φ n) es par para n > 2, se tiene que Long (F (n)) es siempre impar para n mayor que 1, donde los extremos son las fracciones 0/1 y 1/1 y el término de la mitad es 1/2. Cuando n toma un valor grande se tiene que:

Long(F(n)) ~ 3n^2/π

Cada término de la sucesión es la suma de los numeradores de sus vecinos sobre la suma de los denominadores de los mismos


Por ejemplo para F (10), tenemos:

fa = FareySequence[10]

Table[If[(Numerator[fa[[n - 1]]] + 
      Numerator[fa[[n + 1]]])/(Denominator[fa[[n - 1]]] + 
      Denominator[fa[[n + 1]]]) == fa[[n]], "Cumple"], {n, 2, 
  Length[fa] - 1}]

{Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple,
Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple,
Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple, Cumple,
Cumple, Cumple, Cumple}

Representaciones

Círculos de Ford 

(Publicados aquí el 10 de Octubre de 2017) Para cada término de una sucesión de Farey p/q, se le asocia los círculos centrados en (p/q,1/(2q^2)) y con radio 1/(2q^2), obteniendo:

Show@Table[
   Graphics[
    If[CoprimeQ[p, q], Tooltip@Circle[{p/q, 1/(2 q^2)}, 1/(2 q^2)]], 
    Axes -> True, PlotRange -> {{-0.5, 1.5}, {0, 1}}], {q, 1, n}, {p, 0, q}], {n, 1, 10, 1}]

Diagrama de Círculos

Se construyen arcos de circunferencia uniendo términos consecutivos de cada Sucesión de Farey.

FareyPairArc[r1_, r2_] := 
 Circle[{(r1 + r2)/2, 0}, (r2 - r1)/2, {0, Pi}]
Show[Table[Graphics[{ColorData[94, n], 
    FareyPairArc @@@ Partition[FareySequence[n], 2, 1]}], {n, 1,6}]]

Denominadores de las Sucesiones de Farey en Representación Matricula

Representando los denominadores de F (12) en una matriz, donde la posición es la columna y su valor la fila.

Denominator /@ FareySequence[12]

{1, 12, 11, 10, 9, 8, 7, 6, 11, 5, 9, 4, 11, 7, 10, 3, 11, 8, 5, 12, 7, 9, 11, 2, 11, 9, 7, 12, 5, 8, 11, 3, 10, 7, 11, 4, 9, 5, 11, 6, 7, 8, 9, 10, 11, 12, 1}

MatrixPlot[SparseArray[MapIndexed[Prepend[#2, #1] -> 1 &, %]], 
 Mesh -> All]

Para F (100),

MatrixPlot[
 SparseArray[MapIndexed[Prepend[#2, #1] -> 1 &,Denominator/@FareySequence[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 G. H. Hardy

Un matemático, como un pintor o un poeta, 
es un fabricante de modelos. 
Si sus modelos son más duraderos que los de estos, 
es porque están hechos de ideas. 
Los modelos del matemático como los del pintor y los del poeta deben ser hermosos. 
La belleza es la primera prueba; 
no hay lugar permanente para unas matemáticas feas.

G. H. Hardy

Circunferencias en Diferentes Métricas

Descargar como Notebook

En matemáticas el concepto de distancia en un conjunto X se generaliza a funciones

dist: X×X→[0,∞) 

que cumplan las siguientes condiciones:

1. dist(x,y) ≥ 0
2. dist(x,y) = 0, si y sólo si, x = y
3. dist(x,y)=dist(y,x)
4. dist(x,y) ≤ dist(x,z) + dist(z,y)

Vamos a considerar tres diferentes métricas: La usual que corresponde a la métrica Euclidiana, la métrica del taxista o de Manhattan y la métrica del máximo o del tablero de ajedrez. Cada una de ellas está definida por:

estas métricas ya las tiene Mathematica predefinidas como: EuclideanDistance[ ], ManhattanDistance[ ] y ChessboardDistance[ ], respectivamente.

Ahora, vamos a representar todos los puntos del plano que se encuentran a una unidad de distancia del origen en las diferentes métricas:

euclidea[x_, y_] := EuclideanDistance[{x, y}, {0, 0}]

taxista[x_, y_] := ManhattanDistance[{x, y}, {0, 0}]

maximo[x_, y_] := ChessboardDistance[{x, y}, {0, 0}]

Manipulate[

 Show[ContourPlot[metrica[x, y] == 1, {x, -1.5, 1.5}, {y, -1.5, 1.5}, 

   Axes -> True], 

  Graphics[{Red, PointSize[Medium], 

    Which[metrica === euclidea, {Point[{Sqrt[1 - t^2], t}], 

      Line[{{0, 0}, {Sqrt[1 - t^2], t}}]}, 

     metrica === taxista, {Point[{t, 1 - t}], 

      Line[{{0, 0}, {t, 0}, {t, 1 - t}}]}, 

     metrica === maximo, {Point[{t, 1}], 

      Line[{{t, 0}, {t, 1}}]}]}]], {metrica, {euclidea, maximo, 

   taxista}}, {t, 0, 1}]

En rojo se muestra el segmento o la suma de segmentos que determinan la distancia del punto sobre la figura al origen.


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 René Descartes

Dos cosas contribuyen a avanzar: 
ir más deprisa que los otros, 
o ir por el buen camino

René Descartes

Conjetura de Conway sobre el ascenso a Primos

Descargar como Notebook

Es el quinto de cinco problemas planteados por el matemático Británico John Horton Conway (1937-  ), quien ofreció mil dolares por cada problema que se resolviera.

El problema se basa en la descomposición de un número entero positivo mayor que uno como un producto de números primos (Teorema Fundamental de la Aritmética), donde se afirma que esta descomposición es única salvo el orden, pero si ordenamos en forma creciente por las bases tenemos que si es única.

La siguiente función nos da esta descomposición, observen que si un factor primo aparece una sola vez no escribimos el exponente uno.

descom[n_] := 
 If[Not@PrimeQ[n], 
  Apply[CenterDot, 
   Apply[Superscript, FactorInteger[n] /. {a_, 1} :> a, {1}]], n]

Por ejemplo :

descom[600]
2³∙3∙5²

Eliminando los puntos de producto y "bajando" los exponentes, podemos formar el número: 23352. Este proceso lo llamaremos la operación de Conway, en Mathematica la podemos definir como:

conway[n_] := 
 ToExpression@
  StringJoin[ToString /@ Select[Flatten[FactorInteger[n]], # != 1 &]]

Aplicada a nuestro ejemplo

descom[600]
2³∙3∙5²

conway[600]
23352

Ahora, si repetimos iterativamente este proceso:

descom[23352]
2³∙ 3 ∙7 ∙139

conway[conway[600]]
2337139

nuevamente,

descom[2337139]
7 ∙29² ∙397

conway[conway[conway[600]]]
7292397

nuevamente,

descom[7292397]
3 ∙7 ∙347257

conway[conway[conway[conway[600]]]]
37347257

y calculando nuevamente la función de conway, tenemos:

conway[conway[conway[conway[conway[600]]]]]
37347257

vemos que se llega al número 37347257 como número fijo, al seguir iterando se obtiene el mismo resultado. La razón de esto es:

descom[37347257]
37347257

PrimeQ[37347257]
True

Su descomposición como producto de primos es él mismo, pues  37347257 es primo.

Conjetura sobre el ascenso a primos dice :

Si partimos de un entero mayor que uno al realizar el anterior proceso siempre terminaremos en un número primo.

Para componer iterativamente la función de conway y que nos muestre la lista de los resultados, definimos:

conwaylista[n_] := NestWhileList[conway, n, Not@PrimeQ[#] &]

por ejemplo :

conwaylista[600]
{600, 23352, 2337139, 7292397, 37347257}

otro ejemplo :

conwaylista[120]
{120, 2335, 5467, 71171}

PrimeQ[71171]
True

La longitud de la lista para los números 2 al 19 es:

Table[{n, Length@conwaylista[n]}, {n, 2, 19}]
{{2, 1}, {3, 1}, {4, 3}, {5, 1}, {6, 2}, {7, 1}, {8, 2}, {9, 5}, {10, 4}, {11, 1}, {12, 2}, {13, 1}, {14, 4}, {15, 5}, {16, 3}, 
{17, 1}, {18, 4}, {19, 1}}

graficamente,

Show[ListPlot[Table[{n, Length@conwaylista[n]}, {n, 2, 19}]], 
 AxesLabel -> {HoldForm[Entero positivo], 
   HoldForm[Número de Iteraciones]}, 
 PlotLabel -> HoldForm[Iteraciones de Conway], 
 LabelStyle -> {GrayLevel[0]}]

Los números primos son puntos fijos de la función conway[n], por tanto la longitud de la lista es 1. Las mayores longitudes la logran los números 9 y 15 con cinco iteraciones.

El número 20, también cumple la conjetura pero necesita un número alto de iteraciones:

conway[20]
{20, 225, 3252, 223271, 297699, 399233, 715623, 3263907, 32347303, 
160720129, 1153139393, 72171972859, 736728093411, 3245576031137, 
11295052366467, 310807934835791, 1789205424940407, 31745337977379983, 1122916740775279751, 7251536377635958081, 151243563319717018007, 1121396149754176552459, 75932351114908908171459, 3655130778271255318091789, 14959341367755562901131977, 34986447122585187633710659, 1831215981937332389236978179, 313224835114543391579198264647, 476664358193926455139982941801, 3894553245992691175152795023891, 132746366910908266441840480446403, 14827188440943221883267109923487963, 
31677138752258518643179233081330519, 
3399439119019280029138988876664839207, 
1031091355507223378710949904168165523463, 
132411030792311443628391225232966966285737, 
3374773953639640292210918919998158514329541, 
18118645159964859891117187397348056124388561, 
333132143964638500160914816848585652355475611, 
4339779194757514315803243245042123341102411963, 
43467514876394875501133442699882620583081205227, 
321011894373310762051641163853311891567953317269293, 
37210435034772092714046118995294856628184376694869347, 
349828786497847697248921942850440203857761430075804817, 
33182917107436506939494287772998973909148874702313377399, 
1932412735512607965871685923338963030422770854966852116073, 
37392872225493034699309237157170878572245780852206787837181, 
412647766390833734444929769855778777948727276473907467474693, 
3263523000971344529447965690456090974370023735458141834559537, 
3101454147825427160314861186911479357122687657988115033571385847, 
321036281528336051353262347964794823559426086863047234824993347497}

esta lista no es completa, pues el último valor aún no es primo :

PrimeQ[321036281528336051353262347964794823559426086863047234824993347497]
False

Pero sí cumple la conjetura, el problema aquí es la capacidad de la maquina.

La conjetura sería falsa si se encuentra un punto fijo para la función de conway, que no sea primo o un bucle de números que se repitiera indefinidamente sin ser ninguno primo.

Recientemente James Davis, quien afirma no ser matemático, encontró dicho número: 13532385396179, no es primo pues:

PrimeQ[13532385396179]
False

su descomposición es :

descom[13532385396179]
13 ∙53² ∙3853 ∙96179

y por tanto al calcularlo en conway, tenemos :

conway[13532385396179]
13532385396179

es un punto fijo para la función de conway, y no es primo.


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

Aproximación a la Constante Pi por el Método de Montecarlo

Descargar como Notebook

El Método de Montecarlo es un método numérico de orden probabilistico (no determinista) creado por el matemático Stanilaw Ulam y mejorado conjuntamente con John von Neumann en 1944. Su nombre se debe a las ruletas de los casinos de Montecarlo como generadoras de números aleatorios.

El método consiste en realizar experimentos con números generados de forma aleatoria, contando las posibilidades con alguna característica sobre el total de los experimentos.

Se va a realizar una aproximación al número Pi determinando el área de un cuarto de circunferencia de radio uno, sabemos que el área de este cuarto de circunferencia en Pi/4 y está contenida dentro de un cuadrado de área una unidad. Se van a generar puntos al azar dentro del cuadrado y contamos los que están dentro del cuarto de circunferencia, la relación entre estos puntos (dentro del cuarto de circunferencia) con el total de puntos generados nos da el porcentaje del área del cuarto de circunferencia con respecto al área del cuadrado que es una unidad.

En rojo están los puntos dentro del cuarto de circunferencia y en verde los que no lo están, este experimento lo vamos a realizar con 10000 puntos

ran := RandomReal[]
n = 0;
puntos = 10000;
Show[Plot[Sqrt[1 - x^2], {x, 0, 1}], 
 Graphics[Table[{If[a = ran; b = ran; a^2 + b^2 <= 1, n++; Red, 
     Green], Point[{a, b}]}, {puntos}], Axes -> True], 
 AspectRatio -> 1]
n/puntos

7839/10000


De los 10000 puntos 7839 quedaron dentro del cuarto de circunferencia, luego el área del cuarto de circunferencia es 78.39% aproximadamente el área del cuadrado de una unidad, así el área del cuarto de circunferencia es 0.7839 unidades cuadradas. Como sabemos que el área exacta del cuarto de circunferencia es Pi/4, tenemos que Pi aproximadamente es:

N[7839/10000]*4
3.1356

El error de la aproximación va decreciendo 1/√N donde N es el número de puntos que se toman.

Realicemos ahora el conteo con un millón de puntos sin necesidad de realizar el gráfico.

ran := RandomReal[]
n = 0;
veces = 1000000;
Do[If[ran^2 + ran^2 <= 1, n++], {veces}]
N[n/veces]*4

3.14157

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 Arbuthnot

El conocimiento de las matemáticas añade vigor a la mente, 
la libera del prejuicio, credulidad y superstición.

John Arbuthnot

Números expresables como la suma de tres cuadrados

Descargar como Notebook

Si un número no es de la forma 4^n (8m+7) entonces es suma de tres cuadrados

Realizaremos el estudio numérico hasta el primer millón de enteros positivos.

Buscamos hasta el millón los números que son de la forma 4^n (8m+7). Como 4^9 < 1000000 < 4^10, n tomará valores entre 0 y 9, y puesto que 1000000/8=125000, m tomará valores entre 0 y 125000. Estos números se los restamos, de forma conjuntista, a los enteros hasta un millón para determinar los números que NO cumplen ser de la forma 4^n (8m+7).

aaa = Complement[Range[1000000], 
  Flatten@Table[4^n (8 m + 7), {n, 0, 9}, {m, 0, 125000}]]

Ahora, construimos todos los números que son suma de tres cuadrados

bbb = Sort@
  DeleteDuplicates@
   Flatten@Table[a^2 + b^2 + c^2, {a, 0, 1000}, {b, 0, a}, {c, 0, b}]

Seleccionamos los menores a un millón

ccc = Select[bbb, 0 < # <= 1000000 &]

Comparamos los dos conjuntos

Complement[aaa, ccc]
{}

Complement[ccc,aaa]
{}

Por tanto los dos conjuntos son iguales, así :

Si un número no es de la forma 4^n (8m+7) entonces es suma de tres cuadrados.



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 Pitágoras

Los números gobiernan al mundo

Pitágoras

Caracol de Pascal

Descargar como Notebook

Dada la circunferencia unitaria (de radio una unidad y centrada en el origen), consideramos las rectas que pasan por el punto (-1,0), marcamos el punto donde la recta corta la circunferencia y lo llamamos P.

La circunferencia la vamos a considerar de forma paramétrica como los puntos (Cos[t],Sin[t]) y así para un valor t la recta tiene por ecuación:

y = (Sin[t]/(Cos[t] + 1)) (x + 1)

así, podemos generar la siguiente representación :

Manipulate[
 Show[ParametricPlot[{Cos[t], Sin[t]}, {t, 0, 2 Pi}, 
   PlotStyle -> Dashed, PlotRange -> 3], 
  Plot[(Sin[a]/(Cos[a] + 1)) (x + 1), {x, -2.5, 2.5}], 
  Graphics[{PointSize[Large], Point[{Cos[a], Sin[a]}]}], 
  Graphics[Text["P", {Cos[a + 0.2], 
     Sin[a + 0.2]}]]], {{a, Pi/2}, 0, 2 Pi}]

Ahora, consideraremos todos los puntos sobre la recta que se encuentran a una distancia igual a a unidades del punto P, para ello resolvemos la ecuación:

o equivalentemente,

(x - Cos[t])² + ((Sin[t]/(Cos[t] + 1)) (x + 1) - Sin[t])² = a²

por medio del comando Solve[ ] tenemos,

Solve[(x - Cos[t])^2 + ((Sin[t]/(Cos[t] + 1)) (x + 1) - Sin[t])^2 ==  a^2, x]

{{x -> -a Cos[t/2] + Cos[t]}, {x -> a Cos[t/2] + Cos[t]}}

Representando las soluciones de forma paramétrica, tenemos:

Manipulate[
 ParametricPlot[{{-a Cos[t/2] + Cos[t], 
    Sin[t]/(Cos[t] + 1) (-a Cos[t/2] + Cos[t] + 1)}, {a Cos[t/2] + 
     Cos[t], Sin[t]/(Cos[t] + 1) (a Cos[t/2] + Cos[t] + 1)}}, {t, 0, 
   2 \[Pi]}, PlotRange -> 5], {{a, 2}, 0, 4}]

Esta figura se conoce como un Caracol de Pascal, para a=0 es la circunferencia unitaria y hasta a=2 tiene el bucle interior. Representándolo junto con la circunferencia y la recta que lo genera, obtenemos:

Manipulate[
 Show[ParametricPlot[{{-a Cos[t/2] + Cos[t], 
     Sin[t]/(Cos[t] + 1) (-a Cos[t/2] + Cos[t] + 1)}, {a Cos[t/2] + 
      Cos[t], Sin[t]/(Cos[t] + 1) (a Cos[t/2] + Cos[t] + 
        1)}}, {t, \[Pi]/2,θ}, PlotRange -> 5, 
   PlotStyle -> Red], 
  ParametricPlot[{Cos[p], Sin[p]}, {p, 0, 2 Pi}, 
   PlotStyle -> Dashed], 
  Plot[(Sin[θ]/(Cos[θ] + 1)) (x + 1), {x, -2.5, 
    2.5}]], {θ, Pi/2 + 0.00001, Pi/2 + 2 Pi}, {{a, 2},
   0, 4}]

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 Isaac Asimov

Examinen fragmentos de pseudociencia 
y encontrarán un manto de protección, 
un pulgar que chupar, unas faldas a las que agarrarse. 

Y, ¿qué ofrecemos nosotros a cambio? 
¡Incertidumbre! ¡Inseguridad!

Isaac Asimov

Circunferencias de Apolonio

Descargar como Notebook

Creadas por Apolonio de Perge (Circa 262 a.C. - Circa 190 a.C.) cuyas obras se perdieron y aparecen únicamente menciones a sus trabajos. El problema que plantea Apolonio es: dados dos puntos fijos en el plano A y B, y r > 0 deseamos determinar todos los puntos P del plano tal que:

Aquí nos preguntamos por la división de las distancias desde A y B al punto P, si nos preguntamos por la suma la solución son elipses y por la resta son hipérbolas.

Para facilitar la representación vamos a suponer que : A (-a, 0), B (a, 0) y P (x, y), esto para a > 0, por tanto :

Manipulando los valores de a y r, tenemos :

Manipulate[
 Show[ContourPlot[
   a^2 + 2 a x + x^2 + y^2 == r^2 (a^2 - 2 a x + x^2 + y^2), {x, -5, 
    5}, {y, -5, 5}, Axes -> True], Graphics[{Red, Point[{-a, 0}]}], 
  Graphics[{Green, Point[{a, 0}]}]], {{a, 1}, 0, 3}, {{r, 0.5}, 
  0.0001, 5}]

Manipulando a para valores de r = 0.2, 0.4, 0.6, 0.8, 1, 5, 2.5, 1.66, 1.25

Manipulate[
 Show[Table[
   ContourPlot[
    a^2 + 2 a x + x^2 + y^2 == r^2 (a^2 - 2 a x + x^2 + y^2), 
{x, -5, 5}, {y, -5, 5}, Axes -> True], {r, {0.2, 0.4, 0.6, 0.8, 1, 5, 2.5, 1.66, 1.25}}], 
  Graphics[{Red, Point[{-a, 0}]}], 
  Graphics[{Green, Point[{a, 0}]}]], {{a, 1}, 0, 3}]

Ahora, vamos a determinar  la ecuación de las circunferencias que pasan por los puntos A(-a,0) y B(a,0), buscamos el centro (h, k) y el radio R tal que satisfaga :

donde obtenemos el sistema de ecuaciones :

Igualando por R², tenemos:

Clear[a]
Solve[{(a + h)^2 + k^2 == R^2, (a - h)^2 + k^2 == R^2}, {h, R}]

Tomando el valor de R > 0, obtenemos una familia de circunferencias que son ortogonales a las circunferencias de Apolonio.

Manipulate[
 Show[Table[
   ContourPlot[
    a^2 + 2 a x + x^2 + y^2 == r^2 (a^2 - 2 a x + x^2 + y^2), 
{x, -5, 5}, {y, -5, 5}], {r, {0.2, 0.4, 0.6, 0.8, 1, 5, 2.5, 1.66, 
     1.25}}], 
  Table[Graphics[{Red, Circle[{0, k}, Sqrt[a^2 + k^2]]}], {k, -4, 
    4}]], {{a, 1}, 0, 3}]

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