5
$\begingroup$

We have 3 circles. The middle one has to move along the line y=-x towards the top left such that the resulting area of the respective intersecting regions become 4:1

I have below thus far to just depict it with 1 simple example with center located at (-2/10,2/10) But like to have this as a variable and dynamically move it higher in the NW direction to hit that area.

Would be nice to see a dial to drag to move the middle circle up/down and have areas shown! And of course to have an exact value for the desired 4:1 ratio

circles1 = {
     Circle[{-1, 1}, 1],
     Circle[{-2/10, 2/10}, 1]
   };
circles2 = {
     Circle[{1, -1}, 1],
     Circle[{-2/10, 2/10}, 1]
   };

disks1 = circles1 /. Circle -> Disk;
reg1 = RegionIntersection[disks1]
area1 = RegionMeasure[reg1]

disks2 = circles2 /. Circle -> Disk;
reg2 = RegionIntersection[disks2]
area2 = RegionMeasure[reg2]

Show[Graphics
  [{
     {RandomColor[], #} & /@ circles1, Axes -> True, 
   PlotRange -> {{-2, 2}, {-2, 2}},
   {RandomColor[], #} & /@ circles2, Axes -> True, 
   PlotRange -> {{-2, 2}, {-2, 2}},
   Line[{{2, -2}, {-2, 2}}]
    }]
 , RegionPlot[reg1], RegionPlot[reg2]
 ]

3-circles

Improve this question
$\endgroup$
5
  • 1
    $\begingroup$ I might be misunderstanding your problem, but do you want to have something like this? Note that I just get a numeric approximation for the middle circle coordinate that has a 4:1 intersecting area ratio. I feel a solution can be found by hand probably, but I might need to refresh myself on geometry basics. Note you might have to download or copy+paste the cloud notebook onto your local device to get the Manipulate graphics to show $\endgroup$
    – ydd
    Commented Dec 1 at 0:25
  • $\begingroup$ Yes looks great, just post it! manually i did this and I got the origin to be at (-.375, .375) away from dead center. I maybe wrong. Is your shown distance of -0.18 away from dead center (0,0)? $\endgroup$
    – Steve237
    Commented Dec 1 at 1:13
  • $\begingroup$ oh for exact values, just pass in Rationals for the center, not decimals! Increment by say like 1/100 or 1/50 at a time maybe. $\endgroup$
    – Steve237
    Commented Dec 1 at 1:14
  • $\begingroup$ so your looks right, at (-0.185, 0.185)..... what is this value you displayed? 2.4869*10^-14 $\endgroup$
    – Steve237
    Commented Dec 1 at 1:23
  • 1
    $\begingroup$ 2.4869*10^-14 is the Euclidean norm residual between the true ratio at the point {-0.185,0.185} and the goal ratio of 4. So it's very close to 4. I am working on uploading the video of the manipulation graphic right now $\endgroup$
    – ydd
    Commented Dec 1 at 1:29

3 Answers 3

Reset to default
6
$\begingroup$

First we create the desired Manipulateable graphics:

intersectionColors = {Blue, Green};
circleColors = {Blue, Green, Black};
line = Graphics[{Black, Line[{{-2, 2}, {2, -2}}]}];
makeGraphics[x_] := Module[{diskList, intersections, cirlces, allArgs},
  diskList = Disk[{#, -#}, 1] & /@ {-1, 1, x};
  
  intersections =
   MapThread[
    Region@Style[RegionIntersection[#1, Last@diskList], #2] &, {Most@
      diskList, intersectionColors}];
  
  cirlces = 
   MapThread[
    Region@Style[#1, #2] &, {Circle @@@ diskList, circleColors}];
  allArgs = Flatten[{intersections, cirlces, {line}}];
  
  Show @@ allArgs
  ]
Manipulate[
 Labeled[makeGraphics[x], 
  "center of middle circle" <> ToString@ {x, -x}], {x, -1, 1}]

enter image description here

And then we numerically solve for the middle circle center that makes the blue area 4 times that of the green

blueArea = Area@RegionIntersection[Disk[{-1, 1}, 1], Disk[{x, -x}, 1]];
greenArea = 
  Area@RegionIntersection[Disk[{1, -1}, 1], Disk[{x, -x}, 1]];
eq = blueArea/greenArea == 4;
xSoln = x /. FindRoot[eq, {x, 0}]

(*-0.183674*)

And plot to confirm, and calculate residual of ratio to that of the goal 4:

makeGraphics[xSoln]

(*graphics below*)

EuclideanDistance @@ eq /. x -> xSoln

(*2.84217*10^-14*)

enter image description here

I have a feeling there's an elegant way to solve this exactly. If we look at the form of eq, it seems some well chosen variable substitution may simplify it greatly, given how similar the numerator and denominator are:

$$ eq := \frac{2 \cos ^{-1}\left(\frac{\sqrt{(x+1)^2}}{\sqrt{2}}\right)-\sqrt{-(x+1)^2 \left(x^2+2 x-1\right)}}{2 \cos ^{-1}\left(\frac{\sqrt{(x-1)^2}}{\sqrt{2}}\right)-\sqrt{-(x-1)^2 \left(x^2-2 x-1\right)}}==4 $$ I tried the substiution $ x -> 1-\sqrt{2} u$, but with no luck.

Improve this answer
$\endgroup$
2
  • $\begingroup$ Super! Thanks @ydd -- let me study this in detail in a bit and ask if anything ambiguous....And I suppose we cannot find exact value easily? $\endgroup$
    – Steve237
    Commented Dec 1 at 1:52
  • 1
    $\begingroup$ Maybe someone else can find an exact solution easily, but not me :D $\endgroup$
    – ydd
    Commented Dec 1 at 1:53
5
$\begingroup$ 
disk1 = Disk[{-1, 1}, 1];
disk2 = Disk[{1, -1}, 1];
sol = Solve[
   Area@RegionIntersection[Disk[{-x, x}, 1], disk1]/
    Area@RegionIntersection[Disk[{-x, x}, 1], disk2] == 4, x, 
   Reals][[1]]
disk = Disk[{-x, x} /. sol, 1] /. sol

Graphics[{FaceForm[], EdgeForm[Blue], disk1, disk2, EdgeForm[Red], 
  disk, EdgeForm[], Blue, FaceForm[Blue], 
  DiscretizeRegion@RegionIntersection[disk, disk1], FaceForm[Green], 
  DiscretizeRegion@RegionIntersection[disk, disk2]}]

enter image description here enter image description here

Improve this answer
$\endgroup$
6
  • $\begingroup$ Ah I see, I just needed to specify Reals for Solve to work. I'm still wondering if this can be expressed in terms of radicals (though it looks like possibly no because the RootApproximant is degree 13). $\endgroup$
    – ydd
    Commented Dec 1 at 1:59
  • $\begingroup$ Thanks @cvgmt : why does Solve give me this: "-0.183674` is not a valid variable." $\endgroup$
    – Steve237
    Commented Dec 1 at 3:04
  • $\begingroup$ By the way, @ydd : tell me more on that root approximation, Why is it in that format and what does it exactly mean? (I have got that a few times also). And what degrees are not able to be in radical form? Why 13...what others? ... $\endgroup$
    – Steve237
    Commented Dec 1 at 3:08
  • $\begingroup$ @Steve237 Clear[x] $\endgroup$
    – cvgmt
    Commented Dec 1 at 3:14
  • $\begingroup$ Oh yes! variable reuse! lol...works....can you please explain to me what the value is when I hover over it....what is #1 inside it? And is that an exact solution with ArcCos and radicals in it? $\endgroup$
    – Steve237
    Commented Dec 1 at 3:21
4
$\begingroup$ 
d1 = Disk[{-1, 1}, 1];
d2 = Disk[{1, -1}, 1];
dv[t_] := Disk[{-1, 1} + t {1, -1}, 1];
ar[t_] := 
 Area[RegionIntersection[d1, dv[t]]]/
  Area[RegionIntersection[d2, dv[t]]]

The value where area ratio is 4:

 op = t /. FindRoot[ar[t] == 4, {t, 0.8}]

To visualize moving circle you can use Manipulate on the following:

func[u_] := 
 Graphics[{Line[{{-2, 2}, {2, -2}}], EdgeForm[Black], FaceForm[White],
    d1 /. Disk[a__] :> Circle[a], d2 /. Disk[a__] :> Circle[a],
   Circle[{-1, 1} + u {1, -1}, 1],
   Dashed,
   dv[op] /. Disk[a__] :> Circle[a],
   EdgeForm[None], FaceForm[Red], 
   DiscretizeRegion[RegionIntersection[d1, dv[u]]],
   DiscretizeRegion[RegionIntersection[d2, dv[u]]], Black, 
   PointSize[0.02], Point[{-1, 1} + u {1, -1}]}, 
  PlotLabel -> 
   Grid[{{"Area ratio: ", ar[u]}, {"Center: ", {-1, 1} + u {1, -1}}}]]

For example:

enter image description here

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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