Entrada destacada

Distancia media de dos puntos en un cuadrado unitario

martes, 29 de agosto de 2017

Espiral de Ulam



Creada por el matemático de origen polaco Stanislaw Marcin Ulam (1909-1984) durante una conferencia en la que estaba de asistente en 1963, comenzó a representar sobre una espiral los enteros positivos así: el 1 en el centro, el 2 a su derecha, el 3 arriba del 2, el 4 a la izquierda del tres y así sucesivamente. Luego destacó los números primos en la espiral y encontró algunos patrones, como que los números primos se tendían a alinear sobre algunas diagonales más que sobre otras, es sorprendente que esta tendencia se mantiene así se comience desde otro número la secuencia.

En Mathematica

Primero determinamos las coordenadas de los puntos donde se ubican cada uno de los enteros positivos en la espiral sobre el plano cartesiano.

a = 0; b = 0;
ulam = {{{{0, 0}}}};
Do[If[OddQ[n], 
  AppendTo[ulam, {Table[{a + k, b}, {k, 1, n}], 
    Table[{a + n, b + k}, {k, 1, n}]}]; a = a + n; b = b + n, 
  AppendTo[ulam, {Table[{a - k, b}, {k, 1, n}], 
    Table[{a - n, b - k}, {k, 1, n}]}]; a = a - n; b = b - n], {n, 15}]
espiral = Flatten[ulam, 2]
{{0, 0}, {1, 0}, {1, 1}, {0, 1}, {-1, 1}, {-1, 0}, {-1, -1}, 
{0, -1}, {1, -1}, {2, -1}, {2, 0}, {2, 1}, {2, 2}, {1, 2}, 
{0, 2}, {-1, 2}, {-2, 2}, {-2, 1}, {-2, 0}, {-2, -1}, {-2, -2}, 
{-1, -2}, {0, -2}, {1, -2}, {2, -2}, {3, -2}, {3, -1}, {3, 0}, 
{3, 1}, {3, 2}, {3, 3}, {2, 3}, {1, 3}, {0, 3}, {-1, 3}, 
{-2, 3}, {-3, 3}, {-3, 2}, {-3, 1}, {-3, 0}, {-3, -1}, 
{-3, -2}, {-3, -3}, {-2, -3}, {-1, -3}, {0, -3}, {1, -3}, 
{2, -3}, {3, -3}, {4, -3}, {4, -2}, {4, -1}, {4, 0}, {4, 1}, 
{4, 2}, {4, 3}, {4, 4}, {3, 4}, {2, 4}, {1, 4}, {0, 4}, 
{-1, 4}, {-2, 4}, {-3, 4}, {-4, 4}, {-4, 3}, {-4, 2}, 
{-4, 1}, {-4, 0}, {-4, -1}, {-4, -2}, {-4, -3}, {-4, -4}, 
{-3, -4}, {-2, -4}, {-1, -4}, {0, -4}, {1, -4}, {2, -4}, 
{3, -4}, {4, -4}, {5, -4}, {5, -3}, {5, -2}, {5, -1}, {5, 0}, 
{5, 1}, {5, 2}, {5, 3}, {5, 4}, {5, 5}, {4, 5}, {3, 5}, {2, 5}, 
{1, 5}, {0, 5}, {-1, 5}, {-2, 5}, {-3, 5}, {-4, 5}, {-5, 5}, 
{-5, 4}, {-5, 3}, {-5, 2}, {-5, 1}, {-5, 0}, {-5, -1}, 
{-5, -2}, {-5, -3}, {-5, -4}, {-5, -5}, {-4, -5}, {-3, -5}, 
{-2, -5}, {-1, -5}, {0, -5}, {1, -5}, {2, -5}, {3, -5}, 
{4, -5}, {5, -5}, {6, -5}, {6, -4}, {6, -3}, {6, -2}, 
{6, -1}, {6, 0}, {6, 1}, {6, 2}, {6, 3}, {6, 4}, {6, 5}, 
{6, 6}, {5, 6}, {4, 6}, {3, 6}, {2, 6}, {1, 6}, {0, 6}, {-1, 6}, {-2, 6}, {-3, 6}, {-4, 6}, {-5, 6}, {-6, 6}, {-6, 5}, {-6, 4}, 
{-6, 3}, {-6, 2}, {-6, 1}, {-6, 0}, {-6, -1}, {-6, -2}, 
{-6, -3}, {-6, -4}, {-6, -5}, {-6, -6}, {-5, -6}, {-4, -6}, 
{-3, -6}, {-2, -6}, {-1, -6}, {0, -6}, {1, -6}, {2, -6}, 
{3, -6}, {4, -6}, {5, -6}, {6, -6}, {7, -6}, {7, -5}, {7, -4}, 
{7, -3}, {7, -2}, {7, -1}, {7, 0}, {7, 1}, {7, 2}, {7, 3}, 
{7, 4}, {7, 5}, {7, 6}, {7, 7}, {6, 7}, {5, 7}, {4, 7}, {3, 7}, 
{2, 7}, {1, 7}, {0, 7}, {-1, 7}, {-2, 7}, {-3, 7}, {-4, 7}, 
{-5, 7}, {-6, 7}, {-7, 7}, {-7, 6}, {-7, 5}, {-7, 4}, {-7, 3}, 
{-7, 2}, {-7, 1}, {-7, 0}, {-7, -1}, {-7, -2}, {-7, -3}, 
{-7, -4}, {-7, -5}, {-7, -6}, {-7, -7},{-6, -7}, {-5, -7}, 
{-4, -7}, {-3, -7}, {-2, -7}, {-1, -7}, {0, -7}, {1, -7}, 
{2, -7}, {3, -7}, {4, -7}, {5, -7}, {6, -7}, {7, -7}, {8, -7}, 
{8, -6}, {8, -5}, {8, -4}, {8, -3}, {8, -2}, {8, -1}, {8, 0}, 
{8, 1}, {8, 2}, {8, 3}, {8, 4}, {8, 5}, {8, 6}, {8, 7}, {8, 8}}

