11.10  Multiple graphics and animation

This Mathematica notebook supports the corresponding section of M&M.  It's intended to be executed in sequence.  It may include some tests not shown in the book.  It contains code for exercise solutions, but usually little discussion of them.  The version distributed with the book will contain solutions only for odd-numbered exercises.
	Any  Export  commands that produced figures for the book are commented out, so that they won't reference nonexistent folders.  They always duplicate figures rendered just previously by  Show.
	Some items from this notebook are incorporated in the twoDG package.
	The animations in this notebook generate an enormous amount of output.  To avoid crashes due to exhausted memory, delete output once you've seen it.

Initialization

	This cell group contains definitions from notebooks  11_02.nb,  11_07.nb,  11_08.nb,  and  11_09.nb  corresponding to sections 11.2, 11.7, 11.8, and 11.9, which are required for this notebook to function.  It will be executed automatically when you answer affirmatively the question posed when you first attempt to execute any cell in this notebook.

Off[
        General::spell1];
Unprotect[Point];
Point[x_, y_] := Point[{x, y}]; 
origin := Point[0, 0];
cis[θ_] := Point[Cos[θ], Sin[θ]];
c1[Point[{x_, y_}]] ^:= x;
c2[Point[{x_, y_}]] ^:= y;
Point[P_] == Point[Q_] ^:= 
        FullSimplify[P == Q];
Point[P_] ≠  Point[Q_] ^:= 
        Not[Point[P] == Point[Q]];
distance[Point[{x1_, y1_}], 
          Point[{x2_, 
              y2_}]] ^:= 
Sqrt[(x1 - x2)^2 + (y1 - 
                  y2)^2];

  
Point[P_] + Point[Q_] ^:= Point[P + Q];
t_*Point[P_] ^:= Point[t*P];
midpoint[P_, 
          Q_] := (1/2) (P + 
              Q);

  
slope[Point[{x1_, y1_}], Point[{x2_, y2_}]] ^:= 
        Module[{dx, dy}, 
          dx = x2 - x1;   dy = y2 - y1; 
If[
            FullSimplify[dx == 0], noSlope, dy/dx]];
direction[O_, Q_] := 
        Module[{dx, dy, θ}, 
dx = c1[Q] - c1[O]; 
          dy = c2[Q] - c2[O]; 
If [
            dx == 0, 
If[dy == 0, 
              noDirection, 
If[dy < 0, 
                3  π/2, π/2]], 
θ = 
              ArcTan[dy/dx];                
If [
              dx < 0, θ + π, 
If[
                dy < 0, θ + 2  π, θ]]]];
directedAngle[Q_, O_, R_] := 
        Module[{θ}, 
θ = 
            Mod[direction[O, R] - direction[O, Q], 
              2  π]; 
If[θ > π, θ = θ - 2  π, θ]];
angle[Q_, O_, R_] := 
        Abs[directedAngle[Q, O, 
            R]];

  
norm[P_] := distance[origin, P];

lineq[0, 0, c_] := 
        noLine;
c1[lineq[a_, b_, c_]] ^:= a;
c2[lineq[a_, b_, c_]] ^:= b;
c3[lineq[a_, b_, c_]] ^:= c;
lineq[a0_, b0_, c0_] == 
          lineq[a1_, b1_, c1_] ^:= 
FullSimplify[
          a0*b1 == a1*b0  && 
b0*c1 == b1*c0 && 
            c0*a1 == c1*a0];
lineq[a0_, b0_, c0_] ≠ lineq[a1_, b1_, c1_] ^:= 
        Not[lineq[a0, b0, c0] == lineq[a1, b1, c1]];
noLine == noLine ^= badEquation;
\(\(noLine ≠ noLine ^= badEquation;\)

 (*\ 
      Constructing\ \ lineq\ \ objects\ *) \)
pointSlope[P_, m_] := lineq[m, -1, c2[P] - m*c1[P]];
horizontal[y_] :=  lineq[0, 1, -y];
horizontal[Point[x_, y_]] ^:=  horizontal[y];
vertical[x_] := lineq[1, 0, -x];
vertical[Point[x_, y_]] ^:= vertical[x];
pointParallel[P_, g_] := 
        lineq[c1[g], c2[g], -c1[g] c1[P] - c2[g] c2[P]];
