Scuola Superiore
dell'Università di Udine

Corso di Mathematica

Gianluca Gorni
MouseOver

Novembre 2017

Martedì alle 20:30, giovedì alle 20:00, fino a dicembre. Rinnovabile

Perché Mathematica?

Un motivo di fondo:

dopo venticinque anni di uso, sono quasi un guru di Mathematica;

non so usare altri programmi analoghi

(con l'eccezione del LATEX, che ha delle analogie parziali).

Quindi io personalemente non ho scelta,

o Mathematica o niente.

Pagine web

Sito principale: http://www.wolfram.com/

Wolfram Programming Lab

Per scaricare il CdfPlayer gratuito: http://www.wolfram.com/cdf/

Wolfram | Alpha

La mia pagina web http://www.dimi.uniud.it/gorni/Mma

Le origini di Mathematica

L'ideatore di Mathematica è Stephen Wolfram, originariamente un fisico teorico inglese.

Wolfram ha cominciato a lavorare al precursore di Mathematica nel 1981.

La prima versione di Mathematica è stata rilasciata nel 1988. Il nome Mathematica pare sia stato suggerito da Steve Jobs.

Stephen Wolfram è tuttora a capo dell'azienda Wolfram, che sviluppa attivamente il programma.

L’azienda si è espansa su Wolfram Language, Wolfram|Alpha, Wolfram Cloud e altro.

Mathematica: che cosa fa?

Mathematica è un programma molto potente e versatile.
I suoi impieghi principali sono:

Calcolo simbolico

Calcolo numerico

Linguaggio di programmazione

Grafica in 2 e 3 dimensioni, statica e animata, interattiva

Elaborazione di immagini e suono

Documenti interattivi

Accesso a banche dati

Tutti questi aspetti convivono in una singola applicazione con sintassi uniforme.

Libro introduttivo di Wolfram

Per chi non ha mai incontrato Mathematica, Wolfram ha scritto un libro introduttivo scaricabile gratuitamente:

An Elementary Introduction to the Wolfram Language

Esempi di Calcolo Simbolico

Fattorizzazione di un polinomio:

Factor[(x^99)+(y^99)]

Un integrale indefinito:

Integrate[(Sqrt[x])ArcTan[x],x]

Un'equazione differenziale:

DSolve[y''[x]+y'[x]+x y[x]==0,y[x],x]

Il milionesimo numero primo:

Prime[(10^9)]

Eliminazione di quantificatori:

Reduce[Exists[x,(x^2)+a x+b==0],{a,b},Reals]

Semplificazione di formule:

Simplify[Sin[x+2n π],n∈Integers]

Potenze di un binomio:

Manipulate[Expand@(((a+b))^n),Item["Potenze di un binomio"],{n,1,10,1,SetterBar}]

Massimo e minimo limite di successioni (dalla versione 11.2):

DiscreteMaxLimit[(((Sin[2n])^2)/(2+Cos[n])),n->Infinity]

Limit[((x y)/((x^2)+(y^2))),{x,y}->{0,0}]

Limiti in due variabili (dalla versione 11.2):

Limit[((x y)/((x^2)+(y^2))),{x,y}->{0,0}]

MaxLimit[((x y)/((x^2)+(y^2))),{x,y}->{0,0}]

MinLimit[((x y)/((x^2)+(y^2))),{x,y}->{0,0}]

Esempi di Calcolo Numerico

Una matrice casuale 500×500:

m=RandomReal[{},{500,500}];

La prima riga della matrice:

First@m

Calcoliamo gli autovalori della matrice e facciamo un grafico dei loro valori assoluti:

ListPlot@Abs@Eigenvalues@m

Soluzione numerica di un’equazione alle derivate parziali:

sol=NDSolveValue[{-Laplacian[u[x,y],{x,y}]==x-y,DirichletCondition[u[x,y]==0,True]},u,{x,y}∈Disk[]]
Plot3D[sol[x,y],{x,y}∈Disk[]]

Discretizzazione di regioni geometriche:

DiscretizeRegion[Disk[]]

DiscretizeRegion@RegionDifference[Disk[],Disk[{1/4,0},1]]

Numeri in precisione arbitraria

Di un numero simbolico Mathematica può calcolare anche migliaia di cifre decimali:

N[π,1000]

Manipulate[N[(Sqrt[2]),n],{n,{10,100,1000,10000}}]

Un numero di Pisot, che è vicinissimo a un intero:

Manipulate[NumberForm[N[(((((2/(27+3(Sqrt[69])))^(1/3))+(1/3)(((27+3(Sqrt[69]))/2)^(1/3))))^30000),9000],{6000,n},ExponentFunction->(Null&)],
{{n,10,"Cifre dopo la virgola"},{10,100,1000,1800,1831,1832,2000},ControlType->SetterBar}]

Esempio: un generatore di esercizi

Un pulsante che quando premuto spara un'equazione di secondo grado a coefficienti interi con una soluzione intera e una razionale:

Button["scrivimi un'equazione da risolvere",Print[Numerator@Together@Expand[(x-RandomInteger[{-5,5}]) (x-RandomInteger[{-5,5}]/RandomInteger[{1,5}])]==0]]

Grafica in 2 dimensioni

Un grafico:

Plot[2Sin[x]+x,{x,0,15},Filling->Bottom]

Più funzioni insieme, con tooltip:

Plot[Tooltip@{Sin[x],Sin[2x],Sin[3x]},{x,0,2Pi}]

Una curva parametrica:

ParametricPlot[{Sin[u],Sin[2u]},{u,0,2Pi}]

Animazione di una curva parametrica col punto che la percorre:

DynamicModule[{t},
ParametricPlot[{Sin[u],Sin[2u]},{u,0,2Pi},Epilog->{PointSize[Medium],Point@Dynamic[t=Clock[2Pi];{Sin[t],Sin[2t]}]},ImageSize->200]]

Una regione parametrica:

ParametricPlot[r^2{ Sqrt[t]Cos[t], Sin[t]},{t,0,3Pi/2},{r,1,2}]

Curve di livello di funzioni di due variabili:

ContourPlot[Sin[x]-Cos[y],{x,-2Pi,2Pi},{y,-2Pi,2Pi}]

Grafica in 3 dimensioni

Grafico di una funzione di 2 variabili:

Plot3D[Sin[x y], {x, 0, Pi}, {y, 0, Pi}]

Con evidenziate le curve di livello:

Plot3D[Sin[x]-Cos[y],{x,-2Pi,2Pi},{y,-2Pi,2Pi},MeshFunctions->{#3&}]

Raffinamenti successivi di una superficie:

Manipulate[
Plot3D[Sin[x y],{x,0,Pi},{y,0,Pi},
ImageSize->500,MaxRecursion->r,PlotPoints->8,Method->{"DraftRendering"->False,"Refinement" -> {"ControlValue"->(90 - n) Degree}}, Mesh->All],
{{n,15,"Dihedral Angle"}, 10, 90, 5},{{r,2,"MaxRecursion"},{0,1,2,3,4},ControlType->Setter}]

Mathematica ha dei meccanismi per gestire le discontinuità:

Plot3D[Im[Sqrt[x+y I]],{x,-1,1},{y,-1,1}]

e le angolosità:

Plot3D[Max[{1-(x^2)*t,0}],{x,-3,3},{t,0.1,3}]

Sfere concentriche:

ContourPlot3D[x^2+y^2+z^2,{x,-1,1},{y,-1,1},{z,-1,1},
Boxed->False,Axes->False,Contours->4,ContourStyle->{{Red},{Yellow},{Green},{Blue}},Mesh->5]

Una superficie definita implicitamente:

ContourPlot3D[16 (x^3)+16 (y^3)-31 (z^3)+24 (x^2) z-48 (x^2) y-48 x (y^2)+24 (y^2) z-54 (Sqrt[3]) (z^2)-72 z,{x,-3,3},{y,-3,3},{z,-3,3},
Contours->{1},Mesh->None,PlotPoints->50,ContourStyle->{{SurfaceColor[RGBColor[.6,.4,.1],White,200]}},Background->Black,Boxed->False,Axes->False,ImageSize->500,ViewPoint->{2,-3,0},SphericalRegion->True,Mesh->All]

ContourPlot3D[16 (x^3)+16 (y^3)-31 (z^3)+24 (x^2) z-48 (x^2) y-48 x (y^2)+24 (y^2) z-54 (Sqrt[3]) (z^2)-72 z==1,{x,-3,3},{y,-3,3},{z,-3,3},
Mesh->None,PlotPoints->50,ContourStyle->{{SurfaceColor[RGBColor[.6,.4,.1],White,200]}},Background->Black,Boxed->False,Axes->False,ImageSize->500,ViewPoint->{2,-3,0},SphericalRegion->True,Mesh->All]

Linguaggio di programmazione

Il principio alla base delle operazioni di Mathematica sono le regole di riscrittura.
Sono supportati gli stili di programmazione funzionale e procedurale.

Esempio procedurale:

Clear[a];
z=a;
Do[Print[z*=z+i],{i,3}]

Manipolazione concisa di liste:

(({a,b,c})^2)

1+(({a,b,c})^2)

Table[(i^j),{i,4},{j,i}]

Flatten[%]

Partition[%,2]

Map[Norm,%]

Programmazione funzionale:

Clear[f];
NestList[f,x,4]

Clear[f];
NestList[(((1+#))^2)&,x,4]

Composizione di permutazioni:

Fold[f,a,{1,2,3}]

Fold[Permute,{1,2,3,4,5,6},
{{4,1,2,3,5,6},
{3,4,1,2,6,5},
{2,6,5,3,1,4}}]

Programmazione per pattern e regole di sostituzione:

Questa regola stabilisce che la funzione p è additiva:

p[x_+y_]:=p[x]+p[y]

p[a+b+c]

Una funzione che cerca un elemento in una lista e, se lo trova, ristruttura la lista:

s[{x___,a_,y___},a_]:={a,x,x,y,y}

s[{1,2,3,4,5,6},4]

Simmetrie di riflessione nel piano

Manipulate[
rotMat={{0,1},{-1,0}};v[t_]:=rotMat.{Cos[t],Sin[t]};Graphics[{Locator[p],{Red,PointSize[Medium],Tooltip[GeometricTransformation[Point[p],ReflectionTransform[v[θ]]],Style["punto immagine",Red]]},If[mostraAsseQ,{Dashed,Tooltip[Line[{rotMat.v[θ],-rotMat.v[θ]}],"asse di simmetria"]},Nothing]},PlotRange-> {{-1,1},{-1,1}}],
{{p,{1/2,0}},Locator},
{{θ,Pi/4},0,2Pi},
{{mostraAsseQ,True,"mostra l'asse di simmetria"},{True,False}},
TrackedSymbols:>{p,θ,mostraAsseQ}]

Manipulate[
rotMat={{0,1},{-1,0}};v[t_]:=rotMat.{Cos[t],Sin[t]};Graphics[{Line[pts],{Red,GeometricTransformation[{Line[pts]},ReflectionTransform[v[θ]]]},If[mostraAsseQ,{Dashed,Tooltip[Line[{rotMat.v[θ],-rotMat.v[θ]}],"asse di simmetria"]},Sequence@@{}]},PlotRange-> {{-1,1},{-1,1}}],
{{pts,{{1/4,-1/4},{3/4,0},{1/2,1/4}}},Locator,LocatorAutoCreate->True},
{{θ,Pi/4},0,2Pi},
{{mostraAsseQ,True,"mostra l'asse di simmetria"},{True,False}},TrackedSymbols:>{p,θ,mostraAsseQ}]

txt=TextToGraphics["testo",TextRange->{{0,1},{0,1}}];
Manipulate[
rotMat={{0,1},{-1,0}};v[t_]:=rotMat.{Cos[t],Sin[t]};Graphics[{txt,Locator[p],{Red,GeometricTransformation[{txt,PointSize[Medium],Tooltip[Point[p],Style["punto immagine",Red]]},ReflectionTransform[v[θ]]]},If[mostraAsseQ,{Dashed,Tooltip[Line[{rotMat.v[θ],-rotMat.v[θ]}],"asse di simmetria"]},Sequence@@{}]},PlotRange-> (Sqrt[2])],
{{p,{1/2,0}},Locator},
{{θ,Pi/4},0,2Pi},
{{mostraAsseQ,True,"mostra l'asse di simmetria"},{True,False}},TrackedSymbols:>{p,θ,mostraAsseQ}]

Esempio interattivo: punti notevoli di un triangolo

vers=Normalize;
proiezioneOrtogonale[p_,q_,pt_]:=p+((pt-p).Normalize[q-p])Normalize[q-p];
asse[pt1_,pt2_]:=Module[{versOrt,medio},
versOrt={{0,-1},{1,0}}.Normalize[pt1-pt2];
medio=(pt1+pt2)/2;
Line[{medio+4versOrt,medio-4versOrt}]];
risolviConMinimiQuadrati[eqs_,var_]:=Module[{termineNoto,coeff},
{termineNoto,coeff}=Normal@CoefficientArrays[Simplify[eqs/.Equal->Subtract],var];
LeastSquares[coeff,-termineNoto]];
siAnnullaSullAsse[p_,q_,r_]:=Module[{direz,proiez},
direz=vers[q-p];
proiez=p+((r-p).direz)direz;
(r-p).direz-Norm[q-p]/2];
incontroAssi[p_,q_,r_]:=Module[{x,y},
If[Abs@Det[{r-p,q-p}]≤$MachineEpsilon,Return[p]];
risolviConMinimiQuadrati[{siAnnullaSullAsse[p,q,{x,y}],siAnnullaSullAsse[p,r,{x,y}],siAnnullaSullAsse[r,q,{x,y}]},
{x,y}]];
cerchioCircoscritto[p_,q_,r_]:=Module[{centro},
If[Abs@Det[{r-p,q-p}]≤$MachineEpsilon,Return[Line[{p,r}]]];
centro=incontroAssi[p,q,r];
Circle[centro,Norm[p-centro]]];
assiTriangolo[p_,q_,r_]:={asse[p,q],asse[p,r],asse[q,r],PointSize[.01],Point[incontroAssi[p,q,r]]};
siAnnullaSullaMediana[p_,q_,r_,pt_]:=Det[{pt-p,pt-((r+q)/2)}];
incontroMediane[p_,q_,r_]:=Module[{x,y},
If[Abs@Det[{r-p,q-p}]≤$MachineEpsilon,Return[p]];
risolviConMinimiQuadrati[{siAnnullaSullaMediana[p,q,r,{x,y}],siAnnullaSullaMediana[p,r,q,{x,y}],siAnnullaSullaMediana[r,q,p,{x,y}]},
{x,y}]];
medianeTriangolo[p_,q_,r_]:={Line[{p,(q+r)/2}],Line[{q,(p+r)/2}],Line[{r,(q+p)/2}],PointSize[.01],Point[incontroMediane[p,q,r]]};
siAnnullaSullAltezza[p_,q_,r_,pt_]:=Module[{direz,proiez},
direz=vers[q-p];
proiez=p+((r-p).direz)direz;
Det[{pt-r,pt-proiez}]];
incontroAltezze[p_,q_,r_]:=Module[{x,y,centro},
If[Abs@Det[{r-p,q-p}]≤$MachineEpsilon,Return[p]];
risolviConMinimiQuadrati[{siAnnullaSullAltezza[p,q,r,{x,y}],siAnnullaSullAltezza[p,r,q,{x,y}],siAnnullaSullAltezza[r,q,p,{x,y}]},
{x,y}]];
altezza[p_,q_,r_]:=Module[{direz,proiez,ortog},
direz=vers[q-p];
proiez=p+((r-p).direz)direz;
ortog=vers[proiez-r];
Line[{r-4ortog,r+4ortog}]];
altezzeTriangolo[p_,q_,r_]:={altezza[p,r,q],altezza[q,p,r],altezza[r,q,p],PointSize[.01],Point[incontroAltezze[p,q,r]]}
bisettrice[p_,q_,r_]:=Module[{direz1,direz2,pt,t,sol},
direz1=vers[q-p];
direz2=vers[r-p];
If[Abs@Det[{r-p,q-p}]≤$MachineEpsilon,Return[Line[{p,r}]]];
pt=t*q+(1-t)r;
sol=pt/.First@Solve[(pt-p).direz1==(pt-p).direz2,t];
Line[{p,sol}]];
equidistanteQ[p_,q_,r_,pt_]:=Module[{direz1,direz2},
direz1=vers[q-p];
direz2=vers[r-p];
(pt-p).direz1==(pt-p).direz2];
cerchioInscritto[p_,q_,r_]:=Module[{x,y,centro,raggio},
If[Abs@Det[{r-p,q-p}]≤$MachineEpsilon,Return[Line[{p,r}]]];
centro=risolviConMinimiQuadrati[{equidistanteQ[p,q,r,{x,y}],equidistanteQ[q,p,r,{x,y}],equidistanteQ[r,p,q,{x,y}]},{x,y}];
raggio=Norm[centro-proiezioneOrtogonale[p,q,centro]];
Circle[centro,raggio]];
incontroBisettrici[p_,q_,r_]:=First@cerchioInscritto[p,q,r];

Punti notevoli di un triangolo:

Manipulate[Graphics[{{GrayLevel[.5],Polygon[{p,q,r}]},PointSize[.02],Line[{p,q,r,p}],If[TrueQ@assiQ,{asse[p,q],asse[p,r],asse[q,r]},Sequence@@{}],
If[TrueQ@incontroAssiQ,Point[incontroAssi[p,q,r]],Sequence@@{}],If[TrueQ@medianeQ,{Red,medianeTriangolo[p,q,r]},Sequence@@{}],
If[TrueQ@incontroMedianeQ,{Red,Point[incontroMediane[p,q,r]]},Sequence@@{}],
If[TrueQ@altezzeQ,{Blue,altezzeTriangolo[p,q,r]},Sequence@@{}],
If[TrueQ@incontroAltezzeQ,{Blue,Point[incontroAltezze[p,q,r]]},Sequence@@{}],
If[TrueQ@bisettriciQ,{Green,bisettrice[p,q,r],bisettrice[q,p,r],bisettrice[r,q,p]},Sequence@@{}],
If[TrueQ@incontroBisettriciQ,{Green,Point@incontroBisettrici[q,p,r]},Sequence@@{}],If[TrueQ@inscrittoQ,cerchioInscritto[p,q,r],Sequence@@{}],
If[TrueQ@circoscrittoQ,cerchioCircoscritto[p,q,r],Sequence@@{}]},PlotRange->2],
{{inscrittoQ,True,"mostra il cerchio inscritto"},{True,False}},
{{circoscrittoQ,True,"mostra il cerchio circoscritto"},{True,False}},{{assiQ,False,"mostra gli assi del triangolo"},{True,False}},
{{incontroAssiQ,False,"mostra l'incontro degli assi del triangolo"},{True,False}},{{medianeQ,False,Style["mostra le mediane del triangolo",Red]},{True,False}},
{{incontroMedianeQ,False,Style["mostra l'incontro delle mediane del triangolo",Red]},{True,False}},{{altezzeQ,False,Style["mostra le altezze del triangolo",Blue]},{True,False}},
{{incontroAltezzeQ,False,Style["mostra l'incontro delle altezze del triangolo",Blue]},{True,False}},
{{bisettriciQ,False,Style["mostra le bisettrici del triangolo",Green]},{True,False}},
{{incontroBisettriciQ,False,Style["mostra l'incontro delle bisettrici del triangolo",Green]},{True,False}},{{p,{1,1}},Locator},{{q,{-1,-1}},Locator},{{r,{1,-1}},Locator}]

Isocronia del pendolo

Esempio interattivo: il sole nella volta celeste

Un'animazione del movimento del sole nella sfera celeste, all'equatore al tempo dell'equinozio:

estremoOmbra[θ_/;Abs[θ]≤10$MachineEpsilon]={0,0,0};
estremoOmbra[θ_]:={0,-((Cot[θ])/4),0};
sferaCeleste={Opacity[.5],Sphere[{0,0,0},1]};
monumento=Polygon[{{-1/8,0,0},{1/8,0,0},{0,0,1/4}}];
ombraMonumento[θ_/;Norm[estremoOmbra[θ]]≤1]:={GrayLevel[Max[0,Sin[θ]]/2],Polygon[{{-1/8,0,0.01},{1/8,0,0.01},estremoOmbra[θ]}]};ombraMonumento[θ_/;Norm[estremoOmbra[θ]]>1]:={GrayLevel[Max[0,Sin[θ]]/2],Polygon[{{-1/8,0,0.01},{1/8,0,0.01},{(Cot[θ]-4 Sign[Cot[θ]]) Tan[θ]/8,-Sign[Cot[θ]],0},{(Cot[θ]-4 Sign[Cot[θ]]) Tan[θ]/8,-Sign[Cot[θ]],0}}]};
pianoTerrestre=N@Polygon[Table[{Cos[t],Sin[t],0},{t,0,2Pi,2Pi/21}]];
sole[θ_]:={Yellow,Sphere[{0,Cos[θ],Sin[θ]},1/10]};
DynamicModule[{θ},
Graphics3D[{sferaCeleste,{monumento,Dynamic[θ=Clock[2π,20];ombraMonumento[θ]]},{GrayLevel[Sqrt@Max[0,Sin[Dynamic@θ]]],pianoTerrestre},Yellow,Dynamic[sole[θ]]},Boxed->False,PlotRange->12/10]]

Una versione in cui il sole si muove con un cursore:

Manipulate[
Graphics3D[{sferaCeleste,{monumento,Dynamic[ombraMonumento[θ]]},{GrayLevel[Sqrt@Max[0,Sin[Dynamic@θ]]],pianoTerrestre},Yellow,Dynamic[sole[θ]]},Boxed->False,PlotRange->12/10],
{θ,0,2Pi}]

Versione più sofisticata:

With[{r=4,inclinazioneAsseTerrestre=(23+1/2)Degree,semiSpessoreCilindro=2/100,altezzaMonumento=1/4,lunghezzaAnno=12,lunghezzaGiorno=2Pi},
terra={Lighter@Lighter@Blue,Specularity[0],Sphere[]};
asseDiRotazioneTerrestre={Thick,Glow[White],Tube[{{0,0,-1.4},{0,0,1.4}},.05]};
pianoMeridiano={Glow[Gray],Polygon[{{0,-1,-1},{0,-1,1},{0,1,1},{0,1,-1}}]};
equatore={Blue,EdgeForm[],Cylinder[semiSpessoreCilindro{{0,0,-1},{0,0,1}},1.01]};
ternaBase={{PointSize[Large],White,Point[1.1{1,0,0}]},Arrowheads[Tiny],{Red,Arrow[Tube[{{1,0,0},{1,0,1}},.02]]},{Blue,Arrow[Tube[{{1,0,0},{1,-1,0}},.02]]},{Green,Arrow[Tube[{{1,0,0},{2,0,0}},.02]]}};
ternaLocale=Translate[{Arrowheads[.005],{Green,Arrow[{{0,0,0},{0,0,1}}],Text[Zenith,{0,0,1.2}]},{Red,Arrow[{{0,0,0},{1,0,0}}],Text[N,{1.2,0,0}]},{Lighter@Blue,Arrow[{{0,0,0},{0,1,0}}],Text[W,{0,1.2,0}]}},{0,0,semiSpessoreCilindro}];
terraCielo={ternaLocale,{Lighter@Lighter@Green,Opacity[.7],Specularity[0],Cylinder[semiSpessoreCilindro{{0,0,-1},{0,0,1}},1]},Opacity[.2],Lighter@Blue,Sphere[]};
stelle={White,PointSize[.001],Point[(4r) Table[{Cos[#1]Sqrt[1-#2^2],Sin[#1]Sqrt[1-#2^2],#2}&[Random[Real,{0,2Pi}],Random[Real,{-1,1}]],{2000}]]};
stelleInLocale[lat_,tempoNelGiorno_]:=Rotate[Rotate[Rotate[stelle,lat*Degree,{0,-1,0}],tempoNelGiorno,{0,0,1}],inclinazioneAsseTerrestre,{-1,0,0}];
daMeseGiornoATempoAssoluto[m_,g_]:=lunghezzaAnno*AbsoluteTime[{1900,m,g}]/AbsoluteTime[{1901,1,1}];
equinozioPrimavera=daMeseGiornoATempoAssoluto[3,21]//N;
equinozioAutunno=daMeseGiornoATempoAssoluto[9,21];
solstizioEstate=daMeseGiornoATempoAssoluto[6,21];
solstizioInverno=daMeseGiornoATempoAssoluto[12,21];
direzioneTerra[stagione_]=RotationTransform[stagione*2Pi/lunghezzaAnno,{0,0,1}][{1,0,0}];
orbita={Blue,Dotted,Tube[Table[r{Cos[t],Sin[t],0},{t,0,2Pi,Pi/16}],.02]};
daLocaleAGlobale[lat_,stagione_,tempoNelGiorno_]=Composition[TranslationTransform[direzioneTerra[stagione]],RotationTransform[inclinazioneAsseTerrestre,direzioneTerra[equinozioPrimavera]],RotationTransform[2Pi*tempoNelGiorno/lunghezzaGiorno+(stagione)*2Pi/lunghezzaAnno,{0,0,1}],RotationTransform[lat*Degree,{0,-1,0}]];
posizioneRelativaSole[lat_,stagione_,tempoNelGiorno_]=With[{trasf=daLocaleAGlobale[lat,stagione,tempoNelGiorno]},Normalize[{(trasf[{0,0,1}]-trasf[{0,0,0}]),(trasf[{0,1,0}]-trasf[{0,0,0}]),(trasf[{1,0,0}]-trasf[{0,0,0}])}.({0,0,0}-trasf[{0,0,0}])]];
soleGlobale={Glow@Yellow,Sphere[]};
soleInLocale[lat_,stagione_,tempoNelGiorno_]:={Glow@Yellow,Sphere[1.15posizioneRelativaSole[lat,stagione,tempoNelGiorno],.15]};
percorsoDelSole[lat_,stagione_]={Yellow,Line@Table[1.15posizioneRelativaSole[lat,stagione,t],{t,0,2Pi,Pi/16}]};
giornoQ[lat_,stagione_,tempoNelGiorno_]:=posizioneRelativaSole[lat,stagione,tempoNelGiorno][[-1]]>0;
monumento=Polygon[{{-1/8,0,semiSpessoreCilindro},{1/8,0,semiSpessoreCilindro},{0,0,altezzaMonumento}}];
estremoOmbra[{x_,y_,z_}]={t x,t y,semiSpessoreCilindro}/.Solve[altezzaMonumento+t z/Norm[{x,y}]==0,t][[1]];
intersezioneCerchio[{x1_,y1_,_},{x2_,y2_,_}]={t x1,t y1,semiSpessoreCilindro}+{(1-t)x2,(1-t)y2,semiSpessoreCilindro}/.Solve[Norm[t{x1,y1}+(1-t){x2,y2}]==1,t][[2]];
monumentoConOmbra[lat_,stagione_,tempoNelGiorno_]:=With[{punta=estremoOmbra@posizioneRelativaSole[lat,stagione,tempoNelGiorno]},
{GrayLevel[.5],
Which[Not@giornoQ[lat,stagione,tempoNelGiorno],{Black,monumento},
Norm@estremoOmbra@posizioneRelativaSole[lat,stagione,tempoNelGiorno]≤1,
{monumento,EdgeForm[],Polygon[{monumento[[1,1]],monumento[[1,2]],punta}]},
True,{monumento,EdgeForm[],Polygon[{monumento[[1,1]],monumento[[1,2]],intersezioneCerchio[punta,monumento[[1,2]]],intersezioneCerchio[punta,monumento[[1,1]]]}]}]}];
dataEOra[stagione_,tempoNelGiorno_]:=StringReplace[DateString[DateList[Floor[stagione*365/lunghezzaAnno]24*3600+tempoNelGiorno/lunghezzaGiorno*24*3600],{"Day", " ","MonthName", ",  ore ","Hour",":","Minute"}],Thread[Table[DateString[{0,n},{"MonthName"}],{n,12}]->{"gennaio","febbraio","marzo","aprile","maggio","giugno","luglio","aosto","settembre","ottobre","novembre","dicembre"}]];
visioneLocale[lat_,stagione_,tempoNelGiorno_]:=Graphics3D[{terraCielo,percorsoDelSole[lat,stagione],soleInLocale[lat,stagione,tempoNelGiorno],stelleInLocale[lat,tempoNelGiorno],monumentoConOmbra[lat,stagione,tempoNelGiorno]},PlotLabel->Style[dataEOra[stagione, tempoNelGiorno],White],PlotRange->4r,ViewAngle->55Degree,Background->GrayLevel[.1],Boxed->False,ImageSize->300,Lighting->{{"Directional",White,{posizioneRelativaSole[lat,stagione,tempoNelGiorno],{0,0,0}}}},ViewVector->{1/2,-2,2}];
visioneGlobale[lat_,stagione_,tempoNelGiorno_]:=Graphics3D[{stelle,soleGlobale,orbita,
Lighting->{{"Directional",White,{{0,0,0},direzioneTerra[stagione]}}},Translate[{terra,Rotate[{asseDiRotazioneTerrestre,equatore,Rotate[{pianoMeridiano,Rotate[ternaBase,lat*Degree,{0,-1,0}]},(tempoNelGiorno+lunghezzaGiorno*stagione/lunghezzaAnno)2Pi/lunghezzaGiorno,{0,0,1}]},inclinazioneAsseTerrestre,direzioneTerra[equinozioPrimavera]]},r*direzioneTerra[stagione]]},PlotLabel->Style[dataEOra[stagione, tempoNelGiorno],White],Background->GrayLevel[.1],PlotRange->4r,ViewAngle->60Degree,ImageSize->600,Boxed->False,ViewVector->{-2r,-2r,r}];
Manipulate[
Which[visione===globale,visioneGlobale[latitudine,mesi,ore],visione===locale,visioneLocale[latitudine,mesi,ore],visione===entrambe,{visioneLocale[latitudine,mesi,ore],visioneGlobale[latitudine,mesi,ore]}],
{{latitudine,45.},-90,90},
Item[Row[{"ora locale",Slider[Dynamic[mesi],{0.,lunghezzaAnno}],SetterBar[Dynamic[mesi],{equinozioPrimavra->"21 marzo",solstizioEstate->"21 giugno",equinozioAutunno->"21 settembre",solstizioInverno->"21 dicembre"}]}]],
{{ore,3./4lunghezzaGiorno},0.,lunghezzaGiorno,lunghezzaGiorno/60.,Animator,AnimationRate->3,DisplayAllSteps->True},
{{visione,globale},{locale,globale,entrambe}}]]

Sistema solare

DynamicModule[{datiPianeti,periodo,asse,raggio,colore,periodoTerra=5,scalaTemporale,orbita,p,sfondoNeroQ,orbiteQ},
datiPianeti=Dataset[{\[LeftAssociation]"nome"->"Mercurio","periodo"->7.6005438`*^6,"asse"->4.60012719`*^10,"raggio"->2.4397`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Venere","periodo"->1.94141491`*^7,"asse"->1.07476002`*^11,"raggio"->6.0519`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Terra","periodo"->3.15581491`*^7,"asse"->1.470980735`*^11,"raggio"->6.37814`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Marte","periodo"->5.93550362`*^7,"asse"->2.066445449`*^11,"raggio"->3.397`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Giove","periodo"->3.74355659`*^8,"asse"->7.40742598`*^11,"raggio"->7.1492`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Saturno","periodo"->9.29292363`*^8,"asse"->1.34946738`*^12,"raggio"->6.0268`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Urano","periodo"->2.65137002`*^9,"asse"->2.735555035`*^12,"raggio"->2.5559`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Nettuno","periodo"->5.20041856`*^9,"asse"->4.4596315`*^12,"raggio"->2.4764`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Plutone","periodo"->7.8237807`*^9,"asse"->4.43682461`*^12,"raggio"->1.195`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Sole","periodo"->0.`,"asse"->0.`,"raggio"->1.3`*^7,"colore"->\[RightAssociation]}];
periodo[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"periodo"];
asse[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"asse"];
raggio[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"raggio"];
colore[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"colore"];scalaTemporale=periodo["Terra"]/periodoTerra;
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]]};
Manipulate[Deploy@Graphics[{{If[sfondoNeroQ,Yellow,Black],PointSize[Medium],Tooltip[Point[{0,0}],"Sole"]},White,Table[{PointSize[.01raggio[p]/raggio["Mercurio"]],colore[p],If[Not@sfondoNeroQ&&p=="Venere",Black,Nothing],If[orbiteQ,{Dashed,Circle[{0,0},asse[p]]}],Tooltip[Point[orbita[p,t]],p]},{p,{"Mercurio","Venere","Terra","Marte"}}]},PlotRange->1.2asse["Marte"],Background->If[sfondoNeroQ,Black,White],ImageSize->500],
Item[Style["Sistema eliocentrico, pianeti interni",30]],{t,0,Infinity,Animator,ControlPlacement->Bottom},{{sfondoNeroQ,True,"colore sfondo"},{True->"nero",False->"bianco"},ControlPlacement->Right},
{{orbiteQ,False,"orbite"},{False,True},ControlPlacement->Right},SaveDefinitions->True]]

DynamicModule[{datiPianeti,periodo,asse,raggio,colore,periodoTerra=5,scalaTemporale,orbita,p,sfondoNeroQ,orbiteQ},
datiPianeti=Dataset[{\[LeftAssociation]"nome"->"Mercurio","periodo"->7.6005438`*^6,"asse"->4.60012719`*^10,"raggio"->2.4397`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Venere","periodo"->1.94141491`*^7,"asse"->1.07476002`*^11,"raggio"->6.0519`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Terra","periodo"->3.15581491`*^7,"asse"->1.470980735`*^11,"raggio"->6.37814`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Marte","periodo"->5.93550362`*^7,"asse"->2.066445449`*^11,"raggio"->3.397`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Giove","periodo"->3.74355659`*^8,"asse"->7.40742598`*^11,"raggio"->7.1492`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Saturno","periodo"->9.29292363`*^8,"asse"->1.34946738`*^12,"raggio"->6.0268`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Urano","periodo"->2.65137002`*^9,"asse"->2.735555035`*^12,"raggio"->2.5559`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Nettuno","periodo"->5.20041856`*^9,"asse"->4.4596315`*^12,"raggio"->2.4764`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Plutone","periodo"->7.8237807`*^9,"asse"->4.43682461`*^12,"raggio"->1.195`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Sole","periodo"->0.`,"asse"->0.`,"raggio"->1.3`*^7,"colore"->\[RightAssociation]}];
periodo[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"periodo"];
asse[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"asse"];
raggio[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"raggio"];
colore[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"colore"];scalaTemporale=periodo["Terra"]/periodoTerra;
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]]};
Manipulate[Deploy@Graphics[{{If[sfondoNeroQ,Yellow,Black],PointSize[Medium],Tooltip[Point[{0,0}],"Sole"]},White,Table[{PointSize[dimensione*.01raggio[p]/raggio["Mercurio"]],colore[p],If[Not@sfondoNeroQ&&MemberQ[{"Venere","Giove","Saturno"},p],Black,Nothing],If[orbiteQ,{Dashed,Circle[{0,0},asse[p]]}],Tooltip[Point[orbita[p,t]],p]},{p,{"Mercurio","Venere","Terra","Marte","Giove","Saturno"}}]},PlotRange->1.2asse["Saturno"],Background->If[sfondoNeroQ,Black,White],ImageSize->500],
Item[Style["Sistema eliocentrico, fino a Saturno",30]],
{t,0,Infinity,Animator,ControlPlacement->Bottom},{{sfondoNeroQ,True,"colore sfondo"},{True->"nero",False->"bianco"},ControlPlacement->Right},
{{orbiteQ,False,"orbite"},{False,True},ControlPlacement->Right},
{{dimensione,1,"dimensione"},0,1,ControlPlacement->Right,ControlType->VerticalSlider},SaveDefinitions->True]]

DynamicModule[{datiPianeti,periodo,asse,raggio,colore,periodoTerra=5,scalaTemporale,orbita,p,sfondoNeroQ,orbiteQ},
datiPianeti=Dataset[{\[LeftAssociation]"nome"->"Mercurio","periodo"->7.6005438`*^6,"asse"->4.60012719`*^10,"raggio"->2.4397`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Venere","periodo"->1.94141491`*^7,"asse"->1.07476002`*^11,"raggio"->6.0519`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Terra","periodo"->3.15581491`*^7,"asse"->1.470980735`*^11,"raggio"->6.37814`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Marte","periodo"->5.93550362`*^7,"asse"->2.066445449`*^11,"raggio"->3.397`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Giove","periodo"->3.74355659`*^8,"asse"->7.40742598`*^11,"raggio"->7.1492`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Saturno","periodo"->9.29292363`*^8,"asse"->1.34946738`*^12,"raggio"->6.0268`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Urano","periodo"->2.65137002`*^9,"asse"->2.735555035`*^12,"raggio"->2.5559`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Nettuno","periodo"->5.20041856`*^9,"asse"->4.4596315`*^12,"raggio"->2.4764`*^7,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Plutone","periodo"->7.8237807`*^9,"asse"->4.43682461`*^12,"raggio"->1.195`*^6,"colore"->\[RightAssociation],\[LeftAssociation]"nome"->"Sole","periodo"->0.`,"asse"->0.`,"raggio"->1.3`*^7,"colore"->\[RightAssociation]}];
periodo[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"periodo"];
asse[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"asse"];
raggio[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"raggio"];
colore[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"colore"];scalaTemporale=periodo["Terra"]/periodoTerra;
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]]};
orbita["Sole",t_]={0,0};
Manipulate[Deploy@Graphics[{Table[{PointSize[.01raggio[p]/raggio["Mercurio"]],colore[p],If[Not@sfondoNeroQ&&MemberQ[{"Venere","Sole"},p],Black,Nothing],
If[Not@proiettatoQ&&mostraCicliEdEpicicli&&riferimento≠p,
If[qualiEpicicli==="centro nel sole"||asse[p]<asse[riferimento],
{Circle[orbita["Sole",t]-orbita[riferimento,t],asse[p]],If[riferimento≠"Sole",{If[sfondoNeroQ,Yellow,Nothing],Circle[orbita["Sole",t],asse[riferimento]]},Nothing]},
{Circle[orbita["Sole",t],asse[p]],Dashed,
If[riferimento≠"Sole",{Circle[orbita[p,t],asse[riferimento]],Line[{orbita[p,t],orbita[p,t]-orbita[riferimento,t]}],If[p=="Marte",{PointSize[.015],Point[orbita[p,t]],If[sfondoNeroQ,Black,White],PointSize[.01],Point[orbita[p,t]]}]},Nothing]}]],Tooltip[Point[If[proiettatoQ,(asse["Marte"]+asse["Terra"])Normalize[#]&,Identity][orbita[p,t]-orbita[riferimento,t]]],p],
If[raggiQ,{Dashing[{.01,.02}],Line[{{0,0},2(asse["Marte"]+asse["Terra"])Normalize[orbita[p,t]-orbita[riferimento,t]]}]},Nothing]},{p,astri}]},PlotRange->1.2(asse["Marte"]+asse["Terra"]),Background->If[sfondoNeroQ,Black,White],ImageSize->500],
Item[Style["Sistema qualunquecentrico, pianeti interni",30]],{t,0,Infinity,Animator,ControlPlacement->Bottom},{{sfondoNeroQ,True,"colore sfondo"},{True->"nero",False->"bianco"},ControlPlacement->Right},
{{astri,{"Sole","Mercurio","Venere","Terra","Marte"},"astri da mostrare"},{"Sole","Mercurio","Venere","Terra","Marte"},CheckboxBar,Appearance->"Vertical",ControlPlacement->Right},
{{riferimento,"Terra","punto di vista"},{"Sole","Mercurio","Venere","Terra","Marte"},Appearance->"Vertical",ControlPlacement->Right},{mostraCicliEdEpicicli,{False,True},ControlPlacement->Right},
{qualiEpicicli,{"centro nel sole","tolemaici"},ControlPlacement->Right},
{{raggiQ,False,"raggi visivi"},{False,True},ControlPlacement->Right},{{proiettatoQ,False,"proiettati"},{False,True},ControlPlacement->Right},
SaveDefinitions->True]]

DynamicModule[{periodoSinodico=104/5,datiPianeti,periodo,asse,raggio,colore,periodoTerra=13,scalaTemporale=1,orbita,p,sfondoNeroQ=True,orbiteQ},
datiPianeti=Dataset[{\[LeftAssociation]"nome"->"Venere","periodo"->8,"asse"->1.07476002`*^11,"raggio"->6.0519`*^6,"colore"->\[RightAssociation],
\[LeftAssociation]"nome"->"Terra","periodo"->13,"asse"->1.470980735`*^11,"raggio"->6.37814`*^6,"colore"->\[RightAssociation],
\[LeftAssociation]"nome"->"Sole","periodo"->0.`,"asse"->0.`,"raggio"->1.3`*^7,"colore"->\[RightAssociation]}];
periodo[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"periodo"];
asse[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"asse"];
raggio[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"raggio"];
colore[nome_String]:=datiPianeti[SelectFirst[#nome==nome&],"colore"];
orbita[pianeta_,t_]:=AngleVector[{asse[pianeta],2π*t/periodo[pianeta]-Pi/2}];
orbita["Sole",t_]={0,0};
Manipulate[With[{t=Clip[t,{0,13*8}]},Graphics[{If[Divisible[t,104/5],{White,Dashed,HalfLine[{{0,0},orbita["Sole",t]-orbita["Terra",t]}]}],
{{Gray,Through[{Line,Point}@Table[AngleVector[{-2asse["Terra"],2π*s/periodo["Terra"]-Pi/2}],{s,periodoSinodico*Range[0,Floor[t/periodoSinodico]]}]]}},Table[{PointSize[.01raggio[p]/raggio["Venere"]],colore[p],If[Not@sfondoNeroQ&&MemberQ[{"Venere","Sole"},p],Black,Nothing],If[orbiteQ,{Dashed,Circle[-orbita["Terra",t],asse[p]]}],Tooltip[Point[orbita[p,t]-orbita["Terra",t]],p]},{p,{"Sole","Venere","Terra"}}]},PlotRange->1.2(2asse["Terra"]),Background->If[sfondoNeroQ,Black,White],ImageSize->500]],
Item[Style["Moto di Venere rispetto alla Terra",30]],
{t,-periodoSinodico*10/200,13*8+2,periodoSinodico/200,ControlPlacement->Bottom,AnimationRate->10,AnimationRunning->True,DisplayAllSteps->True},
{{orbiteQ,False,"orbite"},{False,True},ControlPlacement->Right},SaveDefinitions->True]]

Hppopede

disco=Polygon[Map[Append[0],Join[CirclePoints[40],{First@CirclePoints[40]}]]];
asseRotazione=Arrow[Tube[{{0,0,0},{0,0,1}}]];
meridiano[long_]=Line[Table[RotationMatrix[long,{0,0,1}].RotationMatrix[t,{0,1,0}].{0,0,1},{t,0,Pi/2,Pi/20}]];
Manipulate[Graphics3D[GeometricTransformation[First@Show[Graphics3D[{{Blue,{Opacity[.2],Sphere[],disco},asseRotazione},meridiano[-Pi/2],PointSize[Large],
GeometricTransformation[{
GeometricTransformation[
GeometricTransformation[{Point[{0,-1,0}],{Opacity[.2],Red,disco},Red,asseRotazione},RotationTransform[θ,{0,0,1}]],
RotationTransform[u,{0,1,0}]]},
RotationTransform[-θ,{0,0,1}]]}],ParametricPlot3D[RotationMatrix[-t,{0,0,1}].RotationMatrix[t,RotationMatrix[u,{0,1,0}].{0,0,1}].{0,-1,0},{t,0,4Pi},PlotStyle->Red]],
RotationTransform[0,{0,0,1}]]],{θ,0,2Pi},{{u,Pi/6},0,Pi/2},SaveDefinitions->True]

disco=Polygon[Map[Append[0],Join[CirclePoints[40],{First@CirclePoints[40]}]]];
asseRotazione=Arrow[Tube[{{0,0,0},{0,0,1}}]];
meridiano[long_]=Line[Table[RotationMatrix[long,{0,0,1}].RotationMatrix[t,{0,1,0}].{0,0,1},{t,0,Pi/2,Pi/20}]];
Manipulate[Graphics3D[GeometricTransformation[First@Show[Graphics3D[{{Blue,{Opacity[.2],Sphere[],disco},asseRotazione},meridiano[-Pi/2],PointSize[Large],
GeometricTransformation[{
GeometricTransformation[
GeometricTransformation[{Point[{0,-1,0}],{Opacity[.2],Red,disco},Red,asseRotazione},RotationTransform[θ,{0,0,1}]],
RotationTransform[u,{0,1,0}]]},
RotationTransform[-θ,{0,0,1}]]}],ParametricPlot3D[RotationMatrix[-t,{0,0,1}].RotationMatrix[t,RotationMatrix[u,{0,1,0}].{0,0,1}].{0,-1,0},{t,0,4Pi},PlotStyle->Red]],
RotationTransform[θ,{0,0,1}]]],
{θ,0,2Pi},{{u,Pi/6},0,Pi/2},SaveDefinitions->True]

Precessione degli equinozi

Il nautilus come spirale logaritmica

nautilus=;
Manipulate[ParametricPlot[p+r{(E^(λ t))Cos[ω t],(E^(λ t))Sin[ω t]},{t,-4Pi,8Pi},PlotStyle->Directive[Thick,Red],Prolog->First@nautilus,PlotRange->Transpose@nautilus[[1,-3]],Ticks->None,Axes->None],
Item[Style["Il nautilus come spirale logaritmica",Large]],{{p,{100,150}},Locator},{{λ,1},.1,2},{{r,1},0,2},{{ω,1},.1,5}]

Esempio interattivo: zoom dentro un grafico

Clear[f,t,x];
Manipulate[f[t_]=(t^2);
y0=f[x0];
gr=1;
GraphicsRow[{Plot[f[t],{t,-2,2},Prolog->{{Yellow,Rectangle[{x0-z,y0-gr*z},{x0+z,y0+gr*z}]}},Epilog->{Point[{x0,y0}],Line[{{x0-z,y0-gr*z},{x0-z,y0+gr*z},{x0+z,y0+gr*z},{x0+z,y0-gr*z},{x0-z,y0-gr*z}}],Red,Text[(Subscript[x, 0]),{x0,0},{0,-1}]},AspectRatio->Automatic,ImageSize->200],
Plot[f[t],{t,x0-z,x0+z},Prolog->{{Yellow,Rectangle[{x0-z,y0-gr*z},{x0+z,y0+gr*z}]}},Epilog->{Point[{x0,y0}]},Frame->True,ImagePadding->20,PlotRange->{{x0-z,x0+z},{y0-gr*z,y0+gr*z}},AspectRatio->Automatic,Axes->False,ImageSize->200]}],
{{x0,1,(Subscript[x, 0])},-2,2},
{{z,1,"zoom"},0.01,1},
TrackedSymbols:>{x0,z}]

Si può usare questo pannello per introdurre il concetto di derivata.

Animazione di un moto browniano

Un'animazione di un moto browniano nel piano:

brown={0,0};
Framed@Graphics[Point[Dynamic[brown+=RandomReal[NormalDistribution[0,1/300],2]]],PlotRange->1]

Un moto browniano con segnata la traiettoria:

brown={1,1}/2;
recentTraj={brown};oldTrajs={};
Dynamic[increment=Table[RandomReal[NormalDistribution[0,1/300]],{2}];
nextBrown=Mod[brown+increment,1];
If[nextBrown===brown+increment,
AppendTo[recentTraj,nextBrown],
AppendTo[oldTrajs,recentTraj];recentTraj={nextBrown}];
brown=nextBrown;
Graphics[{{GrayLevel[.5],Map[Line,oldTrajs],Line@recentTraj},Point[brown]},PlotRange->{{0,1},{0,1}},Frame->True,FrameTicks->None,PlotLabel->"Moto browniano"]]

Animazione di una crescita malthusiana

Un batterio che si muove di moto browniano, e che a ogni istante ha una certa probabilità di riprodursi:

batteri={{0.,0.}};
riproduci[0,punto_]=punto;
riproduci[1,punto_]:=Sequence@@{punto,punto};
generazione[pts_,prob_]:=(estrazioni=RandomInteger[BinomialDistribution[1,prob],Length@pts];
MapThread[riproduci,{estrazioni,pts}]);
scostamento[l_]:=RandomReal[NormalDistribution[0,1/100],{l,2}];
Dynamic[
Framed@Graphics[Point[batteri=generazione[batteri,1/50];batteri+=scostamento[Length@batteri]],
PlotRange->1,PlotLabel->Row[{"popolazione: ",Length@batteri}]]]

Il batterio malthusiano con il grafico dell'andamento della popolazione:

DynamicModule[{batteri={{0.,0.}},storia},
storia={Length[batteri]};
Dynamic[
Row[{Graphics[Point[batteri=generazione[batteri,1/50];AppendTo[storia,Length@batteri];batteri+=scostamento[Length@batteri]],
PlotRange->1,PlotLabel->Row[{"popolazione: ",Length@batteri}],ImageSize->200,Frame->True,FrameTicks->None],
ListPlot[storia,AspectRatio->1,ImageSize->200,ImageMargins->15,Frame->True,Axes->False,FrameLabel->{"tempo","popolazione",None,None}]}]]]

Un'animazione come questa può illustrare il concetto di "crescita esponenziale".

Simulazione di un sistema predatore-preda

Clear[accadimentoSingoloPredatore,generazionePredatori,accadimentoSingolaPreda,generazionePrede,scostamento];
accadimentoSingoloPredatore[distanzaPredaPiuVicina_,singoloPredatore_,opts___Rule]:=
(Sequence@@RandomChoice[({Min[probabilitaInterazione/(distanzaPredaPiuVicina^2),2/3],probabilitaMortePerFamePredatore,1-Min[probabilitaInterazione/(distanzaPredaPiuVicina^2),2/3]-probabilitaMortePerFamePredatore}/.{opts}/.Options[LotkaVolterra])->{{singoloPredatore,singoloPredatore},{},{singoloPredatore}}]);
accadimentoSingoloPredatore[Infinity,singoloPredatore_,opts___Rule]:=Sequence@@RandomChoice[({probabilitaMortePerFamePredatore,1-probabilitaMortePerFamePredatore}/.{opts}/.Options[LotkaVolterra])->{{},{singoloPredatore}}];
ricopiaNeiQuadratiVicini[popolazione_]:=Join[popolazione,Map[#+{2,2}&,popolazione],Map[#+{2,0}&,popolazione],Map[#+{2,-2}&,popolazione],Map[#+{0,2}&,popolazione],Map[#+{0,-2}&,popolazione],Map[#+{-2,2}&,popolazione],Map[#+{-2,0}&,popolazione],Map[#+{-2,-2}&,popolazione]];
generazionePredatori[ptsPredatori_,ptsPrede_/;Length[ptsPrede]>0,opts___Rule]:=Module[{distInterazione,funzionePredaPiuVicina,listaDistanzeDallaPredaPiuVicina,accad},
funzionePredaPiuVicina=Nearest[ricopiaNeiQuadratiVicini@ptsPrede];
listaDistanzeDallaPredaPiuVicina:=Table[EuclideanDistance[First@funzionePredaPiuVicina[pt],pt],{pt,ptsPredatori}];
accad[distanzaPredaPiuVicina_,singoloPredatore_]:=accadimentoSingoloPredatore[distanzaPredaPiuVicina,singoloPredatore,opts];
MapThread[accad,{listaDistanzeDallaPredaPiuVicina,ptsPredatori}]];
generazionePredatori[ptsPredatori_,{},opts___]:=Table[accadimentoSingoloPredatore[Infinity,pt,opts],{pt,ptsPredatori}];


accadimentoSingolaPreda[distanzaPredatorePiuVicino_,singolaPreda_,opts___Rule]:=(Sequence@@RandomChoice[({Min[probabilitaInterazione/(distanzaPredatorePiuVicino^2),2/3],probabilitaRiproduzionePreda,1-Min[probabilitaInterazione/(distanzaPredatorePiuVicino^2),2/3]-probabilitaRiproduzionePreda}/.{opts}/.Options[LotkaVolterra])->{{},{singolaPreda,singolaPreda},{singolaPreda}}]);
accadimentoSingolaPreda[Infinity,singolaPreda_,opts___Rule]:=Sequence@@RandomChoice[({probabilitaRiproduzionePreda,1-probabilitaRiproduzionePreda}/.{opts}/.Options[LotkaVolterra])->{{singolaPreda,singolaPreda},{singolaPreda}}];
generazionePrede[ptsPredatori_/;Length[ptsPredatori]>0,ptsPrede_,opts___Rule]:=Module[{distInterazione,funzionePredatorePiuVicino,listaDistanzeDaiPredatoriPiuVicini,accad},funzionePredatorePiuVicino=Nearest[ricopiaNeiQuadratiVicini@ptsPredatori];
listaDistanzeDaiPredatoriPiuVicini:=Table[EuclideanDistance[First@funzionePredatorePiuVicino[pt],pt],{pt,ptsPrede}];
accad[distanzaPredatorePiuVicino_,singolaPreda_]:=accadimentoSingolaPreda[distanzaPredatorePiuVicino,singolaPreda,opts];
MapThread[accadimentoSingolaPreda,{listaDistanzeDaiPredatoriPiuVicini,ptsPrede}]];
generazionePrede[{},ptsPrede_,opts___Rule]:=Table[accadimentoSingolaPreda[Infinity,pt,opts],{pt,ptsPrede}];
scostamento[l_,opts___Rule]:=RandomReal[NormalDistribution[0,parametroMobilita/.{opts}/.Options[LotkaVolterra]],{l,2}];

istogrammaPopolazioni:=({storicoPredatori,storicoPrede}={{numeroPredatoriIniziali},{numeroPredeIniziali}};
predatori=RandomReal[{-1,1},{numeroPredatoriIniziali,2}];
prede=RandomReal[{-1,1},{numeroPredeIniziali,2}];
Dynamic[prede0=prede;predatori0=predatori;
predatori=generazionePredatori[predatori0,prede0];
prede=generazionePrede[predatori0,prede0];
If[Length@predatori*Length@prede>0,AppendTo[storicoPredatori,Length@predatori];
AppendTo[storicoPrede,Length@prede]];
predatori+=scostamento[Length@predatori];
prede+=scostamento[Length@prede];
predatori=Mod[predatori,2,-1];
prede=Mod[prede,2,-1];
Column[{Grid[{{"predatori: ",Length@predatori},{Style["prede: ",Red],Style[Length@prede,Red]}},Alignment->Right],
ListPlot[{storicoPredatori,storicoPrede},ImageSize->300,PlotRange->{0,Max[storicoPredatori,storicoPrede]},AspectRatio->1,PlotStyle->{Black,Red},Frame->True]}]]);

animazioneEIstogramma:=({storicoPredatori,storicoPrede}={{numeroPredatoriIniziali},{numeroPredeIniziali}};
predatori=RandomReal[{-1,1},{numeroPredatoriIniziali,2}];
prede=RandomReal[{-1,1},{numeroPredeIniziali,2}];
Dynamic[prede0=prede;predatori0=predatori;
predatori=generazionePredatori[predatori0,prede0];
prede=generazionePrede[predatori0,prede0];
If[Length@predatori*Length@prede>0,AppendTo[storicoPredatori,Length@predatori];
AppendTo[storicoPrede,Length@prede]];
predatori+=scostamento[Length@predatori];
prede+=scostamento[Length@prede];
predatori=Mod[predatori,2,-1];
prede=Mod[prede,2,-1];
Row[{Framed@Graphics[{{Red,PointSize[Medium],Point[prede]},
{Black,Table[Text[🐺,pt],{pt,predatori}]}},
PlotRange->1,PlotLabel->Grid[{{"predatori: ",Length@predatori},{Style["prede: ",Red],Style[Length@prede,Red]}},Alignment->Right],ImageSize->300],
ListPlot[{storicoPredatori,storicoPrede},ImageSize->300,PlotRange->{0,Max[storicoPredatori,storicoPrede]},AspectRatio->1,PlotStyle->{Black,Red},Frame->True]}]]);

istogrammaFinale:=ListPlot[{storicoPredatori,storicoPrede},ImageSize->300,PlotRange->{0,Max[storicoPredatori,storicoPrede]},AspectRatio->1,PlotStyle->{Black,Red},Frame->True]

numeroPredatoriIniziali=20;
numeroPredeIniziali=300;
SeedRandom[0];
Options[LotkaVolterra]={
probabilitaInterazione->1/10,
probabilitaMortePerFamePredatore->1/5,
probabilitaRiproduzionePreda->1/5,
parametroMobilita->1/20};

animazioneEIstogramma

Il concetto di funzione

Clear[f];
effe[x_]=(x^2);
Manipulate[
ics=p[[1]];
Graphics[{Line[{{-2,1},{4,1}}],Line[{{-2,0},{4,0}}],{Red,Arrow[{{ics,1},{effe[ics],0}}],Text[If[numQ,ics,x],{ics,1},{0,-1}],Text[If[numQ,effe[ics],f[x]],{effe@ics,0},{0,1}]},GrayLevel[.5],Text[dominio,{-2,1},{-1,1.2}],Text[codominio,{-2,0},{-1,-1.2}],Point[Dynamic[{ics,1}]]},AspectRatio->1/2,Frame->{True,False,True,False},FrameTicks->{Automatic,None,Automatic,None},PlotRange->{{-2.2,4.2},{-.5,1.5}}],
{{p,{0,1}},Locator,Appearance->None},
{{numQ,False,"valori numerici?"},{False,True},ControlPlacement->Bottom}]

I punti del codominio possono essere raggiunti da zero, uno o più punti del dominio:

effe[x_]=(x^2);
Manipulate[
ipsilon=p[[1]];
sol=Union@Select[x/.Solve[effe[x]==ipsilon,x],Chop[Im[#]]==0&];Graphics[{Line[{{-2,1},{4,1}}],Line[{{-2,0},{4,0}}],
{Red,If[Not[sol==={}],MapIndexed[{Arrow[{{#1,1},{effe[#1],0}}],Text[(Subscript[x, Sequence@@#2]),{#1,1},{0,-1}]}&,sol],{}],Text[y,{ipsilon,0},{0,1}]},GrayLevel[.5],Text[dominio,{-2,1},{-1,1.2}],Text[codominio,{-2,0},{-1,-1.2}],Point[Dynamic[{ipsilon,0}]]},AspectRatio->1/2,Frame->{True,False,True,False},FrameTicks->{Automatic,None,Automatic,None},PlotRange->{{-2.2,4.2},{-.5,1.5}}],
{{p,{0,-.2}},Locator,Appearance->None}]

Con un grafico cartesiano:

effe[x_]=(x^2);
graf=Plot[effe[x],{x,-2,2}][[1]];
Manipulate[ics=p[[1]];
Graphics[{graf,{Red,If[Norm[{ics,effe[ics]}]>1/50,Arrow[{{ics,0},{ics,effe[ics]},{0,effe[ics]}}],{}],Text[If[numQ,ics,x],{ics,0},{0,1}],Text[If[numQ,effe[ics],f[x]],{0,effe@ics},{Sign[ics],0}]}},AspectRatio->1/GoldenRatio,Axes->True,PlotRange->{{-2.2,2.2},{-.5,4}}],
{{p,{-1,1}},Locator,Appearance->None},
{{numQ,False,"valori numerici?"},{False,True},ControlPlacement->Bottom}]

Funzioni trigonometriche

Un pannello per illustrare il significato di seno e coseno:

Manipulate[
Graphics[{Circle[{0,0},1],{Thickness[.01],Circle[{0,0},1,If[ics≥0,{0,t ics},{t ics,0}]],Line[{{Cos[t ics],Sin[t ics]},{Cos[t ics],Sin[t ics]}+{-Sin[t ics],Cos[t ics]}(1-t)ics}]},
Text[1,{1,0},{-1.5,1}],Text[-1,{-1,0},{1.2,1}],If[t<.05,Text[x,{1,ics},{-2,0}],Sequence@@{}],If[t>.95,{Red,Line[{{Cos[ics],0},{Cos[ics],Sin[ics]},{0,Sin[ics]}}],Point[{Cos[ics],0}],Point[{0,Sin[ics]}],Text[Cos[x],{Cos[ics],0},If[Sin[ics]≥0,{1,0},{-1,0}],{0,1}],Text[Sin[x],{0,Sin[ics]},If[Cos[ics]≥0,{1,0},{-1,0}]]},Sequence@@{}]},PlotRange->Max[1.1,Abs[ics]+.2],Axes->True,Ticks->None],
{{ics,1,x},-3π,3π},
{{t,0,animazione},0,1}]

Un pannello per illustrare il significato della tangente:

Manipulate[
Graphics[{Circle[{0,0},1],{Thickness[.01],Circle[{0,0},1,If[ics≥0,{0,t ics},{t ics,0}]],Line[{{Cos[t ics],Sin[t ics]},{Cos[t ics],Sin[t ics]}+{-Sin[t ics],Cos[t ics]}(1-t)ics}]},
Text[1,{1,0},{-1.5,1}],Text[-1,{-1,0},{1.2,1}],If[t<.05,Text[x,{1,ics},{-2,0}],Sequence@@{}],If[t>.95,{Line[{{0,0},{1,Tan[ics]},{Cos[ics],Sin[ics]}}],Red,Line[{{1,0},{1,Tan[ics]}}],Point[{1,Tan[ics]}],Text[Tan[x],{1,Tan[ics]},{-2,0}]},Sequence@@{}]},PlotRange->Min[Max[1.1,Abs[ics],Tan[ics]],4]+.2,Axes->True,Ticks->None],
{{ics,1,x},-3π,3π},
{{t,0,animazione},0,1}]

Moto circolare e funzioni trigonometriche:

Manipulate[
Graphics[{Circle[{0,0},1],{Thickness[.005],Circle[{0,0},1,If[ics≥0,{0,ics},{ics,0}]]},PointSize[.02],Point[{Cos[ics],Sin[ics]}],
If[sinQ==True,{Red,Line[{{Cos[ics],Sin[ics]},{0,Sin[ics]}}],Thickness[.005],Line[{{0,0},{0,Sin[ics]}}],Point[{0,Sin[ics]}],Text[Sin[x],{0,Sin[ics]},If[Cos[ics]≥0,{1.5,0},{-1.5,0}]]},Sequence@@{}],
If[cosQ==True,{Red,Line[{{Cos[ics],0},{Cos[ics],Sin[ics]}}],Thickness[.005],Line[{{0,0},{Cos[ics],0}}],Point[{Cos[ics],0}],Text[Cos[x],{Cos[ics],0},If[Sin[ics]≥0,{1.5,0},{-1.5,0}],{0,1}]},Sequence@@{}]},Axes->True,Ticks->None,PlotRange->1.1],
{{ics,0,x},-2Pi,2Pi},
{{sinQ,False,"sen"},{False,True}},{{cosQ,False,"cos"},{False,True}}]

Parametri della distribuzione di probabilità normale

Dato l'istogramma di un campione estratto da una variabile aleatoria normale con media e varianza incogniti, indovinare i parametri agendo sul grafico:

graficoDensita[μ_,σ_,opts___Rule]:=Plot[Evaluate[PDF[NormalDistribution[μ,σ]][x]],{x,-3,3},PlotRange->All,opts];
mioFormato[x_?NumericQ]:=NumberForm[N[x],{3,2},NumberSigns->{"-","+"},NumberPadding->{"","0"}];
Manipulate[
{μ0,σ0}=parametri;
dati=RandomReal[SeedRandom[1];NormalDistribution@@parametri,quantiDati];
hist[dt_]:=Histogram[dt,Automatic,"PDF"];
Show[{hist[dati],graficoDensita[μ,σ],If[risposteQ,graficoDensita[μ0,σ0,PlotStyle->{Red,Opacity[.5]},PlotRange->All],Nothing]},PlotLabel->DisplayForm[GridBox[{{RowBox[{"media sorgente","==",Style[mioFormato[μ0],FontColor->If[risposteQ==True,Black,White]]}],RowBox[{"σ sorgente","==",Style[mioFormato[σ0],FontColor->If[risposteQ==True,Black,White]]}]},{RowBox[{"media stimata","==",mioFormato[μ]}],RowBox[{"σ stimata","==",mioFormato[σ]}]}},
ColumnAlignments->"=="]],PlotRange->All],
{{parametri,{0,1}},Button["Nuovo campione",{μ0,σ0}=parametri=(SeedRandom[];{RandomReal[{-1,1}],RandomReal[{.2,1}]});dati=RandomReal[SeedRandom[1];NormalDistribution@@parametri,quantiDati];risposteQ=False]&},
{{quantiDati,100,"quanti dati"},{10,50,100,500,1000},ControlType->PopupMenu},
{{μ,0,"stima μ"},-3,3},
{{σ,1,"stima σ"},0,3},
{{risposteQ,False,"Mostra le risposte"},{False,True}},
TrackedSymbols:>{μ,σ,risposteQ,parametri}]

Grafici gommosi

Manipulate[
Plot[Interpolation[{{0,p1[[2]]},p2,p3,{3,p4[[2]]}}][t],{t,0,3},PlotRange->{{0,3},{0,4}}],
{{p1,{0,1}},Locator},
{{p2,{1,2}},Locator},
{{p3,{2,1}},Locator},
{{p4,{3,2}},Locator}]

Illustrazione del teorema di Rolle:

Needs["Ersek`RootSearch`"];
Manipulate[
effe=Interpolation[{{0,p1[[2]]},p2,p3,p4,{4,p1[[2]]}},InterpolationOrder->4];
staz=Ersek`RootSearch`RootSearch[effe'[x]==0,{x,0,4}];
Plot[effe[t],{t,0,4},PlotRange->{{0,4},{-1,4}},
Epilog->{{Dashing[{.01,.01}],Line[{{0,p1[[2]]},{4,p1[[2]]}}]},{Red,PointSize[.02],{Point[{x,effe[x]}],Line[{{x-.2,effe[x]},{x+.2,effe[x]}}]}/.staz}},
PlotLabel->"Teorema di Rolle"],
{{p1,{0,1}},Locator},
{{p2,{1,2}},Locator},
{{p3,{2,1}},Locator},
{{p4,{3,2}},Locator}]

Illustrazione del teorema del valor medio di Lagrange:

Manipulate[
effe=Interpolation[{{0,p1[[2]]},p2,p3,p4,{4,p5[[2]]}},InterpolationOrder->4];
pendenza=((p5[[2]]-p1[[2]])/4);
staz=RootSearch[effe'[x]==pendenza,{x,0,4}];
Plot[effe[t],{t,0,4},PlotRange->{{0,4},{-1,4}},
Epilog->{{Dashing[{.01,.01}],Line[{{0,p1[[2]]},{4,p5[[2]]}}]},{Red,PointSize[.02],{Point[{x,effe[x]}],Line[{{x-.2,effe[x]-.2pendenza},{x+.2,effe[x]+.2pendenza}}]}/.staz}},
PlotLabel->"Teorema di Lagrange"],
{{p1,{0,1}},Locator},
{{p2,{1,2}},Locator},
{{p3,{2,1}},Locator},
{{p4,{3,2}},Locator},
{{p5,{4,3}},Locator}]

Individuazione visiva di massimi, minimi, flessi:

Clear[effe,staz,puntiStaz,flessi];
Manipulate[
effe=Interpolation[{{0,p1[[2]]},p2,p3,p4,{4,p5[[2]]}},InterpolationOrder->4];
staz=Ersek`RootSearch`RootSearch[effe'[x]==0,{x,0,4}];
puntiStaz=If[staz=={},{},{{Point[{x,effe[x]}],Line[{{x-.3,effe[x]-.3effe'[x]},{x+.3,effe[x]+.3effe'[x]}}],
Text[If[effe''[x]>0,"min loc","max loc"],{x,effe[x]},If[effe''[x]>0,{0,1},{0,-1}]]}/.staz}];
flessi=Ersek`RootSearch`RootSearch[effe''[x]==0,{x,0,4}];
puntiDiFlesso=If[flessi=={},{},{{Text["flesso",{x,effe[x]},{0,-1},{1,effe'[x]}],Point[{x,effe[x]}],Line[{{x-1,effe[x]-1effe'[x]},{x+1,effe[x]+1effe'[x]}}]}/.flessi}];
ordineValore=Sort[Map[{#,effe[#]}&,Join[If[staz=={},{},x/.staz],{0,4}]],#1[[2]]<#2[[2]]&];
valoriEstremi={Point[ordineValore[[1]]],Text["min glob",ordineValore[[1]],{0,3}],Point[ordineValore[[-1]]],Text["max glob",ordineValore[[-1]],{0,-3}]};
estremiDominio={Point[{0,p1[[2]]}],Text[If[effe'[0]>0,"min loc","max loc"],{0,p1[[2]]},{1.5,0}],
Point[{4,p5[[2]]}],Text[If[effe'[4]<0,"min loc","max loc"],{4,p5[[2]]},{-1.5,0}]};
Plot[effe[t],{t,0,4},PlotRange->{{-.6,4.6},{-1,4}},PlotStyle->Thickness[.005],
Epilog->If[risposteQ==False,{},{Red,PointSize[.02],puntiStaz,puntiDiFlesso,valoriEstremi,estremiDominio}],AspectRatio->Automatic,PlotLabel->"Massimi, minimi, flessi"],
{{p1,{0,1}},Locator,Appearance->None},
{{p2,{1,2}},Locator},
{{p3,{2,1}},Locator},
{{p4,{3,2}},Locator},
{{p5,{4,3}},Locator},
{{risposteQ,False,"Mostra i punti"},{False,True}}]

Legge dei grandi numeri

Una variabile casuale:

f[x_]:=(x^4)-2(x^2)+x;
{cmin,cmax,inutile}=N[f[x]/.Solve[f'[x]==0]]//Chop;
casuale:=f[RandomReal[]];

Dieci estrazioni indipendenti della variabile:

Table[casuale,{10}]

Approssimazioni successive della distribuzione di probabilità:

Manipulate[Histogram[Table[casuale,{n}]],
{n,(10^(Range[6]))}]

Media aritmetica di 10 estrazioni:

Mean[Table[casuale,{10}]]

Andamento delle medie aritmetiche al crescere del numero di estrazioni:

With[{nmax=1000},
estrazioni=Table[casuale,{nmax}];
ListPlot[Table[Mean[Take[estrazioni,n]],{n,nmax}],Joined->True]]

Approssimazioni successive della distribuzione delle medie aritmetiche:

Manipulate[Show[Histogram[Map[Mean,Table[casuale,{m},{n}]]],PlotRange->{{cmin,cmax},All},Ticks->Automatic,AxesOrigin->{0,0}],
{{n,10,"numero di estrazioni su cui fare le medie"},(10^(Range[0,4]))},
{{m,10,"quante volte fare la media"},(10^(Range[4]))}]

Videogioco della definizione di limite con ϵ e δ

Clear[ϵ,δ,x,tiro,tabellone,lineeBase,lineaDelta,datiPartenza,porta];With[{larghezzaBase=2,quotaBase=0,quotaPorta=1,altezzaPorta=.3,maglia=10,x0=1,del0=.3,sfondo=Nest[Lighter,Green,4]},
DynamicModule[{foro,effe,y0,formatoNumeri,tabellone,tiro,lineeBase,lineaDelta,datiPartenza,porta,rng,p={x0+del0,quotaBase},vinceDifensoreQ,vinceAttaccanteQ,trovaTiroFuori,tiroFuori},
foro[x_,y_,r_:.05]:={PointSize[r],Point[{x,y}],PointSize[2r/3],White,Point[{x,y}]};
effe[x_]=(x^2);
y0=effe@x0;
formatoNumeri[t_]:=NumberForm[N@t,{4,3},NumberPadding->{"","0"}];
rng={{x0-larghezzaBase-.5,x0+larghezzaBase+.5},{quotaBase-.5,quotaPorta+1.5}};
lineeBase={Tooltip[Line[{{x0-larghezzaBase,quotaBase},{x0+larghezzaBase,quotaBase}}],"linea di tiro"],Tooltip[Line[{{y0-larghezzaBase,quotaPorta},{y0+larghezzaBase,quotaPorta}}],"linea di fondo"],
Tooltip[{foro[x0,quotaBase,.025],Text["(Subscript[x, 0])",{x0,quotaBase},{0,-2}]},Column[{"il dischetto","del rigore"},Center]],
Tooltip[{PointSize[.025],Point[{y0,quotaPorta}],Text["ℓ",{y0,quotaPorta},{0,-2}]},Column[{"il bersaglio","centro della porta"},Center]]};
datiPartenza=Text[Labeled[Column[{Tooltip["f(x) == (x^2)","la funzione data"],Tooltip[DisplayForm@RowBox[{"(Subscript[x, 0])","==",x0}],"il dischetto del rigore"],Tooltip[DisplayForm@RowBox[{"ℓ","==",y0}],"il bersaglio, il centro della porta"]},Alignment->"==",Background->Yellow,Frame->True],"Assegnati:",Top],Scaled[{1,1}],{1,1}];
lineaDelta[d_]:={Thick,{Blue,Tooltip[Line[{{x0-d,quotaBase},{x0+d,quotaBase}}],Column[{"zona di tiro;","dimensiona dall'attaccante","col cursore δ"},Center]]},Tooltip[Text["(Subscript[x, 0])-δ",{x0-d,quotaBase},{1.2,1.2},{1,1}],Column[{"estremo sinistro della zona di tiro;","mossa dall'attaccante","col cursore δ"},Center]],
Tooltip[Text["(Subscript[x, 0])+δ",{x0+d,quotaBase},{-1.2,1.2},{1,-1}],Column[{"estremo destro della zona di tiro;","mossa dall'attaccante","col cursore δ"},Center]]};
porta[e_]:={{GrayLevel[.8],Tooltip[Rectangle[{x0-e,quotaPorta},{x0+e,quotaPorta+altezzaPorta}],Column[{"la porta","dimensionata dal difensore","col cursore ϵ"},Center]]},{Thick,Line[{{y0-e,quotaPorta},{y0+e,quotaPorta}}]},Line[{{x0-e,quotaPorta},{x0+e,quotaPorta},{x0+e,quotaPorta+altezzaPorta},{x0-e,quotaPorta+altezzaPorta},{x0-e,quotaPorta}}],
Tooltip[Text["ℓ-ϵ",{y0-e,quotaPorta},{1.8,-1.0},{1,-1}],Column[{"palo sinistro della porta;","mossa dal difensore","col cursore ϵ"},Center]],
Tooltip[Text["ℓ+ϵ",{y0+e,quotaPorta},{-1.8,-1.0},{1,1}],Column[{"palo destro della porta;","mossa dal difensore","col cursore ϵ"},Center]]};
vinceDifensoreQ[e_,d_]:=Module[{rdel=Rationalize[d,0],reps=Rationalize[e,0]},
TrueQ@Reduce[Evaluate@Exists[t,-rdel≤t-x0≤rdel,Not[-reps≤effe[t]-y0≤reps]],Reals]];vinceAttaccanteQ[e_,d_]:=Module[{rdel=Rationalize[d,0],reps=Rationalize[e,0],t},Reduce[Evaluate@ForAll[t,-rdel≤t-x0≤rdel,-reps≤effe[t]-y0≤reps],Reals]];
trovaTiroFuori[e_,d_]:=Module[{rdel=Rationalize[d,0],reps=Rationalize[e,0],t},
Last@SortBy[t/.FindInstance[-rdel≤t-x0≤rdel&&Not[-reps≤effe[t]-y0≤reps],t,Reals,10],Abs]];tabellone[e_,fas_,d_,x_]:=Text[Column[{Tooltip[Style[ϵ,Red]==formatoNumeri@e,"scelta dal difensore"],If[MemberQ[{"Sceglie l'attaccante","Tiri","Vincitore"},fas],Tooltip[Style[δ,Blue]==formatoNumeri@d,"scelta dall'attaccante"],Sequence@@{}],If[MemberQ[{"Tiri","Vincitore"},fas],Sequence@@{Tooltip[DisplayForm@RowBox[{"x","==",formatoNumeri@x}],"posizione di tiro in questo istante"],Tooltip[DisplayForm@RowBox[{"In porta?",If[Abs[effe@x-y0]≤e,Style["Sì",Blue,FontFamily->"Courier"],Style["No",Red]]}],Column[{"il tiro va  in porta","in questo istante?"},Center]]},Sequence@@{}],
If[fas==="Vincitore",
If[vinceAttaccanteQ[e,d],Tooltip[Style["Vince l'attaccante",Blue],Column[{"tutti i tiri dell'attaccante","sono in porta;","l'attaccante vince la partita"},Center]],Tooltip[Style["Vince il difensore",Red],Column[{"l'attaccante manda almeno un tiro","fuori porta;","il difensore vince la partita"},Center]]],
Nothing]},Background->Yellow,Frame->True],Scaled[{0,1}],{-1,1}];
tiro[p_,d_]:={Tooltip[Text["x",p,{0,2.5}],Column[{"posizione di tiro","in questo istante.","Spostarla col mouse"},Center]],Tooltip[{Text["f(x)",{effe@p[[1]],quotaPorta},{1.5If[TrueQ[effe[p[[1]]]≤p[[1]]],1,-1],2},Background->Directive[sfondo,Opacity[1]]],Point[{effe[p[[1]]],quotaPorta}]},Column[{"punto colpito dal tiro","in questo istante"},Center]],
Tooltip[Arrow[{p,{effe[p[[1]]],quotaPorta}}],Column[{"traiettoria del tiro","in questo istante"},Center]]};
tiroFuori[x_]:={Red,Tooltip[Text["x",{x,0},{0,2.5}],Style[Column[{"posizione di un tiro","che finisce fuori porta"},Center],Red]],Tooltip[{Text["f(x)",{effe[x],quotaPorta},{1.5If[TrueQ[effe[x]≤x],1,-1],2},Background->Directive[sfondo,Opacity[1]]],Point[{effe[x],quotaPorta}]},Style[Column[{"punto colpito da un tiro","fuori porta"},Center],Red]],
Tooltip[Arrow[{{x,quotaBase},{effe[x],quotaPorta}}],Style[Column[{"traiettoria di un tiro","fuori porta"},Center],Red]]};
Manipulate[
Deploy@Graphics[{Locator@If[automaticoQ,Dynamic[p={Rescale[Abs[Clock[{0,1,1/50},10]-1/2],{0,1/2},If[MemberQ[{"Sceglie l'attaccante","Tiri","Vincitore"},fase],{x0-del,x0+del},{x0-larghezzaBase,x0+larghezzaBase}]],0}],Dynamic[p,(p={If[MemberQ[{"Preliminare","Sceglie il difensore"},fase],First@#,Clip[First@#,{x0-del,x0+del}]],0})&]],Which[fase==="Preliminare",{datiPartenza,lineeBase,tiro[p,del]},
fase==="Sceglie il difensore",{Dynamic@tabellone[eps,fase,del,p[[1]]],porta[eps],lineeBase/.Tooltip[a_,__]:>a,datiPartenza,Dynamic@tiro[p,del]},
fase==="Vincitore",{datiPartenza,lineaDelta[del],porta[eps],lineeBase/.Tooltip[a_,__]:>a,tiro[p,del],tabellone[eps,fase,del,p[[1]]],
If[vinceDifensoreQ[eps,del],tiroFuori[trovaTiroFuori[eps,del]]]},
True,{datiPartenza,lineaDelta[del],porta[eps],lineeBase/.Tooltip[a_,__]:>a,tiro[p,del],tabellone[eps,fase,del,p[[1]]]}]},
PlotRange->rng,Background->sfondo,Frame->{True,False,True,False},FrameTicks->{Automatic,None,Automatic,None},ImageSize->Large],
{{fase,"Preliminare","fase di gioco:"},{"Preliminare"->Tooltip["Preliminare",Column[{"si presentano bersaglio","e dischetto del rigore,","e si fa pratica di tiro","con la funzione f"},Center]],"Sceglie il difensore"->Tooltip[Style["Sceglie il difensore",Red],Column[{"il difensore sceglie ϵ","la semiampiezza della porta"},Center]],"Sceglie l'attaccante"->Tooltip[Style["Sceglie l'attaccante",Blue],Column[{"l'attaccante sceglie δ","la semiampiezza della zona di tiro","basandosi sulla dimensione della porta"},Center]],"Tiri"->Tooltip["Tiri",Column[{"l'attaccante","tira tutti i rigori possibili","dalla zona di tiro","che ha scelto"},Center]],"Vincitore"->Tooltip["Vincitore",Column[{"si proclama il vincitore","della partita"},Center]]}},Spacer[20],
{{eps,1.,Tooltip[Row[{"scelta dal difensore: ",Style[ϵ,Large,Red]}],Column[{"epsilon","semiampiezza della porta"},Center]]},0,1},
{{del,1.5,Tooltip[Row[{"scelta dall'attaccante: ",Style[δ,Large,Blue]}],Column[{"delta","semiampiezza della zona di tiro"},Center]]},0,2,ControlPlacement->Bottom},
{{automaticoQ,False,"tiri automatici"},{False,True},ControlPlacement->Bottom},
SaveDefinitions->True]]]

DynamicModule[{n=0},
Dynamic[n++;Pause[1];N[Fibonacci[n+1]/Fibonacci[n],30]]]

Basi dei vettori nel piano

Le coordinate di un punto del piano al variare della base:

Manipulate[coord=LinearSolve[{e1,e2}//Transpose,p];
Graphics[{{PointSize[Large],Point[{0,0}]},{Thickness[Medium],Arrow[{{0,0},e1}],Arrow[{{0,0},e2}]},Point[p],Text[P,p,-3Normalize@p],Text[Style[(Subscript[(OverVector[e]), 1]),Bold],e1,-3{{0,1},{-1,0}}.Normalize@e1],Text[Style[(Subscript[(OverVector[e]), 2]),Bold],e2,3{{0,1},{-1,0}}.Normalize@e2],{Dashed,Line[{p,coord[[1]]e1,{0,0}}],Line[{p,coord[[2]]e2,{0,0}}]}},PlotRange->2{{-1,1},{-1,1}},PlotLabel->DisplayForm@RowBox[{"P","=","(",NumberForm[coord[[1]],{5,4},NumberPadding->{" ","0"},NumberSigns->{"-","+"}],")",Style[(Subscript[(OverVector[e]), 1]),Bold],"+","(",NumberForm[coord[[2]],{5,4},NumberPadding->{" ","0"},NumberSigns->{"-","+"}],")",Style[(Subscript[(OverVector[e]), 2]),Bold]}]],
Item["Coordinate di un punto nel piano rispetto a una base"],
{{e1,{1,0}},Locator,Appearance->None},
{{e2,{0,1}},Locator},
{{p,{1,1}},Locator}]

Quando si ha a che fare con due basi allo stesso tempo:

Manipulate[coord1=LinearSolve[{e1,e2}//Transpose,p];
coord2=LinearSolve[{f1,f2}//Transpose,p];
Graphics[{{PointSize[Large],Point[{0,0}]},If[base1,{Arrow[{{0,0},e1}],Arrow[{{0,0},e2}],Text[Style[(Subscript[(OverVector[e]), 1]),Bold],e1,-3{{0,1},{-1,0}}.Normalize@e1],Text[Style[(Subscript[(OverVector[e]), 2]),Bold],e2,3{{0,1},{-1,0}}.Normalize@e2],{Dashed,Line[{p,coord1[[1]]e1,{0,0}}],Line[{p,coord1[[2]]e2,{0,0}}]}},Sequence@@{}],If[base2,{Red,Arrow[{{0,0},f1}],Arrow[{{0,0},f2}],Text[Style[(Subscript[(OverVector[f]), 1]),Bold],f1,-3{{0,1},{-1,0}}.Normalize@f1],Text[Style[(Subscript[(OverVector[f]), 2]),Bold],f2,3{{0,1},{-1,0}}.Normalize@f2],{Dashed,Red,Line[{p,coord2[[1]]f1,{0,0}}],Line[{p,coord2[[2]]f2,{0,0}}]}},Sequence@@{}],Point[p],Text[P,p,-3Normalize@p]},PlotRange->2{{-1,1},{-1,1}},PlotLabel->DisplayForm@RowBox[{Style[RowBox[{"(",NumberForm[coord[[1]],{5,4},NumberPadding->{" ","0"},NumberSigns->{"-","+"}],")",Style[(Subscript[(OverVector[e]), 1]),Bold],"+","(",NumberForm[coord[[2]],{5,4},NumberPadding->{" ","0"},NumberSigns->{"-","+"}],")",Style[(Subscript[(OverVector[e]), 2]),Bold]}],If[base1,Black,White]],Style["=",If[base1,Black,White]],"P",Style["=",If[base2,Red,White]],Style[RowBox[{"(",NumberForm[coord2[[1]],{5,4},NumberPadding->{" ","0"},NumberSigns->{"-","+"}],")",Style[(Subscript[(OverVector[f]), 1]),Bold],"+","(",NumberForm[coord2[[2]],{5,4},NumberPadding->{" ","0"},NumberSigns->{"-","+"}],")",Style[(Subscript[(OverVector[f]), 2]),Bold]}],If[base2,Red,White]]}]],
{base1,{True,False}},
{base2,{False,True}},
{{e1,{1,0}},Locator,Appearance->None},
{{e2,{0,1}},Locator},
{{f1,{1,1}},Locator},
{{f2,{-1,1}},Locator},
{{p,{1.5,1.}},Locator}]

Animazioni del sistema solare

I dati di base dei pianeti:

estrai[{nome_String,per_,ax_,rd_,col_}]:=(periodo[nome]=per;asse[nome]=ax;raggio[nome]=rd;colore[nome]=col);
Map[estrai,({{"Mercury", 7.6005438`*^6, 4.60012719`*^10, 2.4397`*^6, Gray}, {"Venus", 1.94141491`*^7, 1.07476002`*^11, 6.0519`*^6, LightGray}, {"Earth", 3.15581491`*^7, 1.470980735`*^11, 6.37814`*^6, Blue}, {"Mars", 5.93550362`*^7, 2.066445449`*^11, 3.397`*^6, Orange}, {"Jupiter", 3.74355659`*^8, 7.40742598`*^11, 7.1492`*^7, LightBrown}, {"Saturn", 9.29292363`*^8, 1.34946738`*^12, 6.0268`*^7, LightYellow}, {"Uranus", 2.65137002`*^9, 2.735555035`*^12, 2.5559`*^7, White}, {"Neptune", 5.20041856`*^9, 4.4596315`*^12, 2.4764`*^7, White}, {"Pluto", 7.8237807`*^9, 4.43682461`*^12, 1.195`*^6, White}})];

Il sistema eliocentrico coi pianeti interni:

Clear[t];
periodoTerra=5;
listaPianeti={"Sun","Mercury","Venus","Earth","Mars"};
scalaTemporale=periodo["Earth"]/periodoTerra;
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]]};
orbita["Sun",t_]={0,0};colore["Sun"]=Yellow;raggio["Sun"]=2raggio["Earth"];
sistema[t_]=Table[{PointSize[.01raggio[p]/raggio["Mercury"]],colore[p],Point[orbita[p,t]]},{p,listaPianeti}];Graphics[{Dynamic[t=Clock[{0,Infinity}];sistema[t]]},PlotRange->1.2asse["Mars"],Background->Black]

Il sistema eliocentrico coi pianeti fino a saturno:

Clear[t];
periodoTerra=5;
listaPianeti={"Sun","Mercury","Venus","Earth","Mars","Jupiter","Saturn"};
scalaTemporale=periodo["Earth"]/periodoTerra;
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]]};
orbita["Sun",t_]={0,0};colore["Sun"]=Yellow;raggio["Sun"]=2raggio["Earth"];
sistema[t_]=Table[{PointSize[.003raggio[p]/raggio["Mercury"]],colore[p],Point[orbita[p,t]]},{p,listaPianeti}];Graphics[{Dynamic[t=Clock[{0,Infinity}];sistema[t]]},PlotRange->1.2asse[Last@listaPianeti],Background->Black]

Il sistema eliocentrico in tre dimensioni, coi pianeti interni:

Clear[t];
periodoTerra=5;
scalaTemporale=periodo["Earth"]/periodoTerra;
listaPianeti={"Sun","Mercury","Venus","Earth","Mars"};
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]],0};
orbita["Sun",t_]={0,0,0};colore["Sun"]=Yellow;raggio["Sun"]=2raggio["Earth"];
sistema[t_]=Table[{colore[p],Sphere[orbita[p,t],.01asse["Mars"]*raggio[p]/raggio["Mercury"]]},{p,listaPianeti}];Graphics3D[{Dynamic[t=Clock[{0,Infinity}];sistema[t]]},PlotRange->1.2(asse[Last@listaPianeti]),Background->Black]

Il sistema eliocentrico in tre dimensioni, coi pianeti fino a saturno:

Clear[t];
periodoTerra=5;
scalaTemporale=periodo["Earth"]/periodoTerra;
listaPianeti={"Sun","Mercury","Venus","Earth","Mars","Jupiter","Saturn"};
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]],0};
orbita["Sun",t_]={0,0,0};colore["Sun"]=Yellow;raggio["Sun"]=2raggio["Earth"];
sistema[t_]=Table[{colore[p],Sphere[orbita[p,t],.01asse["Mars"]*raggio[p]/raggio["Mercury"]]},{p,listaPianeti}];Graphics3D[{Dynamic[t=Clock[{0,Infinity}];sistema[t]]},PlotRange->1.2(asse[Last@listaPianeti]),Background->Black]

