Project Help Notebook by Keith Stroyan

Help NoteBook Copyright 1998 by Academic Press, Inc. - All rights reserved.
Modify this Notebook to prepare your project report.

Project 27: Reflection of Light Off Mirrors

by A. Student and B. Pupil

with technical help from Da LabMonitor and Help Notebook

Arrow & Angle Initialization

We told you not to look.  This horrible stuff sets various defaults and defines some functions needed to draw the geometric side of the lexicon.  Ignore the details here and go on to the lesson.

Off[General::spell];
Off[General::spell1];
Off[ParametricPlot3D::ppcom]
Needs["Graphics`Colors`"]

SetOptions[Graphics,Axes->False,AxesOrigin->{0,0},AspectRatio->Automatic];
SetOptions[Graphics3D,ViewPoint->{5,2,1},Boxed->False,AspectRatio->Automatic];
SetOptions[ParametricPlot3D,ViewPoint->{5,2,1},AspectRatio->Automatic];
SetOptions[Plot3D,ViewPoint->{5,2,1},AspectRatio->Automatic];
SetOptions[ParametricPlot,AspectRatio->Automatic];
SetOptions[Plot,AspectRatio->Automatic];

colorQ[a_]:=(Head[a]===RGBColor);
grayQ[a_]:=(Head[a]===GrayLevel);
thickQ[a_]:=(Head[a]===Thickness);
absthickQ[a_]:=(Head[a]===AbsoluteThickness);
notruleQ[u_] := !(Head[u]===Rule);
ruleQ[u_] := (Head[u]===Rule);

Norm::usage = "Norm[expr] returns the Euclidean length of the
		vector, 'expr'.";

Norm[a_?VectorQ] := Sqrt[a.a];

Angle[a_?VectorQ,b_?VectorQ] := ArcCos[(a.b)/(Norm[a] Norm[b])]

Proj[a_?VectorQ,b_?VectorQ] := ((a.b)/(b.b))b

tol = .5*10^-6;

OrthUp[a_?VectorQ] :=
	Module[{b,c,d,f},
		d = N[a/Norm[a]];
		If[Chop[d[[3]]^2 - 1,tol] == 0, b={1,0,0} ,
		b = {0,0,1} - d[[3]] d; b = b/Norm[b];];
	Return[b]];
	
OrthSet[a_?VectorQ] :=
	Module[{b,c,d},
		d = N[a/Norm[a]];
		If[Chop[d[[1]],tol]==0,b={1,0,0},
			 If[Chop[d[[2]],tol]==0,b={0,1,0},
			  b={-d[[2]],d[[1]],0}]];
			b=b/Norm[b];c = Cross[d,b];
	Return[{b,c/Norm[c],d}]];

				
Rotate[a_?VectorQ,theta_] :=
	Module[{u,v,r},
		u = OrthSet[a];
		v = Transpose[u];
		r = N[{{Cos[theta],-Sin[theta],0},{Sin[theta],Cos[theta],0},{0,0,1}}];
	Return[v.r.u]];

Vector2D[tail_,tip_,opts___]:=
	Module[{ntail,ntip,sopts,Punit,up,arrow},
	ntail = N[tail];
	ntip = N[tip];
	
	sopts = Join[Select[{opts},colorQ],Select[{opts},
				thickQ],Select[{opts},absthickQ],Select[{opts},grayQ]];

If[Chop[ntail.ntail+ntip.ntip,tol] == 0,
			(*too small to plot or not number*)
			Return[Graphics[Point[{0,0}]]];
	,						
If[Chop[(ntip-ntail).(ntip-ntail),tol] == 0,
		Return[Graphics[{Join[sopts,{Line[{ntail,ntip}]}]}]];
	,
	Punit = 0.075 (ntip-ntail) ;
	up = 0.15 {-Punit[[2]],Punit[[1]]};
	arrow = Line[{ntail,ntip,ntip-Punit+up,ntip,ntip-Punit-up}];
	]];
Return[Graphics[{Join[{AbsoluteThickness[2]},Join[sopts,{arrow}]]}]];
];

