Note

This Mathematica notebook is from the WWW project A Visual Dictionary of Special Plane Curves. Copyright © 1995-2000 by Xah Lee. (http://xahlee.org/)

Packages and Initializations

Needs["ParaPlot`"];
(* MathSource Item:0207-986 *)

Needs["PlaneCurveFormulas`"];

Needs["RuledSurfacePlot`"];
(* MathSource Item#: 0207-975 *)

Needs["ExtendGraphics`Geometry3D`"];
(* MathSource Item:0208-976 *)

Needs["GraphicsOperations`"];
(* MathSource Item#:/Enhancements/Graphics/2D/0204-792
by Jeff Adams, ~1993
 *)

Needs["Graphics`Shapes`"];(* 0200-608 *)

Needs["Graphics`Polyhedra`"];(* MathSource#0200-596 *)

Off[General::spell];

Clear[plane];
\(\(\(plane::"usage" = "plane[{xMin,xMax,xStep},{yMin,yMax,yStep}] generates a list of Graphics3D primitive Lines that represents a plane in 3D space. The lines lie in the x-y plane. Example, Show[ Graphics3D@ plane[{0,1,.05}, {2,6,.1}]]";\)\(
\)
    \)\)
\(\(\(plane[{xMin_, xMax_, xStep_}, {yMin_, yMax_, yStep_}] := 
        Module[{}, 
          Join[Table[
              Line[{{i, yMin, 0}, {i, yMax, 0}}], {i, xMin, xMax, xStep}], 
            Table[Line[{{xMin, i, 0}, {xMax, i, 0}}], {i, yMin, yMax, 
                yStep}]]];\)\(
\)
    \)\)
\(\(\(Clear[referenceFrame3DGP, cuttingPlane3DGP];\)\(
\)
    \)\)
referenceFrame3DGP = 
        N[{plane[{-cbr, cbr, ((2 cbr)/4)}, {-cbr, 
                cbr, ((2 cbr)/4)}], 
            RotateShape[plane[{0, cbr, (cbr/2)}, {0, cbr, (cbr/2)}], 
              0, -(π/2), 0], 
            RotateShape[
              plane[{0, cbr, (cbr/2)}, {0, cbr, 
                  (cbr/2)}], -(π/2), -(π/2), (π/2)]}];

On[General::spell];

The usage message for RotateShape is not clear. Here we redefine its usage message. (RotateShape is a function in Graphics`Shapes)

RotateShape::"usage" = "RotateShape[graphics3D, phi, θ, \
psi] rotates the three-dimensional graphics object by the specified Euler \
angles. That is, clockwise on z-axis, clockwise on x-axis, then clockwise on \
z-axis again. Clockwise means looking from the positive side of the axis \
towards the origin.";

\(\(\(Clear[Slice3DGraphics];\)\(
\)
    \)\)
\(\(\(Slice3DGraphics::"usage" = " Slice3DGraphics[ graphics3DPrimitives,  sliceAxis, {p1, p2,...,pn} ] will return a list of Graphics3D primitives that is parts of the given graphics3DPrimitives sliced along planes passing through a list of nPoints {p1, p2,...,pn} and normal to sliceAxis vector. Graphics that lies outside the first and last cutting plane will be clipped. The number of Graphics3D objects returned depends on positions of nPoints. The nPoints that define the slicing plane must be in order; towards the direction of sliceAxis vector. sliceAxis is a vector of the form {x,y,z}. Slice3DGraphics calls functions in the package ExtendGraphics`Geometry3D.";\)\(
\)
    \)\)
\(Slice3DGraphics[gp_List, axis_List, throughPoints_List] := 
	
      Module[{pieces, remain}, 
        remain = gp; 
		pieces = Table[Null, {Length[throughPoints] - 1}]; 
        Do[remain = 
            Clip3D[remain, 
              Plane[throughPoints[[i]], 
                axis]]; 
			pieces[[
              i]] = 
            Clip3D[remain, 
              Plane[throughPoints[[
                  i + 1]], \(-axis\)]], {i, 
            Length[pieces]}]; pieces]\)

unitV[v_] := v/Sqrt[v.v];

SetOptions[{Plot3D, ParametricPlot3D, Graphics3D}, Axes -> True, 
        AxesLabel -> {"x", "y", "z"}, 
        LightSources :> 
          Table[{{Random[], Random[], Random[]}, 
              Hue[Random[], Random[Real, { .5, 1}], 
                Random[Real, { .4,  .9}]]}, {Random[
                Integer, {2, 3}]}]];

Off[General::spell];

Clear[α, θ, v0n0];
\(\(\(Clear[v0\ , \ v1\ , \ v2\ , \ v0v1\ , \ v0v2\ , \ v1v2\ , \ n0, \ 
        c0\ , \ c0v1\ , \ c0f1, 
f1\ , \ f2\ , \ v0f1\ , \ v0f2\ , \ v1f1, \ 
        b0, \ v0b0, \ s1, \ s2, \ s1j1, \ s2j2, 
v0s1, \ v0s2, \ v0j1, \ 
        v0j2\ , \ v0c1, \ v0c2\ , \ c1j1\ , \ c2j2, \ c1d1\ , \ d1, \ 
        d2];\)\(
\)
    \)\)
v0 = {0, 0};
v1 = {v0n0 Csc[α + θ] Sin[α], 
          v0n0 Cos[α] Csc[α + θ]};
v2 = {v0n0 Csc[α - θ] Sin[α], -(v0n0 Cos[α] Csc[α - θ])};
v0v1 = (Sqrt[(v0n0^2) Csc[α + θ]^2]);
v0v2 = (Sqrt[(v0n0^2) Csc[α - θ]^2]);
v1v2 = (Sqrt[(v0n0^2) Csc[α - θ]^2 Csc[α + θ]^2 Sin[2 α]^2]);
n0 = {Cos[θ], Sin[θ]} v0n0;
c0 = {v0n0 Cos[θ] Csc[α - θ] Csc[α + θ] Sin[α]^2, -v0n0 Cos[α]^2 Csc[α - θ] Csc[α + θ] Sin[θ]};
c0v1 = 
        (1/2) (Sqrt[(v0n0^2) Csc[α - θ]^2 Csc[α + θ]^2 Sin[2 α]^2]);
c0f1 = 
        (1/2) Cos[θ] Sec[α] (Sqrt[(v0n0^2) Csc[α - θ]^2 Csc[α + θ]^2 Sin[2 α]^2]);
f1 = {(1/2) v0n0 Cos[θ] Csc[((α + θ)/2)] Sec[((α - θ)/2)] Sin[α], 
          v0n0 Csc[α - θ] Csc[α + θ] (Cos[θ]^2 Sin[α] - 
                Cos[α]^2 Sin[θ])};
f2 = {(1/2) v0n0 Cos[θ] Csc[((α - θ)/2)] Sec[((α + θ)/2)] Sin[α], -v0n0 Csc[α - θ] Csc[α + θ] (Cos[θ]^2 Sin[α] + 
                Cos[α]^2 Sin[θ])};
v0f1 = (1/(2 (Sqrt[2]))) (√(-(v0n0^2) (-3 + 
                      Cos[2 α] - 2 Cos[α - θ] + 
                      2 Cos[α + θ]) Csc[((α + θ)/2)]^2 Sec[((α - θ)/2)]^2));
v0f2 = (1/(2 (Sqrt[2]))) (√(-(v0n0^2) (-3 + 
                      Cos[2 α] + 2 Cos[α - θ] - 
                      2 Cos[α + θ]) Csc[((α - θ)/2)]^2 Sec[((α + θ)/2)]^2));
v1f1 = 
        (1/2) (Sqrt[(v0n0^2) Sec[((α - θ)/2)]^2 Sec[((α + θ)/2)]^2 Sin[α]^2]);
b0 = {0, v0n0 Csc[θ]};
v0b0 = Abs[v0n0 Csc[θ]];
s1 = {0, 
          (1/2) v0n0 Csc[((α + θ)/2)] Sec[
              (1/2) (-α + θ)]};
s2 = {0, -(1/2) (v0n0 Csc[((α - θ)/2)] Sec[((α + θ)/2)])};
s1j1 = 
        Abs[(1/2) v0n0 Csc[((α + θ)/2)] Sec[((α - θ)/2)] Sin[α]];
s2j2 = 
        Abs[(1/2) v0n0 Csc[((α - θ)/2)] Sec[((α + θ)/2)] Sin[α]];
v0s1 = 
        (1/2) v0n0 Csc[((α + θ)/2)] Sec[
            (1/2) (-α + θ)];
v0s2 = -(1/2) (v0n0 Csc[((α - θ)/2)] Sec[((α + θ)/2)]);
v0j1 = 
        (1/2) (v0n0 Csc[((α + θ)/2)] Sec[
                (1/2) (-α + θ)]) Cos[α];
v0j2 = -(1/2) (v0n0 Csc[((α - θ)/2)] Sec[((α + θ)/2)]) Cos[α];
v0c1 = 
        (1/2) (v0n0 Csc[((α + θ)/2)] Sec[
                (1/2) (-α + θ)]) Cos[α]^2;
v0c2 = -(1/2) (v0n0 Csc[((α - θ)/2)] Sec[((α + θ)/2)]) Cos[α]^2;
c1j1 = 
      (1/2) (v0n0 Csc[((α + θ)/2)] Sec[
              (1/2) (-α + θ)]) Cos[α] Sin[α]; 
    c2j2 = -(1/2) (v0n0 Csc[((α - θ)/2)] Sec[((α + θ)/2)]) Cos[α] Sin[α];
c1d1 = ((v0b0 - v0c1)/Tan)[(π/2) - θ];
d1 = {c1d1, v0c1};
d2 = (c0 - d1) + c0;

On[General::spell];

Illustration of Conic Sections
with
Dandelin Sphere

This notebook contain graphic generating codes that illustrate arbitrary Conic Sections. The output 3D graphics includes a double cone, Dandelin sphere, the cutting plane, and the conics on the cutting plane.
Each section contain codes that is tailored for certain cutting plane angle for the best looking graphics.

Ellipse Cut Illustration

The following graphics generating codes are customized for the case of ellipse cut. 
Execute each cell in turn. You may change the values of α and θ.

Clear[α, θ, v0n0]

α = 35 °;
θ = 65 °;  (* θ > α for ellipse *)
v0n0 = 1;

{α, θ, v0n0} = N@ {α, θ, v0n0};

Clear[ll, ch, cbr]
ll = 
        Which[N[α > θ], 1.5 (Sqrt[v2 . v2]), 
          N[α < θ], 1.5 (Sqrt[v2 . v2]), True, 
          2 (Sqrt[v1 . v1])];
ch = ll Cos[α];
cbr = ll Sin[α];

Clear[conicsCurveGP]

conicsCurveGP = (N@ First@ 
ParametricPlot[
	Evaluate[ Ellipse[Cos@θ/Cos@α][t] c0v1 ],
	{t,0, 2 π},
	DisplayFunction->Identity
]) /. {x_?AtomQ, y_?AtomQ}->{x,y,0};

conicsCurveGP =
TranslateShape[ RotateShape[conicsCurveGP, -π/2, π/2-θ, π/2],
	Insert[c0,0,2]
];

Clear[cuttingPlane3DGP, tangentCirclePlane13DGP, tangentCirclePlane23DGP]

cuttingPlane3DGP = N@
TranslateShape[
	RotateShape[
		plane[{-cbr,cbr,2 cbr/1},
			{-Sqrt[Plus@@((d1-c0)^2)],Sqrt[Plus@@((d1-c0)^2)],2 Sqrt[Plus@@((d1-c0)^2)]/1}],
			0, π/2-θ, π/2],
		Insert[c0,0,2]
	];

tangentCirclePlane13DGP = N@
	TranslateShape[
		plane[
			{-c1d1,c1d1,2 c1d1/1},
			{-cbr,cbr,2 cbr/1}],{0,0,v0c1}];

tangentCirclePlane23DGP = N@
	TranslateShape[
		plane[
			{-First@ d2, First@ d2, 2 (First@ d2)/1},
			{-cbr,cbr,2 cbr/1}],{0,0,v0c2}];

Geodesate[ Octahedron[], 5, s1j1]
Geodesate[ Dodecahedron[], 2, s1j1]
Geodesate[Icosahedron[], 3, s1j1]

Clear[dandelinSphere13DGP, dandelinSphere23DGP]

dandelinSphere13DGP = TranslateShape[ Geodesate[Icosahedron[], 3, s1j1],
	Insert[s1,0,2] ];

dandelinSphere23DGP = TranslateShape[ Geodesate[Icosahedron[], 5, s2j2],
	Insert[s2,0,2] ];

Clear[coneGP, wireFramedConeGP]

coneGP = First@ RuledSurfacePlot[
	{	{ cbr Cos[t], cbr Sin[t], ch},
		{0,0,0}},
	{t,0, 2 π}, PlotPoints->{15,2},
	CheckerBoardPattern->False, Axes->True,
	DisplayFunction->Identity
];

coneGP = DeleteCases[coneGP, _Line|_Hue, -1];

wireFramedConeGP = First@ ParametricPlot3D[
	{#1 Tan[α] Cos[t], #1 Tan[α] Sin[t], #1},
	{t, 0, 2 π},
	DisplayFunction->Identity
]& /@ {v0c1, v0c2};

Clear[slicedConeGP]
slicedConeGP = 
	Slice3DGraphics[ coneGP, Insert[n0,0,2],
	{{0,0,0}, Insert[v1,0,2]}
	];

Show[
	Graphics3D[{
		{Hue[0], Thickness[.007],conicsCurveGP,
		cuttingPlane3DGP,
		tangentCirclePlane13DGP,
		tangentCirclePlane23DGP, wireFramedConeGP},
		{EdgeForm[], SurfaceColor[Hue[.2,.1,.7]], dandelinSphere13DGP},
		{EdgeForm[], SurfaceColor[Hue[.2,.1,.7]], dandelinSphere23DGP},
	{Hue[.75], First@ WireFrame[Graphics3D@ coneGP]},
	{Hue[0], PointSize[.02], Point[ Insert[f1, 0, 2] ], Point[ Insert[f2, 0, 2] ]}
	}],
	PlotRange->{{-First@ d2, First@ d2}, {-cbr, cbr}, {-.05, v0c2+.2}} 1.05,
	Axes->False,
	AxesLabel->{"x","y","z"},
	ViewPoint->{-1, -2.5, -1.168},
	ViewVertical->{0,0,-1}
];

Hyperbola Cut Illustration

The following graphics generating codes are customized for the case of hyperbola cut. 
Execute each cell in turn. You may change the values of α and θ.

Clear[α, θ, v0n0]

α = 45 °;
θ = 15 °;  (* θ < α for hyperbola *)
v0n0 = 1;

{α, θ, v0n0} = N@ {α, θ, v0n0};

Clear[ll, ch, cbr]
(*v2 is always farther away from v0 then v1.
This is so because the way we set up our system.
Specifically, the cutting plane has negative slope.*)

ll = Which[
		α > θ//N, 1.5 Sqrt[v2.v2],
		α < θ//N, 1.5 Sqrt[v2.v2],
		True, 2 Sqrt[v1.v1]
	];

ch = ll Cos[α];
cbr = ll Sin[α];

Clear[conicsCurveGP]

conicsCurveGP = (N@ First@ 
ParametricPlot[
	Evaluate[ Hyperbola[Cos@θ/Cos@α][t] c0v1 ],
	{t,0, π/2, π, 3/2 π, 2 π},
	DisplayFunction->Identity
]) /. {x_?AtomQ, y_?AtomQ}->{x,y,0};

conicsCurveGP =
TranslateShape[ RotateShape[ conicsCurveGP, -π/2, π/2 -θ, π/2],
	Insert[c0,0,2]
];

conicsCurveGP = TakeGraphics[
	conicsCurveGP, {{-cbr,-cbr,-ch},{cbr,cbr,ch}},
	ModifyGraphics->True];

Clear[cuttingPlane3DGP, tangentCirclePlane13DGP, tangentCirclePlane23DGP]

If[
v0b0 > ch,
	cuttingPlane3DGP = N@
	TranslateShape[
		RotateShape[
			plane[
				{-cbr,cbr,2 cbr/1},
				{	0,
					(v0b0+ch) / Cos[θ] - (v0b0-ch)/Cos[θ],
					(v0b0+ch) / Cos[θ] - (v0b0-ch)/Cos[θ]
				}
			],
			0, π/2-θ, π/2],
		{(v0b0-ch) Tan[θ], 0, ch}
	],
	cuttingPlane3DGP = N@
	TranslateShape[
		RotateShape[
			plane[
				{-cbr,cbr,2 cbr/1},
				{	0,
					(v0b0+ch) / Cos[θ] + (ch-v0b0)/Cos[θ],
					(v0b0+ch) / Cos[θ] + (ch-v0b0)/Cos[θ]
				}
			],
			0, π/2-θ, π/2],
		{-(ch-v0b0) Tan[θ], 0, ch}
	]
];

tangentCirclePlane13DGP = N@
	TranslateShape[
		plane[
			{-c1d1,c1d1,2 c1d1/1},
			{-cbr,cbr,2 cbr/1}],{0,0,v0c1}];

tangentCirclePlane23DGP = N@
	TranslateShape[
		plane[
			{-First@ d2, First@ d2, 2 (First@ d2)/1},
			{-cbr,cbr,2 cbr/1}],{0,0,v0c2}];

Geodesate[ Octahedron[], 5, s1j1]
Geodesate[ Dodecahedron[], 2, s1j1]
Geodesate[Icosahedron[], 3, s1j1]

Clear[dandelinSphere13DGP, dandelinSphere23DGP]

dandelinSphere13DGP = TranslateShape[ Geodesate[Icosahedron[], 3, s1j1],
	Insert[s1,0,2] ];

dandelinSphere23DGP = TranslateShape[ Geodesate[Icosahedron[], 3, s2j2],
	Insert[s2,0,2] ];

Clear[coneGP, wireFramedConeGP]

coneGP = First@ RuledSurfacePlot[
	{	{ cbr Cos[t], cbr Sin[t], ch},
		{ cbr Cos[t-π], cbr Sin[t-π], -ch}
	},
	{t,0, 2 π}, PlotPoints->{15,3},
	CheckerBoardPattern->False, Axes->True,
	DisplayFunction->Identity
];

coneGP = DeleteCases[coneGP, _Line|_Hue, -1];

wireFramedConeGP = First@ ParametricPlot3D[
	{#1 Tan[α] Cos[t], #1 Tan[α] Sin[t], #1},
	{t, 0, 2 π},
	DisplayFunction->Identity
]& /@ {v0c1, v0c2};

Clear[slicedConeGP]
slicedConeGP = 
	Slice3DGraphics[ coneGP, Insert[n0,0,2],
	{{0,0,0}, Insert[v1,0,2]}
	];

Show[
	Graphics3D[{
		{Hue[0], Thickness[.007],conicsCurveGP,
		cuttingPlane3DGP,
		tangentCirclePlane13DGP,
		tangentCirclePlane23DGP, wireFramedConeGP},
		{EdgeForm[], SurfaceColor[Hue[.2,.1,.7]], dandelinSphere13DGP},
		{EdgeForm[], SurfaceColor[Hue[.2,.1,.7]], dandelinSphere23DGP},
	{Hue[.75], First@ WireFrame[Graphics3D@ coneGP]},
	{Hue[0], PointSize[.02], Point[ Insert[f1, 0, 2] ], Point[ Insert[f2, 0, 2] ]}
	}],
	Axes->False,
	AxesLabel->{"x","y","z"},
	ViewVertical->{1,0,0},
	ViewPoint->{1,1.8,1.2}
];

Parabola Cut Illustration

The following graphics generating codes are customized for the case of parabola cut. 
Execute each cell in turn. You may change the values of α and θ.

Clear[α, θ, v0n0]

α = θ = 35 °;
v0n0 = 1;

{α, θ, v0n0} = N@ {α, θ, v0n0};

Clear[ll, ch, cbr]
(*v2 is always farther away from v0 then v1.
This is so because the way we set up our system.
Specifically, the cutting plane has negative slope.*)

ll = Which[
		α > θ//N, 1.5 Sqrt[v2.v2],
		α < θ//N, 1.2 Sqrt[v2.v2],
		True, 2 Sqrt[v1.v1]
	];

ch = ll Cos[α];
cbr = ll Sin[α];

Clear[conicsCurveGP]

conicsCurveGP = (N@ First@ 
ParametricPlot[ Evaluate[{-t^2/4,t} v1f1], {t,-5,5},
	DisplayFunction->Identity
]) /. {x_?AtomQ, y_?AtomQ}->{x,y,0};

conicsCurveGP =
TranslateShape[ RotateShape[conicsCurveGP, -π/2, π/2-θ, π/2],
	Insert[v1,0,2] ];

conicsCurveGP = TakeGraphics[
	conicsCurveGP, {{-cbr,-cbr,-ch},{cbr,cbr,ch}},
	ModifyGraphics->True];

Clear[cuttingPlane3DGP, tangentCirclePlane13DGP]

cuttingPlane3DGP = N@
TranslateShape[
	RotateShape[
		plane[{-cbr,cbr,2 cbr/1},{-cbr,v1f1,(cbr+v1f1)/1}],
		0, π/2-θ, π/2
	],
	Insert[v1,0,2]
];

tangentCirclePlane13DGP = N@
	TranslateShape[
		plane[ {-cbr,c1d1,(cbr+c1d1)/1},{-cbr,cbr,2 cbr/1}],{0,0,v0c1}];

Geodesate[ Octahedron[], 5, s1j1]
Geodesate[ Dodecahedron[], 2, s1j1]
Geodesate[Icosahedron[], 3, s1j1]

Clear[dandelinSphere13DGP]

dandelinSphere13DGP = TranslateShape[ Geodesate[Icosahedron[], 3, s1j1] ,
	Insert[s1,0,2] ];

Clear[coneGP, wireFramedConeGP]

coneGP = First@ RuledSurfacePlot[
	{	{ cbr Cos[t], cbr Sin[t], ch},
		{0,0,0}},
	{t,0, 2 π}, PlotPoints->{15,2},
	CheckerBoardPattern->False, Axes->True,
	DisplayFunction->Identity
];

coneGP = DeleteCases[coneGP, _Line|_Hue, -1];

wireFramedConeGP = First@ ParametricPlot3D[
	{#1 Tan[α] Cos[t], #1 Tan[α] Sin[t], #1},
	{t, 0, 2 π},
	DisplayFunction->Identity
]& /@ {v0c1, ch };

Clear[slicedConeGP]

slicedConeGP = 
	Slice3DGraphics[ coneGP, Insert[n0,0,2],
	{{0,0,0}, Insert[v1,0,2]}
	];

Show[
	Graphics3D[{
		{Hue[0], Thickness[.007],conicsCurveGP,
		cuttingPlane3DGP,
		tangentCirclePlane13DGP, First@ wireFramedConeGP},
		{EdgeForm[], SurfaceColor[Hue[.2,.1,.7]], dandelinSphere13DGP},
		{	EdgeForm[GrayLevel[.3]],
			SurfaceColor[Hue[.9]],
			Hue[.75], Thickness[.005], 
			First@ WireFrame[Graphics3D@ slicedConeGP]},
		{Hue[.75], Thickness[.005], Last@ wireFramedConeGP},
		{Hue[0], PointSize[.02], Point[ Insert[f1, 0, 2] ]}
	}],
	Background->GrayLevel[1],
	ViewPoint->{0.988, -3.018, 1.168},
	Axes->False,
	Boxed->True
	(* AxesLabel->{"x","y","z"}*)
];