\(\(pointPerpendicular[P_, g_] := 
        lineq[\(-c2[g]\), c1[g], c2[g]\ c1[P] - c1[g]\ c2[P]];\)
 (*\ 
      Join\ and\ intersection\ *) \)
Point[x1_, y1_]⋁Point[x2_, y2_] ^:= 
        FullSimplify[lineq[y2 - y1, x1 - x2, x2*y1 - x1*y2]];
\(\(lineq[a1_, b1_, c1_] ⋂ lineq[a2_, b2_, c2_] ^:= 
        Module[{d}, 
          d = a1*b2 - a2*b1; 
If[
            FullSimplify[d == 0], 
            badIntersection, \ \((1/d)\)\ \ Point[b1*c2 - b2*c1, 
                c1*a2 - c2*a1]]];\)

 (*\ 
      Testing\ for\ concurrence\ *) \)
\(\(concurrentQ[
          lineq[a1_, b1_, c1_], 
		\ \ lineq[a2_, b2_, 
            c2_], 
		\ \ lineq[a3_, b3_, c3_]] ^:= 
        FullSimplify[
          Det[{{a1, b1, c1}, 
\ \ \ \ \ {a2, b2, 
                  c2}, 
\ \ \ \ \ {a3, b3, c3}}] == 
            0];\)\)
\(\(concurrentQT[
          lineq[a1_, b1_, c1_], 
		\ \ \ \ \ lineq[a2_, 
            b2_, c2_], 
		\ \ \ \ \ lineq[a3_, b3_, 
            c3_]] ^:= Module[{d}, 
          d = Det[{{a1, b1, c1}, 
\ \ \ \ \ \ \ {a2, b2, 
                  c2}, 
\ \ \ \ \ \ \ {a3, b3, 
                  c3}}]; 
Print["Det = ", 
            d]; 
FullSimplify[
            d == 0]];\)

 (*\ 
      Additional\ operations\ *) \)
distance[Point[x_, y_], lineq[a_, b_, c_]] ^:= 
        Abs[a*x + b*y + c]/Sqrt[a^2 + b^2];
\(\(slope[lineq[a_, b_, c_]] ^:= 
If[
          FullSimplify[b == 0], 
          noSlope, \(-a\)/b];\)

 (*\ 
      Exercise\ 1\ *) \)
horizontalQ[g_] := c1[g] == 0;
verticalQ[g_] := c2[g] == 0;
onQ[P_, g_] := 
        FullSimplify[
          c1[P] c1[g] + c2[P] c2[g] + c3[g] == 0];
\(\(throughQ[g_, P_] := onQ[P, g];\)

 (*\ 
      Exercise\ 2\ *) \)
between1Q[P_, Q_, R_] := 
        FullSimplify[
          distance[P, Q] + distance[Q, R] == 
            distance[P, R]];

\( (*\ Exercise\ 3\ *) 
 (*\ 
      This\ is\ isolated\ in\ its\ own\ cell\ to\ keep\ Mathematica\ from\ dinging\ and\ reporting\ an\ internal\ \(\(error\)\(.\)\)\ *) 
\(perpendicularQ[g_, h_] := 
        FullSimplify[
          c1[g] c1[h] + c2[g] c2[h] == 0];\)\)
parallelQ[g_, h_] := 
        FullSimplify[
          c1[g] c2[h] == c1[h] c2[g]];

\( (*\ Exercise\ 5\ *) 
\(collinearQ[
          Point[x1_, 
            y1_], 
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ Point[x2_, 
            y2_], 
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ Point[x3_, y3_]] := 
        FullSimplify[
          Det[{{x1, y1, 1}, 
\ \ \ \ \ {x2, y2, 
                  1}, 
\ \ \ \ \ {x3, y3, 1}}] == 
            0];\)

 (*\ 
      Exercise\ 6\ *) \)
counterclockwiseQ[
          Point[x1_, 
            y1_], 
                                   Point[x2_, 
            y2_], 
                                   Point[x3_, y3_]] := 
        FullSimplify[
          Det[{{x1, y1, 1}, 
     {x2, y2, 
                  1}, 
     {x3, y3, 1}}] > 
            0];

 (* 
      Exercise 7 *) 
