Michelson interferometer

A simple model of Michelson spectrograph used in optical spectroscopy.

Light from the source is split into two beams by a half-silvered mirror, one is reflected off a fixed mirror and one off a movable mirror, which introduces a time delay

By moving the left mirror and measuring the intensity of light on the detector (represented as a disk at the bottom) we can record an interoferogram, which represents the spectral content of incomming light (from the left).

Here we use a single frequency source for the simplicity, in real-life cases it is usually a broad-band source (you can add more by modifying freqs symbol)

Download original notebook

getTime := AbsoluteTime[];
rightMirror = 1;
freqs = {7};

fIn[t_, x_, c_:0.1] := (*FB[*)((0.05)(*,*)/(*,*)(Length[freqs]))(*]FB*) Sum[Sin[t \[Omega] - x \[Omega] / c], {\[Omega], freqs}]
fAmp[x_, c_:0.1] :=  (*FB[*)((0.05)(*,*)/(*,*)(Length[freqs]))(*]FB*) Sum[{Sin[- x \[Omega] / c], Cos[- x \[Omega] / c]}, {\[Omega], freqs}]

pathIn := pathInLine = With[{t=getTime}, Table[{x, fIn[t, x]}, {x, -1,0,0.02}]];
pathIn;

pathToM1UpDown := pathToM1UpDownLine = With[{t=getTime}, 
  Table[{fIn[t, x] + fIn[t, 2 - x], x}, {x,0,1,0.02}] 
];
pathToM1UpDown;

pathToDown := pathToDownLine = With[{t=getTime}, 
  Table[{fIn[t, x] + fIn[t, (x-2) + 2 rightMirror], 2-x}, {x,2,3,0.02}] 
];
pathToDown;

pathToM2Left := pathToM2LeftLine = With[{t=getTime}, 
  Table[{x, fIn[t, x] + fIn[t, 2 rightMirror - x]}, {x,0,rightMirror,0.02}] 
];
pathToM2Left;

interferogram = {};

detectorBulb := With[{amp = (*SpB[*)Power[Norm[fAmp[3] + fAmp[(3-2) + 2 rightMirror]](*|*),(*|*)2](*]SpB*) / 0.01}, 
  interferogram = Append[interferogram, {rightMirror, amp}];
  detectorBulbColor = Blend[{Red // Darker, Yellow}, Clip[amp, {0,1}]] /. {RGBColor -> List};
];

detectorBulb;



EventHandler["FTIR", Function[Null, 
  pathIn;
  pathToM1UpDown;
  pathToDown;
  pathToM2Left;
]];

{
Graphics[{
  ColorData[97][12],
  
  Line[pathInLine // Offload],
  Line[pathToM1UpDownLine // Offload],
  Line[pathToDownLine // Offload],
  Line[pathToM2LeftLine // Offload],

  {
    Cyan, Opacity[0.7], Polygon[(*VB[*)(Uncompress["1:eJxTTMoPSuNkYGAoZgESPpnFJWlMyLwiBjA4sL9oJhjs3I8mv0j3eVBM6K79RdzPpdIybPajy1ek7XaS19m8v2iddlrLdva96PKMEPPti2ZBzLdHk1d/dcZWpeagPVwhLv0whWjyMGNx6Yc5C+5QNHmYt+AeBQDm/Vvz"])(*,*)(*"1:eJxTTMoPSmNkYGAoZgESHvk5KWlMIB4XkPBMzs/LrEp1yq/I7GBmYIBIgJQFleakBrMCGT6JSak5wTxAllNqYm5xQU5mSUlqEQDn5BN3"*)(*]VB*)]
  },

  {
    RGBColor[detectorBulbColor // Offload], Disk[{0,-1}, 0.2]
  },
  
  ColorData[97][7], Rectangle[{-0.2,1-0.02}, {0.2,1+0.02}], 
  
  {
    Gray, Opacity[0.5], Rectangle[{1-0.02, -0.2}, {1+0.02, 0.2}]
  },
  
  ColorData[97][7], Translate[
    Rectangle[{1-0.02, -0.2}, {1+0.02, 0.2}]
  , {Offload[rightMirror]-1, 0}]

}, 
  PlotRange->{1.15{-1,1},1.15{-1,1}}, 
  TransitionType->None, 
  ImagePadding->20
],

Graphics[{
  PointSize[0.02], Point[interferogram // Offload]
}, Axes->True, Frame->True, FrameLabel->{"x", "I"}, PlotRange->{{0.9,1.1}, {-0.1,1.1}}, PlotLabel->"Interferogram"]
} // Row

(*GB[*){{(*VB[*)(FrontEndRef["873299f9-16b3-4964-8b2a-ffe4c93715b8"])(*,*)(*"1:eJxTTMoPSmNkYGAoZgESHvk5KRCeEJBwK8rPK3HNS3GtSE0uLUlMykkNVgEKW5gbG1laplnqGpolGeuaWJqZ6FokGSXqpqWlmiRbGpsbmiZZAAB2QhUz"*)(*]VB*)(*|*),(*|*)(*VB[*)(FrontEndRef["87b00596-f28e-4fbc-b97a-f5a4fd092f55"])(*,*)(*"1:eJxTTMoPSmNkYGAoZgESHvk5KRCeEJBwK8rPK3HNS3GtSE0uLUlMykkNVgEKW5gnGRiYWprpphlZpOqapCUl6yZZmifqppkmmqSlGFgapZmaAgCFIRXk"*)(*]VB*)}}(*]GB*)

Mirror controls

EventHandler[InputRange[0.9,1.1,0.0025,1.0], Function[sli,
  rightMirror = sli;
  detectorBulb;
  EventFire["FTIR", True];
]]

(*VB[*)(EventObject[<|"Id" -> "b3eddf4e-f550-48f3-9b55-d98b7485bb63", "Initial" -> 1., "View" -> "2c4ddcf6-69ee-4b9a-beea-1ec33ce1dee9"|>])(*,*)(*"1:eJxTTMoPSmNkYGAoZgESHvk5KRCeEJBwK8rPK3HNS3GtSE0uLUlMykkNVgEKGyWbpKQkp5npmlmmpuqaJFkm6ialpibqGqYmGxsnpxqmpKZaAgCeSxco"*)(*]VB*)