Перекрывающиеся полосы

Question

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

Например:

strips = 
    {{-27,  20},
     { -2,  -1},
     {-47, -28},
     {-41,  32},
     { 22,  31},
     {  2,  37},
     {-28,  30}, 
     { -7,  39}}

Должен вывести:

-47 -41 -27  -7  -2  -1   2  20  22  30  31  32  37  39
  1   2   3   4   5   4   5   4   5   4   3   2   1   0

Каков наиболее эффективный, чистый или лаконичный способ сделать это с учетом положений Real и Rational strip?

Answer 1

Вот один из подходов:

Clear[hasPaper,nStrips]
hasPaper[y_, z_] := Piecewise[{{1, x <= z && x >= y}}, 0];
nStrips[y_, strip___] := Total@(hasPaper @@@ strip) /. x -> y

Количество полос можно получить при любом значении.

Table[nStrips[i, strips], {i, Sort@Flatten@strips}]
{1, 2, 3, 3, 3, 4, 5, 5, 5, 5, 5, 5, 4, 3, 2, 1}

Кроме того, подготовьте его

Plot[nStrips[x, strips], {x, Min@Flatten@strips, Max@Flatten@strips}]

Answer 2

f[u_, s_] := Total[Piecewise@{{1, #1 <= x < #2}} & @@@ s /. x -> u]

Использование

f[#, strips] & /@ {-47, -41, -27, -7, -2, -1, 2, 20, 22, 30, 31, 32, 37, 39}

->

{1, 2, 3, 4, 5, 4, 5, 4, 5, 4, 3, 2, 1, 0}  

Для открытых / закрытых концов, просто используйте <= </strong> или <</strong>

Answer 3

Вы можете посчитать это глупым подходом, но я все равно предложу:

f[x_]:=Sum[UnitStep[x-strips[[k,1]]]-UnitStep[x-strips[[k,2]]],{k,Length[strips]}]
f/@Union[Flatten[strips]]

Answer 4

Вот одно из решений:

In[305]:= 
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2, 
    37}, {-28, 30}, {-7, 39}};

In[313]:= int = Interval /@ strips;

In[317]:= Thread[{Union[Flatten[strips]], 
  Join[Count[int, x_ /; IntervalMemberQ[x, #]] & /@ (Mean /@ 
      Partition[Union[Flatten[strips]], 2, 1]), {0}]}]

Out[317]= {{-47, 1}, {-41, 2}, {-28, 2}, {-27, 3}, {-7, 4}, {-2, 
  5}, {-1, 4}, {2, 5}, {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 
  2}, {37, 1}, {39, 0}}

---

РЕДАКТИРОВАТЬ Используя SplitBy и постобработку, следующий код получает кратчайший список:

In[329]:= 
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2, 
    37}, {-28, 30}, {-7, 39}};

In[330]:= int = Interval /@ strips;

In[339]:= 
SplitBy[Thread[{Union[Flatten[strips]], 
    Join[Count[int, x_ /; IntervalMemberQ[x, #]] & /@ (Mean /@ 
        Partition[Union[Flatten[strips]], 2, 1]), {0}]}], 
  Last] /. {b : {{_, co_} ..} :> First[b]}

Out[339]= {{-47, 1}, {-41, 2}, {-27, 3}, {-7, 4}, {-2, 5}, {-1, 
  4}, {2, 5}, {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 2}, {37, 
  1}, {39, 0}}

Answer 5

Вот мой подход, похожий на Велисарий:

strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2, 
    37}, {-28, 30}, {-7, 39}};

