The Arithmetic of Points on a Conic and Projectivities

H. S. M. Coxeter and George Beck

H. S. M. Coxeter wrote several geometry film scripts that were produced between 1965 and 1971 []. In 1992, Coxeter gave George Beck mimeographs of two scripts that had not been made. Beck wrote Mathematica code for the stills and animations. This material was added to the third edition of Coxeter’s The Real Projective Plane []. This article updates the Mathematica code.

Run This Code First

Geometry

$PointSize=PointSize[.01];

project::usage="project[p, l] is the orthogonal projection of the point p onto the line or plane l.";

project[p_,Line@{q_,r_}]:=p.r r/r.r/;q=={0,0}

project[p_,Line@{q_,r_}]:=q+project[p-q,Line@{{0,0},r-q}]/;q≠{0,0}

distance::usage="distance[p, q] is the length of the segment from the point p to the point q. distance[p, l] (or distance[l, p]) gives the distance from the point p to the line l.";

distance[p_,q_]:=Norm[q-p]

distance[p_,l_Line]:=distance[p,project[p,l]]

distance[l_Line,p_]:=distance[p,l]

collinearQ::usage="collinearQ[{p, q, r}], where p, q and r are points, is 
True if and only if p, q and r lie on the same line.";

collinearQ@{p:{_,_},q:{_,_},r:{_,_}}:=distance[p,Line[{q,r}]]==0

circumcenter::usage="circumcenter[{p, q, r}] is the centre of the circle through the points p, q and r.";

circumcenter@{p_,q_,r_}:={}/;collinearQ@{p,q,r}

perpendicularline::usage="perpendicularline[p, l] is the line at right angles to l passing through the point p.";

perpendicularline[p:{_,_},l:Line@{q_,r_}]:=Line[{p+1/2Cross[r-q],p+1/2Cross[q-r]}]/;distance[p,l]==0

perpendicularline[p:{_,_},l_Line]:=perpendicularline[project[p,l],l]/;distance[p,l]>0

midpoint::usage="midpoint[{p1, p2}] gives the midpoint of the points p1 and p2."

midpoint@{p1_,p2_}:=(p1+p2)/2

rightbisector::usage="rightbisector[l] is the line which is perpendicular to the line l at the midpoint of l.";

rightbisector[l_Line]:=perpendicularline[midpoint@@l,l]

meet::usage="meet[a, b], where a and b are lines or circles, gives the intersection of a and b.";

meetaux1[Line@{{p1_,p2_},{q1_,q2_}},Line@{{r1_,r2_},{s1_,s2_}}]:=(q2-p2) (r1-s1)-(q1-p1) (r2-s2)

meetaux2[Line@{{p1_,p2_},{q1_,q2_}},Line@{{r1_,r2_},{s1_,s2_}}]:=(r2-s2) (p1-s1)-(r1-s1) (p2-s2)

meet[l:Line@{p_,q_},m_Line]:=p+meetaux2[l,m]/meetaux1[l,m] (q-p)/;Chop@meetaux1[l,m]≠0

meet[l:Line@{p_,q_},m_Line]:=p+1000 (q-p)/;Chop@meetaux1[l,m]==0

meet[l:Line@{p_,q_},Circle[d_,r_]]:=Module[
{a,b,c,e,t1,t2},
a=(q-p).(q-p);
b=-2 (d-p).(q-p);
c=(d-p).(d-p)-r^2;
e=N@Sqrt[b^2-4 a c];
t1=(-b+e)/(2 a);
t2=(-b-e)/(2 a);
{p+(q-p) t1,p+(q-p) t2}]/;distance[d,l]≤r

meet[x_,m_InfiniteLine]:=meet[x,Line@@m]

meet[l_InfiniteLine,x_]:=meet[Line@@l,x]

meet[x_,m_HalfLine]:=meet[x,Line@@m]

meet[l_HalfLine,x_]:=meet[Line@@l,x]

circumcircle::usage="circumcircle[{p, q, r}] is the circle through the points p, q and r; it may degenerate into a line, which will be stretched to have length 1000.";

circumcenter@{p_,q_,r_}:=meet[rightbisector@Line@{p,q},rightbisector@Line@{q,r}]/;Last@p==0&&Last@q==0&&Last@r==0&&Not[collinearQ@{p,q,r}]

invert::usage="invert[f, u] is the inversion of the figure f in the circle u.";

invert[p:{_?NumberQ,_?NumberQ},Circle[c_,r_]]:=r^2 p/(p.p)/;c=={0,0}

invert[p:{_?NumberQ,_?NumberQ},Circle[c_,r_]]:=c+invert[p-c,Circle[{0,0},r]]/;c≠{0,0}

invert[Line@{p_,q_},u:Circle[d_,_]]:=Module[
{e,f,g},
e=p;
f=q;
g=p+1/3 (q-p);
If[e==d,e=p+1/3 (q-p);g=p+2/3 (q-p)];
If[f==d,f=p+2/3 (q-p)];
If[g==d,g=p+2/3 (q-p)];
circumcircle[invert[#,u]&/@{e,f,g}]]

invert[Circle[c_,r_],u:Circle[d_,_]]:=Module[
{e,f,g},
e=c+{1,0} r;
f=c+{0,1} r;
g=c+({1,0}+{0,1})/Sqrt[2.] r;
If[e==d,e=c-r {1,0}];
If[f==d,f=c-r {0,1}];
If[g==d,g=c-r ({1,0}+{0,1})/Sqrt[2.]];
circumcircle[invert[#,u]&/@{e,f,g}]
]

invert[Text[t_,p:{_?NumberQ,_?NumberQ},a___],u_Circle]:=Text[t,invert[p,u],a]

invert[GrayLevel[i_],u_Circle]:=GrayLevel[i]

invert[RGBColor[r_,g_,b_],u_Circle]:=RGBColor[r,g,b]

invert[PointSize[s_],u_Circle]:=PointSize[s]

invert[Thickness[t_],u_Circle]:=Thickness[t]

invert[Dashing[d_],u_Circle]:=Dashing[d]

invert[l_List,u_Circle]:=invert[#,u]&/@l

invert[g_,u_List]:=invert[g,#]&/@u

meet[u_Circle,l_Line]:=meet[l,u]

meet[u:Circle[c_,r_],v:Circle[d_,s_]]:=Module[
{w,a,b,m},
w=Circle[c+r {1,0},1];
m=invert[meet[invert[u,w],invert[v,w]],w];
If[distance[c+r {1,0},d]==s,{c+r {1,0},m},m]]/;Abs[r-s]≤distance[c,d]≤r+s

othermeet::usage="othermeet[u, p, q], where u is a circle and p and q are points, gives the point of intersection of of u with the line through p and q that is not the point p.";

othermeet[u_Circle,p_,q_]:=First@Select[meet[u,Line@{p,q}],#≠p&]

polar::usage="polar[p, u], where p is a point and u is a circle, is the line which is perpendicular to the line joining p to the center of u and passing through the inverse of p in u.";

polar[p:{_?NumberQ,_?NumberQ},Circle[c_,r_]]:=perpendicularline[invert[p,Circle[c,r]],Line@{p,c}]

tangentpoints::usage="tangentpoints[p, u], where p is a point and u is a circle, is the pair of points where the tangents from p to u meet the circle u.";

tangentpoints[p:{_?NumberQ,_?NumberQ},Circle[c_,r_]]:={p,p}/;distance[p,c]==r

tangentpoints[p:{_?NumberQ,_?NumberQ},u:Circle[c_,r_]]:=meet[u,polar[p,u]]/;distance[p,c]>r

tangents::usage="tangents[p, u], where p is a point and u is a circle, is the pair of lines that are tangent to u from the point p.";

tangents[p:{_?NumberQ,_?NumberQ},u:Circle[c_,r_]]:={#,#}&@perpendicularline[p,Line@{p,c}]/;distance[p,c]==r

tangents[p:{_?NumberQ,_?NumberQ},u:Circle[c_,r_]]:=Line[{p,#}]&/@tangentpoints[p,u]/;distance[p,c]>r

farpair::usage="farpair[list] gives that pair of points in list which are at the greatest distance apart.";

farpair@{p_,q_,r_}:=Block[{a=distance[p,q],b=distance[q,r],c=distance[r,p],d},If[(a≥b≥c)||(a≥c≥b),d={p,q}];
If[(b≥a≥c)||(b≥c≥a),d={q,r}];
If[(c≥a≥b)||(c≥b≥a),d={r,p}];
d]

farpair@l_List:=farpair@Join[farpair@Take[l,3],Drop[l,3]]/;Length@l>3

Text

lineText[txt_,loc_,x_:.5]:= Text@@@Transpose[{txt,#-{0,x}&/@loc}]

circleText[txt_,loc_,dis_:1.2]:=Text@@@Transpose[{Style[#,Background->White]&/@txt,{0,1}+dis(#-{0,1})&/@loc}]

offi={0,1}+{Cos[.95 1/2Pi],Sin[.95 1/2Pi]};

off0={0,1}+{Cos[1.02 3/2Pi],Sin[1.02 3/2Pi]};

{ai,Ai,bi,Bi,ci,Ci,Di,Ei,Fi,xi}=Style[#,Italic]&/@{"a","A","b","B","c","C","D","E","F","x"};

text[str_,loc_,off_:{0,0}]:=Style[Text[Style[str,Italic],loc,off],Background->White]

pers[str_]:=RawBoxes@RowBox[{StyleBox[OverscriptBox["⌆",StyleBox[StringJoin[str," "],Italic]],FontFamily->"Chalkboard"]}]

proj[str_]:=RawBoxes@RowBox[{StyleBox[OverscriptBox["⌅",StyleBox[str,Italic]],FontFamily->"Chalkboard"]}]

The Arithmetic of Points on a Conic

The example of a thermometer makes it easy to see how the real numbers (positive, zero and negative) can be represented by the points of a straight line.

Framed@Module[
{big,bigLines,small,smallLines},
big=Table[{i,0},{i,-5,5}];
bigLines=Translate[Line[.2 {{0,-1},{0,1}}],big];
small=Table[{i,0},{i,-5,5,.1}];
smallLines=Translate[Line[.1 {-{0,1},{0,1}}],small];
Graphics@{
Translate[
{
{Blue,bigLines,smallLines},
{Magenta,Line[{{-5,0},{5,0}}]}, 
lineText[Range[-5,5],big]
},
{0,.5}
]
}
]

On the x axis of ordinary analytic geometry, the number x is represented by the point (x,0).

Manipulate[
Module[
{big,bigLines,small,smallLines},
big=Table[{i,0},{i,-5,5}];
bigLines=Translate[Line[.2 {{0,-1},{0,1}}],big];
small=Table[{i,0},{i,-5,5,.1}];
smallLines=Translate[Line[.1 {-{0,1},{0,1}}],small];
Graphics@{
Translate[
{
{Blue,bigLines,smallLines},
{Magenta,Line[{{-5,0},{5,0}}]}, 
lineText[Range[-5,5],big],
$PointSize,Point[{x,0}],
Text[Row[{"(",xi,", 0)"}],{x,0},{0,-3}]
},
{0,.5}]
}
],
{{x,2.7,Style["x",Italic]},-4.5,4.5,.01,Appearance->"Labeled"},
SaveDefinitions->True
]

Given any two such numbers, a and b, we can set up geometrical constructions for their sum, difference, product, and quotient.

Manipulate[
Module[
{z={.9,2},xaxis=InfiniteLine[{{-1,0},{1,0}}],yis2,oz,az},
yis2=InfiniteLine[{{-1,2},{1,2}}];
oz=Line@{{0,0},z};
az=Line@{ {a,0},z};
Graphics[
{
{Magenta,InfiniteLine[{{-1,0},{1,0}}],yis2},
{Blue,oz,Translate[oz,{b,0}],az,Translate[az,{b,0}]},
$PointSize,Point[{{0,0},{a,0},{b,0},z,{b,0}+z,{a+b,0}}],
lineText[
{0,ai,bi,ai+bi},
{{0,0},{a,0},{b,0},{a+b,0}}
]
},PlotRange->{{-9,9},{-1,3}},PlotLabel->"sum"
]
],
{{a,2.5,ai},-4,4,.01,Appearance->"Labeled"},
{{b,3.3,bi},-4,4,.01,Appearance->"Labeled"},
SaveDefinitions->True
]

Manipulate[
Module[
{z={.9,2},xaxis=InfiniteLine[{{-1,0},{1,0}}],yis2,oz,az},
yis2=InfiniteLine[{{-1,2},{1,2}}];
oz=Line@{{0,0},z};
az=Line@{{a,0},z};
Graphics[
{
{Magenta,xaxis,yis2},
{Blue,oz,az,Translate[{oz,az},{b-a,0}]},
$PointSize,Point[{{0,0},{a,0},{b,0},z,{b-a,0}+z,{b-a,0}}],
lineText[
{0,ai,bi-ai,bi},
{{0,0},a {1,0},(b-a) {1,0},b {1,0}}
]
},PlotRange->{{-9,9},{-1,3}},PlotLabel->"difference"
]
],
{{a,1.2,ai},-4,4,.01,Appearance->"Labeled"},
{{b,4,bi},-4,4,.01,Appearance->"Labeled"},
SaveDefinitions->True
]

Manipulate[
Module[
{z={1,.5},xaxis=InfiniteLine[{{-1,0},{1,0}}],oz,iz,az},
oz=InfiniteLine@{{0,0},10z};
iz=Line@{{1,0},z};
az=Line@{{a,0},z};
Graphics[
{
{Magenta,xaxis,oz},
{Blue,iz,Line@{{b,0},b z},az,Line@ {{a b ,0},b z}},
$PointSize,Point[{{0,0},{1,0},{a,0},{b,0},z,b z,{a b,0}}],
lineText[
{0,1,ai,bi,ai bi},
{{0,0},{1,0},a {1,0},b {1,0},a b {1,0}}
]
},PlotRange->{{-9,9},{-3,3}},PlotLabel->"product"
]
],
{{a,1.3,ai},-4,4,.01,Appearance->"Labeled"},
{{b,3.3,bi},-4,4,.01,Appearance->"Labeled"},
SaveDefinitions->True
]

Manipulate[
Module[
{z={1,.5},xaxis=InfiniteLine[{{-1,0},{1,0}}],oz,iz,az},
If[a==0,a=.0001];
oz=InfiniteLine@ {{0,0},10z};
iz=Line@{{1,0},z};
az=Line@{{a,0},z};
Graphics[
{
{Magenta,xaxis,oz},
{Blue,iz,az,Line[b/a {{a,0},z}],Line[b/a {{1,0},z}]},$PointSize,Point[{{0,0},{1,0},{a,0},{b,0},z,b/a z,{b/a,0}}],
lineText[
{0,1,ai,bi,Row[{ai," / ",bi}]},
{{0,0},{1,0},{a,0},{b,0},{b/a,0}}]
},PlotRange->{{-9,9},{-3,3}},PlotLabel->"quotient"
]
],
{{a,1.3,ai},-4,4,.01,Appearance->"Labeled"},
{{b,3.3,bi},-4,4,.01,Appearance->"Labeled"},
SaveDefinitions->True
]

However, these constructions require a scaffolding of extra points and lines. It is by no means obvious that a different choice of scaffolding would yield the same final results.

The object of the present program is to make use of a circle (or any other conic) instead of the line, so that the constructions can all be performed with a straight edge, and the only arbitrariness is in the choice of the positions of three of the numbers (for instance, 0, 1 and 2).

Although this is strictly a chapter in projective geometry, let us begin with a prologue in which the scale of abscissas on the x axis is transferred to a circle by the familiar process of stereographic projection.

A circle of any radius (say 1, for convenience) rests on the x axis at the origin 0, and the numbers are transferred from this axis to the circle by lines drawn through the opposite point.

Module[
{xaxis=InfiniteLine[{{-1,0},{1,0}}],m3={-3,0},m2={-2,0},m1={-1,0},x0={0,0},x1={1,0},x2={2,0},x3={3,0},p={0,2},n3,n2,n1,y0,y1,y2,y3},
{n3,n2,n1,y0,y1,y2,y3}=othermeet[Circle[{0,1},1],p,#]&/@{m3,m2,m1,x0,x1,x2,x3};
Framed@Graphics[{
{Magenta,xaxis,Circle[{0,1},1]},{Darker@Green,Line[{p,#}]&/@{(m3+n3)/2,m2,m1,x0,x1,x2,(x3+y3)/2}},$PointSize,Point[{m2,m1,x0,x1,x2,p,n2,n1,y0,y1,y2}],
lineText[{-2,-1,0,1,2},{m2,m1,x0,x1,x2},.2],
circleText[{-2,-1,1,2},{n2,n1,y1,y2}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

That is, the point at the top. In this manner, a definite number is assigned to every point on the circle except the topmost point itself.

Manipulate[
Module[
{xaxis=InfiniteLine[{{-1,0},{1,0}}],p={0,2},y},
y=othermeet[Circle[{0,1},1],p,{x,0}];
Graphics[
{
{Magenta,xaxis,Circle[{0,1},1]},
{Darker@Green,Line@{p,{x,0}}},
$PointSize,Point[{{x,0},p,y}],
Text[xi,{x,0},{0,2}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
],
{{x,2,Style["x",Italic]},-10,10,Appearance->"Labeled"},
SaveDefinitions->True
]

The numbers 10, 100, 1000, … come closer and closer to this point on one side, and the numbers -10, -100, -1000, … come closer and closer on the other side.

Module[
{xaxis=InfiniteLine[{{-1,0},{1,0}}],m100= {-100,0},m10={-10,0},m2={-2,0},m1={-1,0},x0={0,0},x1={1,0},x2={2,0},x10={10,0},x100={100,0},p={0,2},n100,n10,n2,n1,y1,y2,y10,y100},
{n100,n10,n2,n1,y1,y2,y10,y100}=othermeet[Circle[{0,1},1],p,#]&/@{m100,m10,m2,m1,x1,x2,x10,x100};
Framed@Graphics[
{
{Magenta,xaxis,Circle[{0,1},1]},{Darker@Green,Line@{p,#}&/@{m100,m10,m2,m1,x1,x2,x10,x100}},$PointSize,Point[{m2,m1,x0,x1,x2,x10,x100,p,n100,n10,n2,n1,y1,y2,y10,y100}],
lineText[{-2,-1,0,1,2},{m2,m1,x0,x1,x2},.2],
circleText[{-1,-2,"-10  ","-100            ","   100",10,2,1},{n1,n2,n10,n100,y100,y10,y2,y1}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

So it is natural to assign the special symbol ∞ (infinity) to this exceptional point: the only point for which no proper number is available.

The tangent at this exceptional point is, of course, parallel to the x axis; that is, parallel to the tangent at the point 0.

Module[
{xaxis=InfiniteLine[{{-1,0},{1,0}}],m4={-4,0},m3={-3,0},m2={-2,0},m1={-1,0},x0={0,0},x1={1,0},x2={2,0},x3={3,0},x4={4,0},p={0,2},n4,n3,n2,n1,y0,y1,y2,y3,y4},
{n4,n3,n2,n1,y0,y1,y2,y3,y4}=othermeet[Circle[{0,1},1],p,#]&/@{m4,m3,m2,m1,x0,x1,x2,x3,x4};
Framed@Graphics[
{
{Magenta,xaxis,Circle[{0,1},1]},
{Red,InfiniteLine@{ {-1,2}, {1,2}}},
$PointSize,Point[{p,n4,n3,n2,n1,y0,y1,y2,y3,y4}],
circleText[Append[Range[-4,4],∞],{n4,n3,n2,n1,y0,y1,y2,y3,y4,p}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

Having transferred all the numbers to the circle, we can forget about the x axis; but the tangent at the point infinity will play an important role in the construction of sums.

Module[
{m4={-4,0},m3={-3,0},m2={-2,0},m1={-1,0},x0={0,0},x1={1,0},x2={2,0},x3={3,0},x4={4,0},p={0,2},n4,n3,n2,n1,y0,y1,y2,y3,y4},
{n4,n3,n2,n1,y0,y1,y2,y3,y4}=othermeet[Circle[{0,1},1],p,#]&/@{m4,m3,m2,m1,x0,x1,x2,x3,x4};
Framed@Graphics[
{
{Magenta,Circle[{0,1},1]},
{Red,InfiniteLine@{ {-1,2}, {1,2}}},
$PointSize,Point[{p,n4,n3,n2,n1,y0,y1,y2,y3,y4}],circleText[Append[Range[-4,4],∞],{n4,n3,n2,n1,y0,y1,y2,y3,y4,p}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

For instance, there is one point on this tangent that lies on the line joining points 1 and 2, also on the line joining 0 and 3, and on the line joining −1 and 4. We notice that these pairs of numbers all have the same sum: 1+2=0+3=-1+4=3.

Module[
{m1={-1,0},x0={0,0},x1={1,0},x2={2,0},x3={3,0},x4={4,0},p={0,2},n1,y0,y1,y2,y3,y4,s3},
{n1,y0,y1,y2,y3,y4}=othermeet[Circle[{0,1},1],p,#]&/@{m1,x0,x1,x2,x3,x4};
s3=meet[Line@{n1,y4},Line@{y0,y3}];
Framed@Graphics[
{
{Magenta,Circle[{0,1},1]},
{Darker@Green,Line@{s3,n1},Line@{s3,y0},Line@{s3,y1}},
{Red,InfiniteLine@{ {-1,2}, {1,2}}},
$PointSize,Point[{n1,y0,y1,y2,y3,y4,p,s3}],
circleText[{-1,0,1,2,3,4,∞},{n1,y0,y1,y2,y3,y4,p}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

Similarly, the tangent at 1 meets the tangent at infinity in a point that lies on the lines joining 0 and 2, −1 and 3, −2 and 4, in accordance with the equations 1+1=0+2=-1+3=-2+4.

Module[
{m2={-2,0},m1={-1,0},x0={0,0},x1={1,0},x2={2,0},x3={3,0},x4={4,0},p={0,2},n2,n1,y0,y1,y2,y3,y4,s2},
{n2,n1,y0,y1,y2,y3,y4}=othermeet[Circle[{0,1},1],p,#]&/@{m2,m1,x0,x1,x2,x3,x4};
s2=meet[Line@{n2,y4},Line@{y0,y2}];
Framed@Graphics[
{
{Magenta,Circle[{0,1},1]},
{Darker@Green,Line@{s2,n2},Line@{s2,n1},Line@{s2,y0},HalfLine@{s2,y1}},
{Red,Line[{ {-12,2}, {12,2}}]},
$PointSize,Point[{n2,n1,y0,y1,y2,y3,y4,p,s2}],
circleText[{-2,-1,0,1,2,3,4,∞},{n2,n1,y0,y1,y2,y3,y4,p}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

These results could all be verified by elementary analytic geometry, but there is no need to do this, because we shall see later that a general principle is involved.

Having finished the Euclidean prologue, let us see how far we can go with the methods of projective geometry. Let symbols 0, 1, infinity be assigned to any three distinct points on a given conic.

Module[
{x0={0,0},x1={1,0},p={0,2},y0,y1,pp,s2},
{y0,y1}=othermeet[Circle[{0,1},1],p,#]&/@{x0,x1};
pp=First@tangents[p,Circle[{0,1},1]];
s2=meet[First@tangents[y1,Circle[{0,1},1]],pp];
Framed@Graphics[
{
{Magenta,Circle[{0,1},1]},
{Darker@Green,HalfLine@{s2,y1}},
{Red,InfiniteLine@@pp},
$PointSize,Point[{y0,y1,p,s2}],
circleText[{0,1,∞},{y0,y1,p}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

There is a certain line through 0 concurrent with the tangents at infinity and 1; let this line meet the conic again in 2.

Module[
{u=Circle[{0,1},1],x0={0,0},x1={1,0},p={0,2},y0,y1,pp,s2,y2},
{y0,y1}=othermeet[u,p,#]&/@{x0,x1};
pp=First@tangents[p,u];
s2=meet[First@tangents[y1,u],pp];
y2=othermeet[u,y0,s2];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,HalfLine@{s2,y1},
Line@{y0,y2,s2,y0}},
{Red,InfiniteLine@@pp},
$PointSize,Point[{y0,y1,p,s2,y2}],
circleText[
{0,1,2,∞},
{y0,y1,y2,p}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

(Alternatively, if we had been given 0, 1, 2 instead of 0, 1, infinity, we could have reconstructed infinity as the point of contact of the remaining tangent from the point where the tangent at 1 meets the line 02.)

We now have the beginning of a geometrical interpretation of all the real numbers.

To obtain 3, we join 1 and 2, see where this line meets the tangent at infinity, join this point of intersection to 0, and assign the symbol 3 to the point where this line meets the conic again. Thus the line joining 0 and 3 and the line joining 1 and 2 both meet the tangent at infinity in the same point.

Module[
{u=Circle[{0,1},1],x0={0,0},x1={1,0},p={0,2},y0,y1,pp,s2,y2,s3,y3},
{y0,y1}=othermeet[u,p,#]&/@{x0,x1};
pp=First@tangents[p,u];
s2=meet[First@tangents[y1,u],pp];
y2=othermeet[u,y0,s2];
s3=meet[Line@{y1,y2},pp];
y3=othermeet[u,y0,s3];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{y1,y2,s3,y1},Line@{y0,y3,s3,y0}},
{Red,InfiniteLine@@pp},
$PointSize,Point[{y0,y1,p,y2,s3,y3}],
circleText[
{0,1,2,3,∞},
{y0,y1,y2,y3,p}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

More generally, we define addition in such a way that two pairs of points have the same sum if their joins are concurrent with the tangent at the point infinity.

Manipulate[
Module[
{u=Circle[{0,1},1],x0={0,0},x1={1.5 ,0},p={0,2},y0,y1,pp,s,x,y,c,a,b,l,T=20},
{y0,y1}=othermeet[u,p,#]&/@{x0,x1};
pp=InfiniteLine@@First@tangents[p,u];
s=meet[First@tangents[y1,u],pp];
{x,y}=tangentpoints[s,u];
c=t/T x+(1-t/T) y;
{a,b}=If[t==0||t==T,{c,c},meet[Line@{c,s},u]];
l=If[t==0||t==T,Line@{c,s},Line@{a,b,s}];
Graphics[
{
{Magenta,u},
{Red,pp},
{Darker@Green,Line@@l},
$PointSize,Point[{p,s,a,b}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
],
{{t,10,Style["t",Italic]},0,20,Appearance->"Labeled"},
SaveDefinitions->True
]

In other words, we define the sum a+b of any two points a and b to be the remaining point of intersection of the conic with the line joining 0 to the point where the tangent at infinity meets the join of a and b.

To justify this definition, we must make sure that it agrees with our usual requirements for the addition of numbers: the commutative law

a+b=b+a,

a unique solution for every equation of the form

x+a=c,

and the associative law

(a+b)+c=a+(b+c).

The commutative law is satisfied immediately, as our definition for a+b involves a and b symmetrically.

Module[
{u=Circle[{0,1},1],x0={0,0},xa={1,0},xb={2,0},p={0,2},y0,a,b,pp,s,c},
{y0,a,b}=othermeet[u,p,#]&/@{x0,xa,xb};
pp=InfiniteLine@@First@tangents[p,u];
s=meet[Line@{a,b},pp];
c=othermeet[u,y0,s];
Framed@Graphics[
{{Magenta,u},
{Darker@Green,Line@{a,b,s,a},Line@{y0,c,s,y0}},
{Red,pp},
$PointSize,Point[{y0,a,b,p,s,c}],
circleText[{0,ai,bi,ai+bi,∞},{y0,a,b,c,p}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

The equation x+a=c is solved by choosing x so that x and a have the same sum as 0 and c.

Module[
{u=Circle[{0,1},1],x0={0,0},xa={7,0},xc={3,0},p={0,2},y0,a,c,pp,c0,s,x},
{y0,a,c}=othermeet[u,p,#]&/@{x0,xa,xc};
pp=First@tangents[p,u];
s=meet[Line@{c,y0},pp];
x=othermeet[u,a,s];
Framed@Graphics[
{
{Magenta,u},
{Red,InfiniteLine@@pp},
{Darker@Green,Line@{y0,c,s,y0},Line@{x,a,s,x}},
$PointSize,Point[{y0,a,c,p,s,x}],
circleText[{0,ci,xi,ai,∞},{y0,c,x,a,p}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

Thus the only possible cause of trouble is the associative law; we must make sure that for any three points a, b, c (not necessarily distinct), the sum of a+b and c is the same as the sum of a and b+c.

Module[
{u=Circle[{0,1},1],x0={0,0},xa={1,0},xb={3,0},xc={-6,0},p={0,2},y0,a,b,c,pp,l,d,m,e,n},
y0=othermeet[u,p,x0];
{a,b,c}=othermeet[u,p,#]&/@{xa,xb,xc};
pp=InfiniteLine@@First@tangents[p,u];
l=meet[Line@{a,b},pp];
d=othermeet[u,y0,l];
m=meet[Line@{b,c},pp];
e=othermeet[u,y0,m];
n=meet[Line@{d,c},pp];
Framed@Graphics[
{
{Magenta,u},
{Blue,Line@{a,b,l,a},Line@{y0,d,l,y0}},
{Cyan,Line@{y0,e,m,y0},Line@{b,c,m,b}},
{Darker@Green,Line@{a,e,n,a},Line@{d,c,n,d}},
{Red,pp},
$PointSize,Point[{y0,a,b,c,d,e,l,m,n,p}],
circleText[
{0,ai,bi,ci,ai+bi,bi+ci,∞},
{y0,a,b,c,d,e,p}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

For this purpose, we make use of a special case of Pascal’s theorem, which says that if ABCDEF is a hexagon inscribed in a conic, the pairs of opposite sides (namely AB and DE, BC and EF, CD and FA) meet in three points that lie on a line, called the Pascal line of the given hexagon.

Module[
{u=Circle[{0,1},1],x0={-.9,0},xa={1,0},xb={3,0},xc={-4.5,0},p={0,2},y0,a,b,c,pp,l,d,m,e,f,n},
e=y0=othermeet[u,p,x0];
{a,b,c}=othermeet[u,p,#]&/@{xa,xb,xc};
pp=First@tangents[p,u];
l=meet[Line@{a,b},pp];
d=othermeet[u,y0,l];
m=meet[Line@{b,c},pp];
f=othermeet[u,y0,m];
n=meet[Line@{d,c},pp];
Framed@Graphics[
{
{Magenta,u},
{Cyan,Line@{a,b,l,a},Line@{y0,d,l,y0}},
{Blue,Line@{y0,f,m,y0},Line@{b,c,m,b}},
{Darker@Green,Line@{a,f,n,a},Line@{d,c,n,d}},
{Red,InfiniteLine@@pp},
$PointSize,Point[{a,b,c,d,e,f,l,m,n}],
circleText[{Ai,Bi,Ci,Di,Ei,Fi},{a,b,c,d,e,f}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

In 1639, when Blaise Pascal was sixteen years old, he discovered this theorem as a property of a circle.

Module[
{u=Circle[{0,1},1],xa={-9,0},xb={-.1,0},xc={7,0},xd={.5,0},xe={3,0},xf={2,0},p={0,2},a,b,c,d,e,f,l,m,n,x,y,z,γ},
{a,b,c,d,e,f}=othermeet[Circle[{0,1},1],p,#]&/@{xa,xb,xc,xd,xe,xf};
l=meet[Line@{a,b},Line@{d,e}];
m=meet[Line@{b,c},Line@{e,f}];
n=meet[Line@{f,a},Line@{c,d}];
x=distance[l,m];
y=distance[m,n];
z=distance[l,n];
γ=If[x+y==z,{n,l},If[y+z==x,{l,m},{m,n}]];
Framed@Graphics[
{
{Magenta,Circle[{0,1},1]},
{Blue,Line@{a,b,l,a},Line@{d,e,l,d}},
{Cyan,Line@{b,c,m,b},Line@{e,f,m,e}},
{Darker@Green,Line@{f,a,n,f},Line@{c,d,n,c}},
{Red,InfiniteLine@γ},
$PointSize,Point[{a,b,c,d,e,f,l,m,n}],
circleText[{Ai,Bi,Ci,Di,Ei,Fi},{a,b,c,d,e,f}],
text["Pascal line",1.1Last@γ]
},PlotRange->{{-3,3},{-1.5,3}}
]
]

He then deduced the general result by joining the circle to a point outside the plane by a cone and then considering the section of this cone by an arbitrary plane.

We do not know how he proved this property of a hexagon inscribed in a circle, because his original treatise was lost, but we do know how he might have done it, using only the first three books of Euclid's Elements. In our own time, an easier proof can be found in any textbook on projective geometry.

Each hexagon has its own Pascal line. If we fix five of the six vertices and let the sixth vertex run round the conic, we see the Pascal line rotating about a fixed point.

Manipulate[
Module[{
u=Circle[{0,1},1],xa={5.1,0},xb={2.71 ,0},xc={-5.53 ,0},xd={4.43 ,0},xf={-2.93 ,0},p={0,2},a,b,c,d,e,f,l,m,n,x,y,z,γ},
{a,b,c,d}=othermeet[u,p,#]&/@{xa,xb,xc,xd};
e={0,1}+{Cos[2Pi t],Sin[2Pi t]};
f=othermeet[u,p,xf];
l=meet[Line@{a,b},Line@{d,e}];
m=meet[Line@{b,c},Line@{e,f}];
n=meet[Line@{f,a},Line@{c,d}];
x=distance[l,m];
y=distance[m,n];
z=distance[l,n];
γ=If[x+y==z,{n,l},If[y+z==x,{l,m},{m,n}]];
Graphics[
{
{Magenta,u},
{Blue,Line@{a,b,l,a},Line@{d,e,l,d}},
{Cyan,Line@{b,c,m,b},Line@{e,f,m,e}},
{Darker@Green,Line@{f,a,n,f},Line@{c,d,n,c}},
{Red,InfiniteLine@γ},
$PointSize,Point[{a,b,c,d,e,f,l,m,n}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
],
{{t,0,Style["t",Italic]},0,1,Appearance->"Labeled"},
SaveDefinitions->True
]

If this fixed point is outside the conic, we can stop the motion at a stage when the Pascal line is a tangent. This is the special case that concerns us in the geometrical theory of addition.

Module[
{u=Circle[{0,1},1],xa={.51 ,0},xb={2.71 ,0},xc={-5.53 ,0},xd={4.3,0},xf={-2.93 ,0},p={0,2},a,b,c,d,e,f,l,m,n,x,y,z,γ},
{a,b,c,d}=othermeet[u,p,#]&/@{xa,xb,xc,xd};
e={0,1}+{Cos[2Pi 19/30],Sin[2Pi 19/30]};
f=othermeet[u,p,xf];
l=meet[Line@{a,b},Line@{d,e}];
m=meet[Line@{b,c},Line@{e,f}];
n=meet[Line@{f,a},Line@{c,d}];
x=distance[l,m];
y=distance[m,n];
z=distance[l,n];
γ=If[x+y==z,{n,l},If[y+z==x,{l,m},{m,n}]];
Framed@Graphics[
{
{Magenta,u},
{Blue,Line@{a,b,l,a},Line@{d,e,l,d}},
{Cyan,Line@{b,c,m,b},Line@{e,f,m,e}},
{Darker@Green,Line@{f,a,n,f},Line@{c,d,n,c}},
{Red,InfiniteLine@γ},
$PointSize,Point[{a,b,c,d,e,f,l,m,n}],
circleText[{"A",Bi,Ci,Di,Ei,Fi},{a,b,c,d,e,f}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

The hexagon (a,b,c, a+b,0,b+c) shows that the sum of a+b and c is equal to the sum of a and b+c.

Module[
{u=Circle[{0,1},1],xa={-4,0},xb={6,0},xc={-8,0},xe={0,0},xd,xf,p={0,2},a,b,c,d,e,f,l,m,n},
xd=xa+xb;
xf=xb+xc;
{a,b,c,d,e,f}=othermeet[u,p,#]&/@{xa,xb,xc,xd,xe,xf};
l=meet[Line@{a,b},Line@{d,e}];
m=meet[Line@{b,c},Line@{e,f}];
n=meet[Line@{f,a},Line@{c,d}];
Framed@Graphics[
{
{Magenta,u},
{Blue,Line@{a,b,l,a},Line@{d,e,l,d}},
{Cyan,Line@{b,c,m,b},Line@{e,f,m,e}},
{Darker@Green,Line@{f,a,n,f},Line@{c,d,n,c}},
{Red,InfiniteLine@{l,m}},
{$PointSize,Point@{a,b,c,d,e,f,l,m,n,p}},
circleText[
{ai,bi,0,ci,ai+bi,bi+ci,∞},
{a,b,e,c,d,f,p}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

Beginning with 0, 1 and infinity, we can now construct the remaining positive integers

2=1+1, 
3=2+1, 
4=3+1, 
5=4+1,

and so on.

Module[
{u=Circle[{0,1},1],x0={0,0},x1={1,0},p={0,2},y0,y1,pp,s2,y2,s3,y3,s4,y4,s5,y5},
{y0,y1}=othermeet[u,p,#]&/@{x0,x1};
pp=InfiniteLine@@First@tangents[p,u];
s2=meet[First@tangents[y1,u],pp];
y2=othermeet[u,y0,s2];
s3=meet[Line@{y1,y2},pp];
y3=othermeet[u,y0,s3];
s4=meet[Line@{y1,y3},pp];
y4=othermeet[u,y0,s4];
s5=meet[Line@{y1,y4},pp];
y5=othermeet[u,y0,s5];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,
Line@{y1,s2},Line@{y0,y2,s2,y0},
Line@{y1,y2,s3,y1},Line@{y0,y3,s3,y0},
Line@{y1,y3,s4,y1},Line@{y0,y4,s4,y0},
Line@{y1,y4,s5,y1},Line@{y0,y5,s5,y0}},
{Red,pp},
$PointSize,Point[{y0,y1,y2,y3,y4,y5,p,s2,s3,s4,s5}],
circleText[{∞,0,1,2,3,4,5},{p,y0,y1,y2,y3,y4,y5}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

We can also construct the negative integers -1,-2,-3,…, given by

0=-1+1,
0=-2+2,
0=-3+3,

and so on.

Module[
{u=Circle[{0,1},1],x0={0,0},x1={1,0},p={0,2},y0,y1,pp,s2,y2,s3,y3,s4,y4,y0y0,w1,w2,w3,m1,m2,m3},
{y0,y1}=othermeet[u,p,#]&/@{x0,x1};
pp=InfiniteLine@@First@tangents[p,u];
s2=meet[First@tangents[y1,u],pp];
y2=othermeet[u,y0,s2];
s3=meet[Line@{y1,y2},pp];
y3=othermeet[u,y0,s3];
s4=meet[Line@{y1,y3},pp];
y4=othermeet[u,y0,s4];
y0y0=InfiniteLine@@First@tangents[y0,u];
If[
distance[p,y0]==2,w1=project[y1,Line@{y0,p}];
w2=project[y2,Line@{y0,p}];
w3=project[y3,Line@{y0,p}],w1=w2=w3=meet[y0y0,pp]
];
m1=othermeet[u,y1,w1];
m2=othermeet[u,y2,w2];
m3=othermeet[u,y3,w3];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,
InfiniteLine@{y1,m1},
InfiniteLine@{y2,m2},
InfiniteLine@{y3,m3},
y0y0},
{Red,pp},
$PointSize,Point[{y0,y1,p,y2,y3,m1,m2,m3}],
circleText[
{∞,-3,-2,-1,0,1,2,3},
{p,m3,m2,m1,y0,y1,y2,y3}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

Alternatively, we can construct the negative integers using

1=-1+2,
1=-2+3,
1=-3+4,

and so on.

Module[
{u=Circle[{0,1},1],x0={0,0},x1={1,0},p={0,2},y0,y1,pp,s1,s2,y2,s3,y3,s4,y4,m1,m2,m3},
y0=othermeet[u,p,x0];
y1=othermeet[u,p,x1];
pp=InfiniteLine@@First@tangents[p,u];
s1=meet[Line@{y0,y1},pp];
s2=meet[First@tangents[y1,u],pp];
y2=othermeet[u,y0,s2];
s3=meet[Line@{y1,y2},pp];
y3=othermeet[u,y0,s3];
s4=meet[Line@{y1,y3},pp];
y4=othermeet[u,y0,s4];
m1=othermeet[u,y2,s1];
m2=othermeet[u,y3,s1];
m3=othermeet[u,y4,s1];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,
Line@{y0,y1,s1,y0},
Line@{m1,y2,s1,m1},
Line@{m2,y3,s1,m2},
Line@{m3,y4,s1,m3}},
{Red,pp},
$PointSize,Point[{y0,y1,p,s1,y2,y3,y4,m1,m2,m3}],
circleText[
{∞,-3,-2,-1,0,1,2,3,4},
{p,m3,m2,m1,y0,y1,y2,y3,y4}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

By fixing b while letting a vary, we obtain a vivid picture of the transformation that adds b to every number a. The points a and a+b chase each other round the conic, irrespective of whether b happens to be positive or negative.

Manipulate[
Module[{u=Circle[{0,1},1],x0={0,0},xb={3.3,0},p={0,2},y0,a,b,pp,s,c},
y0=othermeet[u,p,x0];
a={0,1}+{Cos[2Pi t],Sin[2Pi t]};
b=othermeet[u,p,xb];
pp=InfiniteLine@@First@tangents[p,u];
s=meet[Line@{a,b},pp];
c=othermeet[u,y0,s];
Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,b,s,a},Line@{y0,c,s,y0}},
{Red,pp},
$PointSize,Point[{y0,a,b,p,s,c}],
circleText[{∞,0,ai,bi,ai+bi},{p,y0,a,b,c}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
],
{{t,.85,Style["t",Italic]},0,1,Appearance->"Labeled"},
SaveDefinitions->True
]

Manipulate[
Module[{u=Circle[{0,1},1],x0={0,0},xb={-3.3,0},p={0,2},y0,a,b,pp,s,c},
y0=othermeet[u,p,x0];
a={0,1}+{Cos[2Pi t],Sin[2Pi t]};
b=othermeet[u,p,xb];
pp=InfiniteLine@@First@tangents[p,u];
s=meet[Line@{a,b},pp];
c=othermeet[u,y0,s];
Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,b,s,a},Line@{y0,c,s,y0}},
{Red,pp},
{$PointSize,Point@{y0,a,b,p,s,c}},
circleText[Join[{∞,0,ai,bi,ai+bi}],{p,y0,a,b,c}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
],
{{t,0.13,Style["t",Italic]},0,1,Appearance->"Labeled"},
SaveDefinitions->True
]

In our construction for the point 2, we tacitly assumed that the tangent at 1 can be regarded as the join of 1 and 1.

Module[
{u=Circle[{0,1},1],x0={0,0},x1={1,0},p={0,2},y0,y1,pp,s2,y2},
{y0,y1}=othermeet[u,p,#]&/@{x0,x1};
pp=InfiniteLine@@First@tangents[p,u];
s2=meet[First@tangents[y1,u],pp];
y2=othermeet[u,y0,s2];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{s2,y1},Line@{y0,y2,s2,y0}},
{Red,pp},
$PointSize,Point[{y0,y1,p,s2,y2}],
circleText[{∞,0,1,2},{p,y0,y1,y2}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

More generally, the join of a and b meets the tangent at infinity in a point from which the remaining tangent has, for its point of contact, a point x such that x+x=a+b, namely, (a+b)/2, which is the arithmetic mean (or average) of a and b.

Module[
{u=Circle[{0,1},1],x0={0,0},xa={3,0},xb={-1.5 ,0},p={0,2},y0,a,b,pp,s,x},
{y0,a,b}=othermeet[u,p,#]&/@{x0,xa,xb};
pp=InfiniteLine@@First@tangents[p,u];
s=meet[pp,Line@{a,b}];
x=First@meet[u,tangents[s,u][[2]]];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,b,s,a},HalfLine@{s,x}},
{Red,pp},
$PointSize,Point[{a,b,p,s,x}],
circleText[{∞,0,ai,bi,(ai+bi)/2},{p,y0,a,b,x}]
},PlotRange->{{-3,3},{-.5,2.5}}
]
]

This result holds not only when a+b is even but also when a+b is odd; for instance, when a and b are consecutive integers. In this way we can interpolate 1/2 between 0 and 1, 1 1/2 between 1 and 2 and so on.

Module[
{u=Circle[{0,1},1],x0={0,0},xa={1,0},p={0,2},a,b,pp,s,x},
a=othermeet[u,p,xa];
pp=InfiniteLine@@First@tangents[p,u];
s=meet[pp,Line@{x0,a}];
x=Last@tangentpoints[s,u];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,s,a},Line@{x0,s},HalfLine@{s,x}},
{Red,pp},
$PointSize,Point[{p,x0,a,s,x}],
circleText[{∞,0,1/2,1},{p,x0,x,a}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

We shall find it convenient to work in the scale of 2 (or binary scale), so that the number 2 itself is written as 10, one half as 0.1, one quarter as 0.01, three quarters as 0.11 and so on.

Module[
{u=Circle[{0,1},1],xa={0,0},xb={1,0},p={0,2},a,b,pp,s,x},
{a,b}=othermeet[u,p,#]&/@{xa,xb};
pp=InfiniteLine@@First@tangents[p,u];
s=meet[pp,Line@{a,b}];
x=Last@tangentpoints[s,u];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,b,s,a},Line@{s,x}},
{Red,pp},
$PointSize,Point[{a,b,p,s,x}],
circleText[{∞,0,1,.1},{p,a,b,x}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

We can now interpolate

1.1 between 1 and 10, …

Module[
{u=Circle[{0,1},1],xa={1,0},xb={2,0},p={0,2},a,b,pp,s,x},
{a,b}=othermeet[u,p,#]&/@{xa,xb};
pp=InfiniteLine@@First@tangents[p,u];
s=meet[pp,Line@{a,b}];
x=Last@tangentpoints[s,u];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,b,s,a},Line@{s,x}},
{Red,pp},
$PointSize,Point[{a,b,p,s,x}],
circleText[{∞,1,10,1.1},{p,a,b,x}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

1.01 between 1 and 1.1, …

Module[
{u=Circle[{0,1},1],x0={0,0},xa={1,0},xb={2,0},p={0,2},a,b,pp,s,x},
{a,b}=othermeet[u,p,#]&/@{xa,xb};
pp=InfiniteLine@@First@tangents[p,u];
s=meet[pp,Line@{a,b}];
x=Last@tangentpoints[s,u];
s2=meet[pp,Line@{x,b}];
x2=Last@tangentpoints[s2,u];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,b,s,a},HalfLine@{s,x},Blue,HalfLine@{s2,x},HalfLine@{s2,x2}},
{Red,pp},
$PointSize,Point[{a,b,p,s,x,s2,x2}],
circleText[{1,10,1.1,1.01},{a,b,x,x2},1.1]},
PlotRange->{{0,1.6},{.5,2.1}}
]
]

… and so on to the eighths between 1 and 10.

Module[
{u=Circle[{0,1},1],xa={#,0}&/@(1+Range[0,8]/8.),p={0,2},a,b,pp,s,x},
a=othermeet[u,p,#]&/@xa;
pp=InfiniteLine@@First@tangents[p,u];
s=meet[pp,Line@#]&/@Transpose@{Most@a,Rest@a};
x=Last@tangentpoints[#,u]&/@s;
Framed@Graphics[
{
{Magenta,u},
$PointSize,Point[a],
circleText[{1,1.001,1.010,1.011,1.100,1.101,1.110,1.111,10},a]
},PlotRange->{{0,2},{.1,1.2}}
]
]

In fact, we can construct a point for every number that can be expressed as a terminating "decimal" in the binary scale. By a limiting process, we can thus theoretically assign a position to every real number.

For instance, the square root of two, being (in the binary scale)

1.0110101000001 …,

is the limit of a certain sequence of constructible numbers:

1,1.01, 1.011, 1.01101, …

Conversely, by a process of repeated bisection, we can assign a binary "decimal" to any given point on the conic. (The "but one" is, of course, the point to which we arbitrarily assigned the symbol infinity.)

Module[
{u=Circle[{0,1},1],ma={-1.75 ,0},mb={-1.5 ,0},mc={-1,0},md={-.5 ,0},x0={0,0},xa={.5 ,0},xb={1,0},xc={1.5 ,0},xd={1.75 ,0},p={0,2},na,nb,nc,nd,y0,a,b,c,d},
{na,nb,nc,nd,y0,a,b,c,d}=othermeet[u,p,#]&/@{ma,mb,mc,md,x0,xa,xb,xc,xd};
Framed@Graphics[
{
{Magenta,u},
$PointSize,Point[{na,nb,nc,nd,y0,a,b,c,d,p}],
circleText[
{∞,-1.11,-1.1,-1,-.1,0,.1,1,1.1,1.11},
{offi,na,nb,nc,nd,y0,a,b,c,d}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

We can now define multiplication in terms of the same three points 0, 1 and infinity.

Two pairs of points have the same product if their joins are concurrent with the line joining 0 and infinity.

Module[
{u=Circle[{0,1},1],m3={-3/2 ,0},m2={-2/2 ,0},x0={0,0},x1={1/2,0},x2={2/2 ,0},x3={3/2 ,0},x6={6/2 ,0},p={0,2},n3,n2,y0,y1,y2,y3,y6,r},
{n3,n2,y0,y1,y2,y3,y6}=othermeet[u,p,#]&/@{m3,m2,x0,x1,x2,x3,x6};
r=meet[Line@{y0,p},Line@{n3,n2}];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{n3,n2,r,n3},Line@{y1,y6,r,y1},Line@{y2,y3,r,y2}},
{Red,InfiniteLine@@Line@{r,p}},
$PointSize,Point[{n3,n2,y0,y1,y2,y3,y6,p,r}],
circleText[
{∞,-3,-2,0,1,2,3,6},
{offi,n3,n2,off0,y1,y2,y3,y6}
]
},PlotRange->{{-2.5,2.5},{-1.5,2.5}}
]
]

The geometrical theory of projectivities is somewhat too complicated to describe here, so let us be content to remark that, if we pursued it, we could prove that our definition for addition is consistent with this definition for multiplication.

Manipulate[
Module[
{u=Circle[{0,1},1],x0={0,0},p={0,2},r={0,-1},y0,x,y,c,a,b},
y0=othermeet[u,p,x0];
{x,y}=tangentpoints[r,u];
c=t x+(1-t) y;
{a,b}=If[t==0||t==1,{c,c},meet[Line@{c,r},u]];
{a,b}=If[distance[r,a]<distance[r,b],{a,b},{b,a}];
Graphics[
{
{Magenta,u},
{Red,InfiniteLine@@Line@{r,p}},
{Darker@Green,Line@{r,b}},
$PointSize,Point[{y0,a,b,p,r}],
circleText[{0,∞},{off0,offi}]
},PlotRange->{{-2.5,2.5},{-1.3,2.5}}
]
],
{{t,0,Style["t",Italic]},0,1,Appearance->"Labeled"},
SaveDefinitions->True
]

The product is positive if the point of concurrence is outside, negative if it is inside the conic.

Module[
{u=Circle[{0,1},1],m6={-6/2,0},m3={-3/2,0},m2={-2/2,0},m1={-1/2,0},x0={0,0},x1={1/2,0},x2={2/2 ,0},x3={3/2,0},x6={6/2,0},p={0,2},n6,n3,n2,n1,y0,y1,y2,y3,y6,r},
{n6,n3,n2,n1,y0,y1,y2,y3,y6}=othermeet[Circle[{0,1},1],p,#]&/@{m6,m3,m2,m1,x0,x1,x2,x3,x6};
c=meet[Line@{n6,y1},Line@{n1,y6}];
Framed@Graphics[
{
{Magenta,Circle[{0,1},1]},
{Darker@Green,Line@{n6,y1},Line@{n3,y2},Line@{n2,y3},Line@{n1,y6}},
{Red,InfiniteLine@{y0,p}},
$PointSize,Point[{n6,n3,n2,n1,y0,y1,y2,y3,y6,p,c}],
circleText[
{0,∞,-6,-3,-2,-1,1,2,3,6},
{off0,offi,n6,n3,n2,n1,y1,y2,y3,y6}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

In other words, we define the product a b of any two points a and b on the conic to be the remaining point of intersection of the conic with the line joining 1 to the point where the line joining 0 and infinity meets the line joining a and b.

Module[
{u=Circle[{0,1},1],x0={0,0},x1={1,0},xa={5,0},xb={-1/2 ,0},p={0,2},y0,y1,a,b,ab,c,r},
{y0,y1,a,b}=othermeet[u,p,#]&/@{x0,x1,xa,xb};
c=meet[Line@{y1,ab},Line@{a,b}];
ab=othermeet[u,y1,meet[Line@{a,b},Line@{y0,p}]];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,b},Line@{y1,ab}},
{Red,InfiniteLine@{y0,p}},
$PointSize,Point[{y0,y1,a,p,ab,b,c}],
circleText[
{0,∞,1,ai,bi,Row[{ai,"",bi}]},
{off0,offi,y1,a,b,ab}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

Of course, the question arises as to whether this definition agrees with our usual requirements for the multiplication of numbers:

the commutative law a b=b a

a unique solution for every equation of the form a x=c (with a≠0)

the associative law (a b)c=a(b c)

The commutative law is satisfied immediately, as our definition for a b involves a and b symmetrically.

The equation a x=c is solved by choosing x so that a and x have the same product as 1 and c.

Module[
{u=Circle[{0,1},1],x0={0,0},x1={1,0},xx={6,0},xa={-1/2,0},p={0,2},y0,y1,x,a,c,r},
{y0,y1,a,x}=othermeet[u,p,#]&/@{x0,x1,xa,xx};
c=othermeet[u,y1,meet[Line@{a,x},Line@{y0,p}]];
v=meet[Line@{a,x},Line@{y1,c}];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,x},Line@{y1,c}},
{Red,InfiniteLine@{y0,p}},
$PointSize,Point[{y0,y1,x,p,c,a,v}],
circleText[
{0,∞,1,ai,xi,ci},
{off0,offi,y1,a,x,c}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

Finally, another application of Pascal's theorem suffices to show the associative law.

Module[
{u=Circle[{0,1},1],x0={0,0},xf={-5,0},xd={-25/16,0},xb={-1/2,0},xe={2/5,0},xa={5/4,0},xc={4,0},p={0,2},,y0,a,b,c,d,e,f,r,v,w,x},
{y0,a,b,c,d,e,f}=othermeet[u,p,#]&/@{x0,xa,xb,xc,xd,xe,xf};
v=meet[Line@{a,b},Line@{d,e}];
w=meet[Line@{b,c},Line@{e,f}];
x=meet[Line@{c,d},Line@{f,a}];
Framed@Graphics[
{
{Magenta,u},
{Blue,Line@{a,b},Line@{d,e}},
{Cyan,Line@{b,c},Line@{e,f}},
{Darker@Green,Line@{f,a},Line@{c,d}},
{Red,InfiniteLine@{y0,p}},
$PointSize,Point[{a,b,c,d,e,f,y0,p,v,w,x}],
circleText[
Join[{0,∞},Style[#,Italic]&/@{"A","B","C","D","E","F"}],
{off0,offi,a,b,c,d,e,f}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

That is, for any three points a, b, c, the product of a b and c is equal to the product of a and b c. In fact, the appropriate hexagon is (a,b,c,a b,1,b c).

Module[
{u=Circle[{0,1},1],x0={0,0},xf={-5,0},xd={-25/16,0},xb={-1/2,0},xe={2/5,0},xa={5/4,0},xc={4,0},p={0,2},y0,a,b,c,d,e,f,r,v,w,x},
{y0,a,b,c,d,e,f}=othermeet[u,p,#]&/@{x0,xa,xb,xc,xd,xe,xf};
v=meet[Line@{a,b},Line@{d,e}];
w=meet[Line@{b,c},Line@{e,f}];
x=meet[Line@{c,d},Line@{f,a}];
Framed@Graphics[
{
{Magenta,u},
{Blue,Line@{a,b},Line@{d,e}},
{Cyan,Line@{b,c},Line@{e,f}},
{Darker@Green,Line@{f,a},Line@{c,d}},
{Red,InfiniteLine@{y0,p}},
$PointSize,Point[{a,b,c,d,e,f,y0,p,v,w,x}],
circleText[
{0,∞,ai,bi,ci,Row[{ai,"",bi}],1,Row[{bi,"",ci}]},
{off0,offi,a,b,c,d,e,f}
]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
]

By fixing b while letting a vary, we obtain a vivid picture of the transformation that multiplies every number by b. If b is positive, the points a and a b chase each other round the conic.

Manipulate[
Module[
{u=Circle[{0,1},1],x0={0,0},x1={1,0},xb={3.2,0},p={0,2},y0,y1,a,b,ab,r,c},
{y0,y1}=othermeet[u,p,#]&/@{x0,x1};
a={0,1}+{Cos[2Pi t],Sin[2Pi t]};
b=othermeet[u,p,xb];
ab=othermeet[u,y1,meet[Line@{a,b},Line@{y0,p}]];
c=meet[Line@{y1,ab},Line@{a,b}];
Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,b,c},Line@{y1,ab,c}},
{Red,InfiniteLine@{y0,p}},
$PointSize,Point[{y0,y1,a,p,ab,b,c}],
circleText[{Row[{ai,"",bi}],ai,1,bi},{ab,a,y1,b}],
Text[0, y0,{-1.5,1.5}],
Text[Style["∞",12],p,{-1.5,-1.5}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
],
{{t,0,Style["t",Italic]},0,1,Appearance->"Labeled"},
SaveDefinitions->True
]

But if b is negative, they go round in opposite directions.

Manipulate[
Module[
{u=Circle[{0,1},1],x0={0,0},x1={1,0},xb={-3.2,0},p={0,2},y0,y1,a,b,ab,r,c},
{y0,y1}=othermeet[u,p,#]&/@{x0,x1};
a={0,1}+{Cos[2Pi t],Sin[2Pi t]};
b=othermeet[u,p,xb];
ab=othermeet[u,y1,meet[Line@{a,b},Line@{y0,p}]];
c=meet[Line@{y1,ab},Line@{a,b}];
Graphics[
{
{Magenta,u},
{Darker@Green,Line@{a,b,c},Line@{y1,ab,c}},
{Red,InfiniteLine@{y0,p}},
$PointSize,Point[{y0,y1,a,p,ab,b,c}],
circleText[{Row[{ai,"",bi}],ai,1,bi},{ab,a,y1,b}],
Text[0, y0,{-1.5,1.5}],
Text[Style["∞",12],p,{-1.5,-1.5}]
},PlotRange->{{-2.5,2.5},{-.5,2.5}}
]
],
{{t,0,Style["t",Italic]},0,1,Appearance->"Labeled"},
SaveDefinitions->True
]

The familiar identity 2×2=4 is illustrated by the concurrence of the tangent at 2 with the line joining 1 and 4 and the line joining 0 and infinity.

Module[
{u=Circle[{0,1},1],m2={-2.5/2,0},x0={0,0},x1={1/2,0},x2={2.5/2,0},x4={6.25/2,0},p={0,2},n2,y0,y1,y2,y4,r},
{n2,y0,y1,y2,y4}=othermeet[u,p,#]&/@{m2,x0,x1,x2,x4};
r=meet[Line@{y1,y4},Line@{y0,p}];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,HalfLine@{r,n2},Line@{r,y4},HalfLine@{r,y2}},
{Red,InfiniteLine@{r,p}},
$PointSize,Point[{y0,y1,y2,y4,p,n2,r}],
circleText[{-2,1,2,4},{n2,y1,y2,y4}],
Text[0, y0,{-1.5,1.5}],
Text[Style["∞",12],p,{-1.5,-1.5}]
},PlotRange->{{-2.5,2.5},{-1.4,2.5}}
]
]

More generally, if a and b are any two numbers having the same sign, the join of the corresponding points meets the line joining 0 to infinity in a point from which the two tangents have, for their points of contact, points x such that (x^2)=a b, namely ±(Sqrt[a b]), where the square root of a b is the geometric mean of a and b.

Module[
{u=Circle[{0,1},1],m2={-2.5/2,0},x0={0,0},x1={1/2,0},x2={2.5/2,0},x4={6.25/2,0},p={0,2},n2,y0,y1,y2,y4,r},
{n2,y0,y1,y2,y4}=othermeet[u,p,#]&/@{m2,x0,x1,x2,x4};
r=meet[Line@{y1,y4},Line@{y0,p}];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,HalfLine@{r,n2},Line@{r,y4},HalfLine@{r,y2}},
{Red,InfiniteLine@{r,p}},
$PointSize,Point[{y0,y1,y2,y4,p,n2,r}],
circleText[{ai,bi},{y1,y4}],
circleText[(Sqrt[Row[{ai,"",bi}]]){-1,1},{n2,y2},1.3],
Text[0, y0,{-1.5,1.5}],
Text[Style["∞",12],p,{-1.5,-1.5}]
},PlotRange->{{-2.5,2.5},{-1.4,2.5}}
]
]

Setting a=1 and b=2, we obtain a construction for the square root of two without having recourse to any limiting process. In fact, we have finite constructions for all the "quadratic" numbers commonly associated with Euclid's straight-edge and compass.

Module[
{u=Circle[{0,1},1],m2={-2.1/2,0},x0={0,0},x1={1/2,0},x2={2.1/2,0},x4={4.41/2,0},p= {0,2},n2,y0,y1,y2,y4,r},
{n2,y0,y1,y2,y4}=othermeet[u,p,#]&/@{m2,x0,x1,x2,x4};
r=meet[Line@{y1,y4},Line@{y0,p}];
Framed@Graphics[
{
{Magenta,u},
{Darker@Green,Line@{r,n2},Line@{r,y4},Line@{r,y2}},
{Red,InfiniteLine@{r,p}},
$PointSize,Point[{y0,y1,y2,y4,p,n2,r}],
circleText[
{∞,0,1,2,(Sqrt[2]),-(Sqrt[2])},
{offi,off0,y1,y4,n2,y2},1.3
]
},PlotRange->{{-2.5,2.5},{-1.3,2.5}}
]
]

Projectivities

One of the most fruitful ideas of the nineteenth century is that of one-to-one correspondence. It is well illustrated by the example of cups and saucers. Suppose we have about a hundred cups and about a hundred saucers and wish to know whether the number of cups is actually equal to the number of saucers. This can be determined, without counting, by the simple device of putting each cup on a saucer, that is, by establishing a one-to-one correspondence between the cups and saucers.

In our first application of this idea to plane geometry, the cups are points, the saucers are lines and the relation "cup on saucer" is incidence. As we know, a line is determined by any two of its points and is of unlimited extent. We say that a point and a line are "incident" if the point lies on the line; that is, if the line passes through the point. It is natural to ask whether the number of points on a line is actually equal to the number of lines through a point. In ordinary geometry both numbers are infinite, but this fact need not trouble us: if we can establish a one-to-one correspondence between the points and lines, there are equally many of each.

The set of all points on a line o is called a range and the set of all lines through a point O is called a pencil. If the line o and the point O are not incident, we can establish an elementary correspondence between the range and the pencil by means of the relation of incidence. Each point X of the range lies on a corresponding line x of the pencil. The range is a section of the pencil (namely the section by the line o) and the pencil projects the range (from the point O).

In our picture, the range is represented by a red point X moving along a fixed line o (which, for convenience, is taken to be horizontal) and the pencil is represented by a green line x rotating around a fixed point O.

Manipulate[
Module[
{OO={-1,2},o1={-4,0},o2={4,0},o,l,X,x},
o=InfiniteLine@{o1,o2};
l=Line@{OO,OO+{Cos[2Pi t],Sin[2Pi t]}};
X=meet[l,o];
x=InfiniteLine@{OO,X};
Graphics[
{
{Blue,o},
{Darker@Green,x},
$PointSize,Point@OO,{Red,Point@X},
text["O",OO,{2,2}],
text["X",X,{2,2}],
text["o",.9 o1+.1 o2,{0,-2}],
text["x",(X+OO)/2,{2,2}],
text[Column[{
Row@{"X"," ",proj[""]," ","x"},
Row@{"x"," ",proj[""]," ","X"}
}],OO+{3,1}]
},
PlotRange->5]
],
{{t,.3,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

There is evidently a green line for each position of the red point. But we must admit that for some positions of the green line the red point cannot be seen because it is too far away; in fact, when the green line is parallel to o (that is, horizontal), the red point is one of the ideal "points at infinity" that we agree to add to the ordinary plane so as to make the projective plane. Without this ideal point, our elementary correspondence would not be one-to-one: the number of points in the range would be one less than the number of lines in the pencil. In other words, the postulation of ideal points makes it possible for us to express the axioms for the projective plane in such a way that they remain valid when we consistently interchange the words "point" and "line" (and consequently also certain other pairs of words such as "join" and "meet", "on" and "through", "collinear" and "concurrent" and so forth). It follows that the same kind of interchange can be made in all the theorems that can be deduced from the axioms.

This principle of duality is characteristic of projective geometry. In the plane we interchange points and lines. In space, the same principle enables us to interchange points and planes, while lines remain lines.

When we regard the elementary correspondence as taking us from the point X to the line x, we write the capital X before the small x, as X ⌅ x. The inverse correspondence, from x to X, is denoted by the same sign with the small x before the capital X, as x ⌅ X. If A, B, C, … are particular positions of X, and a, b, c, … of x, we write all these letters before and after the sign, taking care to keep them in their corresponding order (which need not be the order in which they appear to occur in the figure), A,B,C,… ⌅ a,b,c,….

This notation enables us to exhibit the principle of duality as the possibility of consistently interchanging capital and small letters.

By combining two elementary correspondences, one relating a range to a pencil and the other a pencil to a range, we obtain a perspectivity. This either relates two ranges that are different sections of one pencil, or two pencils that project one range from different centers.

In the former case, two of the symbols with one bar X ⌅ x, x ⌅ Y or X ⌅ x ⌅ Y can be abbreviated to one with two bars, or, if we wish to specify the point O that carries the pencil, we put O above the two bars, as o (Overscript[⌆, O]) m.

Manipulate[
Module[
{OO={-1,2},m1={-4,-2},m2={4,-1},o1={-4,0},o2={4,0},o,m,l,X,Y,x},
m=InfiniteLine@{m1,m2};
o=InfiniteLine@{o1,o2};
l=Line@{OO,OO+{Cos[2Pi t],Sin[2Pi t]}};
X=meet[l,o];
Y=meet[l,m];
x=InfiniteLine@{X,Y};
Graphics[
{
{Blue,o},
{Cyan,m},
{Darker@Green,x},
$PointSize,
Point@OO,{Red,Point[{X,Y}]},
text["O",OO,{2,2}],
text["o",.9 o1+.1 o2,{0,-2}],
text["m",.9m1+.1m2,{2,2}],
text["x",(X+OO)/2,{2,2}],
text["X",X,{2,2}],
text["Y",Y,{2,2}],
text[Column[{
Row@{"X"," ",proj[""]," ","x"},
Row@{"x"," ",proj[""]," ","Y"},
Row@{"X"," ",proj[""]," ","x"," ", proj[""]," ","Y"},
"",
Row@{"X"," ",pers[""]," ","Y"}
}],OO+{3,1}]
},
PlotRange->5]
],
{{t,.3,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

Manipulate[
Module[
{OO={-1,2},m1={-4,-2},m2={4,-1},o1={-4,0},o2={4,0},o,m,pencil1,rangeo,rangem},
m=InfiniteLine@{m1,m2};
o=InfiniteLine@{o1,o2};
pencil1=InfiniteLine@{OO,OO+{Cos[2Pi #],Sin[2Pi #]}}&/@{t,t+0.02,t+0.04,t+0.06};
rangeo=meet[#,o]&/@pencil1;
rangem=meet[#,m]&/@pencil1;
Graphics[
{
{Blue,o},
{Cyan,m},
{Darker@Green,pencil1},
$PointSize,
Point@OO,{Red,Point@Join[rangeo,rangem]},
text["O",OO,{2,2}],
text["o",.9 o1+.1 o2,{0,-2}],
text["m",.9m1+.1m2,{2,2}],
text["A",rangeo[[1]],{0,2}],
text["B",rangeo[[2]],{0,2}],
text["C",rangeo[[3]],{0,2}],
text["D",rangeo[[4]],{0,2}],
text["E",rangem[[1]],{0,2}],
text["F",rangem[[2]],{0,2}],
text["G",rangem[[3]],{0,2}],
text["H",rangem[[4]],{0,2}],
text[Row@{Style["ABCD",Italic]," ",pers["O"]," ",Style["EFGH",Italic]},OO+{3,1}]
},
PlotRange->5]
],
{{t,.3,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

In the latter case (when two pencils project one range from different centers), the two symbols with one bar are again abbreviated to one with two bars, and if we wish to specify the line o that carries the range, we put o above the bars.

Manipulate[
Module[
{OO={-1,2},M={2,2.5},m1={-4,-2},m2={4,-1},o1={-4,0},o2={4,0},mo,l,Y,x,y},
o=InfiniteLine@{o1,o2};
l=Line@{OO,OO+{Cos[2Pi t],Sin[2Pi t]}};
Y=meet[l,o];
x=InfiniteLine@{OO,Y};
y=InfiniteLine@{M,Y};
Graphics[
{
{Blue,o},
{Darker@Green,x,Red,y},
$PointSize,
Point@{OO,M,Y},
text["O",OO,{0,2}],
text["o",.9 o1+.1 o2,{0,-2}],
text["M",M,{0,2}],
text["Y",Y,{0,2}],
text["x",1/2(OO+Y),{0,2}],
text["y",1/2(M+Y),{2,2}],
text[Column[{
Row@{"x"," ",proj[""]," ","Y"},
Row@{"Y"," ",proj[""]," ","y"},
Row@{"x"," ",proj[""]," ","Y"," ",proj[""]," ","y"},
"",
Row@{"x"," ",pers[""]," ","y"},
"",
Row@{"x"," ",pers["o"]," ","y"}
}],OO+{3.5,-4.5}]
},
PlotRange->5]
],
{{t,.3,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

Manipulate[
Module[
{OO={-1,2},M={2,2.5},m1={-4,-2},m2={4,-1},o1={-4,0},o2={4,0},o,pencil1,rangeo,pencil2},
o=InfiniteLine@{o1,o2};
pencil1=InfiniteLine@{OO,OO+{Cos[2Pi #],Sin[2Pi #]}}&/@{t,t+.02,t+.04,t+.06};
rangeo=meet[#,o]&/@pencil1;
pencil2=InfiniteLine@{#,M}&/@rangeo;
Graphics[
{
{Blue,o},
{Darker@Green,pencil1,Red,pencil2},
$PointSize,
Point[{OO,M}],
Point[rangeo],
text["O",OO,{2,0}],
text["o",.9 o1+.1 o2,{0,-2}],
text["M",M,{2,0}],
text["a",1/2(OO+rangeo[[1]])],
text["b",1/2(OO+rangeo[[2]])],
text["c",1/2(OO+rangeo[[3]])],
text["d",1/2(OO+rangeo[[4]])],
text["e",1/2(M+rangeo[[1]])],
text["f",1/2(M+rangeo[[2]])],
text["g",1/2(M+rangeo[[3]])],
text["h",1/2(M+rangeo[[4]])],
Style[text[Row@{Style["abcd",Italic]," ",pers["o"]," ",Style["efgh",Italic]},{0,4.5}],12]
},
PlotRange->5]
],
{{t,.34,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

We can easily go on to combine three or more elementary correspondences. But then we prefer not to increase the complication of the symbols. Instead, we retain the simple symbol (with just one bar) for the product of any number of elementary correspondences. Such a transformation is called a projectivity. Thus elementary correspondences and perspectivities are the two simplest instances of a projectivity.

The product of three elementary correspondences is the simplest instance of a correspondence relating a range to a pencil in such a way that the range is not merely a section of the pencil.

Manipulate[
Module[
{OO={-1,2},M={2,2.5},m1={-4,-2},m2={4,-1},o1={-4,0},o2={4,0},o,m,l,X,Y,x,y},
m=InfiniteLine@{m1,m2};
o=InfiniteLine@{o1,o2};
l=Line@{OO,OO+{Cos[2Pi t],Sin[2Pi t]}};
X=meet[l,o];
Y=meet[l,m];
x=InfiniteLine@{X,Y};
y=InfiniteLine@{M,Y};
Graphics[
{
{Blue,o},
{Cyan,m},
{Darker@Green,x,y},
$PointSize,
Point[{OO,M,Y}],{Red,Point@X},
text["O",OO,{2,2}],
text["M",M,{2,2}],
text["o",.9 o1+.1 o2,{0,-2}],
text["m",.9m1+.1m2,{2,2}],
text["X",X,{2,2}],
text["Y",Y,{2,2}],
text["x",1/2(OO+X),{0,2}],
text["y",.7M+.3Y,{0,2}],
Style[text[Row@{"X"," ",proj[""]," ","y"},{0,4.5}]
,12]},
PlotRange->5]
],
{{t,.3,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

Manipulate[
Module[
{OO={-1,2},M={2,2.5},m1={-4,-2},m2={4,-1},o1={-4,0},o2={4,0},mo,m,pencil1,rangeo,rangem,x,y},
m=InfiniteLine@{m1,m2};
o=InfiniteLine@{o1,o2};
pencil1=InfiniteLine@{OO,OO+{Cos[2Pi #],Sin[2Pi #]}}&/@{t,t+.02,t+.04,t+.06};
rangeo=meet[#,o]&/@pencil1;
rangem=meet[#,m]&/@pencil1;
pencil2=InfiniteLine@{M,#}&/@rangem;
Graphics[
{
{Blue,o},
{Cyan,m},
{Darker@Green,pencil1,pencil2},
$PointSize,
Point[{OO,M}],{Red,Point@rangeo,Point@rangem},
text["O",OO,{2,2}],
text["M",M,{2,2}],
text["o",.9 o1+.1 o2,{0,-2}],
text["m",.9m1+.1m2,{2,2}],
text["A",rangeo[[1]],{0,2}],
text["B",rangeo[[2]],{0,2}],
text["C",rangeo[[3]],{0,2}],
text["D",rangeo[[4]],{0,2}],
text["e",1/2(M+rangem[[1]])],
text["f",1/2(M+rangem[[2]])],
text["g",1/2(M+rangem[[3]])],
text["h",1/2(M+rangem[[4]])],
Style[text[Row@{"ABCD"," ",proj[""]," ","efgh"},{0,4.5}],12]
},
PlotRange->5]
],
{{t,.3,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

The product of four elementary correspondences, being the product of two perspectivities, shares with a simple perspectivity the property of relating a range to a range or a pencil to a pencil. Now there is the interesting possibility that the initial and final range (or pencil) may be on the same line (or through the same point). We see two moving red points X and Z, on o, related by perspectivities from O and M to an auxiliary red point Y on m. When X reaches C, on m, we have another invariant point; the three red points all come together.

Such a projectivity, having two distinct invariant points, is said to be hyperbolic.

Manipulate[
Module[
{OO={-.5,1.5},M={-2,3},m1={-4,-2},m2={3,0},o1={-4,0},o2={4,0},o,m,pencil1,rangeo,rangem,x,y},
m=InfiniteLine@{m1,m2};
o=InfiniteLine@{o1,o2};
l=InfiniteLine@{OO,OO+{Cos[2Pi t],Sin[2Pi t]}};
X=meet[l,o];
Y=meet[l,m];
x=InfiniteLine@{X,Y};
Z=meet[Line@{Y,M},o];
y=InfiniteLine@{Y,Z};
QM=InfiniteLine@{OO,M};
F=meet[QM,o];
c=meet[o,m];
Graphics[
{
{Blue,o},
{Cyan,m},
{Darker@Green,x,y,QM},
$PointSize,
Point[{OO,M,F,c}],{Red,Point@{X,Y,Z}},
text["O",OO,{2,2}],
text["M",M,{2,2}],
text["o",.9 o1+.1 o2,{0,-2}],
text["m",.9m1+.1m2,{2,2}],
text["Y",Y,{2,2}],
text["F",F,{2,2}],
text["C",c,{0,-2}],
text["X",X,{0,-2}],
text["Z",Z,{0,2}],
text[Column[{
"Hyperbolic Projectivity",
"",
Row[{"X"," ",proj[""]," ","Y"," ",proj[""]," ","Z"}],
"",
Row[{"X"," ",proj[""]," ","Z"}]
},Alignment->Center],OO+{3,2}]
},
PlotRange->5]
],
{{t,.3,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

On the other hand, the three lines o, m and O M may all meet in a single point C, so that F coincides with C and there is only one invariant point. Such a projectivity is said to be parabolic.

Manipulate[
Module[
{OO={-.5,1.5},m1={-4,-2},m2={3,0},o1={-4,0},o2={4,0},o,m,l,X,Y,x,c,Z,QM,y},
m=InfiniteLine@{m1,m2};
o=InfiniteLine@{o1,o2};
l=InfiniteLine@{OO,OO+{Cos[2Pi t],Sin[2Pi t]}};
X=meet[l,o];
Y=meet[l,m];
x=InfiniteLine@{X,Y};
c=meet[o,m];
M=c+1.2(OO-c);
Z=meet[Line@{Y,M},o];
QM=InfiniteLine@{OO,M};
y=InfiniteLine@{Y,Z};
Graphics[
{
{Blue,o},
{Cyan,m},
{Darker@Green,x,y,QM},
$PointSize,
Point[{OO,M,c}],{Red,Point@{X,Y,Z}},
text["O",OO,{2,2}],
text["M",M,{2,2}],
text["o",.9 o1+.1 o2,{0,-2}],
text["m",.9m1+.1m2,{2,2}],
text["Y",Y,{2,2}],
text["C",c,{0,-2}],
text["X",X,{0,-2}],
text["Z",Z,{0,2}],
text[Column[{
"Parabolic Projectivity",
"",
Row[{"X"," ",proj["O"]," ","Y"," ",proj["M"]," ","Z"}],
"",
Row[{"X"," ",proj[""]," ","Z"}]
},Alignment->Center],OO+{3,2}]
},
PlotRange->5]
],
{{t,.3,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

A third possibility is an elliptic projectivity that has no invariant point, but this is more complicated, requiring three perspectivities (i.e., six elementary correspondences). The centers of the three perspectivities are S, E and Q. The green lines, rotating around these points, yield four red points. Two of the red points W and Q chase each other along the bottom line A D.

Manipulate[
Module[
{M={-2,3},m1={3,-3},m2={1,3},n1={4,2},n2=-{4,1.2},o1={-4,0},o2={4,0},e,q,s,o,m,n,l,W,X,x,Y,y,Z,z,a,d,k},
e=.75 o1+.25 o2;
q=.6 m1+.4 m2;
s=.56 n1+.44 n2;
m=InfiniteLine@{m1,m2};
n=InfiniteLine@{n1,n2};
o=InfiniteLine@{o1,o2};
l=Line@{s,s+{Cos[2Pi t],Sin[2Pi t]}};
W=meet[l,o];
X=meet[l,m];
x=InfiniteLine@{W,X};
Y=meet[Line@{e,X},n];
y=InfiniteLine@{X,Y};
Z=meet[Line@{q,Y},o];
z=InfiniteLine@{Y,Z};
a=meet[o,n];
d=meet[o,m];
k=meet[m,n];
Graphics[
{
{Blue,o},
{Cyan,m},
{Darker@Green,x,y,z},
$PointSize,
{Blue,Point[{e,q,s,a,d,k}]},
{Red,Point@{W,X,Y,Z}},
text["o",.9 o1+.1 o2,{0,-2}],
text["m",.9m1+.1m2,{2,2}],
text["K",k,{2,2}],
text["S",s,{2,2}],
text["E",e,{2,2}],
text["Q",q,{2,2}],
text["A",a,{2,2}],
text["D",d,{2,2}],
text["W",W,{0,-2}],
text["X",X,{0,-2}],
text["Y",Y,{2,2}],
text["Z",Z,{0,2}],
text[Column[{
"Elliptic Projectivity",
"",
Row[{"W"," ",pers["S"]," ","X"," ",pers["E"]," ","Y"," ",pers["Q"]," ","Z"}]
},Alignment->Center],{2.5,3.5}]
},
PlotRange->5]
],
{{t,.34,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

These two points are related by the elliptic projectivity.

However, this is not the most general elliptic projectivity.

There is a special feature arising from the fact that the points S, E, Q lie on the sides of the green triangle. When one of the two red points is at A, the other is at D, and vice versa: the projectivity interchanges A and D and is consequently called an involution. Thus we are watching an elliptic involution.

Looking closely, we see that it not only interchanges A and D but also interchanges every pair of related points. For instance, it interchanges E with B (on S Q). An important theorem tells us that for any four collinear points A, B, D, E, there is just one involution that interchanges A with D and B with E.

We denote it by (A D)(B E). At any instant, the two red points are a pair belonging to this involution. Call them C and F. We now have three pairs of points, A D, B E, C F, on the bottom dark blue line, all belonging to one involution. The other lines form the six sides of a complete quadrangle P Q R S, which consists of four points (no three collinear) and the six lines that join them in pairs. Two sides are said to be opposite if their point of intersection is not a vertex; for instance, S P and Q R are a pair of opposite sides.

Manipulate[
Module[
{M={-2,3},m1={3,-3},m2={1,3},n1={4,2},n2=-{4,1.2},o1={-4,0},o2={4,0},e,q,s,o,m,n,l,c,r,x,p,y,f,z,a,d,k,b},
e=.75 o1+.25 o2;
q=.6 m1+.4 m2;
s=.56 n1+.44 n2;
m=InfiniteLine@{m1,m2};
n=InfiniteLine@{n1,n2};
o=InfiniteLine@{o1,o2};
l=Line@{s,s+{Cos[2Pi t],Sin[2Pi t]}};
c=meet[l,o];
r=meet[l,m];
x=InfiniteLine@{c,r};
p=meet[Line@{e,r},n];
y=InfiniteLine@{r,p};
f=meet[Line@{q,p},o];
z=InfiniteLine@{p,q};
a=meet[o,n];
d=meet[o,m];
k=meet[m,n];
b=meet[Line@{s,q},o];
sq=InfiniteLine@{s,q};
Graphics[
{
{Blue,o},{Cyan,m,n,sq},{Darker@Green,x,y,z},$PointSize,{Point@{e,q,s,a,d,k,b,r,p}},
{Red,Point@{c,f}},
text["o",.9 o1+.1 o2,{0,-2}],
text["m",.9m1+.1m2,{2,2}],
text["n",.9n1+.1n2,{2,2}],
text["K",k,{2,2}],
text["R",r,{2,2}],
text["E",e,{0,-2}],
text["Q",q,{2,2}],
text["S",s,{0,-2}],
text["A",a,{0,-2}],
text["D",d,{2,2}],
text["B",b,{0,-2}],
text["C",c,{0,-2}],
text["P",p,{2,2}],
text["F",f,{0,2}],
text[Column[{
"Elliptic Involution (AD)(BE)",
"",
Row[{"ACD"," ",pers["S"]," ","KRD"," ",pers["E"]," ","KPA"," ",pers["Q"]," ","DFA"}]
},Alignment->Center],{2.5,3.5}]
},
PlotRange->5]
],
{{t,.34,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

We see now that the six points named on the bottom dark blue line are sections of the six sides of the quadrangle, and that each related pair comes from a pair of opposite sides. Accordingly the six points, paired in this particular way, are said to form a quadrangular set. Here is another version of the quadrangle P Q R S and the corresponding quadrangular set A D, B E, C F. As before, C F is a pair of the involution (A D)(B E).

Manipulate[
Module[
{m1={3,-3},m2={1,3},n1={4,3},n2=-{4,1.2},o1={-4,0},o2={4,0},e,q,s,o,m,n,l,c,r,x,p,y,f,z,a,d,k,b,sq},
e=.45 o1+.55 o2;
q=.37 m1+.67 m2;
s=.39 n1+.61 n2;
m=InfiniteLine@{m1,m2};
n=InfiniteLine@{n1,n2};
o=InfiniteLine@{o1,o2};
l=Line@{s,s+{Cos[2Pi t],Sin[2Pi t]}};
c=meet[l,o];
r=meet[l,m];
x=InfiniteLine@{r,s};
p=meet[Line@{e,r},n];
y=InfiniteLine@{r,p};
f=meet[Line@{q,p},o];
z=InfiniteLine@{p,q};
a=meet[o,n];
d=meet[o,m];
k=meet[m,n];
b=meet[Line@{s,q},o];
sq=InfiniteLine@{s,q};
Graphics[
{
{Blue,o},{Cyan,m,n},{Darker@Green,x,z},{Magenta,y,sq},
$PointSize,Point@{p,q,r,s,k},
{Red,Point@{a,b,c,d,e,f}},
text["o",.1 o1+.9 o2,{0,-2}],
text["m",.9m1+.1m2,{2,2}],
text["n",.9n1+.1n2,{2,2}],
text["K",k,{2,2}],
text["R",r,{2,0}],
text["E",e,{0,2}],
text["Q",q,{2,2}],
text["S",s,{0,-2}],
text["A",a,{0,2}],
text["D",d,{2,2}],
text["B",b,{0,2}],
text["C",c,{0,2}],
text["P",p,{0,-2}],
text["F",f,{0,2}],
text[Column[{
"Quadrangle PQRS",
"",
"Quadrangular Set AD, BE, CF"
},Alignment->Center],{-3,4}]
},
PlotRange->5]
],
{{t,.63,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

This remains true when we move the bottom dark blue line to a new position so that D coincides with A and E with B. Now A and B are invariant points, and we have a hyperbolic involution (A A)(B B), which still interchanges C and F.

The quadrangular set of six points has become a harmonic set of four points. We say that C and F are harmonic conjugates of each other with respect to A and B, and that the four points satisfy the relation H(A B,C F).

This means that there is a quadrangle PQRS having two opposite sides through A and two opposite sides through B, while one of the remaining two sides passes through C and the other through F.

Manipulate[
Module[
{b={2.65,-1.2},m1=-{3.6,1.2},m2={1.2,3},n1={4.4,2.5},n2=-{3.6,1.2},o1=-{3.6,1.2},o2={4.4,-1.2},a,r,m,n,o,c,s,p,q,f,rs,qp,rp,sq},
a=n2;
r=m2;
m=InfiniteLine@{m1,m2};
n=InfiniteLine@{n1,n2};
o=InfiniteLine@{o1,o2};
c=meet[o,Line@{r,r+{Cos[2Pi t],Sin[2Pi t]}}];
s=meet[Line@{r,c},n];
q=meet[Line@{b,s},m];
p=meet[Line@{b,r},n];
f=meet[Line@{q,p},o];
m=InfiniteLine@{a,r};
n=InfiniteLine@{a,p};
o=InfiniteLine@{a,b};
rs=InfiniteLine@{r,s};
qp=InfiniteLine@{q,p};
rp=InfiniteLine@{r,p};
sq=InfiniteLine@{s,q};
Graphics[
{
{Blue,o},{Cyan,m,n},{Darker@Green,rs,qp},{Magenta,rp,sq},
$PointSize,Point@{p,q,r,s},
{Red,Point@{a,b,c,f}},
text["B",b,{0,2}],
text["C",c,{0,2}],
text["A",a,{0,2}],
text["F",f,{0,2}],
text["P",p,{0,2}],
text["Q",q,{0,2}],
text["R",r,{2,0}],
text["S",s,{0,2}],
text[Column[{
"Hyperbolic Involution (AA)(BB)",
"",
Row[{"ABC"," ",pers["S"]," ","AQR"," ",pers["B"]," ","ASP"," ",pers["Q"]," ","ABF"}]
},Alignment->Center],{-2.5,3.5}]
},
PlotRange->5]
],
{{t,.63,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

Given A, B and C, we can construct F by drawing a triangle SRQ whose sides pass through these three points.

Manipulate[
Module[
{b={2.65,-1.2},m1=-{3.6,1.2},m2={1.2,3},n1={4.4,2.5},n2=-{3.6,1.2},o1=-{3.6,1.2},o2={4.4,-1.2},a,r,m,n,o,c,s,p,q,f,rs,qp,rp,sq},
a=n2;
r=m2;
m=InfiniteLine@{m1,m2};
n=InfiniteLine@{n1,n2};
o=InfiniteLine@{o1,o2};
c=meet[o,Line@{r,r+{Cos[2Pi t],Sin[2Pi t]}}];
s=meet[Line@{r,c},n];
p=meet[Line@{b,r},n];
q=meet[Line@{b,s},m];
f=meet[Line@{q,p},o];
rs=InfiniteLine@{r,s};
qp=InfiniteLine@{q,p};
rp=InfiniteLine@{r,p};
sq=InfiniteLine@{s,q};
Graphics[
{
{Blue,o},{Cyan,m},{Darker@Green,rs},{Magenta,sq},$PointSize,Point@{q,r,s},
{Red,Point@{a,b,c}},
text["A",a,{0,2}],
text["B",b,{0,2}],
text["Q",q,{0,2}],
text["C",c,{0,2}],
text["S",s,{0,2}],
text["R",r,{2,0}],
text["Constructing F",{-2.5,3.5}]
},
PlotRange->5]
],
{{t,.65,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

Let AS meet BR in P; then PQ meets AB in F. Of course, the hyperbolic involution (AA)(BB) can still be constructed as the product of three perspectivities (with centers S, B, Q).

Manipulate[
Module[
{b={2.65,-1.2},m1=-{3.6,1.2},m2={1.2,3},n1={4.4,2.5},n2=-{3.6,1.2},o1=-{3.6,1.2},o2={4.4,-1.2},a,r,m,n,o,c,s,p,q,f,rs,qp,rp,sq},
a=n2;
r=m2;
m=InfiniteLine@{m1,m2};
n=InfiniteLine@{n1,n2};
o=InfiniteLine@{o1,o2};
c=meet[o,Line@{r,r+{Cos[2Pi t],Sin[2Pi t]}}];
s=meet[Line@{r,c},n];
p=meet[Line@{b,r},n];
q=meet[Line@{b,s},m];
f=meet[Line@{q,p},o];
rs=InfiniteLine@{r,s};
qp=InfiniteLine@{q,p};
rp=InfiniteLine@{r,p};
sq=InfiniteLine@{s,q};
Graphics[
{
{Blue,o},{Cyan,m,n},{Darker@Green,rs,qp},{Magenta,rp,sq},
$PointSize,Point@{p,q,r,s},
{Red,Point@{a,b,c,f}},
text["B",b,{0,2}],
text["C",c,{0,2}],
text["A",a,{0,2}],
text["F",f,{0,2}],
text["Q",q,{0,2}],
text["S",s,{0,2}],
text["P",p,{0,2}],
text["R",r,{2,0}],
text[Column[{
"Hyperbolic Involution (AA)(BB)",
"",
Row[{"ABC"," ",pers["S"]," ","AQR"," ",pers["B"]," ","ASP"," ",pers["Q"]," ","ABF"}]
},Alignment->Center],{-2.5,3.5}]
},
PlotRange->5]
],
{{t,.63,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

But the invariant points A and B enable us to replace these three perspectivities by two, with centers O (where AP meets CQ) and P.

Manipulate[
Module[
{b={3.65,-1.2},m1=-{2.6,1.2},m2={2.2,3},n1={5.4,2.5},n2=-{2.6,1.2},o1=-{2.6,1.2},o2={5.4,-1.2},a,r,m,n,o,c,s,p,q,f,OO,rs,qp,rp,sq,qc},
a=n2;
r=m2;
m=InfiniteLine@{m1,m2};
n=InfiniteLine@{n1,n2};
o=InfiniteLine@{o1,o2};
c=meet[o,Line@{r,r+{Cos[2Pi t],Sin[2Pi t]}}];
s=meet[Line@{r,c},n];
p=meet[Line@{b,r},n];
q=meet[Line@{b,s},m];
f=meet[Line@{q,p},o];
OO=meet[Line@{a,p},Line@{q,c}];
rs=InfiniteLine@{r,s};
qp=InfiniteLine@{q,p};
rp=InfiniteLine@{r,p};
sq=InfiniteLine@{s,q};
qc=InfiniteLine@{q,c};
Graphics[
{
{Blue,o},{Cyan,n},{Darker@Green,qp,qc},{Magenta,sq},$PointSize,Point@{a,b,s,p,OO,q},
{Red,Point@{c,f}},
text["A",a,{0,2}],
text["F",f,{0,2}],
text["B",b,{0,2}],
text["C",c,{0,2}],
text["O",OO,{0,2}],
text["Q",q,{0,-1.5}],
text["P",p,{0,2}],
text["S",s,{0,2}],
text[Column[{
"Hyperbolic Involution (AA)(BB)",
"",
Row[{"ABC"," ",pers["O"]," ","SBQ"," ",pers["P"]," ","ABF"}]
},Alignment->Center],{2.5,3.5}]
},
PlotRange->5]
],
{{t,.635,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

Another product of two perspectivities relates ranges on two distinct lines. The fundamental theorem of projective geometry tells us that a projectivity relating ranges on two such lines is uniquely determined by any three points of the first range and the corresponding three points of the second. There are, of course, many ways to construct the projectivity as the product of two or more perspectivities, but the final result will always be the same.

For instance, there is a unique projectivity relating AED on the first line to BDC on the second. This means that for any point X on DE there is a definite point Y on CD.

Manipulate[
Module[
{a={-2.5,-1.5},b={1.2,-1.5},g={3.9,-1.5},h={-3.9,.6},d={0,3.5},gh,z,e,c,x,y,ab,ay,ad,bd,bx},
gh=InfiniteLine@{g,h};
z=meet[gh,Line@{d,d+{Cos[2Pi t],Sin[2Pi t]}}];
e=meet[Line@{a,d},gh];
c=meet[Line@{b,d},gh];
x=meet[Line@{b,z},Line@{a,d}];
y=meet[Line@{a,z},Line@{b,d}];
ab=InfiniteLine@{a,b};
ay=InfiniteLine@{a,y};
ad=InfiniteLine@{a,d};
bd=InfiniteLine@{b,d};
bx=InfiniteLine@{b,x};
Graphics[
{
{Blue,ab},{Cyan,ad,bd,gh},{Darker@Green,ay,bx},$PointSize,Point@{a,b,c,d,e,g},
{Red,Point@{x,y,z}},
text["A",a,{0,2}],
text["E",e,{0,2}],
text["G",g,{0,2}],
text["D",d,{0,2}],
text["B",b,{0,2}],
text["C",c,{0,-1.5}],
text["X",x,{0,-2}],
text["Y",y,{0,-2}],
text["Z",z,{0,-2}],
text[Row[{"AEDX"," ",proj["O"]," ","BDCY"}],{2.5,3.5}]
},
PlotRange->6]
],
{{t,.22,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

The simplest way to construct this projectivity is by means of perspectivities from B and A, so that X is first related to Z on EC and then to Y on CD. We can regard XYZ as a variable triangle whose vertices run along fixed lines DE, EC, CD while the two sides YZ and ZX rotate around fixed points A and B. The third side joins the projectively related points X and Y.

Manipulate[
Module[
{a={-2.5,-1.5},b={1.2,-1.5},g={3.9,-1.5},h={-3.9,.6},d={0,3.5},gh,z,e,c,x,y,ay,ad,bd,bx,ce,xy,xyz},
gh=InfiniteLine@{g,h};
z=meet[gh,Line@{d,d+{Cos[2Pi t],Sin[2Pi t]}}];
e=meet[Line@{a,d},gh];
c=meet[Line@{b,d},gh];
x=meet[Line@{b,z},Line@{a,d}];
y=meet[Line@{a,z},Line@{b,d}];
ay=InfiniteLine@{a,y};
ad=InfiniteLine@{a,d};
bd=InfiniteLine@{b,d};
bx=InfiniteLine@{b,x};
ce=InfiniteLine@{c,e};
xy=InfiniteLine@{x,y};
xyz=Polygon@{x,y,z};
Graphics[
{
{Green,ay,bx,xy,xyz},{Cyan,ad,bd,ce},$PointSize,Point@{a,b,c,d,e},{Red,Point@{x,y,z}},
text["A",a,{0,2}],
text["E",e,{0,2}],
text["D",d,{0,2}],
text["B",b,{0,2}],
text["C",c,{0,-1.5}],
text["X",x,{0,-2}],
text["Y",y,{0,-2}],
text["Z",z,{0,2}],
text[Row[{"X"," ",pers["B"]," ","Z"," ",pers["A"],"Y"}],{3,4.5}]
},
PlotRange->6]
],
{{t,.22,Style["t",Italic]},0,1,.001,Appearance->"Labeled"}
]

This construction remains valid when A and B are of general position, instead of lying on the lines that carry the related ranges. Let AB meet DE in I and CD in J. Now we have a construction for the unique projectivity that relates IED to JDC.

As before, the vertices of the variable triangle XYZ run along fixed lines DE, EC, CD while the two sides YZ and ZX rotate around the fixed points A and B. The possible positions for the third side XY include, in turn, each of the five sides of the pentagon ABCDE.

Manipulate[
Module[
{a={-2,-1.8},b={.7,-2.3},ip={-2.5,-1.5},jp={1.2,-1.5},g={3.9,-1.5},h={-3.9,.6},d={0,3.5},i,j,gh,z,e,c,x,y,ay,id,jd,bx,ce,xy,xyz,ij},
i=meet[Line@{a,b},Line@{ip,d}];
j=meet[Line@{a,b},Line@{jp,d}];
gh=InfiniteLine@{g,h};
z=meet[gh,Line@{d,d+{Cos[2Pi t],Sin[2Pi t]}}];
e=meet[Line@{i,d},gh];
c=meet[Line@{j,d},gh];
x=meet[Line@{b,z},Line@{i,d}];
y=meet[Line@{a,z},Line@{j,d}];
ay=InfiniteLine@{a,y};
id=InfiniteLine@{i,d};
jd=InfiniteLine@{j,d};
bx=InfiniteLine@{b,x};
ce=InfiniteLine@{c,e};
xy=InfiniteLine@{x,y};
xyz=Polygon@{x,y,z};
ij=InfiniteLine@{i,j};
Graphics[
{
{Green,ay,bx,xy,xyz},{Blue,ij},{Cyan,id,jd,ce},
$PointSize,Point@{a,b,c,d,e,i,j},
{Red,Point@{x,y,z}},
text["A",a,{0,2}],
text["B",b,{0,2}],
text["E",e,{0,2}],
text["I",i,{0,2}],
text["D",d,{0,2}],
text["C",c,{0,-1.5}],
text["J",j,{0,2}],
text["X",x,{0,-2}],
text["Y",y,{0,-2}],
text["Z",z,{0,2}],
text[Row[{"IEDX"," ",pers[""]," ","JDCY"}],{2.5,4.5}]
},
PlotRange->6]
],
{{t,.23,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

Carefully watching this line XY, we see that it envelops a beautiful curve.

This is the same kind of curve that was constructed quite differently by Menaechmus about 340 BC. Since that time it has been known everywhere as a conic. One important property is that a conic is uniquely determined by any five of its tangents, and that these may be any five lines of which no three are concurrent.

Manipulate[
Module[
{k=100,a={-1.5,-2.7},b={.5,-2.9},ip={-2.5,-1.5},jp={1.2,-1.5},g={3.9,-1.5},h={-3.9,.6},d={0,3.5},i,j,gh,z0,x0,y0,dx0,dy0,xy0,range,z,x,y,xy},
i=meet[Line@{a,b},Line@{ip,d}];
j=meet[Line@{a,b},Line@{jp,d}];
gh=Line@{g,h};
z0=meet[gh,Line@{d,d+{Cos[2Pi t],Sin[2Pi t]}}];
x0=meet[Line@{b,z0},Line@{i,d}];
y0=meet[Line@{a,z0},Line@{j,d}];
dx0=InfiniteLine@{d,x0};
dy0=InfiniteLine@{d,y0};
xy0=InfiniteLine@{x0,y0};
range=ReIm/@Exp[2 N[Pi] I Range[0,1,1/k]];
z=meet[gh,Line@{d,d+#}]&/@range;
x=meet[Line@{b,#},Line@{i,d}]&/@z;
y=meet[Line@{a,#},Line@{j,d}]&/@z;
xy=InfiniteLine@#&/@Transpose[{x,y}];
Graphics[
{
{Darker@Green,dx0,dy0},{Cyan,xy},{Blue,xy0},
$PointSize,Point@d,{Red,Point@{x0,y0}},
text[Row[{"X"," ",pers[""]," ","Y"}],{.3,5.5}]
},
PlotRange->6]
],
{{t,0,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

Since the possible positions for our variable line XY include, in turn, each side of the pentagon ABCDE, we call its envelope the conic inscribed in this pentagon.

Manipulate[
Module[
{k=100,a={-1.5,-2.7},b={.5,-2.9},ip={-2.5,-1.5},jp={1.2,-1.5},g={3.9,-1.5},h={-3.9,.6},d={0,3.5},i,j,gh,e,c,ab,bc,cd,de,ea,z,x,y,xy},
i=meet[Line@{a,b},Line@{ip,d}];
j=meet[Line@{a,b},Line@{jp,d}];
gh=Line@{g,h};
e=meet[Line@{i,d},gh];
c=meet[Line@{j,d},gh];
ab=Line@{a,b};
bc=Line@{b,c};
cd=Line@{c,d};
de=Line@{d,e};
ea=Line@{e,a};
range=ReIm/@Exp[2 N[Pi] I Range[t,t+1,1/k]];
z=meet[gh,Line@{d,d+#}]&/@range;
x=meet[Line@{b,#},Line@{i,d}]&/@z;
y=meet[Line@{a,#},Line@{j,d}]&/@z;
xy=InfiniteLine@#&/@Transpose[{x,y}];
Graphics[
{
{Cyan,xy},{Blue,ab,bc,cd,de,ea},
$PointSize,Point@{a,b,c,d,e},
text["A",a,{2,2}],
text["B",b,{-2,2}],
text["C",c,{-2,0}],
text["D",d,{0,-2}],
text["E",e,{2,0}],
Style[text["The Conic Inscribed in the Pentagon",{0,5.5}],12]
},
PlotRange->6]
],
{{t,0,Style["t",Italic]},0,.1,.0001,Appearance->"Labeled"},
SaveDefinitions->True
]

To sum up: Let Z be a variable point on the diagonal CE of a given pentagon ABCDE. Then the point X, where ZB meets DE, and the point Y, where ZA meets CD, determine a line XY whose envelope is the inscribed conic.

Manipulate[
Module[
{k=100,a={-1.5,-2.7},b={.5,-2.9},ip={-2.5,-1.5},jp={1.2,-1.5},g={3.9,-1.5},h={-3.9,.6},d={0,3.5},i,j,gh,e,c,ab,bc,cd,de,ea,z0,x0,y0,ay,bx,ce,xy0,range,z,x,y,xy},i=meet[Line@{a,b},Line@{ip,d}];
j=meet[Line@{a,b},Line@{jp,d}];
gh=Line@{g,h};
e=meet[Line@{i,d},gh];
c=meet[Line@{j,d},gh];
ab=Line@{a,b};
bc=Line@{b,c};
cd=Line@{c,d};
de=Line@{d,e};
ea=Line@{e,a};
z0=meet[gh,Line@{d,d+{Cos[2Pi t],Sin[2Pi t]}}];
x0=meet[Line@{b,z0},Line@{i,d}];
y0=meet[Line@{a,z0},Line@{j,d}];
ay=Line@farpair@{a,z0,y0};
bx=Line@farpair@{b,z0,x0};
ce=InfiniteLine@farpair@{c,z0,e};
xy0=InfiniteLine@{x0,y0};
range=ReIm/@Exp[2 N[Pi] I Range[0,1,1/k]];
z=meet[gh,Line@{d,d+#}]&/@range;
x=meet[Line@{b,#},Line@{i,d}]&/@z;
y=meet[Line@{a,#},Line@{j,d}]&/@z;
xy=InfiniteLine@#&/@Transpose[{x,y}];
Graphics[
{
{Opacity[.2],Cyan,xy},
{Blue,ab,bc,cd,de,ea,xy0},{Darker@Green,ce,ay,bx},
Point@{a,b,c,d,e,z0},
{Red,$PointSize,Point@{x0,y0}},
text["A",a,{2,2}],
text["B",b,{-2,2}],
text["C",c,{-2,-2}],
text["D",d,{0,-2}],
text["E",e,{2,-2}],
text["X",x0,{0,-2}],
text["Y",y0,{0,-2}],
text["Z",z0,{0,-2}]
},
PlotLabel->Style["\nA Typical Tangent XY",Italic],PlotRange->5]
],
{{t,.23,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

For any particular position of Z (on CE), we see a hexagon ABCYXE whose six sides all touch the conic. The three lines AY, BX, CE, which join pairs of opposite vertices, are naturally called diagonals of the hexagon. Thus, if the diagonals of a hexagon are concurrent, the six sides all touch a conic. Conversely, if all the sides of a hexagon touch a conic, five of them can be identified with the lines DE, EA, AB, BC, CD. Since the given conic is the only one that touches these fixed lines, the sixth side must coincide with one of the lines XY that we have constructed. We thus have Brianchon’s theorem: If a hexagon is circumscribed about a conic, the three diagonals are concurrent.

Manipulate[
Module[{k=100,a={-1.5,-2.7},b={.5,-2.9},ip={-2.5,-1.5},jp={1.2,-1.5},g={3.9,-1.5},h={-3.9,.6},d={0,3.5},i,j,gh,range,e,c,ab,bc,ea,z0,x0,y0,ay,bx,ce,xy0,cy,xe,z,x,y,xy},
i=meet[Line@{a,b},Line@{ip,d}];
j=meet[Line@{a,b},Line@{jp,d}];
gh=Line@{g,h};
range=ReIm/@Exp[2 N[Pi] I Range[0,1,1/k]];
e=meet[Line@{i,d},gh];
c=meet[Line@{j,d},gh];
ab=Line@{a,b};
bc=Line@{b,c};
ea=Line@{e,a};
z0=meet[gh,Line@{d,d+{Cos[2Pi t],Sin[2Pi t]}}];
x0=meet[Line@{b,z0},Line@{i,d}];
y0=meet[Line@{a,z0},Line@{j,d}];
ay=Line@farpair@{a,z0,y0};
bx=Line@farpair@{b,z0,x0};
ce=Line@farpair@{c,z0,e};
xy0=Line@{x0,y0};
cy=Line@{c,y0};
xe=Line@{x0,e};
z=meet[gh,Line@{d,d+#}]&/@range;
x=meet[Line@{b,#},Line@{i,d}]&/@z;
y=meet[Line@{a,#},Line@{j,d}]&/@z;
xy=InfiniteLine@#&/@Transpose[{x,y}];
Graphics[
{
{Opacity[.2],Cyan,xy},
{Blue,ab,bc,cy,xe,ea,xy0},{Darker@Green,ce,ay,bx},
$PointSize,Point@{a,b,c,e,z0,x0,y0},
text["A",a,{2,2}],
text["B",b,{-2,2}],
text["C",c,{-2,0}],
text["E",e,{2,-0}],
text["X",x0,{0,-2}],
text["Y",y0,{0,-2}]
},
PlotLabel->Style["\nA Brianchon Hexagon",Italic],PlotRange->5]
],
{{t,.21,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

All these results can, of course, be dualized. (Now all the letters that we use are lowercase, representing lines.)

Module[{bc={-1.9,2.5},ab={.6,-2.9},ea={1.8,2.3},de={-2.1,-1.4},cd={2.8,-1.2}},
Framed@Graphics[
{
{Blue,Line@{bc,ab},Line@{ea,de},Line@{cd,bc},Line@{ab,ea},Line@{de,cd}},{Red,$PointSize,Point@{bc,ab,ea,de,cd}},text["a",.3 ab+.7 ea,{-2,0}],
text["b",.3 ab+.7 bc,{2,0}],
text["c",.3 cd+.7 bc,{0,-2}],
text["d",.7 de+.3 cd,{0,2}],
text["e",.7 ea+.3 de,{0,-2}],
text["d.e",de,{0,2}],
text["c.d",cd,{0,2}],
text["a.b",ab,{0,2}]
},
PlotLabel->Style["\nA \"pentagon\"",Italic],PlotRange->3.5
]
]

For any pentagon abcde whose vertex a.b is joined to d.e by i and to c.d by j, there is a unique projectivity relating ied to jdc.

Manipulate[
Module[{bc={-1.9,2.5},ab={.6,-2.9},ea={1.8,3.2},de={-2.1,-1.4},cd={2.8,-1.2},ce,az,bz,z,x,y,xy,xyz},
ce=meet[Line@{cd,bc},Line@{de,ea}];
{az,bz}=meet[Line@{ce,ce+{Cos[2Pi t],Sin[2Pi t]}},#]&/@{Line@{ab,ea},Line@{ab,bc}};
z=Line@{az,bz};
x=Line@{cd,az};
y=Line@{de,bz};
xy=meet[x,y];
xyz=Polygon@{bz,az,xy};
Graphics[
{
{Green,xyz},
{Blue,
Line@farpair@{bc,ab,bz},
Line@farpair@{ea,de,ce},
Line@farpair@{cd,bc,ce},
Line@farpair@{ab,ea,az},
Line@{de,cd},
Line@farpair@{xy,cd,az},
Line@farpair@{de,xy,bz},z},
{Cyan,Line@{de,ab},Line@{ab,cd}},
$PointSize,
Point@{bc,ab,ea},
Point@{de,ce,cd},
{Red,Point@{xy,az,bz}},
text["a",.2 ab+.8 ea,{-2,0}],
text["y",.8 cd+.2 xy,{-2,-2}],
text["e",.2 de+.8 ea,{-3,-3}],
text["b",.2 ab+.8 bc,{2,0}],
text["x",.8 de+.2 xy,{2,-2}],
text["c",.2 cd+.8 bc,{0,-2}],
text["d",.5 de+.5 cd,{0,-2}],
text["z",.5 ce+.5 az],
text["i",.5 de+.5 ab,{2,2}],
text["j",.5 ab+.5 cd,{-2,2}],
text["d.e",de,{2,0}],
text["c.d",cd,{-2,0}],
text["a.b",ab,{0,2}]
},PlotLabel->Style[Row[{"iedx"," ",proj[""]," ","jdey"}],Italic],PlotRange->5]
],
{{t,.52,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

The sides of the variable triangle xyz rotate about fixed points d.e, e.c, c.d while the two vertices y.z and z.x run along the fixed lines a and b. The possible positions for the third vertex x.y include, in turn, each of the five vertices of the pentagon.

Manipulate[
Module[{bc={-1.9,2.7},ab={.6,-2.9},ea={1.8,3.2},de={-2.1,-1.4},cd={2.8,-1.2},ce,az,bz,z,x,y,xy,xyz},
ce=meet[Line@{cd,bc},Line@{de,ea}];
{az,bz}=meet[Line@{ce,ce+{Cos[2Pi t],Sin[2Pi t]}},#]&/@{Line@{ab,ea},Line@{ab,bc}};
z=Line@{az,bz};
x=Line@{cd,az};
y=Line@{de,bz};
xy=meet[x,y];
xyz=Polygon@{bz,az,xy};
Graphics[
{
{Green,xyz},
{Blue,
Line@farpair@{bc,ab,bz},
Line@farpair@{ea,de,ce},
Line@farpair@{cd,bc,ce},
Line@farpair@{ab,ea,az},
Line@{de,cd},
Line@farpair@{xy,cd,az},
Line@farpair@{de,xy,bz},z},
{Cyan,Line@{de,ab},Line@{ab,cd}},
$PointSize,
Point@{bc,ab,ea,az,bz},
Point@{de,ce,cd},
{Red,Point@xy},
text["a",.2 ab+.8 ea,{-2,0}],
text["y",.8 cd+.2 xy,{-2,-2}],
text["b",.2 ab+.8 bc,{2,0}],
text["x",.8 de+.2 xy,{2,-2}],
text["z",.5 ce+.5 az],
text["d.e",de,{2,0}],
text["c.d",cd,{-2,0}],
text["e.c",ce,{0,2}],
text["x.y",xy,{0,-2}]
},PlotLabel->Style[Row[{"x"," ",proj[""]," ","y"}],Italic],PlotRange->5]
],
{{t,.52,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

Carefully watching this moving point x.y, we see that it traces out a curve through these five fixed points (no three concurrent).

What is this curve, the dual of a conic?

Manipulate[
Module[{k=100,bc={-1.9,2.2},ab={.6,-3.4},ea={1.8,2.7},de={-2.1,-1.9},cd={2.8,-1.7},ce,az0,bz0,xy0,az,bz,x,y,xy},
ce=meet[Line@{cd,bc},Line@{de,ea}];
{az0,bz0}=meet[Line@{ce,ce+{Cos[2Pi t],Sin[2Pi t]}},#]&/@{Line@{ab,ea},Line@{ab,bc}};
xy0=meet[Line@{cd,az0},Line@{de,bz0}];
range=ReIm/@Exp[2 N[Pi] I Range[0,1,1/k]];
az=meet[Line@{ce,ce+#},Line@{ab,ea}]&/@range;
bz=meet[Line@{ce,ce+#},Line@{ab,bc}]&/@range;
x=Line@{cd,#}&/@az;
y=Line@{de,#}&/@bz;
xy=Map[meet@@#&,Transpose@{x,y}];
Graphics[
{
{Blue,Line@{xy0,cd},Line@{de,xy0}},
$PointSize,{Red,Point@xy},
Point@{xy0,de,cd},
text["x",.8 de+.2 xy0,{2,-2}],
text["y",.8 cd+.2 xy0,{-2,-2}]
},PlotLabel->Style[Row[{"x"," ",proj[""]," ","y"}],Italic],PlotRange->5]
],
{{t,0,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

One of the many possible definitions for a conic exhibits it as a self-dual figure, with the interesting result that the dual of a conic (regarded as the envelope of its tangents) is again a conic (regarded as the locus of the points of contact of these tangents).

Module[{k=100,bc={-1.9,2.2},ab={.6,-3.4},ea={1.8,2.7},de={-2.1,-1.9},cd={2.8,-1.7},ce,range,az,bz,x,y,xy},
ce=meet[Line@{cd,bc},Line@{de,ea}];
range=ReIm/@Exp[2 N[Pi] I Range[0,1,1/k]];
az=meet[Line@{ce,ce+#},Line@{ab,ea}]&/@range;
bz=meet[Line@{ce,ce+#},Line@{ab,bc}]&/@range;
x=Line@{cd,#}&/@az;
y=Line@{de,#}&/@bz;
xy=Map[meet@@#&,Transpose@{x,y}];
Framed@Graphics[
{
{Cyan,InfiniteLine/@Transpose[{Rest@xy,Most@xy}]},$PointSize,{Red,Point@xy},{Blue,Point@{de,cd}}
},PlotRange->5]
]

Thus the locus of the point x.y is a conic, and this is the only conic that can be drawn through the five vertices of the pentagon.

Module[{k=100,bc={-1.9,2.3},ab={.6,-3.1},ea={1.8,3},de={-2.1,-1.6},cd={2.8,-1.4},ce,range,az,bz,x,y,xy},
ce=meet[Line@{cd,bc},Line@{de,ea}];
range=ReIm/@Exp[2 N[Pi] I Range[0,1,1/k]];
az=meet[Line@{ce,ce+#},Line@{ab,ea}]&/@range;
bz=meet[Line@{ce,ce+#},Line@{ab,bc}]&/@range;
x=Line@{cd,#}&/@az;
y=Line@{de,#}&/@bz;
xy=Map[meet@@#&,Transpose@{x,y}];
Framed@Graphics[
{$PointSize,{Red,Point@xy},{Blue,Point@{de,cd}},{Blue,Line@{bc,ab},Line@{ea,de},Line@{cd,bc},Line@{ab,ea},Line@{de,cd}},{Point@{bc,ab,ea,de,cd}},
text["a",.2 ab+.8 ea,{-2,2}],
text["b",.8 ab+.2 bc,{2,2}],
text["c",.2 cd+.8 bc,{-2,-2}],
text["d",.2 de+.8 cd,{0,2}],
text["e",.2 ea+.8 de,{2,-2}]
},PlotLabel->Style["\nThe Conic Circumscribed About the Pentagon",Italic],PlotRange->5]
]

To sum up: Let z be a variable line through the intersection c.e of two non-adjacent sides of a given pentagon abcde. Then the line x, which joins a.b to d.e, and the line y, which joins z.a to c.d, determine a point x.y whose locus is the circumscribed conic.

Module[{k=100,bc={-1.9,2.5},ab={.6,-3.1},ea={1.8,3},de={-2.1,-1.6},cd={2.8,-1.4},ce,range,az,bz,x,y,xy,az0,bz0,z0,x0,y0,xy0},
ce=meet[Line@{cd,bc},Line@{de,ea}];
range=ReIm/@Exp[2 N[Pi] I Range[0,1,1/k]];
az=meet[Line@{ce,ce+#},Line@{ab,ea}]&/@range;
bz=meet[Line@{ce,ce+#},Line@{ab,bc}]&/@range;
x=Line@{cd,#}&/@az;
y=Line@{de,#}&/@bz;
xy=Map[meet@@#&,Transpose@{x,y}];
{az0,bz0}=meet[Line@{ce,ce+{1,0}},#]&/@{Line@{ab,ea},Line@{ab,bc}};
z0=Line@{az0,bz0};
x0=Line@{cd,az0};
y0=Line@{de,bz0};
xy0=meet[x0,y0];
Framed@Graphics[
{
{Blue,Line@{bc,ab},Line@{ea,de},Line@{cd,bc},Line@{ab,ea},Line@farpair@{xy0,cd,az0},Line@farpair@{de,xy0,bz0},Line@farpair@{az0,ce,bz0}},$PointSize,{Red,Point@xy},{Blue,Point@{de,cd}},{Magenta,Point@{az0,bz0}},{Point@{bc,ab,ea,de,cd}},{Darker@Green,Point@xy0},
text["a",.15 ab+.85 ea,{-2,2}],
text["b",.8 ab+.2 bc,{2,2}],
text["c",.15 cd+.85 bc,{0,-2}],
text["e",.2 ea+.8 de,{0,2}],
text["x",.8 de+.2 xy0,{2,0}],
text["y",.8 cd+.2 xy0,{-2,0}],
text["z",.5 ce+.5 az0,{0,-1}],
text["x.y",1.1xy0]
},PlotLabel->Style["\nA Typical Point x.y on the Conic",Italic],PlotRange->5]
]

The hexagon abcyxe, which, for convenience, we rename abcdef, yields the dual of Brianchon's theorem, namely Pascal’s theorem: If abcdef is a hexagon inscribed in a conic, the points a.d, b.d, c.f (where pairs of opposite sides meet) are collinear.

Manipulate[
Module[{k=100,bc={-1.9,2.5},ab={.6,-3.1},ea={1.8,3},de={-2.1,-1.6},cd={2.8,-1.4},ce,range,az,bz,x,y,xy,az0,bz0,z0,x0,y0,xy0},
ce=meet[Line@{cd,bc},Line@{de,ea}];
range=ReIm/@Exp[2 N[Pi] I Range[0,1,1/k]];
az=meet[Line@{ce,ce+#},Line@{ab,ea}]&/@range;
bz=meet[Line@{ce,ce+#},Line@{ab,bc}]&/@range;
x=Line@{cd,#}&/@az;
y=Line@{de,#}&/@bz;
xy=Map[meet@@#&,Transpose@{x,y}];
{az0,bz0}=meet[Line@{ce,ce+{Cos[2Pi t],Sin[2Pi t]}},#]&/@{Line@{ab,ea},Line@{ab,bc}};
z0=Line@{az0,bz0};
x0=Line@{cd,az0};
y0=Line@{de,bz0};
xy0=meet[x0,y0];
Graphics[
{
{Blue,Line@{bc,ab},Line@{ea,de},Line@{cd,bc},Line@{ab,ea},Line@{xy0,cd},Line@{de,xy0}},{Magenta,InfiniteLine@{az0,bz0}},$PointSize,$PointSize,{Red,Point@xy},{Blue,Point@{de,cd}},{Magenta,Point@{az0,bz0,ce}},{Point@{bc,ab,ea,de,cd,xy0}},{Darker@Green,Point@xy0},
text["a",.15 ab+.85 ea,{-2,2}],
text["b",.85 ab+.15 bc,{2,2}],
text["c",.15 cd+.85 bc,{0,-2}],
text["d",.85 cd+.15 xy0,{-2,-2}],
text["e",.85 de+.15 xy0,{2,0}],
text["f",.15 ea+.85 de,{0,2}]
},PlotLabel->Style["\nA Pascal Hexagon",Italic],PlotRange->5]
],
{{t,0,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

The hexagon that we see is, perhaps, unusual, because its sides cross one another. From the standpoint of projective geometry, this feature is irrelevant. A convex hexagon abcdef would serve just as well, but the "diagonal points" would be inconveniently far away. Another natural observation is that our conic looks like the familiar circle. In fact, this famous theorem was first proved for a circle in 1639, when its discoverer, Blaise Pascal, was only sixteen years old. Nobody knows just how he did it, because his original treatise has been lost.

But there is no possible doubt about how he deduced the analogous property of the general conic. He joined the circle and lines to a point outside the plane, obtaining a cone and planes. Then he took the section of this solid figure by an arbitrary plane.

We change the position of the points of the hexagon.

Manipulate[
Module[{k=200,bc={-1.8,3.9},ab={.6,-2.8},ea={1.8,2.2},de={-1,-3.5},cd={2.8,-.8},ce,range,az,bz,x,y,xy,az0,bz0,z0,x0,y0,xy0},
ce=meet[Line@{cd,bc},Line@{de,ea}];
range=ReIm/@Exp[2 N[Pi] I Range[0,1,1/k]];
az=meet[Line@{ce,ce+#},Line@{ab,ea}]&/@range;
bz=meet[Line@{ce,ce+#},Line@{ab,bc}]&/@range;
x=Line@{cd,#}&/@az;
y=Line@{de,#}&/@bz;
xy=Map[meet@@#&,Transpose@{x,y}];
{az0,bz0}=meet[Line@{ce,ce+{Cos[2Pi t],Sin[2Pi t]}},#]&/@{Line@{ab,ea},Line@{ab,bc}};
z0=Line@{az0,bz0};
x0=Line@{cd,az0};
y0=Line@{de,bz0};
xy0=meet[x0,y0];
Graphics[
{
{Blue,Line@{bc,ab},Line@{ea,de},Line@{cd,bc},Line@{ab,ea},Line@farpair@{xy0,cd,az0},Line@farpair@{de,xy0,bz0}},{Magenta,InfiniteLine@@z0},$PointSize,$PointSize,{Red,Point@xy},{Blue,Point@{de,cd}},{Magenta,Point@{az0,bz0,ce}},{Point@{bc,ab,ea,de,cd,xy0}},{Darker@Green,Point@xy0},
text["a",.15 ab+.85 ea,{-2,2}],
text["b",.85 ab+.15 bc,{2,2}],
text["c",.3 cd+.7 bc,{0,-2}],
text["d",.85 cd+.15 xy0,{-2,-2}],
text["e",.85 de+.15 xy0,{2,0}],
text["f",.15 ea+.85 de,{0,2}]
},PlotLabel->Style["\nA Pascal Hexagon",Italic],PlotRange->5]
],
{{t,0,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

In this way the conic appears in one of its most ancient aspects: as the section of a circular cone by a plane of general position.

We change the position of the points of the hexagon.

Manipulate[
Module[{k=200,bc={-1.9,3.4},ab={.6,-2.2},ea={1.8,3.9},de={-.6,.7},cd={1,.9},ce,range,az,bz,x,y,xy,az0,bz0,z0,x0,y0,xy0},
ce=meet[Line@{cd,bc},Line@{de,ea}];
range=ReIm/@Exp[2 N[Pi] I Range[0,1,1/k]];
az=meet[Line@{ce,ce+#},Line@{ab,ea}]&/@range;
bz=meet[Line@{ce,ce+#},Line@{ab,bc}]&/@range;
x=Line@{cd,#}&/@az;
y=Line@{de,#}&/@bz;
xy=Map[meet@@#&,Transpose@{x,y}];
{az0,bz0}=meet[Line@{ce,ce+{Cos[2Pi t],Sin[2Pi t]}},#]&/@{Line@{ab,ea},Line@{ab,bc}};
z0=Line@{az0,bz0};
x0=Line@{cd,az0};
y0=Line@{de,bz0};
xy0=meet[x0,y0];
Graphics[
{
{Blue,Line@{bc,ab},Line@{ea,de},Line@{cd,bc},Line@{ab,ea},Line@{xy0,cd},Line@{de,xy0}},{Magenta,InfiniteLine@{az0,bz0}}(*Line@{xy0,cd},Line@{de,xy0}},{Magenta,InfiniteLine@{az0,bz0}*),$PointSize,$PointSize,{Red,Point@xy},{Magenta,Point@{az0,bz0,ce}},{Point@{bc,ab,ea,de,cd,xy0}},{Darker@Green,Point@xy0},
text["a",.15 ab+.85 ea,{-2,2}],
text["b",.85 ab+.15 bc,{2,2}],
text["c",.15 cd+.85 bc,{0,-2}],
text["d",.5 cd+.5 xy0,{-2,-2}],
text["e",.5 de+.5 xy0,{2,0}],
text["f",.15 ea+.85 de,{0,2}]
},PlotLabel->Style["\nA Pascal Hexagon",Italic],PlotRange->5]
],
{{t,.17,Style["t",Italic]},0,1,.001,Appearance->"Labeled"},
SaveDefinitions->True
]

Acknowledgments

Thanks to Gregory Robbins, who sparked this update and was able to read the files from an old diskette.

References

College Geometry Project (1963–71). (Dec. 19, 2018) archive.org/details/CollegeGeometry.

H. S. M. Coxeter, The Real Projective Plane, 3rd ed., New York: Springer, 1993.