10
$\begingroup$

enter image description here

Viral question on YouTube. But let me start by saying the guy got it wrong. We don't do such things at the age of 11, we do this question about Year 11 (aged 14/15, 16 for some).

I want to draw the following. enter image description here

Tried this

f1 = 10 - Sqrt[10^2 - x^2];
f2 = 5 - Sqrt[5^2 - (x - 5)^2];
f3 = 5 + Sqrt[5^2 - (x - 5)^2];

And

r00 = Graphics[{EdgeForm[Thick], Transparent, Rectangle[{0, 0}, {10, 10}]}]
r0 = Plot[{f1, f2, f3}, {x, 0, 10}, Frame -> True, AspectRatio -> 1,   PlotRange -> {{-0.5, 10.5}, {-0.5, 10.5}}]
r1 = Plot[{f1, f2, f3}, {x, 6.25 - 1.25 Sqrt[7], 6.25 + 1.25 Sqrt[7]},    Filling -> {1 -> {2}}, Frame -> True, AspectRatio -> 1,   PlotRange -> {{-0.5, 10.5}, {-0.5, 10.5}}]
r2 = Plot[{f1, f2, f3}, {x, 6.25 + 1.25 Sqrt[7], 10},   Filling -> {3 -> {2}}, Frame -> True, AspectRatio -> 1,   PlotRange -> {{-0.5, 10.5}, {-0.5, 10.5}}]

Show[{r00, r0, r1, r2}]

enter image description here

Surely there is a simpler way to do this?

$\endgroup$
12
$\begingroup$
f1h = HoldForm[10 - Sqrt[10^2 - x^2]];
f1 = f1h // ReleaseHold;
f2h = HoldForm[5 - Sqrt[5^2 - (x - 5)^2]];
f2 = f2h // ReleaseHold;
f3h = HoldForm[5 + Sqrt[5^2 - (x - 5)^2]];
f3 = f3h // ReleaseHold;

The x values for the curve intersections are

{x1, x2} = x /. Solve[f1 == #, x][[1]] & /@ {f2, f3};

The point coordinates for the curve intersections are

{pt1, pt2} = ({#, f1 /. x -> #} // FullSimplify) & /@ {x1, x2};

reg1 = ImplicitRegion[f1 < y < 10 && x > 0, {x, y}];
reg2 = ImplicitRegion[f2 < y < f3, {x, y}];

Show[
 Region[
  regDiff = RegionDifference[reg2, reg1]],
 Plot[{f1, f2, f3}, {x, 0, 10},
  PlotStyle -> {
    {Orange, AbsoluteThickness[4]},
    {Purple, AbsoluteThickness[4]},
    {Darker@Green, AbsoluteThickness[4]}}],
 Epilog -> {
   Text[Style[x1, 14, Bold], {x1, 2}, {0, -1}],
   Arrow[{pt1, {x1, 2}}],
   Text[Style[x2, 14, Bold], {7.75, pt2[[2]]}, {1, 0}],
   Arrow[{pt2, {7.75, pt2[[2]]}}],
   Text[Style[f1h, 14, Bold], {10, 8}, {-1, 0}],
   Text[Style[f2h, 14, Bold], {9.5, 1.5}, {-1, 0}],
   Text[Style[f3h, 14, Bold], {5, 11}],
   Red, AbsolutePointSize[7],
   Point[{pt1, pt2}]},
 Ticks -> {{5, 10}, {5, 10}},
 PlotRange -> {{-1, 14}, {-1, 12}},
 Axes -> True]

enter image description here

The area of the shaded region is

area = Area[regDiff] // FullSimplify

(* 25/2 (Sqrt[7] + π - ArcCot[3/Sqrt[7]] - 4 ArcTan[(5 Sqrt[7])/9]) *)

The area relative to the smaller circle is

area/Area[reg2] // N

(* 0.186378 *)
|improve this answer|||||
$\endgroup$
10
$\begingroup$

One simple way to visualize complicated regions in mathematica

disk1 = Region[Disk[{5, 5}, 5]]

disk2 = Region[Disk[{0, 10}, 10]]

disk3 = Region[Disk[{10, 0}, 10]]

result = Region[
  RegionUnion[RegionDifference[disk1, disk3], 
   RegionDifference[disk1, disk2]]]

|improve this answer|||||
$\endgroup$
  • $\begingroup$ RegionDifference nice function! $\endgroup$ – CasperYC Oct 4 '19 at 13:49
  • $\begingroup$ Anyway to smooth the "tip"? $\endgroup$ – CasperYC Oct 4 '19 at 13:53
  • 3
    $\begingroup$ result = RegionPlot[ RegionUnion[RegionDifference[disk1, disk3], RegionDifference[disk1, disk2]], PlotPoints -> 100] $\endgroup$ – OkkesDulgerci Oct 4 '19 at 14:19
  • $\begingroup$ This doesn't appear to work in Mathematica 11.1 and 11.2. Only starting from 11.3 does it succeed, although in 11.3 RegionPlot from OkkesDulgerci's comment clips the RHS of the plot. In 12.0 it works normally. $\endgroup$ – Ruslan Oct 5 '19 at 19:48
6
$\begingroup$
RegionPlot[
  x^2 + y^2 < 25 \[And] 
 ((x - 5)^2 + (y + 5)^2 > 100 \[Or] (x + 5)^2 + (y - 5)^2 > 100),
 {x, -5, 5}, {y, -5, 5}]

enter image description here

Or...

z[w_] := EuclideanDistance[{x, y}, w {5, -5}];
RegionPlot[
 z[0] < 5 \[And] (z[1] > 10 \[Or] z[-1] > 10),
 {x, -5, 5}, {y, -5, 5}]

Or...

z[w_] := (a = ({x, y} - 5 {w, -w})).a;
RegionPlot[
 z[0] < 25 \[And] (z[1] > 100 \[Or] z[-1] > 100), 
 {x, -5, 5}, {y, -5, 5}]

Or even shorter....

z[w_, k_] := (a = ({x, y} - 5 {w, -w})).a > 25 k;
RegionPlot[
Not[z[0, 1]] \[And] (z[1, 4] \[Or] z[-1, 4]), 
{x, -5, 5}, {y, -5, 5}]

I would be very impressed if someone uses fewer keystrokes than this in a Region-based solution:

d[c_, r_:10] := Region[Disk[c, r]];
RegionDifference[d[{5, 5}, 5], RegionIntersection[d[{0, 10}], d[{10, 0}]]]

Or...

d[c_, r_:10] := Region[Disk[c, r]];
q = {0, 10};
h = {5, -5};
RegionDifference[d[q + h, 5], RegionIntersection[d[q], d[q + 2 h]]]

Or....

d[c_, r_:10] := Region[Disk[c, r]]; q = {5, 5}; h = {5, -5};
RegionDifference[d[q, 5], RegionIntersection[d[q - h], d[q + h]]]

Pretty efficient!

|improve this answer|||||
$\endgroup$
  • $\begingroup$ I'd add PlotPoints->50 to smooth the tips of the crescents $\endgroup$ – Ruslan Oct 5 '19 at 19:50
  • $\begingroup$ @Ruslan: Yes... thanks. I included PlotPoints in my trial runs, but wanted to keep the code minimal. $\endgroup$ – David G. Stork Oct 5 '19 at 20:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.