betweenQ[s_, t_, u_] := 
        FullSimplify[(s ≤ t ≤ 
                u) ∨ (u ≤ t ≤ 
                s)];

  
between2Q[P_, Q_, 
          R_] := 
collinearQ[P, Q, 
            R] && ((FullSimplify[c2[P] == c2[Q]] && 
                  betweenQ[c1[P], c1[Q], c1[R]]) ∨     betweenQ[
                c2[P], c2[Q], c2[R]]);

bisector1[
          lineq[a1_, b1_, c1_], lineq[a2_, b2_, c2_]] ^:= 
        Module[{d1, d2}, 
d1 = 
            Sqrt[a1^2 + b1^2]; 
d2 = Sqrt[a2^2 + b2^2];  
          lineq[a1*d2 - a2*d1, b1*d2 - b2*d1, c1*d2 - c2*d1]];

\( (*\ 11  _  09.  nb\ *) 

 (*\ 
      Function\ \ draw\ *) 
\(draw[L_] := 
        Show[Graphics[L], AspectRatio -> Automatic];\)\)
draw[L_, M_] := 
        Show[Graphics[L], 
          Append[{M}, 
            AspectRatio -> 
              Automatic]];

  
Point[{x0_, y0_}] Point[{x1_, y1_}] ^:= 
        Line[{{x0, y0}, {x1, y1}}];
polygon[L_] := 
        Line[Table[{c1[L[[k]]], c2[L[[k]]]}, {k, 1, 
              Length[L]}]];
filledPolygon[L_] := 
        Polygon[Table[{c1[L[[k]]], c2[L[[k]]]}, {k, 1, 
              Length[L]}]];

  
Off[General::spell];
corners[G_] := 
        Module[{xMin, xMax, yMin, yMax}, {{xMin, xMax}, {yMin, yMax}} = 
            PlotRange /. AbsoluteOptions[G]; 
{Point[xMin, 
              yMin], Point[xMax, yMax]}];
lineClipped[{LL_, UR_}, g_] := 
        Module[{xleft, xright, ybottom, ytop, left, right, bottom, top, L, R, 
            B, T, xB, xT}, 
          If[g == noLine, Return[{}]]; 
xleft = 
            c1[LL];  xright = c1[UR]; 
ybottom = c2[LL];  
          ytop = c2[UR]; 
left = vertical[LL];  
          right = vertical[UR]; 
bottom = horizontal[LL];  
          top = horizontal[UR]; 
L = 
            g ⋂ left;   R = 
            g ⋂ right; 
B = 
            g ⋂ bottom;   T = 
            g ⋂ top; 
xB = c1[B];   xT = 
            c1[T]; 
If[horizontalQ[g], 
            Return[If[ybottom ≤ c2[L] ≤ ytop, 
                L R, {}]]]; 
If[verticalQ[g], 
            Return[If[xleft ≤ xB ≤ xright, 
                B T, {}]]]; 
If[xT < xleft, 
            Return[If[xB < xleft, {}, 
                If[xB ≤ xright, L B, 
                  L R]]]]; 
If[xT ≤ xright, 
            Return[If[xB < xleft, T L, 
                If[xB ≤ xright, T B, 
                  T R]]]]; 
If[xB < xleft, L R, 
            If[xB ≤ xright, B R, {}]]];
lineClipped[G_, g_] := 
        lineClipped[corners[G], 
          g];

  
Unprotect[Circle];
Circle[Point[x_, y_], r_] ^:= 
If[r < 0, noCircle, 
          Circle[{x, y}, r]];
unitCircle = Circle[origin, 1];
arc[Z_, r_, α_, β_] := 
        If[r < 0, noCircle, 
          Circle[{c1[Z], c2[Z]}, 
            r, {α, 
              If[α ≤ β, β, β + 
                  2  π]}]];

  
angleMark[P_, O_, Q_, r_, dr_, n_] := 
        Module[{α, β}, α = direction[O, P];   β = 
            direction[O, Q]; 
Table[
            arc[O, r + k*dr, α, β], {k, 0, n - 1}]];