Il sistema geocentrico:

Clear[t];
periodoTerra=5;
scalaTemporale=periodo["Earth"]/periodoTerra;
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]]};
orbita["Sun",t_]={0,0};colore["Sun"]=Yellow;raggio["Sun"]=2raggio["Earth"];
sistema[t_]=Table[{PointSize[.01raggio[p]/raggio["Mercury"]],colore[p],Point[orbita[p,t]-orbita["Earth",t]]},{p,{"Sun","Mercury","Venus","Earth","Mars"}}];Graphics[{Dynamic[t=Clock[{0,Infinity}];sistema[t]]},PlotRange->1.2(asse["Mars"]+asse["Earth"]),Background->Black]

Il sistema geocentrico in tre dimensioni:

Clear[t];
periodoTerra=5;
scalaTemporale=periodo["Earth"]/periodoTerra;
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]],0};
orbita["Sun",t_]={0,0,0};colore["Sun"]=Yellow;raggio["Sun"]=2raggio["Earth"];
sistema[t_]=Table[{colore[p],Sphere[orbita[p,t]-orbita["Earth",t],.01asse["Mars"]*raggio[p]/raggio["Mercury"]]},{p,{"Sun","Mercury","Venus","Earth","Mars"}}];Graphics3D[{Dynamic[t=Clock[{0,Infinity}];sistema[t]]},PlotRange->1.2(asse["Mars"]+asse["Earth"]),Background->Black]