Vector3D[tail_,tip_,opts___]:=
	Module[{ntail,ntip,sopts,Punit,up,u2,u3,u4,rotmat,arrow},
	ntail = N[tail];
	ntip = N[tip];
	
	sopts = Join[Select[{opts},colorQ],Select[{opts},
				thickQ],Select[{opts},absthickQ],Select[{opts},grayQ]];

If[Chop[ntail.ntail+ntip.ntip,tol] == 0,
			(*too small to plot or not number*)
			Return[Graphics3D[Point[{0,0,0}]]];					
	,		
If[Chop[(ntip-ntail).(ntip-ntail),tol] == 0,
		Return[Graphics3D[{Join[sopts,{Line[{ntail,ntip}]}]}]];
	,
	Punit = (ntip-ntail);
	rotmat = Rotate[Punit,N[Pi/2]];
	up = OrthUp[Punit];
	Punit = .075 Punit;
	up = .15 Norm[Punit] up;
	u2 = rotmat.up;
	u3 = rotmat.u2;
	u4 = rotmat.u3;
	arrow = Line[{ntail,ntip,
				ntip - Punit + up,ntip,
				ntip - Punit + u2,ntip,
				ntip - Punit + u3,ntip,
				ntip - Punit + u4}];
	]];
Return[Graphics3D[{Join[{AbsoluteThickness[2]},Join[sopts,{arrow}]]}]];
];

aRCtAN[y_,x_] := Module[{v},
	If[ Chop[N[x],tol] == 0 ,If[ N[y] < 0, v = -N[Pi/2], v = N[Pi/2]],
		v = N[ArcTan[y/x]];
		If[ x < 0 && y < 0, v = N[Pi -  v],v]];
	Return[v]];

Arc2D[X_,Y_,opts___] := Graphics[{opts,
		Disk[{0,0},1,{Min[
							aRCtAN[
						N[X[[2]]],N[X[[1]]]
								]
							,
							aRCtAN[
							N[Y[[2]]],N[Y[[1]]]
								]
						]
						,
					Max[
							aRCtAN[
						N[X[[2]]],N[X[[1]]]
								]
							,
							aRCtAN[
							N[Y[[2]]],N[Y[[1]]]
								]
						]}
				]}
				];
Arc3D[X_,Y_] := 
	Module[{t,U,V},
		U[V_]:= N[(1/Sqrt[V.V]) V];
		Return[Graphics3D[
		Polygon[Append[Table[U[t X + (1-t) Y],{t,0,1,0.1}],{0,0,0}]]
				]
		]
	];

(*Zero Arrow causes trouble. Put in Vector?*)

Vector[tail_,tip_,opts___]:=
	If[Length[N[tail]]==2,Return[Vector2D[tail,tip,opts]],
		Return[Vector3D[tail,tip,opts]]];
		
Arrow[vec_,opts___]:= 
	Module[{a,b},
				If[Length[N[vec]]==2,
				a=ToExpression["Tail"]/.Select[{opts},ruleQ]/.
					{ToExpression["Tail"]->{0,0}};
				Return[Vector2D[a,a+vec,opts]],
				a=ToExpression["Tail"]/.Select[{opts},ruleQ]/.
					{ToExpression["Tail"]->{0,0,0}};
				Return[Vector3D[a,a+vec,opts]]]
				];

Frame2D[delta_] := 
      Graphics[{
            {Green,Line[{{-delta/4,0},{delta,0}}]},
                    Text["x",{1.01 delta,0}],
            {Green,Line[{{0,-delta/4},{0,delta}}]},
                    Text["y",{0, 1.01 delta}]}];