Graficando la espiral, tenemos :

Graphics[Table[Text[k, espiral[[k]]], {k, Length[espiral]}]]



Seleccionando los números primos:

Graphics[Table[
  If[PrimeQ[k], Text[k, espiral[[k]]]], {k, Length[espiral]}]]



Realizando todo el proceso, pero marcando con punto donde se ubica un número primo sobre la espiral:

a = 0; b = 0;
ulam = {{{{0, 0}}}};
Do[If[OddQ[n], 
  AppendTo[ulam, {Table[{a + k, b}, {k, 1, n}], 
    Table[{a + n, b + k}, {k, 1, n}]}]; a = a + n; b = b + n, 
  AppendTo[ulam, {Table[{a - k, b}, {k, 1, n}], 
    Table[{a - n, b - k}, {k, 1, n}]}]; a = a - n; b = b - n], {n, 
  300}]
espiral = Flatten[ulam, 2];
Graphics[Table[
  If[PrimeQ[k], Point[espiral[[k]]]], {k, Length[espiral]}]]




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


viernes, 25 de agosto de 2017

Frase Célebre de Galileo Galilei

En cuestiones de Ciencia, la autoridad 
de mil no vale lo que el humilde
razonamiento de un individuo.

Galileo Galilei

martes, 22 de agosto de 2017

Conjetura de Singmaster



Como no podía faltar el Triángulo de Pascal también tiene su conjetura asociada, que se debe al matemático estadounidense David Singmaster.

El número de veces que aparece un número diferente de 1 en el triángulo de Pascal está acotado por un número M

Manipulate[
 Pane[Text@
   TraditionalForm[
    Column[{Grid[{{Column[
          Table[Row[Table[Binomial[i, j], {j, 0, i}], "   "], {i, 0, 
            n}], Center]}}]}]], {550, 200}, 
  Alignment -> {Center, Top}], {{n, 7}, 0, 8, 1}]




Es decir ningún número diferente de uno aparece infinitas veces en el Triángulo de Pascal, pero esto es obvio pues ningún número aparece más allá de su fila. Pero lo importante que afirma es que la cota para el número de apariciones no depende del número, hay números que aparecen pocas veces y otros que aparecen un número mayor de veces, sobre todo para los números grandes.

Así, para determinar el número de veces que aparece un número entero positivo m, solo tenemos que construir m filas del Triángulo de Pascal y contar sus apariciones:

sing[m_] := Count[Flatten[Table[tp[n, k], {n, 0, m}, {k, 0, n}]], m]

Si deseamos contar las apariciones de los enteros entre 2 y m, es más eficiente calcular primero el Triángulo de Pascal y luego contar las apariciones de cada número:

singmaster[m_] := 
 Module[{sin}, 
  sin = Flatten[Table[Binomial[n, k], {n, 0, m}, {k, 0, n}]]; 
  ParallelTable[Tooltip[{p, Count[sin, p]}], {p, 2, m, 1}]]

singmaster[2000]















graficando:

ListPlot[%]



Vemos que la gran mayoría aparecen un número par de veces, esto se debe a la simetría del Triángulo de Pascal, los que aparecen un número impar de veces es porque están sobre el eje de simetría. De los números del 2 al 2000 los que más aparecen son 120, 210 y 1540 que lo hacen seis veces.

El manipulate fue adaptado de
http : // demonstrations.wolfram.com/PascalsTriangleAndTheBinomialTheorem/



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


viernes, 18 de agosto de 2017

Frase Célebre de Danica McKellar

Una de las cosas más impresionantes
sobre las matemáticas 
es que la gente que las practica 
no están normalmente interesadas 
en su aplicación, porque las matemáticas 
en sí misma son una forma de hermoso arte.

Danica McKellar

lunes, 14 de agosto de 2017

Espiral de Theodorus, Einstein o Pitagórica


