Mathematica：加入线段

Question

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

给定一组线段，如何连接两个连接的线段并且位于同一条线上。例如，考虑线段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中的下一行，发现没有终点匹配{{1}行中的一个终点所以我将这一新行添加到R。 R中的下一行是lines，端点{{2,2},{1,1}}与{1,1}中的第一行匹配，因此我将R添加到{2,2}中的一行。现在我将R添加到{{1,1}, {0.5,0.5}}，我还添加了R。由于{{0,1}, {0,2}}中的最后一行的端点与lines中的一个匹配，因此我添加了R。最后，我查看{{2,1}, {0,1}, {0,2}}中的所有行，看看是否有任何端点匹配，在这种情况下，行R匹配{{3,3}, {2,2}}中第一行的右端点，所以我追加{ {1}}因此无需R。

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

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

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

{3,3}

以下 Mathematica 8 函数将3D对象更改为描述对象线框的行列表（一行是2个点的列表）：

{2,2}

请注意，在 Mathematica 7 中，我们必须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} ] 替换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} ] 。在_JoinedCurve上应用函数我们获得

_Line

那里有90个线段但我们只需要12个（如果我没有在直线计数上犯任何错误）。

所以你有挑战。我们如何操纵g1以获得描述图形所需的最少量信息。

Answer 1

步骤1是查找线条是否在同一投影上。如果第一行的斜率等于从第一行的倒数第二点到第二行的第二点的构造线段的斜率，则为真。

我的工作机器上没有Mathematica所以我无法测试它（可能存在语法错误），但以下内容应该有效：

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

实际上，所有这一切都是测试第一行的“上升超过”等于连接线段的“上升超过”。

我假设：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]}])

这都假定您要比较的线对在列表中是相邻的。如果它们可能是您集合中的任何行，那么您首先需要生成要比较的所有可能行对的列表，例如，使用元组[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步测试和替换功能分解为命名的纯函数，这样#s就不会混淆了。

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}}}，则返回{{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}而lines2 = {{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}则removeExtraPts[lines2] {{0, 0}, {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让它在不再变化时停止）。这应该加入所有队列。