I pianeti interni e il sole proiettati sulla sfera celeste, come visti dalla terra:

Clear[t];
periodoTerra=5;
scalaTemporale=periodo["Earth"]/periodoTerra;
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]]};
orbita["Sun",t_]={0,0};colore["Sun"]=Yellow;raggio["Sun"]=2raggio["Earth"];
sistema[t_]=Table[{PointSize[.01raggio[p]/raggio["Mercury"]],colore[p],Point[Normalize[orbita[p,t]-orbita["Earth",t]]]},{p,{"Sun","Mercury","Venus","Earth","Mars"}}];Graphics[{Dynamic[t=Clock[{0,Infinity}];sistema[t]]},PlotRange->1.2,Background->Black]

Con pannello di controllo:

periodoTerra=5;
scalaTemporale=periodo["Earth"]/periodoTerra;
orbita[pianeta_,t_]:=asse[pianeta]{Cos[2π*t*scalaTemporale/periodo[pianeta]],Sin[2π*t*scalaTemporale/periodo[pianeta]]};
orbita["Sun",t_]={0,0};colore["Sun"]=Yellow;raggio["Sun"]=2raggio["Earth"];asse["Sun"]=0;
Manipulate[
centratoIn=Switch[puntoDiVista,"Sole","Sun","Mercurio","Mercury","Venere","Venus","Terra","Earth","Marte","Mars"];sistema[t_]=Table[{PointSize[.01raggio[p]/raggio["Mercury"]],colore[p],Point[orbita[p,t]-orbita[centratoIn,t]]},{p,{"Sun",If[mercurioQ,"Mercury",Sequence@@{}],If[venereQ,"Venus",Sequence@@{}],If[terraQ,"Earth",Sequence@@{}],If[marteQ,"Mars",Sequence@@{}]}}];
Graphics[{Dynamic[t=Clock[{0,Infinity}];sistema[t]]},PlotRange->1.2(asse["Mars"]+asse[centratoIn]),PlotLabel->{puntoDiVista,centratoIn},Background->Black],
Item[Row[{"Pianeti da mostrare:",Column[{"Mercurio",Checkbox[Dynamic[mercurioQ]]},Center],Column[{"Venere",Checkbox[Dynamic[venereQ]]},Center],Column[{"Terra",Checkbox[Dynamic[terraQ]]},Center],Column[{"Marte",Checkbox[Dynamic[marteQ]]},Center]},Spacer[5]]],
{{puntoDiVista,"Sole","Sistema di riferimento di:"},{"Sole","Mercurio","Venere","Terra","Marte"}}]