Frame3D[delta_] := 
      Graphics3D[{
            {Green,Line[{{-delta/4,0,0},{delta,0,0}}]},
                    Text["x",{1.01 delta,0,0}],
            {Green,Line[{{0,-delta/4,0},{0,delta,0}}]},
                    Text["y",{0, 1.01 delta,0}],
            {Green,Line[{{0,0,-delta/4},{0,0,delta}}]},
                    Text["z",{0,0,1.01 delta}]}];

View2D[stuff_] := Show[stuff,Frame2D[1]];
View3D[stuff_] := Show[stuff,Frame3D[1]];

My Project Introduction

Write this last.  Begin with the basic question and state your main finding clearly, but with few technical details.  You might even modify the title of this section to make it more interesting.

Reflections Off a Flat Mirror

Hint 27.3

Work this basic coordinate geometry problem to show that Fermat's Least Time Principle implies Snell's empirical law on reflection angles.  The main difficulty is seeing the connection between coordinate formulas and angles.  (Hint: SOH, sine equals opposite over hypotenuse.)

Reflections Off a Curved Mirror

Hint 27.7

Read the written project leading up to HINT 27.7 and then complete that exercise.  Re-count the proof of Snell's Law from Fermat's Principle in your own words.

The Trig of Combining Slopes

Calculus works easily with slopes, but geometry uses angles.  The tangent of the angle is the slope, but when we add angles and need to compute in terms of slopes, we must to make the connexion between sums of angles and slopes using tangent identities.  Read the written project and use the following to help explain your computations.

Begin by explaining how you use the angle of a ray of incoming light to find the angle of a ray of reflected light.

Note: You can supress the code in the help and only show the figures by setting Cell Grouping to Manual and then re-grouping and closing cells you don't want to show.

A curve for reflection

\(Clear[θ, Subscript, f, x]; 
f[x_]\  := \ Sqrt[x + 1] - 1; 

    curve = Plot[f[x], {x, \(-1\), 1}, AspectRatio -> Automatic, 
        Ticks -> None, Axes -> None]; \)

The incoming ray's angle from the horizontal

