EJEMPLOS DE PROGRAMACION

Polinomios Ciclotómicos

Estudiar si los coeficientes de los factores irreducibles
del polinómio 1-x^n, son 0,1 o -1.

Factor[1-x^18]

                                2            2         3    6
     (-1 + x) (1 + x) (1 - x + x ) (1 + x + x ) (-1 + x  - x ) 
      
             3    6
       (1 + x  + x )

q[n_Integer]:=
Module[{g,s},
    g[p_]:=Max[Abs[CoefficientList[p,x]]]<2;
    s=Apply[List,Factor[1-x^n]];
    Apply[And,Map[g,s]]
    ]
    

NoUnos[k_,l_]:=Do[If[Not[q[n]],Print[n]],{n,k,l}]

NoUnos[100,110]

105

q[105]

     False

q[18]

     True

Primos Cuadráticos

Calcular los números primos p para los que la sucesión
p,p+2,p+4,p+6,...,p+n^2-n,..., está formada por números
primos, n=1,...,p-1.

Test[k_]:=
Module[{n},
    n=2;
    While[PrimeQ[Prime[k]+n^2-n],n++];
    n];

PrimCuad[l_,m_]:=
    Module[{},
    Do[If[Test[j]==Prime[j],Print[Prime[j]]],
    {j,l,m}]]

PrimCuad[1,60]

2
3
5
11
17
41

Otra versión:

PrimCuad2[l_,m_]:=
    Module[{n},
    Do[n=2;While[PrimeQ[Prime[j]+n^2-n],n++];
    If[n==Prime[j],Print[n]],
    {j,l,m}]]

PrimCuad2[1,60]

2
3
5
11
17
41

Números Perfectos

Son aquellos números que coinciden con la suma de sus divisores

Perfectos[a_,b_]:=
Module[{n},
    Di[n_]:=Divisors[n];
    Lon[n_]:=Length[Di[n]];
    Per[n_]:=Sum[Di[n][[k]],{k,1,Lon[n]-1}];
    Do[If[Per[n]==n, 
    Print[n," ",Drop[Di[n],-1]]],
    {n,a,b}]
    ]
    

Perfectos[1,40]

6 {1, 2, 3}
28 {1, 2, 4, 7, 14}

Otra versión:

Perfectos2[a_,b_]:=
Module[{Per},
    Per[n_]:=Apply[Plus,Divisors[n]];
    Do[If[Per[n]==2n, 
    Print[n," ",Drop[Divisors[n],-1]]],
    {n,a,b}]
    ]

Perfectos2[1,40]

6 {1, 2, 3}
28 {1, 2, 4, 7, 14}

Una última versión:

Perfectos3[a_,b_]:=
Module[{q},
    Do[q=Divisors[n];If[Apply[Plus,q]==2n, 
    Print[n," ",Drop[q,-1]]],
    {n,a,b}]
    ]

Perfectos3[1,500]

6 {1, 2, 3}
28 {1, 2, 4, 7, 14}
496 {1, 2, 4, 8, 16, 31, 62, 124, 248}

Números Amigos

Dos números son amigos si coinciden con la suma de los divisores del otro.

Div[n_]:=Apply[Plus,Divisors[n]]-n

Amigos[n_]:=
    Module[{q},
    Do[q=Div[k];If[Div[q]==k,Print[k,",",q]],
    {k,3,n}]
    ]

Amigos[2000]

6,6
28,28
220,284
284,220
496,496
1184,1210
1210,1184

Movimientos Aleatorios

CaminoAleatorio[n_]:=
    Module[{q,Lista},
    q=Table[{Random[]-.5,Random[]-.5},{k,1,n}];
    Lista=FoldList[Plus,{0,0},q];
    ListPlot[Lista,AspectRatio->Automatic,
    PlotJoined->True]
    ]

CaminoAleatorio[2000]

     -Graphics-

Regularización de Datos

Eliminación del ruido  en una señal mediante un filtro (convolución)

kern=Fourier[Table[N[Exp[-200(n/256)^2]],{n,0,255}]];

Regular[f_]:=
    Module[{data,conv,a,b},
    data=Table[f/.x->n/256+.2(Random[]-.5),{n,0,255}];
    conv=InverseFourier[Fourier[data] kern];
    a=ListPlot[Chop[conv],PlotJoined->True,
        DisplayFunction->Identity];
    b=ListPlot[Chop[data],DisplayFunction->Identity];
    Show[a,b,DisplayFunction->$DisplayFunction]
    ]

Regular[3Sin[10x]+4Cos[12x]]

     -Graphics-

Regular[Sin[10x]]

     -Graphics-