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 31: Geometric Optimization

by A. Student and B. Pupil

with technical help from Da LabMonitor and Help Notebook

Special Mathematica Functions used in this NoteBook

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.  What is the Interior Critical Points Theorem?  When does the Extreme Value Theorem guarantee that there is a max and a min?.  You might even modify the title of this section to make it more interesting.

Beginning Explorations with Two Curves

The following Mathematica help is intended to compliment the development of the printed project.  You should work to understand and combine both approaches.

Distance between two lines

Following is a Mathematica material that supplements the example in the print project.  You should add your paper and pencil work to this.

Two parametric lines are given by:

x1 = s					y1 = 3 + t

x2 = 0					y2 = 3 + t

x3 = 0					y3 = 1 + 2t

in vector form,

(({{x1}, {x2}, {x3}}))= (({{0}, {0}, {0}})) + s (({{1}, {0}, {0}}))		(({{y1}, {y2}, {y3}}))= (({{3}, {3}, {1}})) + t (({{1}, {1}, {2}}))

X[s] = P1 + s V1			Y[t] = 	P2 + t V2

The square of the distance between any one point on one line and any other point on the other line is given by

D[s,t] = (X[s]-Y[t])•(X[s]-Y[t])

The lines look as follows.

P1 = {0, 0, 0};
V1 = {1, 0, 0};
X[s_] = P1 + s V1;

P2 = {3, 3, 1};
V2 = {1, 1, 2};
Y[t_]  =  P2 + t V2;

dist2[s_, t_]  =  (X[s] - Y[t]) . (X[s] - Y[t]);
      

line1 = 
        ParametricPlot3D[X[s], {s, -1, 3}, 
          AxesLabel -> {"x", "y", "z"}];
X[s]
line2 = ParametricPlot3D[Y[t], {t, -2, 1}];
Y[t]
Show[line1, line2, Arrow[X[1] - Y[1], Tail -> Y[1], Blue], 
        Arrow[X[0] - Y[-1], Tail -> Y[-1], Brown]];
dist2[s, t]
(Sqrt[dist2])[1, 1]
(Sqrt[dist2])[0, -1]

In the print project we show that ∂(((dist2))/∂)s = 0  and  ∂(((dist2))/∂)t = 0  at the unique point where  s = 2  and  t = -1.  Mathematica can solve these equations, too.

D[dist2[s, t], s]

D[dist2[s, t], t]

Solve[{D[dist2[s, t], s] == 0, D[dist2[s, t], t] == 0}, 
      {s, t}]

Mathematica minimizes the square distance directly as follows:

minValues = FindMinimum[dist2[s, t], {s, 1}, {t, 1}]

The minimizing segment looks as follows:

minArrow = X[2] - Y[-1]; 
    Show[line1, line2, Arrow[minArrow, Tail -> Y[-1], Red]];
(Sqrt[minValues])[[1]]

This segment is perpendicular to both lines because the following dot products are zero.

minArrow . V1

minArrow . V2

Why is this minimal?

Plot3D[dist2[s, t], {s, -1, 3}, {t, -2, 1}, 
        PlotRange -> {5, 10}, ClipFill -> None];
Clear[s, t];
dist2[s, t]

Expand[dist2[s, t]] == 
      Expand[5 + 5 (((1 + t))^2) + (((-3 + s - t))^2)]

Solve[{t + 1 == 0, s - t == 3}]

Hint 31.3 Critical Points

Work Hint 31.3 from the print project and type in your proof that the critical values of  s  and  t  make the segment connecting the two lines perpendicular to both lines.  Notice that you can use the previous Mathematica computations to solve the specific problems in the hint.

(1.a)  Define parametric equations for line1 through the point (0,1,0)  in the direction of  (1,-1,1)  and  line2  in the direction of  (1,2,1)  through the point (2,2,2).  Plot them and show them together.

(1.b)  Define the squared distance function between points on the two lines.  Use FindMinimum[.] to find the distance between the lines.

(1.c)  Compute its partial derivatives and solve the critical equations in these partials.  Show that the solutions are the same as those found by FindMinimum.

(1.d)  Show that the segment connecting the two closest points on the lines is perpendicular to both lines.

(2)  Repeat part (1) for  line1  and  line3  through the point (2,1,2)  in the direction of  (1,2,1).

(3)  Express the critical equations in vector notation for general lines:  line1  through  P1  in direction V1  and  line2  through  P2  in direction  V2.  Use vector algegra to show that the crirical equations say the segment connecting the closest points is perpendicular to both lines.

