Увеличение скорости (или альтернативы) RegionPlot

Question

Я хочу включить некоторые региональные графики в структуру Manipulate, однако рендеринг почти запредельно медленный. Код

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

Который производит графику как

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

Вычисление и рендеринг на моем компьютере занимает около 40 секунд. Кто-нибудь может предложить способ получить графику аналогичного качества быстрее?

---

Примечание 1. Я запомнил графический объект, так что нет необходимости каждый раз пересчитывать его в моей демонстрации - но он слишком медленный даже в первый раз.
Примечание 2: я доволен растеризованными изображениями, так что, возможно, вариант с заливкой заливки будет вариант ...
Примечание 3: мне нужно что-то вроде Manipulate[ rplot[n, o], {n, 2, 10, 1, Appearance -> "Labeled"}, {{o, 1}, Range[1, (n + 1)/2], ControlType -> RadioButtonBar}], чтобы его можно было использовать.

Answer 1

Вы можете сделать что-то вроде этого

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

Тогда GraphicsGrid[{{rplot[3, 2], rplot[5, 3]}, {rplot[7, 2], rplot[4, 1]}}] выдаст что-то вроде

Редактировать

Перенес предыдущее изменение в отдельный ответ.

Answer 2

Я ранее опубликовал это как дополнение к моему другому ответу. Он вдохновлен аналитическим подходом Саймона, с некоторыми изменениями, чтобы ускорить процесс

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

Прежде всего, я использую это для заданного значения n и o, область пересечения между i -ым и i+o-1 -ым кругом такая же, как область пересечения между первый и o -й круг за исключением поворота на угол 2 Pi (i-1)/n, поэтому достаточно один раз рассчитать область и использовать Rotate для поворота области.

Кроме того, вместо использования ParametricPlot для построения области пересечения, я использую Polygon, поэтому мне нужно только рассчитать некоторые точки на границе, что экономит время.

Результат для GraphicsGrid[{{rplot2[3, 2], rplot2[5, 2]}, {rplot2[7, 3], rplot2[4, 1]}}] выглядит как

И время, которое я получаю

rplot2[10, 3]; // Timing

(* ==> {0.0016, Null} *)

по сравнению с решениями Саймона

rplot[10, 3]; // Timing

(* ==> {0.16519, Null} *)

Answer 3

г. Мастер заставил меня понять, что, хотя у меня была аналитическая форма для областей, которые я мог бы использовать в RegionPlot, если бы я получил параметризованную форму для границ, то я мог бы использовать ParametricPlot. Итак, давайте сделаем это!

Круг i ^th (i=0,...,n-1) параметризован в комплексной плоскости как
Exp[I t] + Exp[2 i Pi I / n] для t в [0, 2 Pi].

Мы можем решить, чтобы найти пересечение i ^th и (i+o-1) ^th кругов, где o - количество перекрытий, как в оригинале код вопроса. Это дает очки на

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

Теперь мы можем параметризовать дуги, идущие от начала координат к point[n,o,i], и отразить их через линию, идущую от начала координат к point[n,o,i]. Интерполяция между ними с параметром s дает параметризованные области

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 + n t - 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])}]

Тогда мы можем определить

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

А GraphicsGrid[{{rplot[3, 2], rplot[5, 3]}, {rplot[7, 2], rplot[4, 1]}}] производит

Answer 4

Аналитический метод

Если окружности всегда расположены в четном кольце, как показано, должно быть аналитическое решение для пересечения окружность-окружность.Я бы начал с количества градусов между каждым кругом, как указано на кольце.

Я буду исследовать этот метод, как позволяет время.

Растровый метод

1. Двоичная растеризация серии дисков в правильных местах

2. Назначение уникальных значений степени 2 для каждого растра вместо единиц

3. Добавить массивы

4. Вычислить уникальный набор перекрытий из значения в каждой точке массива итогов

5. Отображение правильных цветов в результирующий массив исгенерировать вывод

---

Первый грубый проход растрового метода, просто как подтверждение концепции.Вы можете видеть, что каждый регион имеет уникальную штриховку, которая является просто суммой растров в этой точке.

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]

---

Второй черновик, добавление цветов.Это все еще довольно неуклюже.

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