pw = PiecewiseExpand[Total[Boole[# <= x < #2] & @@@ strips]]

Grid[Transpose[
  SplitBy[SortBy[Table[{x, pw}, {x, Flatten[strips]}], First], 
    Last][[All, 1]]], Alignment -> "."]

Answer 6

Одним из способов решения этой проблемы является преобразование полос

strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}
         ,{ 22, 31}, { 2, 37}, {-28,  30}, {-7, 39}}

в список разделителей, помечая начало или конец полосы и сортируя их по позиции

StripToLimiters[{start_, end_}] := Sequence[BeginStrip[start], EndStrip[end]]
limiterlist = SortBy[StripToLimiters /@ strips, First]

Сейчасмы можем отобразить отсортированные ограничители на приращения / убывания

LimiterToDiff[BeginStrip[_]] := 1
LimiterToDiff[EndStrip[_]] := -1

и использовать Accumulate для получения промежуточных итогов пересеченных полос:

In[6]:= Transpose[{First/@#,Accumulate[LimiterToDiff/@#]}]&[limiterlist]
Out[6]= {{-47,1},{-41,2},{-28,3},{-28,2},{-27,3},{-7,4},{-2,5},{-1,4}
        ,{2,5},{20,4},{22,5},{30,4},{31,3},{32,2},{37,1},{39,0}}

или без промежуточных limiterlist:

In[7]:= StripListToCountList[strips_]:=
          Transpose[{First/@#,Accumulate[LimiterToDiff/@#]}]&[
            SortBy[StripToLimiters/@strips,First]
          ]

        StripListToCountList[strips]
Out[8]= {{-47,1},{-41,2},{-28,3},{-28,2},{-27,3},{-7,4},{-2,5},{-1,4}
        ,{2,5},{20,4},{22,5},{30,4},{31,3},{32,2},{37,1},{39,0}}

Answer 7

Соедините вместе примыкающие полосы, определите ключевые точки, где количество слоев изменения и подсчитайте, сколько полос обитает каждая ключевая точка:

splice[s_, {}] := s
splice[s_, vals_] := Module[{h = First[vals]},
   splice[(s /. {{x___, {k_, h}, w___, {h, j_}, z___} :>  {x, {k, j}, 
       w, z}, {x___, {k_, h}, w___, {h, j_}, z___} :>  {x, {k, j}, w,
       z}}), Rest[vals]]]

splicedStrips = splice[strips, Union@Flatten@strips];
keyPoints = Union@Flatten@splicedStrips;

({#, Total@(splicedStrips /. {a_, b_} :> Boole[a <= # < b])} & /@ keyPoints)
// Transpose // TableForm

---

EDIT

После некоторой борьбы я смог удалить splice и, более точно, исключить точки, которые не нужно проверять (-28, в данных strips, которые мы использовали):

keyPoints = Complement[pts = Union@Flatten@strips, 
   Cases[pts, x_ /; MemberQ[strips, {x, _}] && MemberQ[strips, {_, x}]]];
({#, Total@(strips /. {a_, b_} :> Boole[a <= # < b])} & /@ keyPoints)

Answer 8

Вот моя попытка - она ​​работает с целыми числами, рациональными и действительными числами, но не претендует на то, чтобы быть ужасно эффективной. (Я сделал ту же ошибку, что и Саша, моя оригинальная версия не вернула самый короткий список. Поэтому я украл исправление SplitBy!)

layers[strips_?MatrixQ] := Module[{equals, points},
  points = Union@Flatten@strips;
  equals = Function[x, Evaluate[(#1 <= x < #2) & @@@ strips]];
  points = {points, Total /@ Boole /@ equals /@ points}\[Transpose];
  SplitBy[points, Last] /. {b:{{_, co_}..} :> First[b]}]

strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, 
          {2, 37}, {-28, 30}, {-7, 39}};

In[3]:= layers[strips]
Out[3]= {{-47, 1}, {-41, 2}, {-27, 3}, {-7, 4}, {-2, 5}, {-1, 4}, {2, 5}, 
         {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 2}, {37, 1}, {39, 0}}

In[4]:= layers[strips/2]
Out[4]:= {{-(47/2), 1}, {-(41/2), 2}, {-(27/2), 3}, {-(7/2), 4}, 
          {-1, 5}, {-(1/2), 4}, {1, 5}, {10, 4}, {11, 5}, {15, 4}, {31/2, 3}, 
          {16, 2}, {37/2, 1}, {39/2, 0}}

In[5]:= layers[strips/3.]
Out[5]= {{-15.6667, 1}, {-13.6667, 2}, {-9., 3}, {-2.33333, 4}, {-0.666667, 5}, 
         {-0.333333, 4}, {0.666667, 5}, {6.66667, 4}, {7.33333, 5}, {10.,4}, 
         {10.3333, 3}, {10.6667, 2}, {12.3333, 1}, {13., 0}}

Answer 9

Следующее решение предполагает, что функция подсчета слоев будет вызываться большое количество раз. Он использует предварительное вычисление слоя и Nearest, чтобы значительно сократить количество времени, необходимое для вычисления количества слоев в любой заданной точке:

layers[strips:{__}] :=
  Module[{pred, changes, count}
  , changes = Union @ Flatten @ strips /. {c_, r___} :> {c-1, c, r}
  ; Evaluate[pred /@ changes] = {changes[[1]]} ~Join~ Drop[changes, -1]
  ; Do[count[x] = Total[(Boole[#[[1]] <= x < #[[2]]]) & /@ strips], {x, changes}]
  ; With[{n = Nearest[changes]}
    , (n[#] /. {m_, ___} :> count[If[m > #, pred[m], m]])&
    ]
  ]

В следующем примере используется layers для определения новой функции f, которая будет вычислять количество слоев для предоставленных образцов полос:

$strips={{-27,20},{-2,-1},{-47,-28},{-41,32},{22,31},{2,37},{-28,30},{-7,39}};
f = layers[$strips];

f теперь можно использовать для вычисления количества слоев в точке:

Union @ Flatten @ $strips /. s_ :> {s, f /@ s} // TableForm

Plot[f[x], {x, -50, 50}, PlotPoints -> 1000]

Для 1000 слоев и 10000 точек этап предварительного вычисления может занять довольно много времени, но вычисление отдельных точек выполняется относительно быстро: