Pascal's Mystic Hexagon

(* LineThru[M,N]— Return Line[] through M and N, clipped to plot range(([-2,2])^2) *)
LineThru[T_,Q_]:=Module[{x,y,gotone=0,dP=T-Q},
If[Chop[dP]=={0,0},
Point[T],(* same points *)
Line[Reap[
If[dP[[1]] ≠0&&-2≤(y=T[[2]]+((dP[[2]](2-T[[1]]))/(dP[[1]] )))≤2, Sow[{2,y}];++gotone];
If[dP[[1]] ≠0&&-2≤(y=T[[2]]+((dP[[2]](-2-T[[1]]))/(dP[[1]] )))≤2, Sow[{-2,y}];++gotone];
If[dP[[2]] ≠0&&-2≤(x=T[[1]]+((dP[[1]](2-T[[2]]))/(dP[[2]] )))≤2&&gotone<2, 
If[x≠2&&x≠-2,Sow[{x,2}];++gotone]];
If[dP[[2]] ≠0&&-2≤(x=T[[1]]+((dP[[1]](-2-T[[2]]))/(dP[[2]] )))≤2&&gotone<2, Sow[{x,-2}];++gotone];
][[2,1]]]]
];

(* LineIntersect[P,Q,R,S]— Return {x,y} of intersection of lines PQ and RS *)
LineIntersect[T_,Q_,R_,S_]:=Quiet[Check[T+(Q-T)LinearSolve[{Q-T,R-S}//Transpose,R-T][[1]],	(* no intersection: return ∞, i.e. (10^4) *)
If[Chop[Q-T]≠{0,0},(* not same pts *)
(10^4)(Q-T)/Norm[Q-T],
If[Chop[R-S]≠{0,0},(* not same pts *)
(10^4)(R-S)/Norm[R-S],
{(10^4),0}] (* both pairs of points identical (arb. ans.) *)
]]];

(* Class[myPts]— return {class,coefficient} of conic/quad.eqn.thru first 5 points (ABCDE) in myPts *)
Class[myPts_]:=Module[{m,ns,det,discr,coeff},
If[Length[Union[myPts]]≠Length[myPts],
coeff=ConstantArray[0,6];Return[{Style["duplicate points",Italic],coeff}]];
m=Table[{i[[1]]^2,i[[1]]i[[2]],i[[2]]^2,i[[1]],i[[2]],1},{i,myPts}];coeff=First[ns=NullSpace[m]];
If[Length[ns]>1,Return[{"degenerate",coeff}]];
det=Det[(({{coeff[[1]], ((coeff[[2]])/2), ((coeff[[4]])/2)}, {((coeff[[2]])/2), coeff[[3]], ((coeff[[5]])/2)}, {((coeff[[4]])/2), ((coeff[[5]])/2), coeff[[6]]}}))];
If[Chop[det,(10^(-5))]==0,
{"degenerate",coeff},
discr=Det[(({{coeff[[1]], ((coeff[[2]])/2)}, {((coeff[[2]])/2), coeff[[3]]}}))];
Which[
Chop[discr,(10^(-4))]== 0,{"parabola",coeff},
discr < 0,{"hyperbola",coeff},
discr > 0, {If[Chop[coeff[[3]]-coeff[[1]]]==0,"circle","ellipse"],coeff}
]]
];

(* MyColor: Returns a color for each named Point (defines the color scheme) *)
MyColor["X"]=Darker[Red];
Do[MyColor[c]=Darker[Blue],{c,CharacterRange["A","F"]}];
Do[MyColor[c]=Lighter[Purple],{c, {"R","S","T"}}];

Manipulate[With[{
δ={(10^(-3)),(10^(-4))}(* offset X = pts[[6]] so as not to coincide w/other pts *)},

If[preset≠"",
If[preset=="reset trace",trace={};wasInPlotRange=False,
pts=Join[Cases[presetList,{preset,_},1,1][[1,2]],{pts[[6]]}]
];
preset="" (* reset *)
];
PR=LineIntersect[pts[[1]],pts[[2]],pts[[5]],pts[[4]]];
PS=LineIntersect[pts[[1]],pts[[6]]+δ,pts[[3]],pts[[4]]];
PT=LineIntersect[pts[[3]],pts[[2]],PR,PS];
PF=LineIntersect[pts[[1]],pts[[6]]+δ,pts[[5]],PT];
configChanged=Drop[pts,-1]=!=prevConfig;
If[configChanged,
prevConfig=Drop[pts,-1];
trace={};wasInPlotRange=False;lastPF=PF];
	(* This controls when plot is recomputed *)
If[configChanged||wasActive,
{classlabel,coeff}=Class[Drop[pts,-1]];
	(* Round coeff so Tooltip looks nice - negligible error *)
plot=ContourPlot[Round[coeff,(10.^(-3))].{x^2,x y, y^2,x,y,1}==0,{x,-2,2},{y,-2,2},Frame->False,PlotRange->2,PlotRangePadding->0,ContourStyle->{Thick,LightRed},BaseStyle->{"Label",14},PlotLabel->classlabel];
wasActive=$ControlActiveSetting;
];
	(* What is seen *)
Show[
If[MemberQ[toShow,"conic"],
plot,
Graphics[{},PlotRange->2,PlotRangeClipping->True,PlotRangePadding->0,BaseStyle->{"Label",14},PlotLabel->classlabel]],
Graphics[{
	(* Lines *)
{Blue,LineThru[pts[[1]],pts[[2]]],LineThru[pts[[5]],pts[[4]]],LineThru[pts[[3]],pts[[4]]],LineThru[pts[[3]],pts[[2]]]},
{Thick,LineThru[pts[[1]],pts[[6]]+δ]}, (* AX *)
{ControlActive[Lighter[Purple],Blue],LineThru[pts[[5]],PF]},
{Thick,Lighter[MyColor["R"]],Line[{PR,PS,PT}]}, (* Pascal line RST *)
If[MemberQ[toShow,"trace"],
If[PF=!=lastPF, (* Maintain trace *)
If[-2≤PF[[1]]≤2&&-2≤PF[[2]]≤2,
If[wasInPlotRange,
	(* in -> in: add to current segment *)
AppendTo[trace[[trace//Length]],PF],
	(* out -> in: start new segment *)
AppendTo[trace,{lastPF,PF}] 
];
wasInPlotRange=True,
If[wasInPlotRange,
	(* in -> out: add to current segment *)
AppendTo[trace[[trace//Length]],PF]
	(* out -> out: skip *)
];
wasInPlotRange=False
]
];
lastPF=PF;
{Thick,Red,Line[trace]},(* Show trace *)
{} (* Don't show trace *)
],
	(* Points not Locators *)
Table[ (* RST *)
Inset[Graphics[{Nest[Lighter,MyColor["R"],4],EdgeForm[MyColor[p[[1]]]],Disk[],MyColor[p[[1]]],Style[Text[p[[1]],{0,0},{-0.3,0.1}],"Label"]},ImageSize->15],p[[2]]],{p,{{"R",PR},{"S",PS},{"T",PT}}}],
Inset[Graphics[{Nest[Lighter,MyColor["F"],5], (* F *)
EdgeForm[MyColor["F"]],Disk[],MyColor["F"],Style[Text["F",{0,0},{-0.3,0.1}],"Label",12]},ImageSize->20/1.2],PF]	(* Adj. size-no ticks on F *)
}
],
ImageSize->350]
],
	(* dynamic variables *)
{{preset,"circle","preset"},{"circle","ellipse","parabola","hyperbola","degenerate","reset trace"},SetterBar},
{{toShow,{"trace","conic"},"show"},{"trace","conic"},TogglerBar},
{{pts,Join[Table[{Cos[#],Sin[#]}&@(i π/4.),{i,{1,2,3,7,6}}],{1.7{Cos[#],Sin[#]}&@(5π/4.)}]},{-2,-2},{2,2},Locator,Appearance->Table[Graphics[{White,EdgeForm[MyColor[c]],Disk[],MyColor[c],Line[{{{-1.2,0},{-0.8,0}},{{0.8,0},{1.2,0}},{{0,-1.2},{0,-0.8}},{{0,0.8},{0,1.2}}}],Style[Text[c,{0,0},{-0.3,0.1}],"Label",12]},ImageSize->20],{c,{"A","B","C","D","E","X"}}]},
	(* local variables not tracked *)
{PF,None},{PR,None},{PS,None},{PT,None},
{coeff,None},
{wasActive,{False,True},None},
{{prevConfig,{}},None},
{{plot,Graphics[{}]},None},
{classlabel,None},
{trace,None},
{lastPF,None},
{{wasInPlotRange,False},None},
{configChanged,None},
{{presetList,
({{"circle", Table[{Cos[#], Sin[#]} &@(i π/4.), {i, {1, 6, 3, 7, 2}}]}, {"ellipse", Table[{Cos[#], 0.8 Sin[#]} &@(i π/4.), {i, {1, 6, 3, 7, 2}}]}, {"degenerate", {{1, 1}, {1, -1}, {-1, 1}, {-1, -1}, {0.3, 0.3}}}, {"hyperbola", Table[{Cos[#], 0.7/Sin[#]} &@(i π/4.), {i, {1, 6, 3, 7, 2}}]}, {"parabola", Table[{i, i^2 - 0.6}, {i, {-0.4, -1.0, 0., 0.4, 1.0}}]}})},None},
	(* options *)
TrackedSymbols->{preset,pts,toShow},
SaveDefinitions->True,AutorunSequencing->{1},ControllerLinking->False
]

Pascal discovered that if hexagon ABCDEF is inscribed in a conic section, the points of intersection RST of the pairs of opposite chords are collinear. You can generate the conic through points A, B, C, D, E, since F can be derived from an arbitrary line AX through A. Moving X and F traces the conic. Move A, B, C, D, or E to get a new conic that passes through them.

Pascal (1640) discovered that if a hexagon (or hexagram) ABCDEF is inscribed in a conic section, then taking opposite chords, the points of intersection R = AB.ED, S = AF.CD, and T = EF.CB are collinear. (If you put the points in the order AECDBF, as in snapshot 2, then the chords are pairs of opposite sides.) Pascal stated his result slightly differently. In effect, his theorem asserts that AF, CD, and RT run through the same point (S).  Braikenridge and Maclaurin (1733) discovered how to generate the conic through A, B, C, D, E. The point F can be derived from an arbitrary line AX through A from the following intersections:
	R = AB.ED,
	S = AX.CD,
	T = RS.CB, 
	F = AX.ET.
Moving X and F traces the conic. You can choose whether just to trace the conic, have the whole conic displayed, or both.

Pascal's "Essai pour les coniques," written in 1640 when he was sixteen, from D. E. Smith, A Source Book in Mathematics, London: Dover, 1959 pp. 326-330.

H. S. M. Coxeter, Introduction to Geometry, 2nd ed., Wiley, 1989.

Contributed by: Michael Rogers (Oxford College/Emory University)