What's the most efficient way to draw this region?

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.

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


Surely there is a simpler way to do this?

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]


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 *)


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


• RegionDifference nice function! Oct 4, 2019 at 13:49
• Anyway to smooth the "tip"? Oct 4, 2019 at 13:53
• result = RegionPlot[ RegionUnion[RegionDifference[disk1, disk3], RegionDifference[disk1, disk2]], PlotPoints -> 100] Oct 4, 2019 at 14:19
• 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. Oct 5, 2019 at 19:48
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}]


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!

• I'd add PlotPoints->50 to smooth the tips of the crescents Oct 5, 2019 at 19:50
• @Ruslan: Yes... thanks. I included PlotPoints in my trial runs, but wanted to keep the code minimal. Oct 5, 2019 at 20:22