Уточнение конуса

Question

Пытаясь сделать красивую трехмерную графику конуса, пересекаемого плоскостью, я выбираю небольшую перестройку существующего подхода в Mathematica (т.е. книги С. Мангано и С. Вагона).Предполагается, что код под ним показывает так называемую конструкцию Данделина: внутренняя и внешняя сферы касаются внутри конуса, а также плоскости, пересекающей конус.Точки касания сфер к плоскости одновременно являются фокусами эллипса.

 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.

1. Может кто-нибудь увидеть другой подход к удалению белых пятен?Я предпочитаю GrayLevel[z] с z <0,5. </p>

2. Я был заинтригован с немного другим рисунком пятен на нижней и верхней сферах на графике.У вас есть идеи, как это можно объяснить?

Answer 1

Вы можете построить конус, используя Tube с различными радиусами:

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

Answer 2

Возможно, вы захотите сделать сферы немного меньше:

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

Это взлом, но он избегает проблемы пересечения.

Кроме того, вы можете увеличить PlotPoints на конусе:

PlotPoints -> 100

но это замедлит рендеринг.

Редактировать: Или комбинация из них, чтобы помочь со скоростью и качеством.

Answer 3

Почему никто не предложил просто использовать встроенный Cone[] примитив?

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

Это прекрасно работает здесь (без белых пятен). Кроме того, это не хак или обходной путь. Цель пустого EdgeForm[] - удалить черный контур основания конуса.

_{Я только что понял, что Cone[] имеет прочную основу, также очень хорошо видимую на включенном изображении Так что это не точно так же, как оригинальная RevolutionPlot версия.}