angleMark[P_, O_, Q_, r_] := angleMark[P, O, Q, r, 0, 1];
rightAngle[P_, O_, Q_, s_] := 
        Module[{t, u, T, U, V}, 
          t = s/distance[O, P]; 
u = 
            s/distance[O, Q]; 
T = 
            t (P - O); 
U = 
            u (Q - O); 
polygon[{O + T, O + T + U, 
              O + U}]];

  
tick[P_, Q_, u_, t_, n_] := 
        Module[{M, d, T, U, dT, dU}, 
          M = midpoint[P, Q];               d = 
            distance[P, Q]; 
T = 
            Q - P;                                      dT = (t/(2  d)) T;  U = Point[-c2[T], c1[T]];  
          dU = (u/(2  d)) 
              U; 
Table[(M + k dT + dU) (M + k dT - 
                  dU), {k, -(n - 1), n - 1, 2}]];
tick[P_, Q_, u_] := tick[P, Q, u, 0, 1];

End of initialization

Superposition

a = 1;   b = 0.7;
Clear[P];
P[t_] := {a Cos[t], b Sin[t]};
n = 50;   dt = 2  π/n;
ellipse = 
        ParametricPlot[
          P[t], {t, 0, 2  π}, 
PlotStyle -> 
            AbsoluteThickness[
              0.5], 
DisplayFunction -> 
            Identity];
PP = Table[P[k*dt], {k, 0, n - 1}];
dots = 
        ListPlot[
          PP, 
PlotStyle -> 
            AbsolutePointSize[3], 
DisplayFunction -> 
            Identity];
F = {Sqrt[a^2 - b^2], 0};
L = {AbsolutePointSize[5], Point[F], Point[-F], 
          AbsoluteThickness[1], 
AbsoluteDashing[{8, 4}], 
          Line[{-F, PP[[20]], F}], AbsoluteDashing[{2, 2}], 
          Line[{-F, PP[[40]], F}]};
λ = {ellipse, dots, Graphics[L]};
\(\(Show[λ, 
        Axes -> False, 
AspectRatio -> Automatic, 
        DisplayFunction -> $DisplayFunction, 
        ImageSize -> 
          216];\)
 (*\(Export["d:\M&M\Chapter11\11_10\11_10_01.pdf", %, 
          ImageSize -> 216];\)*) \)

I had trouble exporting and importing this.  I finally exported to  *.pdf,  then used Acrobat to export again to *.eps, then did a lot of scaling and moving with WordPerfect Image Tools to get it right.

Graphics arrays

$TextStyle = "Input";
\(\(Show[GraphicsArray[λ], 
        ImageSize -> 
          936];\)
 (*\(Export["d:\M&M\Chapter11\11_10\11_10_02.jpg", %, 
          ImageSize -> 936];\)*) \)

Partition[{1, 2, 3, 4, 5, 6, 7}, 2]

Animation

a = 1;   b = 0.7;
P[t_] := {a Cos[t], b Sin[t]};
n = 50;   dt = 2  π/n;
Do[
        L = {AbsolutePointSize[3], Point[P[k*dt]]}; 
Show[
          Graphics[L], 
          PlotRange -> {{-1.2, 1.2}, {-0.9, 0.9}}], {k, 0, 
          n - 1}];

\(\(animate := {SelectionMove[SelectedNotebook[], All, 
            GeneratedCell]; 
FrontEndTokenExecute["SelectionCloseAllGroups"]; 
SelectionAnimate[SelectedNotebook[], 
            AnimationDisplayTime -> 0.1]};\)\)

Do[
        L = {AbsolutePointSize[3], Point[P[k*dt]]}; 
Show[
          Graphics[L], 
          PlotRange -> {{-1.2, 1.2}, {-0.9, 0.9}}], {k, 0, 
          n - 1}];
animate;

F = {Sqrt[a^2 - b^2], 0};
Do[
        L = {AbsolutePointSize[3], AbsoluteThickness[0.5], Point[F], 
            Point[P[k*dt]], Point[-F], 
            Line[{-F, P[k*dt], F}]}; 
Show[Graphics[L], 
          PlotRange -> {{-1.2, 1.2}, {-0.9, 0.9}}], {k, 0, 
          n - 1}];
