Wolfram mathematica 重叠条
假设我沿着一把无限长的尺子放了一系列的纸条，起点和终点由成对的数字指定。我想创建一个列表，表示沿标尺各点的纸张层数 例如：Wolfram mathematica 重叠条,wolfram-mathematica,Wolfram Mathematica,假设我沿着一把无限长的尺子放了一系列的纸条，起点和终点由成对的数字指定。我想创建一个列表，表示沿标尺各点的纸张层数 例如： 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
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
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}}
使用
SplitByIn[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}}
这是我的尝试——它适用于整数、有理数和实数，但并不声称它非常有效。（我犯了与Sasha相同的错误，我的原始版本没有返回最短的列表。所以我偷了
SplitBy层[strips_？MatrixQ]：=模块[{equals，points}，
点数=Union@Flatten@条状物；
等于=函数[x，求值[（#1优先[b]}]
条带={-27,20}，{-2，-1}，{-47，-28}，{-41,32}，{22,31}，
{2, 37}, {-28, 30}, {-7, 39}};
在[3]：=层[条]
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}}
在[4]：=层[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}}
在[5]：=层[strips/3]
[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}}
f[x_]:=Sum[UnitStep[x-strips[[k,1]]]-UnitStep[x-strips[[k,2]]],{k,Length[strips]}]
f/@Union[Flatten[strips]]
Clear[hasPaper,nStrips]
hasPaper[y_, z_] := Piecewise[{{1, x <= z && x >= y}}, 0];
nStrips[y_, strip___] := Total@(hasPaper @@@ strip) /. x -> y
Plot[nStrips[x, strips], {x, Min@Flatten@strips, Max@Flatten@strips}]
将相邻的板条拼接在一起，确定关键点，确定层数 更改，并计算每个关键点所在的条带数：
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
这是我的方法，类似于belisarius的方法：
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 -> "."]
strips={-27,20}，{-2，-1}，{-47，-28}，{-41,32}，{22,31}，{2，
37}, {-28, 30}, {-7, 39}};
pw=分段展开[总计[布尔[#“]
以下解决方案假设层计数函数将被调用大量次。它使用层预计算和最近的
来大大减少在任何给定点计算层计数所需的时间量：
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
现在可用于计算某一点的层数：
Union @ Flatten @ $strips /. s_ :> {s, f /@ s} // TableForm
Plot[f[x], {x, -50, 50}, PlotPoints -> 1000]
对于1000层和10000个点，预计算阶段可能需要相当长的时间，但单个点计算相对较快：
解决这一问题的一种方法是转换条带
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}}
你为什么不在输出中列出-28？如果一条带在-28处结束，另一条带在-28处开始，这不意味着两条带将在点28处重叠吗？（我假设间隔是闭合的）。@David似乎间隔是开放的，因为最后一个间隔在39处结束，但f[39]==0@belisarius开放式间隔是有意义的。@David:但是-47不应该是零吗？我假设它们是[开始，结束]/code>类型的间隔，这样纸张就可以彼此平放在一起，也就是说，{{0,1}，{1,2}=={0,2}
等价地：[0,1）并集[1,2]=[0,2）
。这是一个好的、干净的方法——但并没有完全返回W先生想要的答案的形式。
$strips={{-27,20},{-2,-1},{-47,-28},{-41,32},{22,31},{2,37},{-28,30},{-7,39}};
f = layers[$strips];
Union @ Flatten @ $strips /. s_ :> {s, f /@ s} // TableForm
Plot[f[x], {x, -50, 50}, PlotPoints -> 1000]
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}}