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["PlaneCurveGenerator`"]

Needs["Graphics`ImplicitPlot`"]
(*MathSource Item:0200-529*)

Needs["Graphics`Shapes`"]	(* MathSource Item#: 0200-608 *)

Needs["ExtendGraphics`Geometry3D`"]
(* MathSource Item#:/Enhancements/Graphics/3D/0205-041 *)

Clear[ Slice3DGraphics]

(*Clip3D is a function in Tom W.J.'s Package*)
(*It is not well documented. Here's a replacement usage documentation*)
Clip3D::usage= "Clip3D[ gPrim, Plane[p,v] ]
	will take a list of Graphics3D primitives gPrim, and return a list of
	Graphics3D primitives that is on one side of the plane Plane[p,v],
	where v is the normal vector and p is a point on the plane. Primitives
	that contain points on both sides are cut. Example:
	Needs[\"Graphics`Shapes`\"];
	Show@ Graphics3D@ Clip3D[ Torus[2,1,15,15], Plane[{2,0,0}, {-1,0,0}]]";

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
]

torusSweepingCircles::usage="
torusSweepingCircles[b,a,n,{tMin, tMax},{thetaMin,thetaMax}]
will return Graphics3D primitives of circular arcs that represents
the path of surface of revolution for a torus. Example:
Show@ Graphics3D@ torusSweepingCircles[4,1,6,{1,5},{0, Pi}]";

Clear[torusSweepingCircles]

torusSweepingCircles[b_,a_,n_,{tMin_, tMax_},{thetaMin_,thetaMax_}]:=
	First@ ParametricPlot3D[
		{ (b+First@#) Cos[t], (b+First@#) Sin[t], Last@ #},
		{t, tMin, tMax},
		DisplayFunction->Identity
	]& /@
		( (a{Cos[#], Sin[#]})& /@
			Range[thetaMin,thetaMax,(thetaMax-thetaMin)/(n-1)]
		)

Clear[torusGeneratingCircles]

torusGeneratingCircles::usage="
torusGeneratingCircles[b,a, n, {tMin,tMax}, {thetaMin,thetaMax}]
will return Graphics3D primitives that represents the generating
circles of a torus. Example:
Show@ Graphics3D@ torusGeneratingCircles[3,1, 5, {1,5}, {0,6}]";

torusGeneratingCircles[b_,a_,n_,{tMin_,tMax_},{thetaMin_,thetaMax_}]:=
	First@ ParametricPlot3D[#, {theta, thetaMin, thetaMax},
		DisplayFunction->Identity]& /@
		(Rotate3D[{a Cos[theta],0,a Sin[theta]}+{b,0,0}, -#,0,0]& /@
			Range[tMin, tMax, (tMax-tMin)/(n-1)]
		)

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

Lemniscate of Bernoulli

Lemniscate of Bernoulli is a special case of Cassinian Oval. (see Cassinian Oval) Here we will give a different set of formulas.

Parametric formula: Cos[t]/(1+Sin[t]^2) {1, Sin[t]}, 0 < t <= 2 Pi.
Cartesian equation is (x^2 + y^2)^2 == (x^2-y^2).
Polar equation is r^2 == Cos[2 theta].

Foci: {-1/Sqrt[2],0}, {1/Sqrt[2],0}

ParaPlot[ LemniscateOfBernoulli[][t], {t, 0, 2 Pi},
	AspectRatio->Automatic,
	Epilog->{
		Hue[.65], PointSize[.02], Point[{-1/Sqrt[2],0}],
		Hue[.65], PointSize[.02], Point[{1/Sqrt[2],0}]
	}
];

It is the Inverse of a rectangular Hyperbola with respect to its center.

ParaPlot[ LemniscateOfBernoulli[][t], {t, 0, 2 Pi, 2 Pi/60},
	InversionCircle->{{0,0},1},
	PlotCurve->False,
	PlotRange->{{-1,1}2,{-1,1}1.76},
	AspectRatio->Automatic,
	Axes->False,
	Prolog->{
		Hue[.12],
		Line[{{0,0}, 100 LemniscateOfBernoulli[][#]}]& /@
			Range[0, 2 Pi, 2 Pi/60]
	}
];

ParaPlot[ 
	{	LemniscateOfBernoulli[][t],
		Inversion[ LemniscateOfBernoulli[][t], {{0,0},1}]
	},
	{t, -3.14,3.14},
	PlotStyle->{{Hue[.65]}, {Hue[.0], Thickness[.005]}},
	PlotRange->{{-1,1},{-1,1}} 2,
	AspectRatio->Automatic
];

Its negative Pedal with respect to its center is the rectangular Hyperbola.

Clear[NegativePedalPlot, unitV]

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

NegativePedalPlot::usage = "NegativePedalPlot[{xf,yf},{min,max,step},
	{x0,y0}] draws the negative pedal lines of the parametric curve
	{xf,yf} at points {xf,yf}& /@ Range[min,max,step].
	xf and yf must be pure functions with head Function.
	This is a quick hack function written for experienced
	Mathematica users.
	Example:
	NegativePedalPlot[{Cos@#&, Sin@#&}, {0,2 Pi, 2 Pi/30},{.8,0}]";

NegativePedalPlot[{xf_Function,yf_Function},
	{tmin_,tmax_, dt_}, {a_,b_}, opts___Rule]:=
	Module[{curvePoints, curvePointsGP,pedalPointGP,
		linesToCurveGP, negativePedalLinesGP},
		curvePoints = N@ {xf@ #,yf@ #}& /@ Range[tmin,tmax,dt];
		curvePointsGP = {Hue[0],PointSize[.015], Point[#]}& /@ curvePoints;
		pedalPointGP = {Hue[.7], PointSize[.02], Point[{a,b}]};
		linesToCurveGP = N@ Line[{{a,b},#}]& /@ curvePoints;
		negativePedalLinesGP = Line[{
				100 Reverse[unitV[N[#-{a,b}]]{1,-1}] +#,
				-100 Reverse[unitV[N[#-{a,b}]]{1,-1}] +#
			}]& /@ curvePoints;
		Show[
			Graphics[{ {Hue[.7],linesToCurveGP, negativePedalLinesGP},
				curvePointsGP, pedalPointGP}],
				opts
		]
	]

Off[Power::infy, Infinity::indet, Graphics::gptn]
NegativePedalPlot[
	Function /@ LemniscateOfBernoulli[][#],
	{0, 2 Pi, 2 Pi/40},
	{0,0},
	AspectRatio->Automatic,
	PlotRange->{{-1,1}2,{-1,1}1.76}
];
On[Power::infy, Infinity::indet, Graphics::gptn]

It is the Envelope of Circles with centers on a rectangular Hyperbola and each circle passing the hyperbola's center.

Clear[circles, curve]

circles =
	Table[ Circle[ p = Hyperbola[Sqrt@2][i], Sqrt[p.p] ], 
		{i, -Pi, Pi, 2 Pi/60}
	];

curve = First@ ParametricPlot[
	Evaluate@ Hyperbola[Sqrt@2][t],
	{t,-Pi,-Pi/2,Pi/2,Pi},
	PlotStyle->{Hue[.7,.7,1]},
	AspectRatio->Automatic,
	PlotRange->{{-1,1},{-1,1}}2,
	DisplayFunction->Identity
];

Show[
	Graphics[ 
		{Hue[0], circles, curve}
	],
	AspectRatio->Automatic,
	Axes->False,
	PlotRange->{{-1,1},{-1,1}}4
];

Illustration of slicing a torus to form Cassinian Oval

Lemniscate of Bernoulli can be formed as the intersection of a torus and a plane.

Let b-a be the inner radius of a torus whose generating circle has radius a.
Cassinian oval is the intersection of a plane parallel to the torus' axis and a distant from it. If b == 2 a, then it's Lemniscate of Bernoulli.

Clear[a,b, wallGP, torusGP1, torusGP2, cassOvalGP]
a = 1; b = 2;

wallGP = Table[
	{	Line[{{i,a,-(b+a)},{i,a,(b+a)}}],
		Line[{{-(b+a),a,i},{(b+a),a,i}}]
	},
	{i,-(b+a), (b+a), 2 (b+a)/1}
];

torusGP1 = Clip3D[Torus[b,a,24,20], Plane[{0,a,0},{0,-1,0}]];

torusGP2 =
 Clip3D[
 {
	torusSweepingCircles[b,a, 5,{0, Pi},{0, 2 Pi}],
	torusGeneratingCircles[b,a, 4, {0, Pi}, {0,2 Pi}]
	}
 ,Plane[{0,a,0},{0,1,0}]
];

Show[ 
	Graphics3D[ 
		{	{EdgeForm[],torusGP1},
		{Hue[0], torusGP2},
			 wallGP
		}
	],
	Axes->False,
	Boxed->False,
ViewPoint->{2.169, 2.351, 1.104}
];

Now we wish to add the an outline to the intersection.

The formula of torus with generating circle radius a and center to axis b is

(Sqrt[x^2 + y^2] -b)^2 + z^2 - a^2 == 0

we want to find the intersection of this torus with a plane x=a

so, solve the system of eq. by subsitute x=a,

cassOvalGP = First@ ImplicitPlot[ 
	(Expand[ (Sqrt[x^2 + y^2] -b)^2] + z^2 - a^2 /. x->a)==0,
	{y,-(b+a), (b+a)}
];

cassOvalGP = cassOvalGP /. {x_?AtomQ,y_?AtomQ} ->{x,a,y};

Show[ 
	Graphics3D[ 
		{	{EdgeForm[],torusGP1},
		{Hue[0], Thickness[.003], torusGP2},
		{Hue[.75], wallGP, cassOvalGP}
		}
	],
	Axes->False,
	Boxed->False,
ViewPoint->{0.975, 2.711, 1.775}
];

Graphics Gallery

Off[Power::infy, Infinity::indet, ParametricPlot::pptr]
ParametricPlot[
	Evaluate@
		Conchoid[ LemniscateOfBernoulli[][t], {0,.25}, Range[-2,2,4/40]],
	{t,0, 2 Pi},
	AspectRatio->Automatic,
	Axes->False,
	PlotStyle->Table[ GrayLevel[i], {i,0, 1,1/10}],
	Background->GrayLevel[0]
];
On[Power::infy, Infinity::indet, ParametricPlot::pptr]