animate;

Do[
        L = {AbsolutePointSize[3], AbsoluteThickness[0.5], Point[F], 
            Table[Point[P[j*dt]], {j, 0, k}], Point[-F], 
            Line[{-F, P[k*dt], F}]}; 
Show[Graphics[L], 
          PlotRange -> {{-1.2, 1.2}, {- .9,  .9}}], {k, 0, 
          n - 1}];
animate;

Do[
        L = {AbsolutePointSize[3], AbsoluteThickness[0.5], Point[F], 
            Table[Point[P[j*dt]], {j, 0, k}], Point[-F], 
            Line[{-F, P[k*dt], F}]}; 
Show[Graphics[L], 
          PlotRange -> {{-1.2, 1.2}, {- .9,  .9}}], {k, 0, 
          n - 1}];
\(\({SelectionMove[SelectedNotebook[], After, 
          GeneratedCell]; 
SelectionMove[
          SelectedNotebook[], Previous, Cell]; 
SetOptions[
          NotebookSelection[SelectedNotebook[]], 
          AnimationDisplayTime -> 5]; 
SelectionMove[
          SelectedNotebook[], All, 
          CellGroup]; 
FrontEndTokenExecute["SelectionCloseAllGroups"]; 
FrontEndTokenExecute["SelectionAnimate"]};\)\)

Exercise 1

a = 1;   b = 0.7;
P[t_] := {a Cos[t], b Sin[t]};
n = 50;   dt = 2  π/n;
ellipse = 
        ParametricPlot[
          P[t], {t, 0, 2  π}, 
PlotStyle -> 
            AbsoluteThickness[
              0.5], 
DisplayFunction -> 
            Identity, 
AspectRatio -> 
            Automatic];
PR = PlotRange /. AbsoluteOptions[ellipse];
PP = Table[P[k*dt], {k, 0, n - 1}];
dots = 
        ListPlot[
          PP, 
PlotStyle -> 
            AbsolutePointSize[3], 
DisplayFunction -> 
            Identity, AspectRatio -> Automatic, 
          PlotRange -> PR];
F = {Sqrt[a^2 - b^2], 0};
L = {AbsolutePointSize[5], Point[F], Point[-F], 
          AbsoluteThickness[1], 
AbsoluteDashing[{8, 4}], 
          Line[{-F, PP[[20]], F}], AbsoluteDashing[{2, 2}], 
          Line[{-F, PP[[40]], F}]};
λ = {ellipse, dots, 
          Graphics[L, PlotRange -> PR]};
Show[λ, 
        Axes -> False, 
AspectRatio -> Automatic, 
        DisplayFunction -> $DisplayFunction, 
        ImageSize -> 216];

$TextStyle = "Input";
Show[GraphicsArray[λ], ImageSize -> 936];

Exercise 2

This exercise hasn't been developed yet.

Exercise 3

Needs["Graphics`ImplicitPlot`"];
Clear[F];
F[x_, 
          y_] := (y - (x^2)) (x - (y^2));
dv = 0.02;
T = 
        Table[ImplicitPlot[F[x, y] == n*dv, {x, -3/2, 2}, 
            PlotRange -> {{-3/2, 2}, {-3/2, 
                  2}}, 
DisplayFunction -> Identity, 
            PlotLabel -> "F[x,y] = " <> ToString[n*dv]], {n, -3, 
            4}];
Show[GraphicsArray[Partition[T, 2]], 
        DisplayFunction -> $DisplayFunction, 
ImageWidth -> 916, Frame -> True];

dv = 0.01;
Table[
        ImplicitPlot[F[x, y] == n*dv, {x, -3/2, 2}, 
          PlotRange -> {{-3/2, 2}, {-3/2, 2}}], {n, -10, 
          10}];
animate;

Exercise 4

a = 1;
Do[
        ParametricPlot[
{a Cos[t] + b Cos[6  t], 
            a Sin[t] +  b Sin[6 t]}, {t, 0, 
            2  π}, 
Axes -> False, 
          AspectRatio -> Automatic, 
          PlotStyle -> 
            AbsoluteThickness[
              0.5], 
PlotRange -> {{-3, 
                3}, {-3, 3}}], {b, 0, 2, 
          0.1}];
