Apolonijev problem

Znameniti Apolonijev problem se glasi:

“Konstruiraj krožnico, ki se dotika treh danih krožnic.”

Rešimo ga z Mathematico.

Pomožne funkcije

Ker bomo primerjali razdalje, definiramo funkcijo razdalja2, ki izračuna kvadrat razdalje med dvema točkama:

ClearAll[razdalja2]
razdalja2::usage = "Kvadrat razadalje med točkama P in Q.";
razdalja2[P_,Q_]:=(P-Q).(P-Q)

razdalja2[{0,0},{1,1}]

Graphics[{Circle[{0,0},1]}]

Krožnico s središčem S in polmerom r predstavimo simbolno z izrazom Circle[S,r], pri čemer je točka S predstavljena s parom koordinat {x,y}. Tu je besedica Circle samo simbol ali oznaka, ki nakazuje pome podatkov S in r. Prav lahko bi uporabili kako drugo predstavitev, na primer {S,r}, a to bi bilo manj razumljivo.

Definiramo funkcijo, ki pove, ali se dve krožnici dotikata. Tu vidimo, kako uporabimo vzorce, s katerimi izluščimo podatke o krožnicah.

EvenQ[20]

PrimeQ[12387]

ClearAll[dotikataQ]
dotikataQ::usage:="Ali se dani krožnici dotikata?";

dotikataQ[Circle[S1_,r1_],Circle[S2_,r2_]]:=razdalja2[S1,S2]==(((r1+r2))^2)∨razdalja2[S1,S2]==(((r1-r2))^2)

Preverimo, kako deluje dotikataQ

Graphics[{Circle[{0,0},1],Circle[{2,0},1]},Axes->True]

dotikataQ[Circle[{0,0},1],Circle[{2,0},1]]

dotikataQ[Circle[{0,0},1],Circle[{2,0},r]]

Reduce[dotikataQ[Circle[{0,0},1],Circle[{2,0},r]]]

Graphics[{Circle[{0,0},1],Blue,Circle[{2,0},1],Circle[{2,0},3]},Axes->True]

Sedaj že lahko izračunamo kaj zanimivega. Denimo, kolikšen je polmer krožnice s središčem (1,1), ki se dotika enotske krožnice s središčem (0,0)?

Solve[dotikataQ[Circle[{0,0},1],Circle[{1,1},r]],r]

V poštev pridejo samo pozitivne rešitve, ki jih lahko izluščimo s funkcijo Select:

Select[Solve[dotikataQ[Circle[{0,0},1],Circle[{1,1},r]],r],Function[resitev,(r/.resitev)>0]]

Select[{1,23,4,5,10,12,15,16,78},EvenQ]

Funkcijski predpis x↦(x^2)+3 pišemo Function[x,(x^2)+3]

f=Function[x,(x^2)+3]

f[4]

Function[x,(x^2)+3][4]

Select[{1,23,4,5,10,12,15,16,78},]

Select[{1,23,4,5,10,12,15,16,78},Function[x,EvenQ[x]∧x>5]]

Solve[dotikataQ[Circle[{0,0},1],Circle[{1,1},r]],r]

r/.{r->1-(Sqrt[2])}

Select[
Solve[dotikataQ[Circle[{0,0},1],Circle[{1,1},r]],r],
Function[resitev,(r/.resitev)>0]
]

V Mathematici zapis z # in & pomeni funkcijski predpis. Denimo, (# + 7)& pomeni x↦x+7. Bolj človeški alternativni zapis je Function[x, x+7], ki ga priporočamo začetniku. Naloga: razvozlajte, kako deluje zgornji ukaz Select.

Pravzaprav imamo še bolj eleganten način, da izberemo le pozitivne rešitve – v Solve preprosto dodamo pogoj r > 0, zraven pa povemo še, da nas zanimajo le realne rešitve:

Solve[dotikataQ[Circle[{0,0},1],Circle[{1,1},r]]∧ r > 0,r, Reals]

