Thin Lens

ThinLens=Module[{xo,ho,si,hi,G,F,PlotOBJECT,PlotIMAGE,PlotLENS,PL,IMAGE,FLAT,THETA1,THETA2,R1,R2,X1,X2,X},
Manipulate[
ho=2;
PlotOBJECT={
Graphics[Text[Style["Object",{Directive[18],FontFamily->"Palatino"}],{xo,-0.5}]],
Graphics[{Gray,Thickness[0.005],Arrowheads[0.02],Arrow[{{xo,0},{xo,ho}}]}]
};
If[Abs[xo G+1]>0.001,
{IMAGE=True;
si:=xo/(xo G+1);
hi:=ho/(xo G+1);
PlotIMAGE={
Graphics[Text[Style["Image",{Directive[18],FontFamily->"Palatino"}],{si,-0.5 Sign[hi]}]],
Graphics[{Orange,Thickness[0.005],Arrowheads[0.02],Arrow[{{si,0},{si,hi}}]}]
}
},
IMAGE=False
];
If[Abs[G]<0.001,
{FLAT=True;
PlotLENS={
Graphics[{Cyan,Thickness[0.002],Line[{{0,-4},{0,4}}]}]
};
PL="Flat Lens";
},
{FLAT=False;
F:=1/G;
PlotLENS={
ListPlot[{{-F,0},{F,0}},PlotMarkers->{Automatic,Medium},PlotStyle->{Cyan}],
Graphics[Text[Style["F",{Directive[18],FontFamily->"Palatino"}],{-F,-0.5}]],
Graphics[Text[Style["F",{Directive[18],FontFamily->"Palatino"}],{F,-0.5}]]
};
If[F>0,
{THETA1:=ArcCot[F/2];
R1:=4/Sin[THETA1];
X1:=R1-2F;
AppendTo[PlotLENS,{
Plot[{Sqrt[R1^2-(X+2 F)^2],-Sqrt[R1^2-(X+2 F)^2]},{X,0,X1},Filling->Axis,PlotStyle->{Cyan}],
Plot[{Sqrt[R1^2-(X-2 F)^2],-Sqrt[R1^2-(X-2 F)^2]},{X,-X1,0},Filling->Axis,PlotStyle->{Cyan}],
Graphics[{Cyan,Thickness[0.002],Circle[{-2 F,0},R1,{-THETA1,THETA1}]}],
Graphics[{Cyan,Thickness[0.002],Circle[{2 F,0},R1,{Pi-THETA1,Pi+THETA1}]}]
}
];
PL="Converging Lens";
},
{THETA2:=ArcSin[2/F];
R2:=-2F;
X2:=R2 (1-Cos[THETA2]);
AppendTo[PlotLENS,{
Plot[{Sqrt[R2^2-(X+R2)^2]},{X,-X2,0},Filling->Top,PlotStyle->{Cyan}],
Plot[{-Sqrt[R2^2-(X+R2)^2]},{X,-X2,0},Filling->Bottom,PlotStyle->{Cyan}],
Plot[{Sqrt[R2^2-(X-R2)^2]},{X,0,X2},Filling->Top,PlotStyle->{Cyan}],
Plot[{-Sqrt[R2^2-(X-R2)^2]},{X,0,X2},Filling->Bottom,PlotStyle->{Cyan}],
Graphics[{Cyan,Thickness[0.002],Circle[{-2F,0},R2,{Pi-THETA2,Pi+THETA2}]}],
Graphics[{Cyan,Thickness[0.002],Circle[{2F,0},R2,{-THETA2,THETA2}]}],
Graphics[{Cyan,Thickness[0.002],Line[{{-X2,4},{X2,4}}]}],
Graphics[{Cyan,Thickness[0.002],Line[{{-X2,-4},{X2,-4}}]}]
}
];
PL="Diverging Lens";
}
]
}
];
Figure={
ListPlot[{{0,0}},PlotMarkers->{Automatic,Medium},PlotStyle->{Cyan}, PlotRange->{{-21,21},{-10,10}},GridLines->{{-20,-19,-18,-17,-16,-15,-14,-13,-12,-11,-10,-9,-8,-7,-6,-5,-4,-3,-2,-1,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20},{-10,-9,-8,-7,-6,-5,-4,-3,-2,-1,0,1,2,3,4,5,6,7,8,9,10}},Ticks->{None,None},AspectRatio->Automatic,AxesLabel->{"(Subscript[s, i])",None},LabelStyle->{Directive[20],FontFamily->"Palatino"},PlotLabel->PL],
Graphics[{Thickness[0.001],Arrowheads[0.015],Arrow[{{0,0},{21,0}}]}],
Graphics[{Thickness[0.001],Arrowheads[0.015],Arrow[{{0,0},{-20,0}}]}],
Graphics[Text[Style["(Subscript[s, o])",{Directive[20],FontFamily->"Palatino"}],{-20.5,0}]]
};
AppendTo[Figure,PlotLENS];
AppendTo[Figure,PlotOBJECT];
AppendTo[Figure,{
Graphics[{Red,Thickness[0.001],Arrowheads[0.015],Arrow[{{xo,ho},{0,0}}]}],
Graphics[{Red,Thickness[0.001],Arrowheads[0.015],Arrow[{{xo,ho},{20,40/xo}}]}],
Graphics[{Darker[Green],Thickness[0.001],Arrowheads[0.015],Arrow[{{xo,2},{0,2}}]}],
Graphics[{Darker[Green],Thickness[0.001],Arrowheads[0.015],Arrow[{{0,2},{20,2(1-20G)}}]}]
}
];
If[IMAGE,
{AppendTo[Figure,PlotIMAGE];
AppendTo[Figure,
{Graphics[{Blue,Thickness[0.001],Arrowheads[0.015],Arrow[{{xo,2},{0,hi}}]}],
Graphics[{Blue,Thickness[0.001],Arrowheads[0.015],Arrow[{{0,hi},{20,hi}}]}]
}
];
If[hi>0 &&!FLAT,
{AppendTo[Figure,{
Graphics[{Dashed,Red,Thickness[0.001],Line[{{xo,ho},{si,hi}}]}],
Graphics[{DotDashed,Blue,Thickness[0.001],Line[{{-F,0},{xo,ho}}]}],
Graphics[{Dashed,Blue,Thickness[0.001],Line[{{0,hi},{si,hi}}]}]
}
],
If[hi>ho,
AppendTo[Figure,{Graphics[{Dashed,Darker[Green],Thickness[0.001],Line[{{0,ho},{si,hi}}]}]}],
AppendTo[Figure,{Graphics[{Dashed,Darker[Green],Thickness[0.001],Line[{{0,ho},{F,0}}]}]}]
]
}
]
}
];
Show[Figure,ImageSize->Full],
{{G,0,"1/f"},-1/5,1/5},{{xo,-10,"-(Subscript[s, o])"},-20,-1,0.1},LabelStyle->{Directive[20],FontFamily->"Palatino"},ContinuousAction->True,ControlPlacement->Top
]
]

Export["ThinLens.cdf",ThinLens,"CDF"]