\(\({SelectionMove[SelectedNotebook[], After, 
          GeneratedCell]; 
SelectionMove[
          SelectedNotebook[], Previous, Cell]; 
SetOptions[
          NotebookSelection[SelectedNotebook[]], 
          AnimationDisplayTime -> 5]; 
SelectionMove[
          SelectedNotebook[], All, 
          CellGroup]; 
FrontEndTokenExecute["SelectionCloseAllGroups"]; 
FrontEndTokenExecute["SelectionAnimate"]};\)\)

Exercise 5

a = 1;   b = 0.7;
P[t_] := {a Cos[t], b Sin[t]};
n = 50;   dt = 2  π/n;
F = {Sqrt[a^2 - b^2], 0};
For[k = 0, k < n, k++, 
        K = ParametricPlot[{a Cos[t], b Sin[t]}, {t, 0, (k + 1)*dt}, 
            DisplayFunction ->  Identity, Axes -> False, 
            AspectRatio -> Automatic, 
            PlotStyle -> 
              AbsoluteThickness[
                0.5]]; 
L = {AbsolutePointSize[3], 
            AbsoluteThickness[0.5], Point[F], Point[P[(k + 1)*dt]], 
            Point[-F], 
            Line[{-F, P[(k + 1)*dt], F}]}; 
Show[K, 
          Graphics[L], PlotRange -> {{-1.2, 1.2}, {- .9,  .9}}, 
          DisplayFunction -> $DisplayFunction]];
\(\({SelectionMove[SelectedNotebook[], After, 
          GeneratedCell]; 
SelectionMove[
          SelectedNotebook[], Previous, Cell]; 
SetOptions[
          NotebookSelection[SelectedNotebook[]], 
          AnimationDisplayTime -> 5]; 
SelectionMove[
          SelectedNotebook[], All, 
          CellGroup]; 
FrontEndTokenExecute["SelectionCloseAllGroups"]; 
FrontEndTokenExecute["SelectionAnimate"]};\)\)

Exercise 6

a = 1;  b = 0.4;
n = 100;   dt = 2  π/n;
P[t_] := {a Cos[t] + b Cos[6  t], 
          a Sin[t] +  b Sin[6 t]};
For[k = 0, k < n, k++, 
        K = ParametricPlot[{a Cos[t] + b Cos[6  t], 
              a Sin[t] +  b Sin[6 t]}, {t, 0, (k + 1)*dt}, 
            DisplayFunction ->  Identity, Axes -> False, 
            AspectRatio -> Automatic, 
            PlotStyle -> 
              AbsoluteThickness[
                0.5], 
PlotRange -> {{-1.5, 
                  1.5}, {-1.5, 
                  1.5}}]; 
L = {AbsolutePointSize[3], 
            Point[P[(k + 1)*dt]]}; 
Show[K, 
          Graphics[L], 
          DisplayFunction -> $DisplayFunction]];
\(\({SelectionMove[SelectedNotebook[], After, 
          GeneratedCell]; 
SelectionMove[
          SelectedNotebook[], Previous, Cell]; 
SetOptions[
          NotebookSelection[SelectedNotebook[]], 
          AnimationDisplayTime -> 5]; 
SelectionMove[
          SelectedNotebook[], All, 
          CellGroup]; 
FrontEndTokenExecute["SelectionCloseAllGroups"]; 
FrontEndTokenExecute["SelectionAnimate"]};\)\)

Exercise 7

α = 1.2;   β = -0.8;   γ = 1.3;
A0 = Point[0, α];  
    B = Point[β, 0];   𝒞 = 
      Point[γ, 0];
