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 = "Razdalja2[P,Q] je kvadrat razadalje med točkama P in Q.";
razdalja2[P_,Q_]:=(P-Q).(P-Q)

razdalja2[{0,0},{3,4}]

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.

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

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

EvenQ[10]

PrimeQ[12329]

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],Blue,Circle[{2,0},1],Circle[{2,0},3]},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]]]

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[{1,2,3,4,5,6,7,20,22,23},EvenQ]

Select[{1,2,3,4,5,6,7,20,22,23},PrimeQ]

Funkcijski predpis x ↦(x^2)+3 zapišemo kot Function[x,(x^2)+3] ali (((#)^2)+3)&

Matematiki so zmedeni, če kdo napiše (x ↦(x^2)+3)(3). Programerji nismo zmedeni.

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

Select[{1,2,3,4,5,6,7,20,22,23},Function[x,x>8]]

Function[resitev,(r/.resitev)>0][{r->1-(Sqrt[2])}]

Function[resitev,(r/.resitev)>0][{r->1+(Sqrt[2])}]

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

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

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

Sin

Sin[Pi/6]

x->4

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]

?dotikataQ

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

ClearAll[dotikaQ]
dotikaQ::usage="Ali se krožnica dotika vseh 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.

Pogoj, da se k dotika l1 in l2

dotikataQ[k,l1]∧dotikata[k,l2]//FullForm

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

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

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

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

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

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

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:

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

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}]

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[{x,y},r]}], Axes->True, PlotRange->{{-10,10},{-10,10}}],{{r,1},0,5},{x,-2,2},{y,-2,2}]

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

MandelbrotSetPlot[]