Duality

by Andreas Kriegl, 2013.02.04

Dual of Point, Line, and Segment

Clear[G,Gd]
p1={-1/2,-1/2};
p2={1/2,0};
p3={-1/2,-1/2};
Dynamic[p1];
Dynamic[p2];
Dynamic[p3];
Grid[{{Manipulate[
Module[{},
k:=(p2[[2]]-p1[[2]])/(p2[[1]]-p1[[1]]);
d:=p1[[2]]-k*p1[[1]];
If[OnS,p3[[2]]=k*p3[[1]]+d];
Graphics[{
PointSize[0.03],
Text["r",p3,{-2,-2},Background->White],Cyan,Point[p3],Black,
Text["p",p1,{-2,-2},Background->White],Green,Point[p1],Black,
Text["q",p2,{-2,-2},Background->White],Blue,Point[p2],Black,
Red,
Line[{{-1,-k+d},{1,k+d}}], (* l *)
Text["ℓ",{-1,-k+d},{-1,-1}],
Thickness[0.01],
Red,Line[{p1,p2}],Black, (* s *)
Text["s",(p1+p2)/2,Background->White]
},PlotRange->1,BaseStyle->{FontSize->16}]],{OnS,{False,True},ControllType->Setter,ControlPlacement->Top},
{{p1,{-1/2,-1/2}},Locator},
{{p2,{1/2,1/2}},Locator},
{{p3,{-1/2,-1/2}},Locator},LocalizeVariables->False],
Dynamic@Graphics[{
PointSize[0.02],
Thickness[0.005],
(* r^* *) Cyan,Line[{{-1,-p3[[1]]-p3[[2]]},{1,p3[[1]]-p3[[2]]}}],Text["(SuperStar[r])",{1,p3[[1]]-p3[[2]]},{2,0},Background->White],Black,
(* p^* *) Green,Line[{{-1,-p1[[1]]-p1[[2]]},{1,p1[[1]]-p1[[2]]}}],Text["(SuperStar[p])",{1,p1[[1]]-p1[[2]]},{2,0},Background->White],Black,
(* q^* *) Blue,Line[{{-1,-p2[[1]]-p2[[2]]},{1,p2[[1]]-p2[[2]]}}],Text["(SuperStar[q])",{1,p2[[1]]-p2[[2]]},{2,0},Background->White],Black,
(* l^* *) Red,Point[{k,-d}],Text["(SuperStar[ℓ])",{k,-d},{0,2}]
},PlotRange->1,ImageSize->400,BaseStyle->{FontSize->16}]}}]

Duality via Parabola

Clear[p,x];
lb=-Sqrt[2];
rb=Sqrt[2];
tb=2;bb=-1;
Manipulate[
Module[{t1,t2,x},
k=p[[1]];
d=-p[[2]];
If[p[[2]]≤p[[1]]^2/2,
d=-p[[2]],
d=p[[2]]-p[[1]]^2
];
sol=Solve[x^2/2==k*x+d,x];
x1=x/.sol[[1]];
t1={x1,k*x1+d};
x2=x/.sol[[2]];
t2={x2,k*x2+d};
If[p[[2]]≤p[[1]]^2/2,
r=p; d1=d,
r={(x1+x2)/2,x1*x2/2}; d1=r[[2]]-k*r[[1]]
];
Graphics[{
GrayLevel[0.5],
PointSize[0.02],Line[{{p[[1]],bb},{p[[1]],tb}}],
Line[{{lb,k*lb+d},{rb,k*rb+d}}],
Point[{p[[1]],p[[1]]^2/2}],
Line[{{lb,lb*p[[1]]-p[[1]]^2/2},{rb,rb*p[[1]]-p[[1]]^2/2}}],
Line[{{p[[1]],bb},{p[[1]],tb}}],
Thickness[0.005],
Blue,
Line[
Table[{x,x^2/2},{x,lb,rb,(rb-lb)/100}]
],
Black,
Point[r],
Point[t1],Point[t2],
Red,
Point[p],
Black,
Text["p",{p[[1]],p[[1]]^2/2},{0,-2}],
Red,
Text["q",p,{0,2},Background->White],
Line[{{lb,k*lb+d1},{rb,k*rb+d1}}],
If[p[[2]]≤p[[1]]^2/2,
Text["(SuperStar[q])",{0,d},{0,-2},Background->White],
Text["(SuperStar[q])",r,{0,-2},Background->White]],
GrayLevel[0.5],
Line[{r,2*t1-r}],
Line[{r,2*t2-r}]
},PlotRange->{{lb,rb},{bb,tb}}]
],{{p,{0,0}},Locator}]