Increase speed (or alternatives) of RegionPlot

Question

I want to include some parts of the region in the Manipulate structure, but rendering is almost forbidden. The code

 ClearAll[regions, rplot] r:regions[n_Integer, o_Integer] := r = Apply[And, Subsets[Table[(#1 - Cos[t])^2 + (#2 - Sin[t])^2 <= 1, {t, 2 Pi/n, 2 Pi, 2 Pi/n}], {o}], {1}] & r:rplot[n_Integer, o_Integer] := r = Show[{RegionPlot[ Evaluate[regions[n, o][x, y]], {x, -2, 2}, {y, -2, 2}, PlotRange -> {{-2, 2}, {-2, 2}}, PlotRangePadding -> .1, Frame -> False, PlotPoints -> 100], Graphics[Table[Circle[{Cos[t], Sin[t]}, 1], {t, 2 Pi/n, 2 Pi, 2 Pi/n}]]}] 

What creates the graphics, for example

 GraphicsGrid[{{rplot[3, 2], rplot[5, 3]}, {rplot[7, 2], rplot[4, 1]}}] 

The above takes about 40 seconds to calculate and render on my computer. Can anyone suggest a way to get better graphics faster?

---

Note 1: I have a memoized graphic object, so there is no need to recount it every time in my demo, but it is too slow even for the first time.
Note 2: I am pleased with rasterized images, so maybe a fill fill type solution would be an option ...
Note 3: I need something like Manipulate[ rplot[n, o], {n, 2, 10, 1, Appearance -> "Labeled"}, {{o, 1}, Range[1, (n + 1)/2], ControlType -> RadioButtonBar}] to use.

Answer 1

I previously posted this as a complement to my other answer. He is inspired by Simon's analytic approach, with some changes to speed things up.

 intersect[n_, o_] := With[{a = Pi/2 - (o-1) Pi/n}, If[o-1 >= n/2, Return[{}]]; (* intersection is {} *) Polygon[ Join[Table[{Sin[a] + Sin[phi], (-Cos[a] + Cos[phi])}, {phi, -a, a-2 a/10, 2 a/10}], Table[{Sin[a] + Sin[phi], (Cos[a] - Cos[phi])}, {phi, a, -a+2 a/10, -2 a/10}]]]] rplot2[n_, o_] := With[{pl = intersect[n, o], opac = .3, col = ColorData[1]}, Graphics[{{Opacity[opac], Table[{col[k], Rotate[pl, Mod[o - 1, 2] Pi/n + 2 Pi k/n, {0, 0}]}, {k, n}]}, {Black, Circle[Through[{Re, Im}[Exp[I #]]]] & /@ (Range[n] 2 Pi/n)}}] ] 

First of all, I use this for a given value of n and o , the intersection between the i -th and i+o-1 circles is the same as the intersection between the first and o circles, except for 2 Pi (i-1)/n , so just calculate the area once and use Rotate to rotate the area.

Also, instead of using ParametricPlot to build the intersection area, I use Polygon , so I only need to calculate some points on the border, which saves time.

The result for GraphicsGrid[{{rplot2[3, 2], rplot2[5, 2]}, {rplot2[7, 3], rplot2[4, 1]}}] looks like

And the time that I get

 rplot2[10, 3]; // Timing (* ==> {0.0016, Null} *) 

compared to those for Simon's solution

 rplot[10, 3]; // Timing (* ==> {0.16519, Null} *) 

Answer 2

You can do something like this

 rplot[n_Integer, o_Integer] := Module[{centres, masks, opacity = .3, colours, region, img, createmask}, centres = Table[Through[{Re, Im}[Exp[I t]]], {t, 2 Pi/n, 2 Pi, 2 Pi/n}]; createmask[centres_] := Fold[ImageMultiply, #[[1]], Rest[#]] &@ (ColorNegate[ Image[Graphics[Disk[#, 1], PlotRange -> {{-2, 2}, {-2, 2}}, PlotRangePadding -> .1], ColorSpace -> "Grayscale"]] & /@ centres); masks = createmask /@ Subsets[centres, {o}]; colours = PadRight[#, Length[masks], #] & @ (List @@@ ColorData[1, "ColorList"]); region[img_, col_] := SetAlphaChannel[ColorCombine[ImageMultiply[img, #] & /@ col, "RGB"], ImageMultiply[img, opacity]]; img = Fold[ImageCompose, #[[1]], Rest[#]] &@(MapThread[region, {masks, colours}]); Overlay[{img, Graphics[Circle[#, 1] & /@ centres, PlotRangePadding -> .1, PlotRange -> {{-2, 2}, {-2, 2}}]}] ] 

Then GraphicsGrid[{{rplot[3, 2], rplot[5, 3]}, {rplot[7, 2], rplot[4, 1]}}] creates something like

Edit

Moved previous edit to split response.

Answer 3

Mr. Wizard made me realize that although I had an analytic form for areas that I could use in RegionPlot , if I got a parameterized form for borders, then I could use ParametricPlot . So let's do it!

The circle i ^th ( i=0,...,n-1 ) is parameterized in the complex plane using Exp[I t] + Exp[2 i Pi I / n] for t in [0, 2 Pi] .

We can decide to find the intersection of the circles i ^th and (i+o-1) ^th where o is the number of overlaps, as in the source code of the question. It gives points in

 point[n_, o_, i_] := {Cos[(2 i Pi)/n] + Cos[(2 Pi (i + o - 1))/n], Sin[(2 i Pi)/n] + Sin[(2 Pi (i + o - 1))/n]} 

Now we can parameterize the arcs going from the origin to a point[n,o,i] , and reflect them along the line going from the origin to a point[n,o,i] . Interpolation between two parameters s gives parameterized regions

 area[n_, o_, i_, t_, s_] := With[{a = 2 Sin[((2 + n - 2 o) (1 - t) )/(2 n) Pi], b = (2 - 4 i + 2 t + nt - 2 o (1 + t))/(2 n) Pi, c = ((2 + n - 2 o) (1 - t) - 4 i)/(2 n) Pi}, {a (s Cos[b] + (1 - s) Sin[c]) , -a (s Sin[b] - (1 - s) Cos[c])}] 

Then we can determine

 rplot[n_Integer, o_Integer] := ParametricPlot[Evaluate[ Table[area[n, o, i, t, s], {i, 0, n - 1}]], {t, 0, 1}, {s, 0, 1}, Mesh -> False, MaxRecursion -> 1, Frame -> False, Axes -> False, PlotRange -> 2.1 {{-1, 1}, {-1, 1}}, Epilog -> {Table[Circle[{Cos[t], Sin[t]}, 1], {t, 0, 2 Pi (n-1)/n, 2 Pi/n}], Red, Point[Table[point[n, o, i], {i, 1, n}]]}] 

And GraphicsGrid[{{rplot[3, 2], rplot[5, 3]}, {rplot[7, 2], rplot[4, 1]}}] creates

Answer 4

Analytical method

If the circles are always located in an even ring, as shown, there should be an analytical solution for intersecting the circle. I started with the number of degrees between each circle, as it was on the ring.

I will research this method when time permits.

Raster method

• Binary rasterization of a series of disks in the right places

• Assign unique power-2 values ​​for each raster instead

• Add Arrays

• Compute a unique set of overlaps from the value at each point in the totals array

• Display the correct colors in the resulting array and generate output

---

The first rough pass of the raster method, just as a proof of concept. You can see that each region has a unique shade, which is just the sum of the rasters at this point.

 raster = 1 - First@Binarize@Rasterize@Graphics[#, PlotRange -> {{-2, 2}, {-2, 2}}] &; disks = Table[raster @ Disk[{Cos[t], Sin[t]}, 1], {t, 2 Pi/#, 2 Pi, 2 Pi/#}] &; n = 5; array = disks[n] * 2^Range[0, n - 1] //Total; ArrayPlot[array] 

---

The second draft, adding colors. This is still pretty awkward.

 n = 7; o = 2; sets = Table[ NestList[RotateLeft, PadLeft[Table[1, {o + i}], n], n - 1], {i, 0, n - o} ]; colors = NestList[ Mean /@ Partition[#, 2, 1, 1] &, List @@@ Take[ColorData[4, "ColorList"], n], n - o ]; rules = Append[Rule @@@ Flatten[{sets, colors}, {{2, 3}}], _ -> {1, 1, 1}]; Replace[Transpose[disks[n], {3, 2, 1}], rules, {2}] // Image