WavicaTour.nb

Lens Characterization

FindLensParameters

sys =
    {WedgeOfRays[10, NumberOfRays -> 5],
    Move[PlanoConvexLens[{f1,100}, 50, 9, CurvatureDirection -> Back],90.5],
    Move[ApertureStop[50,30],100],
    Move[PlanoConvexLens[{f2,100}, 50, 9], 100.5],
    Boundary[208, GraphicDesign -> Off]};

AnalyzeSystem[sys,PlotType->TopView];

FindLensParameters[sys]

[Graphics:HTMLFiles/index_1.gif]

RowBox[{{, RowBox[{RowBox[{AngularMagnification, , RowBox[{-, 0.931602}]}], ,, RowBox[ ... , RowBox[{-, 1.09103}]}], ,, WaveFrontID1, ,, RowBox[{WaveLength, , 0.532}]}], }}]

Pupil Function

sys3D =
    {PointOfRays[{10,10}, NumberOfRays -> 5],
    Move[PlanoConvexLens[{f1,100}, 50, 9, CurvatureDirection -> Back], 90.5],
    Move[ApertureStop[50,30],100],
    Move[PlanoConvexLens[{f2,100}, 50, 9], 100.5],
    Boundary[208, GraphicDesign -> Off]};

AnalyzeSystem[sys3D];

[Graphics:HTMLFiles/index_3.gif]

pupfun = PupilFunction[sys3D,Plot2D->False];

[Graphics:HTMLFiles/index_4.gif]

Point Spread Function

PSF[pupfun,NumberOfPoints->128];

[Graphics:HTMLFiles/index_5.gif]

Modulation Transfer Function

ModulationTransferFunction[sys3D, FindImagePoint->True, FocalFraction->0, NumberOfPoints->128];

[Graphics:HTMLFiles/index_6.gif]

[Graphics:HTMLFiles/index_7.gif]

[Graphics:HTMLFiles/index_8.gif]

Seidel Aberrations

Seidel aberrations are included in the same calculations that determine the pupil function of an imaging system. These are based on Zernike polynomials.

PupilFunction[sys3D]

[Graphics:HTMLFiles/index_9.gif]

RowBox[{{, RowBox[{RowBox[{AngularMagnification, , RowBox[{-, 0.931602}]}], ,, RowBox[ ... , ,, <>}], ]}], False, Editable -> False]}], ,, RowBox[{WaveLength, , 0.532}]}], }}]

Interference

Optical Flat

[Graphics:HTMLFiles/index_11.gif]

[Graphics:HTMLFiles/index_12.gif]

Fabry Perot Interferometer

TurboPlot[{
    Move[GaussianBeam[1.5,.01],-50],
    PlanoConcaveLens[-30,20,2,"L1",CurvatureDirection->Back],
    Move[PlanoConvexLens[160,30,6.5,"L2"],110],
    Resonate[{Move[Window[50,25,Transmittance->70],150],
    Move[Baffle[75],200]}]
    }, PlotType->TopView, SequentialTrace->False, GenerationLimit->16, ThresholdIntensity->.001];

[Graphics:HTMLFiles/index_13.gif]

In[32]:=

FindInterference[{
    Move[GaussianBeam[1.5,.01,FullForm->True],-50],
    PlanoConcaveLens[-30,20,2,"L1",CurvatureDirection->Back],
    Move[PlanoConvexLens[160,30,6.5,"L2"],110],
    Resonate[{Move[Window[50,25,Transmittance->70],150],
    Move[Baffle[75],90],
    Move[Baffle[75],200]}]
    }, ReportedSurfaces -> {{3,4}}, SequentialTrace->False, GenerationLimit->16,
    ThresholdIntensity->.001];

[Graphics:HTMLFiles/index_14.gif]

Michelson Interferometer

In[148]:=

