3

这是我尝试在 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并注意到没有端点与行中的端点匹配，R因此我将此新行添加到R. 中的下一行lines是{{2,2},{1,1}}，端点{1,1}与中的第一行匹配，R因此我将其附加{2,2}到中R。现在我添加{{1,1}, {0.5,0.5}}，R我也添加{{0,1}, {0,2}}. 由于 in 的最后一行lines有一个与 in 匹配的端点，R所以我附加了它，所以我们有{{2,1}, {0,1}, {0,2}}. 最后，我查看所有行，R看看是否有任何端点匹配，在这种情况下，该行{{3,3}, {2,2}}与第一行的右端点匹配R所以我追加{3,3}，从而消除了对{2,2}.

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

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

我问这个问题的原因是因为我想减少描述二维图形所需的点数。尝试以下操作：

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

输出

以下Mathematica 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}
]

请注意，在Mathematica 7中，我们必须替换_JoinedCurve为_Line. 应用g1我们得到的函数

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

输出

那里有 90 条线段，但我们只需要 12 条（如果我在计算直线时没有犯任何错误）。

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

4

2 回答 2

3

第 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]}])

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

于 2011-06-16T05:07:41.830 回答
1

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

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

这样 if lines={{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}then 返回{{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}，而 if lines2 = {{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}thenremoveExtraPts[lines2]给出{{0, 0}, {2, 2}}。

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

如果您拥有的是行列表，则可以在它们之间产生所有不同的配对，因此：

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

（您可以按照我在此处描述的方式在功能上执行此操作，但我发现这更容易一目了然地理解此版本）。例如，

 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它来让它停止一旦它不再改变）。这应该加入所有行。

于 2011-06-19T19:36:50.627 回答