Mathematica：3D 线框

Question

Mathematica 是否支持线框图像的隐藏线删除？如果不是这种情况，这里有人遇到过方法吗？让我们从这里开始：

Plot3D[Sin[x+y^2], {x, -3, 3}, {y, -2, 2}, Boxed -> False]

要创建线框，我们可以这样做：

Plot3D[Sin[x+y^2], {x, -3, 3}, {y, -2, 2}, Boxed -> False, PlotStyle -> None]

为了实现这种效果，我们可以做的一件事是将所有表面涂成白色。然而，这是不希望的。原因是因为如果我们将此隐藏线线框模型导出为 pdf，我们将拥有 Mathematica 用于渲染图像的所有白色多边形。我希望能够获得 pdf 和/或 eps 格式的带有隐藏线去除功能的线框。

---

更新：

我已经发布了这个问题的解决方案。问题是代码运行速度非常慢。在当前状态下，无法生成此问题中图像的线框。请随意使用我的代码。我在帖子末尾添加了一个链接。您还可以在此链接中找到代码

Answer 1

这里我提出一个解决方案。首先，我将展示如何使用生成线框的函数，然后我将继续详细解释构成该算法的其余函数。

---

wireFrame

wireFrame[g_] := Module[{figInfo, opt, pts},
   {figInfo, opt} = G3ToG2Info[g];
   pts = getHiddenLines[figInfo];
   Graphics[Map[setPoints[#] &, getFrame[figInfo, pts]], opt]
]

该函数的输入是一个 Graphics3D 对象，最好没有轴。

fig = ListPlot3D[
   {{0, -1, 0}, {0, 1, 0}, {-1, 0, 1}, {1, 0, 1}, {-1, 1, 1}},
   Mesh -> {10, 10},
   Boxed -> False,
   Axes -> False,
   ViewPoint -> {2, -2, 1},
   ViewVertical -> {0, 0, 1},
   MeshStyle -> Directive[RGBColor[0, 0.5, 0, 0.5]],
   BoundaryStyle -> Directive[RGBColor[1, 0.5, 0, 0.5]]
]

现在我们应用函数wireFrame。

wireFrame[fig]

如您所见，wireFrame 获取了大部分线条及其颜色。有一条绿线未包含在线框中。这很可能是由于我的阈值设置造成的。

在继续解释函数 G3ToG2Info、getHiddenLines、getFrame 和 setPoints 的详细信息之前，我将向您展示原因具有隐藏线去除功能的线框可能很有用。

上面显示的图像是使用 3D 图形中的栅格与此处生成的线框相结合。这在很多方面都是有利的。无需保留三角形的信息即可显示彩色表面。相反，我们显示表面的光栅图像。所有的线条都非常平滑，除了光栅图的边界没有被线条覆盖之外。我们还减小了文件大小。在本例中，使用光栅图和线框的组合，pdf 文件大小从 1.9mb 减小到 78kb。在 pdf 查看器中显示所需的时间较短，并且图像质量非常好。

Mathematica 在将 3D 图像导出为 pdf 文件方面做得非常好。当我们导入 pdf 文件时，我们获得一个由线段和三角形组成的 Graphics 对象。在某些情况下，这些对象重叠，因此我们有隐藏线。要制作没有曲面的线框模型，我们首先需要删除重叠部分，然后删除多边形。我将首先描述如何从 Graphics3D 图像获取信息。

---

G3ToG2Info

getPoints[obj_] := Switch[Head[obj], 
   Polygon, obj[[1]], 
   JoinedCurve, obj[[2]][[1]], 
   RGBColor, {Table[obj[[i]], {i, 1, 3}]}
  ];
setPoints[obj_] := Switch[Length@obj, 
   3, Polygon[obj], 
   2, Line[obj], 
   1, RGBColor[obj[[1]]]
  ];
G3ToG2Info[g_] := Module[{obj, opt},
   obj = ImportString[ExportString[g, "PDF", Background -> None], "PDF"][[1]];
   opt = Options[obj];
   obj = Flatten[First[obj /. Style[expr_, opts___] :> {opts, expr}], 2];
   obj = Cases[obj, _Polygon | _JoinedCurve | _RGBColor, Infinity];
   obj = Map[getPoints[#] &, obj];
   {obj, opt}
  ]

此代码适用于版本 7 中的 Mathematica 8，您可以将函数 getPoints 中的 JoinedCurve 替换为 行。函数 getPoints 假定您正在提供一个原始 Graphics 对象。它将查看收到的对象类型，然后从中提取所需的信息。如果它是一个多边形，它会得到一个包含 3 个点的列表，对于一条线，它会得到一个包含 2 个点的列表，如果它是一个颜色，它会得到一个包含 3 个点的单个列表的列表。这样做是为了保持与列表的一致性。

函数setPoints 的作用与getPoints 相反。您输入一个点列表，它将确定是否应返回多边形、线条或颜色。

为了获取三角形、线条和颜色的列表，我们使用 G3ToG2Info。该函数将使用
ExportString 和 ImportString 从 Graphics3D 版本获取 Graphics 对象。此信息存储在 obj 中。我们需要执行一些清理工作，首先我们获取 obj 的选项。这部分是必需的，因为它可能包含图像的PlotRange。然后我们获取所有Polygon、JoinedCurve和RGBColor对象，如获取图形基元和指令。最后，我们对所有这些对象应用函数 getPoints 来获取三角形、线条和颜色的列表。这部分涵盖了行{figInfo, opt} = G3ToG2Info[g]。

---

getHiddenLines

我们希望能够知道一行的哪一部分不会被显示。为此，我们需要知道两条线段之间的交点。我用来查找交集的算法可以在此处找到。

lineInt[L_, M_, EPS_: 10^-6] := Module[
  {x21, y21, x43, y43, x13, y13, numL, numM, den},
  {x21, y21} = L[[2]] - L[[1]];
  {x43, y43} = M[[2]] - M[[1]];
  {x13, y13} = L[[1]] - M[[1]];
  den = y43*x21 - x43*y21;
  If[den*den < EPS, Return[-Infinity]];
  numL = (x43*y13 - y43*x13)/den;
  numM = (x21*y13 - y21*x13)/den;
  If[numM < 0 || numM > 1, Return[-Infinity], Return[numL]];
 ]

lineInt 假定线 L 和 M 不重合。如果两条线是平行的或者包含线段L的线不与线段M相交，它将返回-Infinity。如果包含 L 的线与线段 M 相交，则返回一个标量。假设该标量为 u，则交点为 L[[1]] + u (L[[2]]-L[[1]])。请注意，u 可以是任何实数。您可以使用此操作函数来测试 lineInt 的工作原理。

Manipulate[
   Grid[{{
      Graphics[{
        Line[{p1, p2}, VertexColors -> {Red, Red}],
        Line[{p3, p4}]
       },
       PlotRange -> 3, Axes -> True],
      lineInt[{p1, p2}, {p3, p4}]
     }}],
   {{p1, {-1, 1}}, Locator, Appearance -> "L1"},
   {{p2, {2, 1}}, Locator, Appearance -> "L2"},
   {{p3, {1, -1}}, Locator, Appearance -> "M1"},
   {{p4, {1, 2}}, Locator, Appearance -> "M2"}
]

现在我们知道距离 L[[1]] 有多远对于线段M，我们可以找出线段的哪一部分位于三角形内。

lineInTri[L_, T_] := Module[{res},
  If[Length@DeleteDuplicates[Flatten[{T, L}, 1], SquaredEuclideanDistance[#1, #2] < 10^-6 &] == 3, Return[{}]];
  res = Sort[Map[lineInt[L, #] &, {{T[[1]], T[[2]]}, {T[[2]], T[[3]]},  {T[[3]], T[[1]]} }]];
  If[res[[3]] == Infinity || res == {-Infinity, -Infinity, -Infinity}, Return[{}]];
  res = DeleteDuplicates[Cases[res, _Real | _Integer | _Rational], Chop[#1 - #2] == 0 &];
  If[Length@res == 1, Return[{}]];
  If[(Chop[res[[1]]] == 0 && res[[2]] > 1) || (Chop[res[[2]] - 1] == 0 && res[[1]] < 0), Return[{0, 1}]];
  If[(Chop[res[[2]]] == 0 && res[[1]] < 0) || (Chop[res[[1]] - 1] == 0 && res[[2]] > 1), Return[{}]];
  res = {Max[res[[1]], 0], Min[res[[2]], 1]};
  If[res[[1]] > 1 || res[[1]] < 0 || res[[2]] > 1 || res[[2]] < 0, Return[{}], Return[res]];
 ]

该函数返回L行中需要删除的部分。例如，如果它返回 {.5, 1}，这意味着您将删除该行的 50%，从线段的一半开始到线段的终点。如果 L = {A, B} 并且函数返回 {u, v} 那么这意味着线段 {A+(BA)u, A+( BA)v} 是三角形 T 中包含的直线部分。

实现 lineInTri 时，您需要注意线 L 不是 T 的边缘之一，如果是这种情况，则该线不在三角形内。这就是舍入错误可能很糟糕的地方。当Mathematica导出图像时，有时一条线位于三角形的边缘，但这些坐标有一定的差异。由我们来决定线与边缘的距离有多近，否则函数将看到线几乎完全位于三角形内部。这就是函数第一行的原因。要查看一条线是否位于三角形的边上，我们可以列出三角形和线的所有点，并删除所有重复项。在这种情况下，您需要指定重复项是什么。最后，如果我们得到一个包含 3 个点的列表，则意味着一条线位于边缘上。下一部分有点复杂。我们所做的是检查线 L 与三角形 T 每条边的交点，并将结果存储在列表中。接下来，我们对列表进行排序，并找出该线的哪一部分（如果有）位于三角形内。尝试通过玩这个来理解它，一些测试包括检查线的端点是否是三角形的顶点，线是否完全在三角形内部，部分在内部或完全在外部。

Manipulate[
  Grid[{{
    Graphics[{
      RGBColor[0, .5, 0, .5], Polygon[{p3, p4, p5}],
      Line[{p1, p2}, VertexColors -> {Red, Red}]
     },
     PlotRange -> 3, Axes -> True],
    lineInTri[{p1, p2}, {p3, p4, p5}]
   }}],
 {{p1, {-1, -2}}, Locator, Appearance -> "L1"},
 {{p2, {0, 0}}, Locator, Appearance -> "L2"},
 {{p3, {-2, -2}}, Locator, Appearance -> "T1"},
 {{p4, {2, -2}}, Locator, Appearance -> "T2"},
 {{p5, {-1, 1}}, Locator, Appearance -> "T3"}
]

lineInTri 将用于查看线条的哪一部分不会被绘制。这条线很可能会被许多三角形覆盖。因此，我们需要保留每条线中不会绘制的所有部分的列表。这些列表不会有顺序。我们所知道的是，这个列表是一维段。每一个都由 [0,1] 区间内的数字组成。我不知道一维段的联合函数，所以这是我的实现。

union[obj_] := Module[{p, tmp, dummy, newp, EPS = 10^-3},
  p = Sort[obj];
  tmp = p[[1]];
  If[tmp[[1]] < EPS, tmp[[1]] = 0];
  {dummy, newp} = Reap[
    Do[
     If[(p[[i, 1]] - tmp[[2]]) > EPS && (tmp[[2]] - tmp[[1]]) > EPS, 
       Sow[tmp]; tmp = p[[i]], 
       tmp[[2]] = Max[p[[i, 2]], tmp[[2]]]
      ];
     , {i, 2, Length@p}
    ];
    If[1 - tmp[[2]] < EPS, tmp[[2]] = 1];
    If[(tmp[[2]] - tmp[[1]]) > EPS, Sow[tmp]];
   ];
  If[Length@newp == 0, {}, newp[[1]]]
 ]

这个函数会更短，但这里我包含了一些 if 语句来检查数字是否接近零或一。如果一个数字是 EPS 除了零之外，那么我们将这个数字设为零，这同样适用于 1。我在这里讨论的另一个方面是，如果要显示的段的部分相对较小，那么很可能需要将其删除。例如，如果我们有 {{0,.5}, {.500000000001}}，这意味着我们需要绘制 {{.5, .500000000001}}。但这条线段非常小，甚至在一条大线段中都很难被注意到，因为我们知道这两个数字是相同的。实现联合时需要考虑所有这些事情。

现在我们准备看看需要从线段中删除什么。接下来需要从 G3ToG2Info 生成的对象列表、该列表中的一个对象和一个索引。

getSections[L_, obj_, start_ ] := Module[{dummy, p, seg},
  {dummy, p} = Reap[
    Do[
     If[Length@obj[[i]] == 3,
      seg =  lineInTri[L, obj[[i]]];
      If[Length@seg != 0, Sow[seg]];
     ]
     , {i, start, Length@obj}
    ]
   ];
  If[Length@p == 0, Return[{}], Return[union[First@p]]];
 ]

getSections 返回一个列表，其中包含需要从 L 中删除的部分。我们知道 obj 是三角形、线条和颜色的列表，我们知道列表中索引较高的对象将绘制在索引较低的对象之上。因此我们需要索引start。这是我们将开始在 obj 中寻找三角形的索引。一旦找到三角形，我们将使用函数 lineInTri 获得位于三角形内的线段部分。最后，我们将得到一个部分列表，我们可以使用union将其组合起来。

最后，我们到达getHiddenLines。所需要的只是查看 G3ToG2Info 返回的列表中的每个对象并应用函数 getSections。 getHiddenLines 将返回列表的列表。每个元素都是需要删除的部分的列表。

getHiddenLines[obj_] := Module[{pts},
  pts = Table[{}, {Length@obj}];
  Do[
   If[Length@obj[[j]] == 2,
      pts[[j]] = getSections[obj[[j]], obj, j + 1]
    ];
    , {j, Length@obj}
   ];
   Return[pts];
  ]

---

getFrame

如果您已经成功理解了到目前为止的概念，我相信您知道接下来要做什么。如果我们有三角形、线条和颜色的列表以及需要删除的线条部分，我们只需绘制可见的颜色和线条部分。首先我们创建一个complement函数，这将告诉我们到底要画什么。

complement[obj_] := Module[{dummy, p},
  {dummy, p} = Reap[
    If[obj[[1, 1]] != 0, Sow[{0, obj[[1, 1]]}]];
    Do[
     Sow[{obj[[i - 1, 2]], obj[[i, 1]]}]
     , {i, 2, Length@obj}
    ];
    If[obj[[-1, 2]] != 1, Sow[{obj[[-1, 2]], 1}]];
   ];
  If[Length@p == 0, {}, Flatten@ First@p]
 ]

现在是 getFrame 函数

getFrame[obj_, pts_] := Module[{dummy, lines, L, u, d},
  {dummy, lines} = Reap[
    Do[
     L = obj[[i]];
     If[Length@L == 2,
      If[Length@pts[[i]] == 0, Sow[L]; Continue[]];
      u = complement[pts[[i]]];
      If[Length@u > 0, 
       Do[
        d = L[[2]] - L[[1]];
        Sow[{L[[1]] + u[[j - 1]] d, L[[1]] + u[[j]] d}]
        , {j, 2, Length@u, 2 }]
      ];
    ];
    If[Length@L == 1, Sow[L]];
    , {i, Length@obj}]
  ];
 First@lines
]

---

最后的话

我对算法的结果有些满意。我不喜欢的是执行速度。我已经像在 C/C++/java 中使用循环一样编写了此代码。我尽力使用 Reap 和 Sow 来创建不断增长的列表，而不是使用函数 Append。不管怎样，我仍然必须使用循环。需要注意的是，这里发布的线框图片生成需要 63 秒。我尝试为问题中的图片制作线框，但这个 3D 对象包含大约 32000 个对象。计算一行需要显示的部分大约需要 13 秒。如果我们假设有 32000 行，并且需要 13 秒来完成所有计算，则计算时间约为 116 小时。

我确信，如果我们在所有例程上使用Compile 函数，并且也许找到一种不使用Do 循环的方法，那么这个时间就可以减少。我可以在这里获得 Stack Overflow 的帮助吗？

为了您的方便，我已将代码上传到网络。您可以在此处找到它。如果您可以将此代码的修改版本应用于问题中的绘图并显示线框，我会将您的解决方案标记为本文的答案。

最好的，
J·曼努埃尔·洛佩兹

Answer 2

这是不对的，但有点有趣：

Plot3D[Sin[x + y^2], {x, -3, 3}, {y, -2, 2}, Boxed ->错误的，
绘图样式 -> {EdgeForm[无]，FaceForm[红色，无]}，网格 -> False]

如果 FaceForm 为 None，则不会渲染多边形。我不确定是否有办法用网格线来做到这一点。