Definirajmo funkcijo, ki pove ali se dana krožnica dotika vseh krožnic v danem seznamu:

Ali se krožnica k dotika krožnic {l1,l2,l3}?

dotikataQ[k,l1]∧dotikataQ[k,l2]∧dotikataQ[k,l3]

Map[g,{a,b,c,d}]

Map[Function[l,dotikataQ[k,l]],{l1,l2,l3}]

Apply[g,h[a,b,c]]

a+b+c//FullForm

a*b*c//FullForm

Apply[Times,x+y+z]

{a,b,c,d}//FullForm

List[1,2,3,4]

Apply[Plus,{a,b,c,d}]

p && q && r//FullForm

Apply[And,Map[Function[l,dotikataQ[k,l]],{l1,l2,l3}]]

ClearAll[dotikaQ]
dotikaQ::usage="Ali se krožnica dotika danih krožnic?";
dotikaQ[k_Circle,kroznice_List]:=Apply[And,Map[Function[l,dotikataQ[k,l]],kroznice]]

Naloga: naučite se, kako delujeta Apply in Map. Tu je nekaj primerov uporabe, preberite tudi dokumentacijo.

Rešitev Apolonijevega problema

Rešimo Apolonijev problem:

ClearAll[apolonij]
apolonij[kroznice_List]:=
Module[{x,y,r},
Circle[{x,y},r]/.
Solve[dotikaQ[Circle[{x,y},r],kroznice]∧ r > 0,{x,y,r}, Reals]
]

Preverimo, ali funkcija deluje:

Graphics[{Circle[{0,0},1],Circle[{3,0},1],Circle[{0,3},1]},Axes->True]

dotikaQ[Circle[{x,y},r],{Circle[{0,0},1],Circle[{3,0},1],Circle[{0,3},1]}]

Solve[dotikaQ[Circle[{x,y},r],{Circle[{0,0},1],Circle[{3,0},1],Circle[{0,3},1]}]∧ r > 0,{x,y,r}, Reals]//ColumnForm

apolonij[{Circle[{0,0},1],Circle[{3,0},1],Circle[{0,3},1]}]

apolonij[{Circle[{0,0},1],Circle[{3,0},1],Circle[{0,3},1]}]//Graphics

Grafični prikaz Apolonijevega problema

Sedaj bi radi rešitve tudi narisali.

ClearAll[narisiApolonij]
narisiApolonij[kroznice_List]:=
Graphics[{{Black,Thick,kroznice}, {Red,apolonij[kroznice]}}]

narisiApolonij[{Circle[{0,0},1],Circle[{3,0},1],Circle[{0,3},1]}]

Radi bi tudi videli, kako se spreminja rešitev, ko spreminjamo krožnice. V ta namen uporabimo Manipulate

Off[Solve::ratnz]
Manipulate[narisiApolonij[{Circle[{0,0},1],Circle[{3,0},1],Circle[{0,3},r]}],{r,1,3}]

Manipulate[
Show[narisiApolonij[{Circle[{0,0},1],Circle[{3,0},1],Circle[S,r]}],Axes->True,PlotRange->{{-10,10},{-10,10}}],
{r,1,3},{{S,{0,3}},Locator}]

Zgornja slika zelo “skače”, ko spreminjamo polmer. Poskusimo še enkrat, tako da fiksiramo območje, ki ga rišemo. Dodajmo še premikanje središča kroga, kar se naredi z  Locator:

Off[Solve::ratnz]
Manipulate[Show[narisiApolonij[{Circle[{0,0},1],Circle[{3,0},1],Circle[S,r]}], Axes->True, PlotRange->{{-10,10},{-10,10}}],{{r,1},0,5},{{S,{0,3}},Locator}]

Off[Solve::ratnz]
Manipulate[Show[narisiApolonij[{Circle[{0,0},1],Circle[T,1],Circle[S,r]}], Axes->True, PlotRange->{{-10,10},{-10,10}}],{{r,1},0,5},{{S,{0,3}},Locator},{{T,{3,0}},Locator}]