锥形图像细化答案

【问题标题】：Cone image refinement锥形图像细化
【发布时间】：2011-11-23 00:18:25
【问题描述】：

为了制作一个与平面相交的圆锥体的漂亮 3D 图形，我选择了对 Mathematica 中现有方法的轻微重新排列（即 S.Mangano 和 S.Wagon 的书籍）。假设下面的代码显示了所谓的 Dandelin 结构：内球体和外球体在内部与锥体相切，并且还与与锥体相交的平面相切。球体与平面的切点同时是椭圆的焦点。

 Block[{r1, r2, m, h1, h2, C1, C2, M, MC1, MC2, T1, T2, cone, slope, plane},
   {r1, r2} = {1.4, 3.4};
    m = Tan[70.*Degree];
    h1 := r1*Sqrt[1 + m^2];
    h2 := r2*Sqrt[1 + m^2];
    C1 := {0, 0, h1};
    C2 := {0, 0, h2};
    M = {0, MC1 + h1};
    MC2 = MC1*(r2/r1);
    MC1 = (r1*(h2 - h1))/(r1 + r2);
    T1 = C1 + r1*{-Sqrt[1 - r1^2/MC1^2], 0, r1/MC1};
    T2 = C2 + r2*{Sqrt[1 - r2^2/MC2^2], 0, -(r2/MC2)};

    cone[m_, h_] := RevolutionPlot3D[{t, m*t}, {t, 0, h/m}, Mesh -> False][[1]];
    slope = (T2[[3]] - T1[[3]])/(T2[[1]] - T1[[1]]);
    plane = ParametricPlot3D[{t, u, slope*t + M[[2]]}, {t, -2*m, 12/m}, {u, -3, 3},
                              Boxed -> False, Axes -> False][[1]];
    Graphics3D[{{Gray, Opacity[0.39], cone[m, 1.2*(h2 + r2)]},
                {Opacity[0.5], Sphere[C1, r1], Sphere[C2, r2]},
                {LightBlue, Opacity[0.6], plane},
                 PointSize[0.0175], Point[T1], Point[T2]},
                 Boxed -> False, Lighting -> "Neutral", 
                 ViewPoint -> {-1.8, -2.5, 1.5}, ImageSize -> 950]]

这是图形：

问题在于切点附近两个球体周围的白点。将上面的代码放到Manipulate[...GrayLevel[z]...{z,0,1} ]，我们可以很容易地“删除”z 趋于 1 的点。

谁能看到去除白点的不同方法？我更喜欢 z GrayLevel[z]。
我对图形上上下球体上的斑点图案略有不同很感兴趣。你有什么想法可以解释吗？

【问题讨论】：

为漂亮的图形+1（即使它确实有“白点”）！圆锥曲线上的一些旧数学真的很漂亮，包括你问题中的丹德林结构。

标签： image math wolfram-mathematica geometry

【解决方案1】：

您可以使用具有不同半径的Tube 构造圆锥体：

cone[m_, h_] := {CapForm[None], Tube[{{0, 0, 0}, {0, 0, h}}, {0, h/m}]};

【讨论】：

有人能解释一下这是如何工作的吗？交叉点似乎不是基于渲染的多边形。
不错的一个。我不知道Tube 的这种变化。它隐藏在其文档页面的“更多信息”部分。

【解决方案2】：

你可能想让球体稍微小一点：

Sphere[C1, .98 r1], Sphere[C2, .98 r2]

这是一个 hack，但它避免了交叉问题。

或者，您可以将 PlotPoints 放在圆锥上：

PlotPoints -> 100

但这会使渲染变慢。

编辑：或将这些组合以帮助提高速度和质量。

【讨论】：

PlotPoints -> 60 在我的机器上就足够了，而且渲染时间只会加倍。
@Arnoud，谢谢！设置Sphere[C1, .985 r1], Sphere[C2, .985 r2] 和PlotPoints -> 100 时几乎看不到白点，但使用Sphere[C1, .98 r1], Sphere[C2, .98 r2] 我不需要额外的PlotPoints 选项。

【解决方案3】：

为什么没有人建议只使用内置的Cone[] 原语？

cone[m_, h_] := {EdgeForm[], Cone[{{0, 0, h}, {0, 0, 0}}, h/m]};

这在这里工作正常（没有白点）。此外，这不是黑客或解决方法。空EdgeForm[]的目的是为了去掉圆锥底的黑色轮廓。

_{我刚刚意识到Cone[] 有一个坚实的基础，在包含的图像上也非常明显。所以这与原来的RevolutionPlot 版本完全不一样。}

【讨论】：