重叠条带

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

适应实数和有理数条带位置的最有效、最干净或最简洁的方法是什么？

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

这是一种解决方案：

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

---

EDIT Using SplitBy and postprocessing the following code gets the shortest list:

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 3

您可能认为这是一种愚蠢的方法，但无论如何我都会提供它：

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

Answer 4

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}  

对于开放/封闭端，只需使用 <= 或 <

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

这是我的尝试——它适用于整数、有理数和实数，但并没有声称非常高效。 （我犯了和 Sasha 一样的错误，我的原始版本没有返回最短列表。所以我偷了 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 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

解决此问题的一种方法是将条带转换

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

，并使用累加来获取相交条带的中间总数：

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

或者没有中间限制器列表：

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 9

以下解决方案假设层计数函数将被调用大量次。它使用层预计算和“最近”来大大减少计算任何给定点的层计数所需的时间：

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

以下示例使用“层”定义一个新函数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]

对于 1,000 层和 10,000 个点，预计算阶段可能需要相当长的时间，但单个点计算相对较快：