Mathematica：加入线段

Question

这是我试图找到我的问题wireframes in Mathematica的答案的第一部分。

给定一组线段，如何连接两条连接的AND段位于同一条线上。例如考虑线段l1 = {(0,0), (1,1)}和l2 = {(1,1), (2,2)}。这两条线段可以组合成一条线段，即l3 = {(0,0), (2,2)}。这是因为l1和l2分享点(1,1)和每个线段的斜率是相同的。这里是一个视觉：

l1 = JoinedCurve[{{{0, 2, 0}}}, {{{0, 0}, {1, 1}}}, CurveClosed -> {0}]; 
l2 = JoinedCurve[{{{0, 2, 0}}}, {{{1, 1}, {2, 2}}}, CurveClosed -> {0}]; 
Graphics[{Red, l1, Blue, l2}, Frame -> True] 

有一点要注意的是，在上述的例子l1和l2可以被组合成由3个点指定的一个行，即{{0,0},{1,1},{2,2}}。

这个问题的第一部分是：给定一个由2个点指定的线段集合，如何减少这个集合的最小重复点数量。考虑这个由例如：

lines = { 
    {{0,0}, {1,1}}, 
    {{3,3}, {2,2}}, 
    {{2,2}, {1,1}}, 
    {{1,1}, {0.5,0.5}}, 
    {{0,1}, {0,2}}, 
    {{2,3}, {0,1}} 
} 

我要的是一个函数说REDUCE这给了我下面的输出：

R = { 
{{0,0}, {1,1}, {2,2}, {3,3}}, 
{{1,1}, {0.5,0.5}}, 
{{2,1}, {0,1}, {0,2}} 
} 

唯一重复的我们需要的是{1,1}。我这样做的方式如下：我把第一行R然后我看着lines中的下一行，并注意到没有终点匹配R行中的终点，所以我将此新行添加到R。 lines中的下一行是{{2,2},{1,1}}，端点{1,1}与R中的第一行相匹配，因此我在R中追加了{2,2}。现在我加{{1,1}, {0.5,0.5}}到R，我也加了{{0,1}, {0,2}}。由于lines中的最后一行有一个端点与R中的端点匹配，所以我附加了它，因此我们有{{2,1}, {0,1}, {0,2}}。最后，我查看R中的所有行，并查看是否有任何端点匹配，在这种情况下，行{{3,3}, {2,2}}与R中第一行的右端匹配，因此我附加{3,3}，因此不需要{2,2}。

这可能不是最好的办法，因为它可能不会给你最好的减少。无论如何，假设我们有这个约简函数，那么我们可以检查是否需要所有的点来描述一条线。这可以按如下方式完成：

如果我们有超过3个点描述该行，请检查前3个点是否共线，如果是，则删除中间一个，并检查2个端点的集合和一个新的观点。如果他们不是共线，那么转移一个点并检查接下来的3个点。

我问这个问题的原因是因为我想减少描述2D图形所需的点数。尝试以下方法：

g1 = ListPlot3D[ 
    {{0, -1, 0}, {0, 1, 0}, {-1, 0, 1}, {1, 0, 1}, {-1, 1, 1}}, 
    Mesh -> {2, 2}, 
    Boxed -> False, 
    Axes -> False, 
    ViewPoint -> {2, -2, 1}, 
    ViewVertical -> {0, 0, 1} 
] 

以下数学8函数改变3D对象进行的列表（一个线是2点的列表）描述对象的线框：