Continuation of the Hint: Existence of Critical Solutions

Show that the critical point equations have a solution as long as both lines have nonzero directions.  Following are two suggested approaches, an abstract one based on calculus and a specific one based on algebra.

An Abstract Approach to Showing The Critical Equations have a Solution:

The Extreme Value Theorem does not apply to this problem because  s  and  t  are not bounded.  However, we could use a "fake" boundary  s = ±H or  t =±H, with H infinitely large (as we did in Examples of Chapter 19).  On the huge square, |s|≤H, |t|≤H, the distance squared function has a max and min by the Extreme Value Theorem.  Show that dist2[±H,t] and dist2[s,±H] are infinite on the boundary, so that there must be an interior critical point where the minimum is attained.  This approach generalizes to curves, but does not show that the critical equations have only one solution.  (They may not in the case of curves or special cases of parallel lines.)

Complete this approach or the next one.

An Algebraic Approach to Showing The Critical Equations have a Solution:

Algebraically show that the equations have solutions and the solutions are unique unless the lines have parallel directions.  Following is some help with the algebra.

Mathematica can solve the general problem, but it is not as revealing as the perpendicularity information contained in the critical point equations.  Vector formulas for the partial derivatives makes this clear, whereas Mathematica leaves everything in coordinate expressions as in the following general solution.

Clear[X, Y, s, t, dist2, V1, V2, u1, u2, u3, v1, v2, v3];
V1 = {u1, u2, u3};
V2 = {v1, v2, v3};
P1 = {p1, p2, p3};
P2 = {q1, q2, q3};
X[s_] = P1 + s V1;
Y[t_] = P2 + t V2;
dist2[s_, t_]  =  (X[s] - Y[t]) . (X[s] - Y[t]);
Solve[{D[dist2[s, t], s] == 0, D[dist2[s, t], t] == 0}, 
      {s, t}]

Notice that this only makes sense provided the denominators are nonzero.  Using vector algebra from the print project, you can show that these denominators arise by solving the 2X2 system of linear equations in  s  and  t:

V1 •V1  s - V1 •V2  t = V1 •(P2 -P1 )

-V1 •V2  s + V2 •V2  t = V2 •(P1 -P2 )

or

(({{V1 •V1 , -V1 •V2 
                }, {-V1 •V2 , V2 •V2 
                }}))(({{s}, {t}}))= (({{V1 • (P2 - P1)}, {V2 • (P1 - P2)}}))

Cramer's rule says the UNIQUE solutions are given by certain determinants provided

determinant(({{V1 •V1 , -V1 •V2 
                }, {-V1 •V2 , V2 •V2 
                }})) ≠0

This determinant is the denominator in the Mathematica solution above.

Det[(({{V1  . V1 , -V1  . V2 }, {-V1  . V2 , V2  . V2 }}))]

We may write the determinant as

\(\(\(|\)\(V1\)\(\ \)\( | \^2\)\(|
      \)\(V2\)\(\ \)\( | \^2\)\((1 - \ \((\ Cos[θ])\)\^2)\)\)\)

where  θ  is the angle between the direction vectors  V1   and  V2 .

Geometrically, we assume that the equations describe lines, so the vectors V1  and V2  are not zero. If the vectors are parallel, θ = 0, then there are infinitely many segments perpendicular to both lines

, because ...  COMPLETE THE ALGEBRAIC SOLUTION OF THE CRITICAL EQUATIONS FOR TWO LINES.

Why is the critical point minimal?

The general expression for the squared distance between two lines is a quadratic in two variables.  You might be able to find a general expression, first completing the square of the linear terms, then collecting the remaining purely quadratic terms and showing that they are "elliptical."  This is a tough way to go.  For example, here is the general form of the coefficient of  s:

Clear[X, Y, s, t, dist2];
X[s_] = {p1, p2, p3} + s {u1, u2, u3};
Y[t_] = {q1, q2, q3} + t {v1, v2, v3};
dist2[s_, t_]  =  (X[s] - Y[t]) . (X[s] - Y[t]);
Coefficient[Expand[dist2[s, t]],  s ]

The Pythagorean theorem says the sum of the squares of the sides of a right triangle equals the square of the hypotenuse.  This can give a geometric way to show that the perpendicular connecting segment is minimal.  Why?