system =
    {
        Move[GaussianBeam[1.5,.01,FullForm->True],-50],
        PlanoConcaveLens[-30,20,2,"L1",CurvatureDirection->Back],
        Move[PlanoConvexLens[160,30,6.5,"L2"],130],
        Move[BeamSplitter[{70,30},50,10],175,-45],
        Move[Mirror[50,10],250],
        Move[Mirror[50,10],{175,50},90.01],
        Move[BeamSplitter[{70,30},50,10,""],175,-45,GraphicDesign->Off],
        Move[Screen[50],{175,-50},90]
    };
AnalyzeSystem[system];

[Graphics:HTMLFiles/index_15.gif]

interference = FindInterference[system];

[Graphics:HTMLFiles/index_16.gif]

In[162]:=

Plot3D[Evaluate[(InterferenceFunction/.interference)][x,y],{x,-13.5,6.7},{y,-10.,10.},PlotPoints->100,Mesh->False];

[Graphics:HTMLFiles/index_17.gif]

More Elaborate Interference Example

[Graphics:HTMLFiles/index_18.gif]

[Graphics:HTMLFiles/index_19.gif]

[Graphics:HTMLFiles/index_20.gif]

FindGratingFunction

Diffraction

Gaussian Beam Propagation

opticalsystemoffaxis = {
Move[GaussianBeam[{5.,5.},{.01,.01},SymbolicWaveLength->λ],{0,10}],
Move[PlanoConvexLens[{f,100},{a,50},{t,10},DesignWaveLength->.532],{d1,50}],
Move[Mirror[20],175,-45],
Move[Screen[50],{175,50},90]};
ShowSystem[opticalsystemoffaxis, ShowGaussian->True];

[Graphics:HTMLFiles/index_21.gif]

ShowSystem[opticalsystemoffaxis, PlotType->TopView, ShowGaussian->True];

[Graphics:HTMLFiles/index_22.gif]

opticalsystemreflected = {
GaussianBeam[20.,.01, NumberOfRays->6],
Move[PlanoConvexLens[100,50,10,DesignWaveLength->.532],50],
Move[Mirror[20],175,-45],
Move[Screen[50],{175,50},90]};
AnalyzeSystem[opticalsystemreflected, PlotType->TopView];

[Graphics:HTMLFiles/index_23.gif]

GaussianPlot[opticalsystemreflected];

[Graphics:HTMLFiles/index_24.gif]

GaussianPlot[opticalsystemreflected, RenderedParameters->BeamCurvature];

[Graphics:HTMLFiles/index_25.gif]

Here is a more elaborate example. The defining details have not been included in order to simplify the presentation.

[Graphics:HTMLFiles/index_26.gif]

Gaussian Beam Interference

[Graphics:HTMLFiles/index_27.gif]

[Graphics:HTMLFiles/index_28.gif]

[Graphics:HTMLFiles/index_29.gif]

Generalized Wave Propagation

[Graphics:HTMLFiles/index_30.gif]

[Graphics:HTMLFiles/index_31.gif]

[Graphics:HTMLFiles/index_32.gif]

[Graphics:HTMLFiles/index_33.gif]

Symbolic Calculations

Symbolic ABCD Matrix Calculations

opticalsystemreflected = {
GaussianBeam[20,1/100,SymbolicWaveLength->λ,NumberOfRays->6, IntrinsicMedium->1],
Move[PlanoConvexLens[{f,100},{a,50},{t,10},ComponentMedium->3/2],{d1,50}],
Move[Mirror[{b,20}],175,-45],
Move[Screen[50],{175,50},90]};
AnalyzeSystem[opticalsystemreflected, PlotType->TopView];

[Graphics:HTMLFiles/index_34.gif]

FindABCDMatrix[opticalsystemreflected,{f>0}, MatrixForm->True, DecomposeABCD->False, NumericalResults->False, MakeFloatingPoint->False]