\(x\  = \ 0; 
a\  = \ \(-1\); 
b\  = \ \(- .175\); 

    t1\  = \ \((f[x] - b)\)/\((x - a)\); 
t2\  = \ \(f'\)[x]; 

    t22\  = \ 2  t2/\((1 - t2^2)\); 

    t3\  = \ \((t22 - t1)\)/\((1 + t22\ t1)\); 
dx\  = \  .8; 

    u\  = \ dx + x; 
v\  = \ f[x] + t3*dx; 

    theta1 = Show[{curve, Graphics[Point[{0, 0}]], 

          Arrow[{x - a, f[x] - b}, Tail -> {a, b}, RGBColor[1, 0, 0]], 

          Arrow[{x - a, f[x] - b}, RGBColor[1, 0, 0]], 

          Arrow[{u - x, v - f[x]}, Tail -> {x, f[x]}, RGBColor[0, 0, 1]], 

          Graphics[{RGBColor[0, 1, 0], 
              Line[{{x - dx, f[x] - dx*\(f'\)[x]}, {x + dx, 
                    f[x] + dx*\(f'\)[x]}}]}], 

          Arc2D[{\(-a\), \(-b\)}, {\(-1\), 0}], 

          Graphics[{DarkGreen, Line[{{\(-dx\), 0}, {dx, 0}}]}], 

          Graphics[Text[\*""\!\(θ\_1\)"", {1.1,  .07}]]
	}]; 
    \)

The angle of elevation of the curve

\(\(theta2 = 
      Show[{curve, Graphics[Point[{0, 0}]], 
		
          Arrow[{x - a, f[x] - b}, Tail -> {a, b}, RGBColor[1, 0, 0]], 

          				Arrow[{u - x, v - f[x]}, Tail -> {x, f[x]}, 
            RGBColor[0, 0, 1]], 
		
          Graphics[{RGBColor[0, 1, 0], 
              Line[{{x - dx, f[x] - dx*\(f'\)[x]}, {x + dx, 
                    f[x] + dx*\(f'\)[x]}}]}], 
		
          Arc2D[{x + dx, f[x] + dx*\(f'\)[x]}, {1, 0}], 
				
          Graphics[{DarkGreen, Line[{{\(-dx\), 0}, {dx, 0}}]}], 
		
          Graphics[Text[θ\_2, {1.1,  .2}]]
	}]; \)\)

The outgoing ray's angle

\(\(theta3 = 
      Show[{curve, Graphics[Point[{0, 0}]], 
		
          Arrow[{x - a, f[x] - b}, Tail -> {a, b}, RGBColor[1, 0, 0]], 

          				Arrow[{u - x, v - f[x]}, Tail -> {x, f[x]}, 
            RGBColor[0, 0, 1]], 
		
          Graphics[{RGBColor[0, 1, 0], 
              Line[{{x - dx, f[x] - dx*\(f'\)[x]}, {x + dx, 
                    f[x] + dx*\(f'\)[x]}}]}], 
		Arc2D[{u, v}, {1, 0}], 

          Graphics[{DarkGreen, Line[{{\(-dx\), 0}, {dx, 0}}]}], 
		
          Graphics[Text[θ\_3, {1. ,  .5}]]
	}]; \)\)

The three angles together

Show[GraphicsArray[{theta1, theta2, theta3}]];

Hint 27.12, 13 & 15

Read, solve and explain these hints.  Then implement it in a program with the following help.

\(f[x_]\  := \ 2\ Sqrt[x]; 

    curve = Plot[f[x], {x, 0, 8}, AspectRatio -> Automatic, Ticks -> None, 
        AxesOrigin -> {0, 0}, \ AxesLabel -> {"x", "y"}]; 

    x\  = \ 4; 
a\  = \ 0; 
b\  = \ 6; 

    t1\  = \ \((f[x] - b)\)/\((x - a)\)\)t2  =  f'[x]t22  =  2  t2/(1 - t2^2)\(t3\  = \ \(?? 
dx\ =\ 2;
u\  = \ dx + x

        v\  = \ f[x] + t3*dx

        \(Show[{curve, 
            Graphics[{RGBColor[1, 0, 0], Line[{{a, b}, {x, f[x]}}]}], 
            Graphics[{RGBColor[0, 0, 1], Line[{{x, f[x]}, {u, v}}]}], 
            Graphics[{RGBColor[0, 1, 0], 
                Line[{{x - dx, f[x] - dx*\(f'\)[x]}, {x + dx, 
                      f[x] + dx*\(f'\)[x]}}]}]}, AspectRatio -> Automatic]; 
        \)\)\)

Vertical Incoming Light

Hint 27.17

Solve this hint and explain the following computation.

\(Clear[f, x]; 
f[x_]\  := \ x^2; 

    curve2 = Plot[f[x], {x, \(- .5\), 1}, AspectRatio -> Automatic, 
        Ticks -> None, AxesOrigin -> {0, 0}, AxesLabel -> {"x", "y"}, 
        DisplayFunction -> Identity]; 
x\  = \  .25; 
a\  = \  .25; 

    b\  = 1; 

t3\  = \ \((\(f'\)[x]^2 - 1)\)/\((2 \( f'\)[x])\); 

    dx\  = \ \(- .25\); 
u\  = \ 2\ dx + x; 
v\  = \ f[x] + t3*2\ dx; 

    first\  = \ 
      Show[{curve2, 

          Graphics[{RGBColor[1, 0, 0], Line[{{a, b}, {x, f[x]}}]}], 

          Graphics[{RGBColor[0, 0, 1], Line[{{x, f[x]}, {u, v}}]}], 

          Graphics[{RGBColor[0, 1, 0], 
              Line[{{x - dx, f[x] - dx*\(f'\)[x]}, {x + \ dx, 
                    f[x] + \ dx*\(f'\)[x]}}]}], 
	
          Graphics[Text["(a,b)", {a, b}]], 

          Graphics[Text["(u,v)", {u +  .1, v}]], 
		
          Graphics[Text["α", {x +  .1, f[x] +  .1}]], 
		
          Graphics[Text["β", {x -  .1, f[x]}]], 
		
          Graphics[Text["y = f[x]", { .75,  .5}]], 
		
          Graphics[Text["(x,f[x])", {x +  .1, f[x] -  .15}]], 
	
          Graphics[{AbsolutePointSize[3], Point[{x, f[x]}]}]}, 
	
        AspectRatio -> Automatic, DisplayFunction -> $DisplayFunction]; 
t3
    \)

Explorations

You're on your own now, but there are some interesting pictures to draw.

Sample pictures

\(Clear[f, x]; 
f[x_]\  := \ x^2; 

    curve = Plot[f[x], {x, \(- .5\), 1}, AspectRatio -> Automatic, 
        Ticks -> None, Axes -> None, DisplayFunction -> Identity]; 

    x\  = \  .25; 
a\  = \  .25; 
b\  = 1; 


    t3\  = \ \((\(f'\)[x]^2 - 1)\)/\((2 \( f'\)[x])\); 
dx\  = \ \(- .125\); 
    
u\  = \ 2\ dx + x; 
v\  = \ f[x] + t3*2\ dx; 

    first\  = \ 
      Show[{curve2, 

          Graphics[{RGBColor[1, 0, 0], Line[{{a, b}, {x, f[x]}}]}], 

          Graphics[{RGBColor[0, 0, 1], Line[{{x, f[x]}, {u, v}}]}], 

          Graphics[{RGBColor[0, 1, 0], 
              Line[{{x - dx, f[x] - dx*\(f'\)[x]}, {x + \ dx, 
                    f[x] + \ dx*\(f'\)[x]}}]}], 
	
          Graphics[{AbsolutePointSize[3], Point[{x, f[x]}]}]}, 
	
        AspectRatio -> Automatic, DisplayFunction -> $DisplayFunction]; \)

\(\ x\  = \  .5; 
a\  = \  .5; 
b\  = 1; 


    t3\  = \ \((\(f'\)[x]^2 - 1)\)/\((2 \( f'\)[x])\)\)\(dx\  = \ \(- .25\); 
u\  = \ 2\ dx + x; 
v\  = \ f[x] + t3*2\ dx; 

    second = \ 
      Show[{curve2, 

          Graphics[{RGBColor[1, 0, 0], Line[{{a, b}, {x, f[x]}}]}], 

          Graphics[{RGBColor[0, 0, 1], Line[{{x, f[x]}, {u, v}}]}], 

          Graphics[{RGBColor[0, 1, 0], 
              Line[{{x - dx, f[x] - dx*\(f'\)[x]}, {x + \ dx, 
                    f[x] + \ dx*\(f'\)[x]}}]}], 
	
          Graphics[{AbsolutePointSize[3], Point[{x, f[x]}]}]}, 
	
        AspectRatio -> Automatic, DisplayFunction -> $DisplayFunction]; \)

\(x\  = \  .75; 
a\  = \  .75; 
b\  = 1; 


    t3\  = \ \((\(f'\)[x]^2 - 1)\)/\((2 \( f'\)[x])\)\)\(dx\  = \ \(- .75\); 
u\  = \ \ dx + x; 
v\  = \ f[x] + t3*dx; 

    third = \ Show[{curve2, 

          Graphics[{RGBColor[1, 0, 0], Line[{{a, b}, {x, f[x]}}]}], 

          Graphics[{RGBColor[0, 0, 1], Line[{{x, f[x]}, {u, v}}]}], 

          Graphics[{RGBColor[0, 1, 0], 
              Line[{{x - dx, f[x] - dx*\(f'\)[x]}, {x + \ dx/3, 
                    f[x] + \ dx*\(f'\)[x]/3}}]}], 
	
          Graphics[{AbsolutePointSize[3], Point[{x, f[x]}]}]}, 
	
        AspectRatio -> Automatic, DisplayFunction -> $DisplayFunction]; \)

Show[first, second, third];

\(Clear[m, f, x]; 
f[x_] := x^2/4\)\(curve = 
      Plot[f[x], {x, \(-1\), 1}, Ticks -> None, 
        DisplayFunction -> Identity]; 

    vertLines = Table[Line[{{x, 1}, {x, f[x]}}], {x, \(-1\), 1,  .1}]; 

    \(f'\)[x]; 
m[x_] := \((\((\(f'\)[x])\)^2 - 1)\)/\((2\ \(f'\)[x])\); 

    m[x]; 
dx = \(-x\) -  .1\ Sign[x]; 

    reflectedLines = 
      Table[Line[{{x, f[x]}, {x\  + dx, f[x] + m[x]*dx}}], {x, \(-1\), 
          1,  .1}]; 
    parabRefl = 
      Show[curve, 
        Graphics[{RGBColor[1, 0, 0], AbsoluteThickness[1], vertLines}], 
        Graphics[{RGBColor[0, 1, 0], AbsoluteThickness[1], reflectedLines}], 
        AspectRatio -> Automatic, DisplayFunction -> $DisplayFunction]; 

    f[x]\)

Suggestions

Following are some student explorations.

A parabolic mirror

A spherical mirror

lightOptics package (a complicated solution)

BeginPackage["LightOptics`"]

lightOptics::usage = "lightOptics[f, {xmin, xmax}, rayhite, dx,
raylength, opns] draws a graph illustrating the reflection of light
rays from a surface given by the function f and orginating at rayhite
units above the x-axis.  The parameters dx and raylength give the
separation of the rays and the length of the reflected rays.  opns
are passed to Plot."

Begin["`Private`"]

makeRays[ f_, {xmin_, xmax_}, rayhite_, dx_ ] :=
	Block[ {raylist, x},
		raylist = {} ;
		Do[
			AppendTo[raylist, {GrayLevel[0.5],
							Line[{{x, rayhite}, {x, f[x]}}]}],
			{x, xmin, xmax, dx}
		] ;
		raylist
	]
	
reflections[ f_, {xmin_, xmax_}, raylength_, dx_ ] :=
	Block[ {refects, x},
		reflects = {} ;
		Do[
			AppendTo[reflects, {Line[{{x, f[x]},
				{x + raylength (-2 Derivative[1][f][x]),
					-raylength (Derivative[1][f][x]^2 - 1) + f[x]}}]} ],
			{x, xmin, xmax, dx}
		] ;
		reflects
	]
	
lightOptics[ f_, {xmin_, xmax_}, rayhite_, dx_, raylength_,
					opns___Rule ] :=
	Block[ {x},
		incidentRays = makeRays[ f, {xmin, xmax}, rayhite, dx ] ;
		reflectedRays = reflections[ f, {xmin, xmax}, raylength, 
											dx ] ;
		Plot[ f[x], {x, xmin, xmax},
				PlotStyle -> {{incidentRays, reflectedRays}},
				opns ] ;
	]
	
End[]

Protect[lightOptics]

EndPackage[]

Example

f[x_] := -Sqrt[1 - x^2] ;
{xmin, xmax} = {-.7, .7} ;
rayhite = 4 ;
dx = 0.05 ;
raylength = .75

lightOptics[ f, {xmin, xmax}, rayhite, dx, raylength,Axes->None]

Example

f[x_] := x^2/2 ;
{xmin, xmax} = {-.7, .7} ;
rayhite = 4 ;
dx = 0.05 ;
raylength = .75

lightOptics[ f, {xmin, xmax}, rayhite, dx, raylength,Axes->None]