Entrada destacada

Distancia media de dos puntos en un cuadrado unitario

viernes, 21 de octubre de 2016

Datos de volcanes desde WolframAlpha



Una de las grandes evoluciones de Mathematica en las últimas versiones, es la capacidad de adquisición de datos con las características : curados, actuales y computables. Para presentar un ejemplo vamos a trabajar con el comando VolcanoData[ ].

Adquirimos como entidades, todos los volcanes activos y no activos en el planeta tierra.

volcanes = VolcanoData[]
















Establecemos la posición geográfica de cada volcán en latitud y longitud, esta lista viene en el mismo orden de volcanes:

posicion = Map[VolcanoData[#, "Coordinates"] &, volcanes];

Eliminamos de las que no se encontraron datos o falló su búsqueda :

posicion1 = 
  Complement[posicion, {Missing["NotAvailable"]}, {Missing["RetrievalFailure"]}];


Cargamos datos de todos los países, SC[ ] es una función que nos convierte de las coordenadas de geoposicion(latitud, longitud) a coordenadas cartesianas:

paises = CountryData[];
SC[{lat_, lon_}] := 
  r {Cos[lon \[Degree]] Cos[lat \[Degree]], 
    Sin[lon  \[Degree]] Cos[lat  \[Degree]], Sin[lat \[Degree]]};
r = 6378.700;

Representamos sobre el globo terraqueo:

Graphics3D[{Opacity[0.8], Sphere[{0, 0, 0}, r], 
  Map[Line[Map[SC, CountryData[#, "SchematicCoordinates"], {-2}]] &, 
   paises], Red, PointSize[Medium], Map[Point[SC[#]] &, posicion1]}, 
 Boxed -> False, SphericalRegion -> False]

























Para Colombia




volcanoes = 
  With[{entities = 
     GeoNearest["Volcano", 
      colombia, {All, Quantity[10, "Kilometers"]}]},
   Select[VolcanoData[entities, "Countries", "EntityAssociation"], 
    Length[#[[1]]] > 1 &]
   ];

GeoGraphics[{
  EdgeForm[Thin], Opacity[0.5], 
  Tooltip[Polygon[colombia], EntityValue[colombia, "Name"]],
  Opacity[0.2], 
  Tooltip @@@ 
   EntityValue[Union@Flatten@Values[volcanoes], {"Polygon", "Name"}],
  Opacity[0.7], Red, AbsolutePointSize[5], 
  Tooltip[Point[#1], #2] & @@@ 
   VolcanoData[Keys[volcanoes], {"Position", "Name"}]}, 
 ImageSize -> Medium
 ]


jueves, 13 de octubre de 2016

Conjetura de Legendre


El enunciado de la conjetura es:

Para todo n número natural existe un número primo 
entre n^2 y (n+1)^2

Comprobación de la conjetura de Legendre hasta numero. Recordemos que la función PrimePi[num] nos presenta la cantidad de números primos menores o iguales a num, así si PrimePi[n^2]==PrimePi[(n+1)^2] no se cumple la conjetura de Legendre.

numero = 1000000;
Do[If[PrimePi[(n + 1)^2] == PrimePi[n^2], 
  Print[n, "no cumple Legendre"]], {n, numero}]

Otra forma de visualizarlo es con la terna  {n^2, un primo entre ellos ,(n+1)^2}

numero = 20;
Table[{n^2, 
  Text[Prime[PrimePi[(n + 1)^2]], Background -> Red], (n + 1)^2}, {n, 
  numero}]



lunes, 10 de octubre de 2016

Los Primos Gemelos



Una pareja de números primos se dice que son gemelos si distan dos unidades, como (3,5), (5,7), (11,13). Y se conjetura que:

Existen infinitas parejas de primos gemelos.

El pasado 14 de septiembre el grupo colaborativo PrimeGrid encontró la pareja de primos gemelos más grande hasta el momento, ellos son:





que tienen cada uno 200700 cifras.

En Mathematica

Vamos a generar la lista de primos gemelos de varias formas :

Forma 1

generamos una lista de las parejas de primos gemelos menores que Prime[numero]

numero = 10000;
gemelos = {};
SetSharedVariable[gemelos]

AbsoluteTiming[
 ParallelDo[
  If[PrimeQ[Prime[k] + 2], 
   AppendTo[gemelos, {Prime[k], Prime[k] + 2}]], {k, numero}];
 gemelos]



Aquí, hay que tener presente que al utilizar el comando ParallelDo se pueden presentar duplicaciones en los resultados, pues cada núcleo del computador por separado puede generar la misma pareja.

Forma 2

Otro código para imprimir la mayor pareja de primos gemelos menor que Prime[numero]

numero = 1000000000;
k = 0;
While[! PrimeQ[Prime[numero - k] + 2], 
 k++]; Print[{Prime[numero - k], Prime[numero - k] + 2}]

{22801763321,22801763323}

Forma 3

Otro código que genera el primer elemento de la pareja de primos gemelos

primergemelo = 
  Select[Range[1000], PrimeQ[#] && NextPrime[#] == 2 + # &];
primergemelo

{3, 5, 11, 17, 29, 41, 59, 71, 101, 107, 137, 149, 179, 191, 197, 227, 239, 269, 281, 311, 347, 419, 431, 461, 521, 569, 599, 617, 641, 659, 809, 821, 827, 857, 881}

Aquí, formamos las parejas de primos gemelos.

Transpose[{primergemelo, primergemelo + 2}]

{{3, 5}, {5, 7}, {11, 13}, {17, 19}, {29, 31}, {41, 43}, {59, 61}, {71, 73}, {101, 103}, {107, 109}, {137, 139}, {149, 151}, {179,181}, {191, 193}, {197, 199}, {227, 229}, {239, 241}, {269, 271}, {281, 283}, {311, 313}, {347, 349}, {419, 421}, {431, 433}, {461, 463}, {521, 523}, {569, 571}, {599, 601}, {617, 619}, {641, 643}, {659, 661}, {809, 811}, {821, 823}, {827, 829}, {857, 859}, {881, 883}}

Constante de Brun B2

Corresponde al número resultante de la sumatoria de los inversos multiplicativos de las parejas de números gemelos




si esta suma fuera divergente se tendría demostrada la conjetura de los primos gemelos, pues serían infinitos. Pero en 1919 Viggo Brun demostró su convergencia, y en el año 2002 Pascal Sebah y Patrick Demichel han calculado su valor en 1.902160583104

Calculando el valor de B2 con los primos gemelos entre los primeros 10000 números primos, como comentaba en la Forma 1, gemelos puede tener duplicaciones de parejas, así se deben eliminar:

geme = DeleteDuplicates[gemelos];






1.74268

valor lejano al encontrado en 2002.

viernes, 7 de octubre de 2016

Regresión Lineal y Cuadrática por Mínimos Cuadrados



Creamos la función regresion que tiene dos parámetros, el primero es el número de puntos que vamos a ingresar y el segundo parámetro es: 1 si es lineal y 2 si es cuadrática.

Clear["Global`*"]
regresion[numero_Integer, tipo_Integer] := 
 Module[{xx, xi, xf, t, i, j},
  li = Table[{Input[x[i]], Input[y[i]]}, {i, 1, numero, 1}];
  xx = Sort@Table[li[[i, 1]], {i, 1, numero, 1}];
  xi = First[xx]; xf = Last[xx];
  Which[tipo == 1,
   ca = Minimize[
     Sum[(a li[[j, 1]] + b - li[[j, 2]])^2, {j, 1, numero}], {a, b}];
   cp = Plot[(a /. ca[[2, 1]]) t + (b /. ca[[2, 2]]), {t, xi, xf}];, 
   tipo == 2, 
   ca = Minimize[
     Sum[(a li[[j, 1]]^2 + b li[[j, 1]] + c - li[[j, 2]])^2, {j, 1, 
       numero}], {a, b, c}];
   cp = Plot[(a /. ca[[2, 1]]) t^2 + (b /. ca[[2, 2]]) t + (c /. 
        ca[[2, 3]]), {t, xi, xf}]];
  Grid[{{li}, {ca}, {Show[ListPlot[li, PlotStyle -> Red], cp, 
      PlotLabel -> 
       Which[tipo == 1, y == (a /. ca[[2, 1]]) x + (b /. ca[[2, 2]]), 
        tipo == 2, 
        y == (a /. ca[[2, 1]]) x^2 + (b /. ca[[2, 2]]) x + (c /. 
            ca[[2, 3]])]]}}]]

Después de cargar el código anterior, si vamos a ingresar 4 puntos y es lineal, entonces :

regresion[4, 1]


si vamos a ingresar 4 puntos y es cuadrática:

regresion[4, 2]



Vemos que en el caso lineal el mínimo es 61/13 y en el caso cuadrático es 9/13, obviamente mejora el ajuste de la curva a los puntos en el caso cuadrático.

miércoles, 5 de octubre de 2016

Conjetura Débil de Goldbach (Teorema)



Su enunciado dice :

Todo número impar mayor que 5 es 
la suma de tres números primos.

Se conoce como la conjetura débil, pues si se tiene como cierta la Conjetura de Goldbach, esta se obtiene de forma inmediata: pues si se tiene que todo número par mayor que dos es la suma de una pareja de primos, al sumarle 3 (también número primo) a la pareja se obtiene esta conjetura. Pero la conjetura débil NO implica la conjetura de Goldbach.

Actualmente se encuentra en estudio una demostración propuesta en 2013 por el matemático peruano Harald Helfgott quien trabaja en el Instituto Nacional de CIencias de Francia, el demostró que es cierta para números mayores que:




y para los números menores ya era simplemente un proceso computacional.

Helfgott actualmente ha desarrollado, basado en la Criba de Eratóstenes, un método computacional para la detección de números primos grandes. El último primo descubierto tiene más de 22 millones de dígitos.

En Mathematica

Establecemos una cuarteta formada por : el número impar y los tres números primos que sumados dan el numero impar.

numero = 50;
goldebil = {};

SetSharedVariable[goldebil]

AbsoluteTiming[
 ParallelDo[
  If[k == Prime[n] + Prime[m] + Prime[p], 
   AppendTo[goldebil, {k, Prime[n], Prime[m], Prime[p]}]], {k, 7, 
   Prime[numero], 2}, {n, 1, numero}, {m, n, numero}, {p, m, numero}];
  SortBy[goldebil, First]]



La gráfica de cuántas formas es posible la representación, pues vemos que se puede de más de una forma, por ejemplo: {9,2,2,5}, {9,3,3,3}.

numero = 50;
debil = {};
SetSharedVariable[debil]
AbsoluteTiming[
 ParallelDo[
  If[k == Prime[n] + Prime[m] + Prime[p], AppendTo[debil, k]], {k, 7, 
   Prime[numero], 2}, {n, 1, numero}, {m, n, numero}, {p, m, 
   numero}];
 ListPlot@Tally[debil]]



Vemos al igual que en la Conjetura de Goldbach, que entre mayor sea el número más formas de representación como la suma de tres números primos tiene.

martes, 4 de octubre de 2016

Problema 1

En este tipo de entradas quiero plantear problemas para que mis lectores propongan soluciones utilizando Mathematica. Buena suerte y animo. Las soluciones anéxenlas como comentarios.

Encontrar tres números naturales en progresión aritmética de dos tales que la suma de sus cuadrados sea un número de cuatro dígitos iguales.

lunes, 3 de octubre de 2016

Regresión Lineal por Mínimos Cuadrados


Mathematica cuenta con comandos que facilitan el ajuste de curvas a diferentes tipos de modelos, por diferentes métodos. Comandos tales como:

Fit, FindFit, LeastSquares, Interpolation, InterpolationPoints, LinearModelFit

entre muchos otros. Pero aquí, realizaré un ejercicio para mostrar el manejo de las listas realizando una regresión lineal por mínimos cuadrados.

(*Regresión Lineal*)
Clear[li, xx, xi, xf, ca, m, b];
numero = Input["número de puntos"];
li = Table[{Input[x[i]], Input[y[i]]}, {i, 1, numero, 1}];
xx = Sort@Table[li[[i, 1]], {i, 1, numero, 1}];
xi = First[xx]; xf = Last[xx];
ca = Minimize[
  Sum[(m li[[j, 1]] + b - li[[j, 2]])^2, {j, 1, numero}], {m, b}]
Show[ListPlot[li], 
 Plot[(m /. ca[[2, 1]]) x + (b /. ca[[2, 2]]), {x, xi, xf}], 
 PlotLabel -> y == (m /. ca[[2, 1]]) x + (b /. ca[[2, 2]])]

Este ejemplo corresponde a cuatro puntos (0,3), (3,5), (5,7) y (8,9)



El resultado nos muestra: la gráfica de los puntos y a recta que mejor los aproxima, junto con su ecuación.

domingo, 2 de octubre de 2016

Conjetura de Goldbach


El matemático Chistian Goldbach (1690-1764) nacido en Rusia, en una carta escrita a Leonard Euler daba a conocer en 1742 la que se conoce como la conjetura de Goldbach, que dice:

Todo número par mayor que 2 puede 
escribirse como la suma de dos números primos

Aún 300 años después todavía no se ha podido ni demostrar ni refutar esta afirmación.

En Mathematica

El siguiente código genera el número par y las diferentes combinaciones de dos primos que sumados dan el número par hasta Prime[numero] (el primo en la posición numero)

numero = 200;
goldbach = {{4, 2, 2}};
DistributeDefinitions[goldbach, numero]

AbsoluteTiming[
 ParallelDo[
  If[k == Prime[n] + Prime[m], 
   AppendTo[goldbach, {k, Prime[n], Prime[m]}]], {k, 4, Prime[numero],
    2}, {n, 2, numero}, {m, n, numero}]; goldbach]


Como se puede notar por ejemplo para el número 10, se puede obtener de dos formas diferentes: {10,5,5} y {10,3,7}. Luego aquí se gráfica la cantidad posible de forma de obtener cada número para como la suma de dos primos

numero = 200;
gold = {4};

DistributeDefinitions[gold]

numero = 500;
gold = {4};
AbsoluteTiming[
 ParallelDo[
  If[k == Prime[n] + Prime[m], AppendTo[gold, k]], {k, 4, Prime[numero], 2}, {n, 2, numero}, {m, n, numero}];
 ListPlot@Tally[gold]]



Es claro, desde la gráfica, que cuando el número es mayor más posibles formas tiene de ser escrito como la suma de dos números primos.


La comprobación de la Conjetura de Goldbach para el conjunto representado anteriormente, es si encuentra un número para el que no sea posible se detendría el proceso y mostraría: no cumple. Obvio esto no sucede con los números que hemos probado.

Do[If[Tally[gold][[k, 2]] == 0, 
  Print[Tally[gold][[k, 1]], "no cumple"]], {k, 1, 
  Length[Tally[gold]]}]