Watt's Curve

d = 0.9; r1 = r2 = 1; l = 1;
\[Theta]min = 0;
\[Theta]max = 2 Pi;
d\[Theta] = Pi/100;
\[Theta]s =
  Table[\[Theta], {\[Theta], \[Theta]min, \[Theta]max, d\[Theta]}];
pmids = Table[
   Sqrt[r1^2 - (d/2 Sin[\[Theta]] +
        Sqrt[(l/2)^2 - (d/2)^2 Cos[\[Theta]]^2])^2] {Cos[\[Theta]],
     Sin[\[Theta]]}, {\[Theta], \[Theta]s}];
p1s = {};
p2s = {};
Module[{pmid, \[Theta], p1, p2, \[Theta]2, \[Theta]last = False},
  Do[
    pmid = pmids[[i]];
    \[Theta] = \[Theta]s[[i]];
    \[Theta]2 =
     First@SortBy[Select[Table[\[Theta], {\[Theta], 0, 2 Pi, 0.01}],
        (
          p1 = {d/2 + Cos[#], Sin[#]}; p2 = p1 + 2 (pmid - p1);
          Abs[Norm[p2 - {-d/2, 0}] - r2] < 0.01
          ) &
        ],
       (Norm[{d/2 + Cos[#], Sin[#]} - pmid] - l/2)^2
        &
       ];
    \[Theta]last = \[Theta]2;
    p1 = {d/2 + Cos[\[Theta]2], Sin[\[Theta]2]};
    AppendTo[p1s, p1];
    AppendTo[p2s, p1 + 2 (pmid - p1)];
    , {i, Length@pmids}];
  ];

Manipulate[
 Module[{i = 1 + Mod[j, Length[p1s]], p2, p1, pm},
  p2 = p2s[[i]]; p1 = p1s[[i]]; pm = pmids[[i]];
  Show[
   Graphics[{
     {Red,
      Line[
       Table[
        pm, {pm, If[j < Length@pmids, pmids[[;; j]], pmids[[i ;;]]]}]
       ]
      },
     {Dashed,
      Circle[{d/2, 0}, r1],
      Circle[{-d/2, 0}, r2]
      },
     {
      Line[{{d/2, 0}, p1}],
      Line[{{-d/2, 0}, p2}]
      },
     {PointSize[Large],
      Point[{d/2, 0}],
      Point[{-d/2, 0}],
      Blue,
      Thick,
      PointSize[Medium],
      Point[p1],
      Point[p2],
      Line[{p1, p2}],
      Darker@Red,
      Point[pm]
      }
     }]
   ]
  ]
 ,
 {j, 1, 2 Length[p1s] - 1, 1}]