G3TOG2INFO[g_] := Module[{obj, opt}, 
    obj = ImportString[ExportString[g, "PDF", Background -> None], "PDF"][[1]]; 
    opt = Options[obj]; 
    obj = Cases[obj, _JoinedCurve, \[Infinity]]; 
    obj = Map[#[[2]][[1]] &, obj]; 
    {obj, opt} 
] 

注意，在数学7我们必须通过_Line分别代替_JoinedCurve。应用功能上g1我们得到

{lines, opt} = G3TOG2INFO[g1]; 
Row[{Graphics[Map[Line[#] &, lines], opt], Length@lines}] 

里面还有90个线段，但我们只需要12（如果我没有做对的直线计数的任何错误）。

所以你有挑战。我们如何操作lines以具有描述该图所需的最少量的信息。

Answer 1

第1步是找出线条是否在同一投影上。如果第一条线的斜率等于从第一条线的倒数第二个点到第二条线的第二个点构成的线段的斜率，则这是正确的。

我没有我的工作机器上数学，所以我不能测试了这一点（有可能是语法错误），但类似下面应该工作：

((#2[[2,2]]-#1[[-2,2]])/(#2[[2,1]]-#1[[-2,1]])) == 
((#1[[-1,2]]-#1[[-2,2]])/(#1[[-1,1]]-#1[[-2,1]])) & 
@@@ (Transpose[{Most[lines],Rest[lines]}]) 

Essentialy所有这样做是测试第一行的“上涨超过”等于连接线段的“上涨超过”。

我假设：lines：不是JoinedCurve元素的列表，而是n * 2列表的简单列表。我还假定定义每个线段的点对是按照规范顺序的，并且点在x方向上以升序排列。也就是说，第一个点的第一个元素的值低于第二个点的第一个元素。如果不是，请先排序。

第2步实际上是加入点。这将应用步骤1中的测试，然后用一条连接线替换这两条线。您可以将其包裹在FixedPoint中以加入同一投影中的所有线条。

If[((#2[[2,2]]-#1[[-2,2]])/(#2[[2,1]]-#1[[-2,1]])) == 
((#1[[-1,2]]-#1[[-2,2]])/(#1[[-1,1]]-#1[[-2,1]])), {#1[[-2]],#2[[2]]}] & 
@@@ (Transpose[{Most[lines],Rest[lines]}]) 

这一切都假定您想要比较的行对在列表中相邻。如果它们可能是集合中的任何一行，那么首先需要生成要比较的所有可能行对的列表，例如，使用Tuples [listOfLines，{2}]，而不是上面的Transpose函数。

好了，把这个放在一起：

f = If[((#2[[2,2]]-#1[[-2,2]])/(#2[[2,1]]-#1[[-2,1]])) == 
((#1[[-1,2]]-#1[[-2,2]])/(#1[[-1,1]]-#1[[-2,1]])), {#1[[-2]],#2[[2]]}] & ; 
FixedPoint[f @@@ #, Tuples[Sort[listOfLines],{2}] ] 

我已经打破了第2步测试和替换功能到一个名为纯函数，这样＃分别就不会感到困惑。

Answer 2

如果这仍然是有趣的，这里是一个不同的实现：

ClearAll[collinearQ] 
collinearQ[{{{x1_, y1_}, {x2_, y2_}}, {{x3_, y3_}, {x4_, y4_}}}] := (
(y1 - y2)*(x1 - x3) == (y1 - y3)*(x1 - x2)) && (y1 - y2)*(x1 - x4) == 
    (y1 - y4)*(x1 - x2) 

ClearAll[removeExtraPts]; 
removeExtraPts[{{{x1_, y1_}, {x2_, y2_}}, {{x3_, y3_}, {x4_, y4_}}}] := 
If[collinearQ[{{{x1, y1}, {x2, y2}}, {{x3, y3}, {x4, y4}}}],{First@#, Last@#} &@ 
SortBy[{{x1, y1}, {x2, y2}, {x3, y3}, {x4, y4}}, #[[1]] &], 
    {{{x1, y1}, {x2, y2}}, {{x3, y3}, {x4, y4}}}] 

因此，如果lines={{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}然后返回如果lines2 = {{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}然后removeExtraPts[lines2]给{{0, 0}, {2, 2}}{{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}一段时间。

这适用于垂直线，水平线等（没有被零除的危险）。

如果你有什么是行的列表，你可以因此产生它们之间的所有不同的配对：

ClearAll[permsnodupsv2] 
permsnodupsv2 = Last@Last@ 
Reap[Do[Sow[{#[[i]], #[[j]]}], {i, 1, Length@# - 1}, {j, i + 1, 
    Length@#}]] &; 

（你可以做到这功能我描述here的方式，但我觉得这是比较容易理解这版本一目了然）。例如，

lines = {l1, l2, l3, l4, l5, l6, l7, l8, l9}; 
permsnodups[lines] 
(* 
---> {{l1, l2}, {l1, l3}, {l1, l4}, {l1, l5}, {l1, l6}, {l1, l7}, {l1, l8}, 
     {l1, l9}, {l2, l3}, {l2, l4}, {l2, l5}, {l2, l6}, {l2, l7}, 
     {l2, l8}, {l2, l9}, {l3, l4}, {l3, l5}, {l3, l6}, {l3,l7}, 
     {l3, l8}, {l3, l9}, {l4, l5}, {l4, l6}, {l4, l7}, {l4, l8}, 
     {l4, l9}, {l5, l6}, {l5, l7}, {l5, l8}, {l5, l9}, {l6, l7}, 
     {l6, l8}, {l6, l9}, {l7, l8}, {l7, l9}, {l8, l9}} 
*) 

如果l1={{pt1,pt2},{pt3,pt4}}等等，你可以简单地映射removeExtraPts在此，扁平化的结果（使用类似Flatten[#,1]&，但确切的格式取决于你的输入结构）和重复，直到它停止变化（@Verbeia说，你可以使用FixedPoint使它停止，一旦它不再改变）。这应该加入所有的阵容。