Es una espiral compuesta por triángulos rectángulos contiguos, se inicia con un triángulo rectángulo con catetos de una unidad, su hipotenusa se toma como un cateto del siguiente triángulo y el otro cateto es una unidad y así sucesivamente. Por tanto, las hipotenusas son del primer triángulo raíz de dos, del segundo raíz de tres y del triángulo enésimo raíz de (n+1).

















El ángulo


y el ángulo


Así en coordenadas polares tenemos que :


por tanto las coordenadas de Pn para n>0 son:


En Mathematica


angulo := Sum[ArcTan[1/Sqrt[i]], {i, n}]

cart[n_] := {radio[[n, 2]] Cos[radio[[n, 1]]], 
  radio[[n, 2]] Sin[radio[[n, 1]]]}

cart1[n_] := {Sqrt[n + 1] Cos[radio[[n, 1]] + ArcTan[1/Sqrt[n]]/2], 
  Sqrt[n + 1] Sin[radio[[n, 1]] + ArcTan[1/Sqrt[n]]/2]}

ne[n_] := HoldForm[Sqrt[n]]

radio = Prepend[Table[{angulo, Sqrt[n + 1]}, {n, 1, 20}], {0, 1}];

theodorus[k_] := 
 Module[{}, 
  radio = Prepend[Table[{angulo, Sqrt[n + 1]}, {n, 1, k}], {0, 1}]; 
  Show[Graphics[{Red, Line[Table[{{0, 0}, cart[n]}, {n, k + 1}]]}], 
   ListPolarPlot[radio, Joined -> True], 
   Graphics[Table[Text[1, cart1[i]], {i, k}]], 
   Graphics[Table[Text[ne[i], 2 cart[i]/3], {i, k + 1}]]]]


theodorus[16]



theodorus[35]



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


viernes, 11 de agosto de 2017

Frase Célebre de Isaac Barrow

Las matemáticas son:

El inconmovible fundamento de todas las ciencias 
y la generosa fuente de beneficios para los asuntos humanos.

Isaac Barrow

martes, 8 de agosto de 2017

Sucesión Golomb-Silverman




Su nombre se debe a Solomon Golomb, un matemático, ingeniero y profesor estadounidense de la Universidad de California del Sur nacido en 1932. También se conoce como de Silverman por el estudio que sobre ella hizo el profesor Joseph Silverman de Brown University.

Se define por la sucesión creciente, tal que:

s (1) = 1, s (2) = 2, s (n) es el número de veces que aparece n en la sucesión

Por las condiciones iniciales, así comienza la sucesión:

(*código para generar la tabla*)
Grid[{{n, 1, 2, 3, 4, 5, 6, 7, 8, 9, 
   10,...}, {"s(n)", 1, 2, , , , , , , }}, 
 Frame -> All]



como para n=2 el valor s(2)=2, quiere decir que dos aparece dos veces en la sucesión, es decir:



Ahora, para n = 3 el valor s (3)=2, así 3 aparece dos veces en la sucesión:



para n = 4 el valor s(4)=3, así 4 aparece tres veces en la sucesión:



y así sucesivamente.

Ahora, generemosla en Mathematica

suc = {1, 2, 2};
Do[Do[AppendTo[suc, n], {i, suc[[n]]}], {n, 3, 10}]
suc

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

o, como una función que nos muestra el elemento correspondiente a la posición en la sucesión :

golomb[x_] := 
 Module[{sil = {1, 2, 2}}, 
  Do[Do[AppendTo[sil, n], {i, sil[[n]]}], {n, 3, x}]; sil[[x]]]

Calculando el elemento en la posición n = 10 :

golomb[10]
5

Calculando los 100 primeros elementos de la sucesión :

Table[golomb[i], {i, 100}]

{1, 2, 2, 3, 3, 4, 4, 4, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 21, 21}

Un hecho interesante es que para valores grandes de n se tiene que:





del cual hablaremos en futuras entradas.


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


viernes, 4 de agosto de 2017

Frase Célebre de Arthur Cayley

Como en cualquier otra situación, 
así pasa también en una teoría matemática: 
la belleza puede captarse, 
pero no puede explicarse.

Arthur Cayley

martes, 1 de agosto de 2017

Una Suma de Cubos Curiosa


Partimos en bloques de uno, dos , tres, etc. las cifras del número 153 intercalándole respectivamente 6, 0 y 3, luego la suma de los cubos de cada bloque da el mismo número.

a = {1}; b = {5}; c = {3};
Do[aa = FromDigits[a]; bb = FromDigits[b]; cc = FromDigits[c]; 
 Print[Spacer[300 - 24 n], 
  FromDigits[a]^3 + FromDigits[b]^3 + FromDigits[c]^3, " = ", aa, 
  Defer[Superscript[ "", 3]], " + ", bb, Defer[Superscript[ "", 3]], 
  " + ", cc, Defer[Superscript[ "", 3]]]; AppendTo[a, 6]; 
 AppendTo[b, 0]; AppendTo[c, 3], {n, 10}]






Resultado bastante curioso





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