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