( 2 2 2 ... --------------- (d1 - f) f f

FindABCDMatrix[opticalsystemreflected,{f>0}, MatrixForm->True, DecomposeABCD->True, NumericalResults->False, MakeFloatingPoint->False]

( 2 ) ... ------------------------ 3 Sqrt[(d1 - f) ] f 3 f

FindABCDMatrix[opticalsystemreflected,MatrixForm->True,DecomposeABCD->True,NumericalResults->True]

Symbolic Transfer Functions

Wave Optica can be used to calculate the symbolic solution to optical systems by taking a symbolic Taylor's series expansion about the chief ray trajectory through space. The next example shows the fifth order symbolic solution to a spherical mirror system. In this case, y is the initial ray height from the optical axis, r is the radius of curvature for the mirror, and d is the longitudinal position of the final optical surface, S.

In[66]:=

opticalSystem = {
    Move[LineOfRays[20],{0,{y,0}}],
    Move[SphericalMirror[{r,-100},50,10],25],
    Move[Screen[50],{d,-25}]};
AnalyzeSystem[opticalSystem,PlotType->TopView];
SymbolicTrace[opticalSystem, {{y,0,5},{r<0}}]

[Graphics:HTMLFiles/index_52.gif]

Out[68]=

$RowBox[{{, RowBox[{SymbolicOpticalLength50 - d + (50 y^2)/r^2 - (2 d y^2)/r^2 + y^2/r ... #62754; {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}, ,, RowBox[{SymbolicWaveLength, , 0.532}]}], }}]$

Fifth order solution to indicated optical parameters.

In the following example, we will determine the third order symbolic solution to a spherical lens system.

opticalsystem = {
    Move[LineOfRays[10],{-50,{y,0}}],
    SphericalLens[{1/c1,35},{1/c2,-55},50,20],
    Move[Screen[50],50]};

AnalyzeSystem[opticalsystem,PlotType->TopView];

[Graphics:HTMLFiles/index_54.gif]

Here we use SymbolicTrace to calculate the third-order transfer function for the system. In this case, y is the initial ray height from the optical axis and Py is the resulting height on the final optical surface, S.

Py = (SymbolicSurfaceCoordinates/.
SymbolicTrace[opticalsystem,{{y,0,3}, {c1>0,c2<0,y∈Reals}},
SymbolicRefractiveModels->BK7->3/2])[[1]]

Out[5]=

y - (65 c1 y)/3 + 15 c2 y - 100 c1 c2 y + (c1^2 y^3)/6 - (2045 c1^3 y^3)/216 + 1/12 c1 c2 y^3 ... c1^3 c2^2 y^3 + (105 c2^3 y^3)/8 - 525/2 c1 c2^3 y^3 + 1750 c1^2 c2^3 y^3 - 35000/9 c1^3 c2^3 y^3

Third order symbolic transfer function

Symbolic Global Optimization

Next we calculate the merit function for the optical system.

In[6]:=

meritFunction = Expand[Integrate[Expand[Py^2],{y,-5,5}]]

Out[6]=

250/3 - (32500 c1)/9 + (1067500 c1^2)/27 - (1765625 c1^3)/54 + (291125000 c1^4)/567 - (1597656 ... c2^6)/3 + (341796875000 c1^4 c2^6)/3 - (2734375000000 c1^5 c2^6)/9 + (27343750000000 c1^6 c2^6)/81

Symbolic Merit Function

Here is a plot of the merit function space.

In[77]:=

Plot3D[meritFunction,{c1,0,.1},{c2,-.1,0}];

[Graphics:HTMLFiles/index_57.gif]

Plot of merit function space.

Next we calculate the minimization roots for the system.

RowBox[{{, RowBox[{RowBox[{{, RowBox[{RowBox[{c1, , RowBox[{RowBox[{0.169546,  ... RowBox[{c1, , 0.041791}], ,, RowBox[{c2, , RowBox[{-, 0.00800245}]}]}], }}]}], }}]

Minimization roots to symbolic merit function.

Finally, we isolate the global minimum from the polynomial roots.

Here is a plot of the globally optimized system.

[Graphics:HTMLFiles/index_60.gif]

Plot of Optimized System

Ray Caustics Through a Lens Focus

[Graphics:HTMLFiles/index_61.gif]

[Graphics:HTMLFiles/index_62.gif]

Created by Mathematica (September 1, 2005)