nMax = 50;  dθ = π/nMax;
\(\(Do[
A = 
          norm[A0] cis[n*dθ]; 
a = 
          B⋁𝒞; \ \ b = 𝒞⋁A; \ \ c = 
          A⋁B; 
g = bisector1[b, c]; \ \ h = 
          bisector1[c, a]; \ \ j = bisector1[a, b]; 

        Ia = g ⋂ a; \ \ Ib = h ⋂ b; \ \ Ic = 
          j ⋂ c; \ \ ℐ = g ⋂ h; 

        L = {AbsoluteThickness[1], 
            polygon[{A, B, 𝒞, 
                A}], 
\ \ \ 𝒞\ Ic, 
\ \ \ AbsolutePointSize[20], 
            GrayLevel[
              1], ℐ, 
\ \ \ AbsolutePointSize[5], 
            GrayLevel[0], ℐ, 
\ \ \ A\ Ia, 
            B\ Ib, 
\ \ \ A, B, 𝒞}; 

        r = 0.1; \ \ dr = 0.03; \ \ s = r + dr/2; 

        AppendTo[
          L, {angleMark[B, A, Ia, 
              r], 
	\ \ \ \ \ \ angleMark[Ia, 
              A, 𝒞, 
              s], 
	\ \ \ \ \ \ angleMark[𝒞, B, Ib, r, dr, 
              2], 
	\ \ \ \ \ \ angleMark[Ib, B, A, s, dr, 
              2], 
	\ \ \ \ \ \ angleMark[
              A, 𝒞, Ic, r, dr, 
              3], 
	\ \ \ \ \ \ angleMark[
              Ic, 𝒞, B, s, dr, 3]}]; 
draw[
          L, PlotRange -> {{\(-1.3\), 1.4}, {\(- .1\), 1.3}}], {n, 4, 
          46, 1/2}];\)\)
\(\({SelectionMove[SelectedNotebook[], After, 
          GeneratedCell]; 
SelectionMove[
          SelectedNotebook[], Previous, Cell]; 
SetOptions[
          NotebookSelection[SelectedNotebook[]], 
          AnimationDisplayTime -> 5]; 
SelectionMove[
          SelectedNotebook[], All, 
          CellGroup]; 
FrontEndTokenExecute["SelectionCloseAllGroups"]; 
FrontEndTokenExecute["SelectionAnimate"]};\)\)

Exercise 8

α = 1.2;   β = -0.8;   γ = 
      1.3;
A0 = Point[0, α];  
    B = Point[β, 0];   𝒞 = 
      Point[γ, 0];
nMax = 50;  dθ = π/nMax;
Do[
A = 
          norm[A0] cis[n*dθ]; 
a = 
          B⋁𝒞;   b = 𝒞⋁A;   c = 
          A⋁B; 
A1 = 
          midpoint[B, 𝒞];   B1 = 
          midpoint[𝒞, A];   C1 = 
          midpoint[A, B]; 
g =  
          pointPerpendicular[A1, a]; 
h = 
          pointPerpendicular[B1, b]; 
Oh = 
          g ⋂ h; 
r = 
          distance[Oh, A]; 
s = 
          0.06; 
t = 0.06; 
u = 
          0.03; 
L = {AbsoluteThickness[1], 
            polygon[{A, B, 𝒞, 
                A}], 
   Oh A1,  Oh B1,  
            Oh C1, 
   AbsolutePointSize[
              5], 
   A, B, 𝒞, A1, B1, 
            C1, Oh, 
   rightAngle[Oh, A1, B, s], 
            rightAngle[Oh, B1, 𝒞, 
              s], 
   rightAngle[Oh, C1, A, 
              s], 
   tick[B, A1, t], 
            tick[A1, 𝒞, 
              t], 
   tick[𝒞, B1, t, u, 
              2], tick[B1, A, t, u, 2], 
   tick[A, C1, 
              t, u, 3], 
            tick[C1, B, t, u, 3], 
   Circle[Oh, 
              r]}; 
draw[L, 
          PlotRange -> {{-2, 4}, {-2, 
                4}}], 
{n, 4, 46, 
          1/2}];
\(\({SelectionMove[SelectedNotebook[], After, 
          GeneratedCell]; 
SelectionMove[
          SelectedNotebook[], Previous, Cell]; 
SetOptions[
          NotebookSelection[SelectedNotebook[]], 
          AnimationDisplayTime -> 5]; 
SelectionMove[
          SelectedNotebook[], All, 
          CellGroup]; 
FrontEndTokenExecute["SelectionCloseAllGroups"]; 
FrontEndTokenExecute["SelectionAnimate"]};\)\)