Alternatively, the abstract approach using the Extreme Value Theorem shows that there is a minimum.  When we have only one critical point, that must be the minimum point.

Distance between two curves

Following is a Mathematica program that supplements the example in the print project.  You should add your paper and pencil work of Hints 31.5, 6, 8  to this.

Clear[s, t, X, Y, dist2];
X[s_]  = { 3  Cos[s], 4  Sin[s]};
Y[t_] = {t, 10/t};
dist2[s_, t_]  =  (X[s] - Y[t]) . (X[s] - Y[t]);
      

curve1 = ParametricPlot[X[s], {s, 0, 2  π}];
X[s]
curve2 = ParametricPlot[Y[t], {t, 1, 7}];
Y[t]
Show[curve1, curve2];
dist2[s, t]

FindMinimum[dist2[s, t], {s, 1}, {t, 1}]

Clear[min, s, t];
min[s_, t_] = X[s] - Y[t];
s = 0.817307;
t = 2.82747;
Show[curve1, curve2, Arrow[min[s, t], Tail -> Y[t], Red], 
        AspectRatio -> Automatic];
X[s]
Y[t]

There may be other critical point solutions for this problem.

Clear[s, t];
eqs = {D[dist2[s, t], s] == 0, D[dist2[s, t], t] == 0}
FindRoot[eqs, {s, 4}, {t, 3}]

Clear[min, s, t];
min[s_, t_] = X[s] - Y[t];
s = 4.1667;
t = 3.51454;
Show[curve1, curve2, Arrow[min[s, t], Tail -> Y[t], Red], 
        AspectRatio -> Automatic];
X[s]
Y[t]

Perpendicularity at the Critical Point

Solve Hint 31.8.  What would you see in a powerful microscope?

The Implicit-Parametric Approach

If desired use Mathematica to help solve the problem of print Project Section 31.3.

Beginning Explorations with Curves and Surfaces

The following Mathematica help is intended to compliment the development of the printed project and text Example CD 19.9.  You should complete the written description of the solution.

Clear[x1, x2, x3, y1, y2, y3, t, X, Y];
z = (x1^2) + (x2^2);
X[x1_, x2_] = {x1, x2, z};
Y[t_]  =  {3  Cos[t], 4  Sin[t], 1 - 3  Cos[t] - 4  Sin[t]};
surface = 
        Plot3D[z, {x1, -3, 3}, {x2, -3, 3}, 
          AxesLabel -> {"x", "y", "z"}];
curve = ParametricPlot3D[Y[t], {t, 0, 2  π}];
Show[surface, curve, BoxRatios -> Automatic, 
        ViewPoint -> {5, 2, 1}];
dist2[x1_, x2_, t_] = (X[x1, x2] - Y[t]) . (X[x1, x2] - Y[t])

FindMinimum[dist2[x1, x2, t], {x1, 1}, {x2, 1}, {t, 1}]

Clear[min, x1, x2, t];
min[x1_, x2_, t_] = X[x1, x2] - Y[t];
x1 = -2.11178;
x2 = -0.879844;
t = -2.83895;
Show[surface, curve, Arrow[min[x1, x2, t], Tail -> Y[t], Red], 
        BoxRatios -> Automatic, ViewPoint -> {-5, 2, 1}];
X[x1, x2]
Y[t]

Clear[x1, x2, t];
eqs = 
      {D[dist2[x1, x2, t], x1] == 0, 
        D[dist2[x1, x2, t], x2] == 0, D[dist2[x1, x2, t], t] == 0}
        
FindRoot[eqs, {x1, 1}, {x2, 1}, {t, 1}]

Clear[min, x1, x2, t];
min[x1_, x2_, t_] = X[x1, x2] - Y[t];
x1 = 0.159;
x2 = 0.377;
t = 1.06;
Show[surface, curve, Arrow[min[x1, x2, t], Tail -> Y[t], Red], 
        BoxRatios -> Automatic, ViewPoint -> {-5, 2, 1}];
X[x1, x2]
Y[t]

FindMinimum[-dist2[x1, x2, t], {x1, 0.15934}, {x2, 0.37663}, 
      {t, 1.0572}]

What's wrong here?

Invent Your Own

Invent and solve some geometric distance problems of your own.  For example, you might find the distance between two surfaces or solve the linear case of a line and a surface, namely find the distance from a line to a plane.  What is required in order for this problem to be interesting?  How does this condition apply in a powerful microscope for the problem of a curve and a surface?