Whitehead Link

Author

Eric W. Weisstein
March 7, 2011

This notebook downloaded from http://mathworld.wolfram.com/notebooks/KnotTheory/WhiteheadLink.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/WhiteheadLink.html.

©2011 Wolfram Research, Inc. except for portions noted otherwise

Initialization

<<Knots`Knots`

Symbol

TraditionalForm[link=WhiteheadLink]

Braid Word

BraidWord[link]//TraditionalForm

Properties

Through[{Arf,LinkCrossingNumber,AmphichiralQ,InvertibleQ}[link]]

Polynomials

AlexanderNabla[link,{x,y}]//TraditionalForm

BLMHoQ[link,x]//TraditionalForm

HomflyP[link,{ℓ,m}]//TraditionalForm

JonesV[link,t]//TraditionalForm

KauffmanF[link,{a,z}]//TraditionalForm

Figure

KnotPlot

Show[ClosedBraid[BraidWord[link],Style->Tube]]

ParametricPlot

Partition[Range[5],2,1]

myParametricPlot[f_,var_,opts___?OptionQ]:=
ParametricPlot[f,Evaluate[{var[[1]],Sequence@@#}],opts]&/@Partition[Rest[var],2]

With[{c=.26,dc=.2,l=.45},
Show[{
myParametricPlot[{Cos[t],Sin[t]},{t,c+dc,π+c,π+dc+c,2Pi+c},PlotStyle->{Black,Thickness[.02]}],
myParametricPlot[(1/(1+((Sin[t])^2))){1.4Cos[t],Sin[t]Cos[t]},{t,0,π/2-.7dc,π/2+.7dc,π+l,π+l+dc,2Pi-l-dc,2Pi-l,2Pi},PlotStyle->{Black,Thickness[.02]}]
},PlotRange->All,Axes->False]
]

Show[{(*layer 1 black line*)ParametricPlot[1/(1+Sin[t]^2) {Cos[t],Sin[t] Cos[t]},{t,0,Pi},PlotStyle->{Thickness[.02],Black},Axes->False],(*layer 2 white line*)ParametricPlot[1/(1+Sin[t]^2) {Cos[t],Sin[t] Cos[t]},{t,1.4 Pi,1.6 Pi},PlotStyle->{Thickness[.05],White},Axes->False],(*layer 3 black line*)ParametricPlot[1/(1+Sin[t]^2) {Cos[t],Sin[t] Cos[t]},{t,Pi,2 Pi},PlotStyle->{Thickness[.02],Black},Axes->False]}]

Show[{(*layer 1 black line*)ParametricPlot[1/(1+Sin[t]^2) {Cos[t],Sin[t] Cos[t]},{t,0,Pi},PlotStyle->{Thickness[.02],Black},Axes->False],(*layer 2 white line*)ParametricPlot[1/(1+Sin[t]^2) {Cos[t],Sin[t] Cos[t]},{t,1.4 Pi,1.6 Pi},PlotStyle->{Thickness[.05],White},Axes->False],(*layer 3 black line*)ParametricPlot[1/(1+Sin[t]^2) {Cos[t],Sin[t] Cos[t]},{t,Pi,2 Pi},PlotStyle->{Thickness[.02],Black},Axes->False]}]

With[{x=1.4},
Show[{
(*layer 1 black line*)
ParametricPlot[1/(1+Sin[t]^2) {x Cos[t],Sin[t] Cos[t]},{t,0,Pi},PlotStyle->{Thickness[.02],Black},Axes->False],
(*layer 2 white line*)
ParametricPlot[1/(1+Sin[t]^2) {x Cos[t],Sin[t] Cos[t]},{t,1 Pi,2 Pi},PlotStyle->{Thickness[.05],Green},Axes->False],
ParametricPlot[{Cos[t],Sin[t]},{t,0,Pi},PlotStyle->{Thickness[.05],White},Axes->False],
(*layer 3 black line*)
ParametricPlot[1/(1+Sin[t]^2) {x Cos[t],Sin[t] Cos[t]},{t,Pi,2 Pi},PlotStyle->{Thickness[.02],Red},Axes->False],
ParametricPlot[{Cos[t],Sin[t]},{t,0,2Pi},PlotStyle->{Thickness[.02],Yellow},Axes->False]
},
PlotRange->All]
]

Maxim Rytin

r[t_]:={Cos[t],Sin[t] Cos[t]}/(1+Sin[t]^2)

ParametricPlot[r[t]+u Normalize@Cross[r'[t]]//Evaluate,{t,0,2 Pi},{u,-.1,.1},Axes->False,Frame->False,PlotPoints->{50,2},BoundaryStyle->None,MeshStyle->None,Mesh->{1,3},MeshShading->{{White},{Black},{Black},{White}}]

Style[%,Antialiasing->True,"PolygonMesh"->True]

Andrew Moylan

r[t_]:={Cos[t],Sin[t] Cos[t]}/(1+Sin[t]^2)

z[t_]:=Sin[t]+1

ParametricPlot3D[Evaluate[Append[r[t]+u Normalize@Cross[r'[t]],z[t]]],{t,0,2 Pi},{u,-.1,.1},Axes->False,Boxed->False,PlotPoints->{100,2},BoundaryStyle->None,MeshStyle->None,Mesh->{1,3},ViewPoint->{0,0,Infinity},ViewVertical->{0,1,0},MeshShading->{{White},{Black},{Black},{White}},Lighting->{{"Ambient",White}}]

Ulises

Graphics`Mesh`MeshInit[]

p=Show[{
ParametricPlot[{Cos[t],Sin[t]},{t,0,2Pi}],
ParametricPlot[1/(1+Sin[t]^2) {14/10 Cos[t],Sin[t] Cos[t]},{t,0,2Pi}]
},PlotRange->All]

lines=Flatten[Cases[p,_Line,Infinity]];

Graphics[lines]

Graphics[slines1=SimplifyPolyLine[lines[[1]],EdgesDistanceGoal->0.001,TestIntersections->False,SegmentLengthGoal->0.5,SegmentPartition->True]]

Graphics[slines2=SimplifyPolyLine[lines[[2]],EdgesDistanceGoal->0.001,TestIntersections->False,SegmentLengthGoal->0.5,SegmentPartition->True]]

slines1

Join[slines1,slines2]

Graphics[{{slines1,slines2},Red,PointSize[0.04],Point@FindIntersections[{slines1,slines2}]}]

components=FindIntersections[slines,Method->"SortBySegment"]/.{{c_,c_},{i_,j_}}->{i,j};

path=slines[[1]];

segments=Partition[path,2,1];

doverlap[{i_,j_}->pt_,r_]:= {Black,Line[segments[[i]]],White,Disk[pt,r],Black,Line[segments[[j]]]}

Graphics[{Thickness[0.005],slines,doverlap[#,0.04]& /@ components}]