Steiner Points

Author

Eric W. Weisstein
December 25, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/PlaneGeometry/SteinerPoints.nb.

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

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

Code

SteinerPointIndices::usage="SteinerPointIndices gives the indices of the hexagonal vertices whose Pascal lines concur in the 20 Steiner points."

SteinerPoints::usage="SteinerPoints[b,{a1,...,a6}] gives a list of the 20 Steiner points for the ellipse with semiminor axis b and hexagon specified by angles ai."

SteinerIntersectionPoint::usage="SteinerIntersectionPoint[n,d] gives the point of intersection of the lines in an n-circle Steiner chain with offset d."

SteinerLines::usage="SteinerLines[k,n,d] gives the lines from the circle tangents (k=1 or 2) in an n-circle Steiner chain with offset d."

SteinerIntersectionPoint[n_,d_]:=Module[{b=(1-Sin[Pi/n])/(1+Sin[Pi/n]),r,c,h=1/2,k=1,p,ctrs,i},c=(1-b)/2;
r=b+c;
p=Table[InversePoint[{{0,0},1},{d+Sqrt[r^2-c^2]Cos[2Pi(i+h)/n],Sqrt[r^2-c^2]Sin[2Pi(i+h)/n]}],{i,n}];
ctrs=Table[InverseCircle[k,{{d+r Cos[2Pi i/n],r Sin[2Pi i/n]},c}][[1]],{i,n}];
Point[Intersections[Line@perp[ctrs[[1]],p[[1]]],Line@perp[ctrs[[2]],p[[2]]]]]]

SteinerLines[1,n_,d_]:=Module[{b=(1-Sin[Pi/n])/(1+Sin[Pi/n]),r,i,c,k=1,ctr,ctrs,h=1/2,o,p,big},c=(1-b)/2;
r=b+c;
big=InverseCircle[k,{{d,0},b}];
p=Table[InversePoint[{{0,0},1},{d+Sqrt[r^2-c^2]Cos[2Pi(i+h)/n],Sqrt[r^2-c^2]Sin[2Pi(i+h)/n]}],{i,n}];
o=Table[InversePoint[{{0,0},1},{d+b Cos[2Pi i/n],b Sin[2Pi i/n]}],{i,n}];
ctrs=Table[InverseCircle[k,{{d+r Cos[2Pi i/n],r Sin[2Pi i/n]},c}][[1]],{i,n}];
ctr=Intersections[Line@perp[ctrs[[1]],p[[1]]],Line@perp[ctrs[[2]],p[[2]]]];
Table[Line[Intersections[Circle[ctr,p[[i]]],Line[{big[[1]],big[[2]]}]]],{i,n}]]

SteinerLines[2,n_,d_]:=Module[{b=(1-Sin[Pi/n])/(1+Sin[Pi/n]),r,i,c,k=1,ctr,ctrs,h=1/2,o,p,big},c=(1-b)/2;
r=b+c;
big=InverseCircle[k,{{d,0},b}];
p=Table[InversePoint[{{0,0},1},{d+Sqrt[r^2-c^2]Cos[2Pi(i+h)/n],Sqrt[r^2-c^2]Sin[2Pi(i+h)/n]}],{i,n}];
o=Table[InversePoint[{{0,0},1},{d+b Cos[2Pi i/n],b Sin[2Pi i/n]}],{i,n}];
ctrs=Table[InverseCircle[k,{{d+r Cos[2Pi i/n],r Sin[2Pi i/n]},c}][[1]],{i,n}];
ctr=Intersections[Line@perp[ctrs[[1]],p[[1]]],Line@perp[ctrs[[2]],p[[2]]]];
Table[Line[Intersections[Circle[o[[i]],ctr],Line[{big[[1]],big[[2]]}]]],{i,n}]]

SteinerPointIndices:=Module[{l=PascalHexagonIndices,i},Union[Table[Sort[CyclicOrder/@{l[[i]],l[[i]][[{1,4,3,6,5,2}]],l[[i]][[{1,6,3,2,5,4}]]}],{i,Length[l]}]]]

SteinerPoints[b_,ang_List]:=Module[{v,i,s=SteinerPointIndices},v=Table[{Cos[ang[[i]]],b Sin[ang[[i]]]},{i,6}];
Table[Select[{Intersections[LongestLine[v[[s[[i,1]]]]],LongestLine[v[[s[[i,2]]]]]],Intersections[LongestLine[v[[s[[i,1]]]]],LongestLine[v[[s[[i,3]]]]]],Intersections[LongestLine[v[[s[[i,2]]]]],LongestLine[v[[s[[i,3]]]]]]},ListQ][[1]],(*All 3 should be the same*){i,Length[s]}]]

Brocard

Figure

tri={{0.,0.},{1.,1.3},{3.,0.}};
bt=BrocardTriangle[1,tri][[1]];
pts={SteinerPoint,"S",TarryPoint,"T",Circumcenter,"O",
	tri[[1]],"A",tri[[2]],"B",tri[[3]],"C",
	bt[[1]],"",bt[[2]],"",bt[[3]],""};
s=SteinerPoint[tri][[1]];
l=Table[Line[{tri[[i]],s}],{i,3}];

Show[Graphics[{
			{Dashing[{.02,.02}],l},
			{Dashing[{.01,.04}],Line[{SteinerPoint[tri],TarryPoint[tri]} /. Point->Identity]},
			Dashing[{}],
			Triangle[tri],Circumcircle[tri],
			BrocardTriangle[1,tri],
			PointLabels[tri,pts,.03]
}],AspectRatio->Automatic]

Triangle Center

((b c(a^2-b^2)(a^2-c^2))/(a b c(a^2-b^2)(a^2-c^2)(b^2-c^2)))

Pascal's Theorem

If the six points on a {\sc Conic} in {\sc Pascal's Theorem} are joined in all possible ways, one
obtains 60 {\sc Pascal
Lines} which intersect 3 by 3 in 20 Steiner points.

SteinerPointsEllipse[e_,ang_:0.,pt_List]:=Module[
  {
    b=Sqrt[1-e^2],
    i,ellipse,
    rot={{-Cos[ang Degree],Sin[ang Degree]},{Sin[ang Degree],Cos[ang Degree]}},
    lines={},lines2={},
    points={},dr={},len=10.
  },
  ellipse=ParametricPlot[{Cos[t],b Sin[t]},{t,0,2 Pi},Ticks->None,Axes->None];
  points=Table[
    N[b/Sqrt[b^2 Cos[2Pi pt[[i]]]^2+Sin[2Pi pt[[i]]]^2] {Cos[2Pi pt[[i]]],Sin[2Pi pt[[i]]]}],
      {i,1,Length[pt]}
  ];
  Do[For[j=i+1,j<=Length[pt],j++,lines=Append[lines,Line[{points[[i]],points[[j]]}]]],
    {i,1,Length[pt]}];
  Do[dr=lines[[i,1,2]]-lines[[i,1,1]];
    lines2=Append[lines2,Line[{lines[[i,1,1]]-len dr,lines[[i,1,2]]+len dr}]],
    {i,1,Length[lines]}];
  Show[ellipse,Graphics[PointSize[.02],Map[Point,points]],Graphics[lines2],PlotRange->All]
]

Clear[SteinerPointsEllipse,points]

SteinerPointsEllipse[.1,20.,{0.,.1,.25,.4,.5,.7}]