Geografia

GeoGraphics[]

GeoGraphics[Polygon[LinguisticAssistant]]

GeoGraphics[GeoRange->"World",GeoProjection->"Robinson"]

Esempio interattivo: effetto lente d'ingrandimento

UpdatePts[mp_,pts_]:=If[mp===None,pts,( # + (#-mp)(E^(-(3 Norm[#-mp])^2)))&  /@ pts]
uniformGrid[space_:0.05]:=Flatten[Table[{x,y},{x,-1,1,space},{y,-1,1,space}],1];
DynamicModule[{pts = uniformGrid[]},
Graphics[{Dynamic@With[{t=MousePosition[{"Graphics",Graphics}]},
Point @ UpdatePts[t,pts]]},PlotRange->2]]

Esempio interattivo: effetto "bruciatura"

MovePts[t_,pts_]:=If[t===None,pts,( # + 0.2(#-t)(E^(-(3 Norm[#-t])^2)))&  /@ pts]

DynamicModule[{pts = uniformGrid[]},
Panel @ Column[{Button["reset",pts:=uniformGrid[],ImageSize->150],Graphics[{
Dynamic @
With[{t=MousePosition[{"Graphics",Graphics}]},
Point @ (pts=MovePts[t,pts];pts)]
},PlotRange->2,ImageSize->500]},ColumnAlignments->Center]]

Caricamento di basi di dati della Wolfram

Il grafico dell'indice di borsa Dow Jones:

dati=FinancialData["^DJI",All];
DateListPlot[{#1,Log[10,#2]}&@@@Take[dati,{1,-1,50}],Joined->True,PlotLabel->"Logaritmo dell'indice Dow Jones",ImageSize->400]

Prodotto interno lordo dei paesi del G8, dal 1970 al 2007:

TabView[Show[CountryData[#,"Shape"],ImageSize->{40,40}]->DateListPlot[CountryData[#,{{"GDP"},{1970,2016}}]]&/@CountryData["GroupOf8"]]

Andamento delle azioni della Microsoft ed Apple dal 1986 a oggi:

TabView[{"Microsoft"->DateListPlot[Take[FinancialData["MSFT","Jan. 1, 1986"],{1,-1,20}],Joined->True,PlotRange->All],"Apple"->DateListPlot[Take[FinancialData["AAPL","Jan. 1, 1986"],{1,-1,20}],Joined->True,PlotRange->All]}]

La molecola del benzene:

ChemicalData["Benzene","MoleculePlot"]

Le molecole il cui nome contiene "chloro" e "hex":

Grid[Partition[Select[Map[Column[{ChemicalData[#,"MoleculePlot"],#}]&,ChemicalData["*chloro*hex*"]],FreeQ[#,Missing]&],3]]

Dal sito Demonstrations: incontro con Saturno

Manipulate[Show[Graphics3D[{Specularity[GrayLevel[.3],1],RGBColor[.75,.7,.45],Sphere[{0,0,0},1],White,PointSize[.001],Point[stars]},Method->{"SpherePoints"->80}],(Graphics3D[{EdgeForm[GrayLevel[.3]],Lighter[RGBColor[.65,.6,.35],Rescale[(#[[1]]+#[[2]])/2,{1.24,2.30}]],Specularity[White,128],Ring[#[[1]],#[[2]]]}]&)/@Partition[Drop[Flatten[Nest[Flatten[({{#1[[1]],#1[[1]]+(1/3) (#1[[2]]-#1[[1]])},{#1[[2]]-(1/3) (#1[[2]]-#1[[1]]),#1[[2]]}}&)/@#1,1]&,{{1.24,2.30}},n]],1],2],ImageSize->{500,380},Background->Black,PlotRange->30,Lighting->{{"Ambient",GrayLevel[.2]},{"Directional",White,{0,-5,3}}},SphericalRegion->True,ViewVector->Dynamic[{{1.1,y,1},{1.5,0,0}},None],Boxed->False,ViewRange->{.9,30},ViewAngle->Pi/5],{{n,4,"number of iterations"},{0,1,2,3,4,5},ControlType->SetterBar},{{y,-10,"fly by"},-10,10},AutorunSequencing->{{1,4},{2,10}},Initialization:>{SeedRandom[12345];stars=20 Table[{Cos[#1]Sqrt[1-#2^2],Sin[#1]Sqrt[1-#2^2],#2}&[Random[Real,{0,2Pi}],Random[Real,{-1,1}]],{5000}];Ring[rMin_,rMax_]:=Polygon[Join[Table[rMin {Cos[a],Sin[a],0},{a,0,2 Pi,Pi/64}],Table[rMax {Cos[a],Sin[a],0},{a,0,2 Pi,Pi/64}]]]}]

Dal sito Demonstrations: traiettorie balistiche

Manipulate[Module[{impacttime,time,range,tpeak,mxheight},impacttime=time/.Last@Solve[pos[[2]]+vel[[2]] time-1/2 (9.8) time^2==0,time];
range=pos[[1]]+vel[[1]] impacttime;
tpeak=time/.First@Solve[D[pos[[2]]+vel[[2]] time-1/2 (9.8) time^2,time]==0,time];
mxheight=pos[[2]]+vel[[2]] tpeak-1/2(9.8)tpeak^2;
ParametricPlot[{pos[[1]]+vel[[1]] t,pos[[2]]+vel[[2]] t-1/2(9.8)t^2},{t,0,10},PlotRange->{{0,16},{0,16}},PlotStyle->{{Thickness[.007]}},Epilog->{Blue,PointSize[.01],Point[{{pos[[1]],0},{pos[[1]],pos[[2]]}}],RGBColor[.7,.7,1],Thickness[.005],Line[{{pos[[1]],0},{pos[[1]],pos[[2]]}}],Line[{{0,pos[[2]]},{pos[[1]],pos[[2]]}}],RGBColor[1,.3,0],Arrow[{{pos[[1]],pos[[2]]},{pos[[1]],pos[[2]]}+{vel[[1]],vel[[2]]}}]},AxesLabel->{"range (meters)","height (meters)"},ImageSize->{450,400},AspectRatio->1,PlotLabel->Column[{Row[{Style["x velocity = "<>ToString[NumberForm[vel[[1]],{2,1},NumberPadding->{"","0"},ExponentFunction->(Null&)]]<>" m/s","Label"],Style["    |    ",GrayLevel[.5]],Style["y velocity = "<>ToString[ToString[NumberForm[vel[[2]],{2,1},NumberPadding->{"","0"},ExponentFunction->(Null&)]]]<>" m/s","Label"],Style["    |    ",GrayLevel[.5]],Style["range = "<>ToString[ToString[NumberForm[range,{3,1},NumberPadding->{" ","0"},ExponentFunction->(Null&)]]]<>" m","Label"]}],Row[{Style["max height = "<>ToString[ToString[NumberForm[mxheight,{3,1},NumberPadding->{" ","0"},ExponentFunction->(Null&)]]]<>" m","Label"],Style["    |    ",GrayLevel[.5]],Style["impact time = "<>ToString[ToString[NumberForm[impacttime,{2,1},NumberPadding->{"","0"},ExponentFunction->(Null&)]]]<>" s","Label"]}]},Center],ImagePadding->{{50,100},{30,70}}]],"XY"->{{pos,{2,6},"position"},{0,0},{6,10},Locator},"XY2"->{{vel,{2,2},"velocity"},{0,0},{5,5},ImageSize->Tiny},ControlPlacement->{Automatic,Left}]