Minimization problem in proving Fermat's principle

Question

I am trying to prove the Fermat's Principle of least distance, the problem statement goes:

Minimize[{n1* d1 * Sec[theta1] + n2 * d2 * Sec[theta2], d1 * Tan[theta1]+d2*Tan[theta2]==d},theta1]

I can't get a solution to this. The good solution should satisfyn1*Sin[theta1]=n2*Sin[theta2]

Can anyone help?

Answer 1

As far as I understand it, you try to derive the law of retraction. Unfortunately, your notations are

not defined, so I'll use the notations from that Wiki article.

Without loss of generality we may put $c=1$. We know the quantities $a,b,l,n_1,n_2,$ and $x$ is unknown. The optimization problem to derminate $x$ is formulated as follows.

ClearAll["Global`*"];
Minimize[{n1*Sqrt[x^2 + a^2] + n2*Sqrt[b^2 + (l - x)^2], 
n1 > 0 && n2 > 0 && l >= 0 && b > 0 && a > 0 && x <= l && x >= 0},  x] 

Five parameters are too much for Minimize and the command is running without any response for hours. However, Mathematica does it for the specified parameters , e.g.

n1 = 1; n2 = 3/2; l = 2; b = 5; a = 1; 
Minimize[{n1*Sqrt[x^2 + a^2] + n2*Sqrt[b^2 + (l - x)^2], n1 > 0 && n2 > 0 && l >= 0 && b > 0 && 
x <= l && x >= 0}, x] // AbsoluteTiming

{0.183459, {1/ 2 (2 Sqrt[ 1 + Root[36 - 36 # - 71 #^2 - 20 #^3 + 5 #^4& , 1, 0]^2] + 3 Sqrt[29 - 4 Root[36 - 36 # - 71 #^2 - 20 #^3 + 5 #^4& , 1, 0] + Root[36 - 36 # - 71 #^2 - 20 #^3 + 5 #^4& , 1, 0]^2]), {x -> Root[36 - 36 # - 71 #^2 - 20 #^3 + 5 #^4& , 1, 0]}}}.

Now we extract

x = x /. x -> Root[36 - 36 # - 71 #^2 - 20 #^3 + 5 #^4 &, 1, 0];

and express $\sin \theta_1$ and $\sin \theta_2$ through $a,b,x,l$ (see the linked Wiki article)

FullSimplify[x/Sqrt[x^2 + a^2]/(l - x)*Sqrt[(l - x)^2 + b^2]]

3/2.

I think Mathematica is able to crack the general case, but it requires a lot of time.

Answer 2

One could solve for critical points for the travel time T from one point to the other:

Block[{d, d1, n1, d2, n2},
 SetAttributes[#, Constant] & /@ {d, d1, n1, d2, n2};
 dT = Dt@{ (* differential of time + distance constraint *)
    d1 n1 Sec[theta1] + d2 n2 Sec[theta2],
    d1 Tan[theta1] + d2 Tan[theta2] - d}
 ]

(*
  {d1 n1 Dt[theta1] Sec[theta1] Tan[theta1] + 
    d2 n2 Dt[theta2] Sec[theta2] Tan[theta2], 
   d1 Dt[theta1] Sec[theta1]^2 + d2 Dt[theta2] Sec[theta2]^2}
*)

jacT = CoefficientArrays[ 
    dT, Dt@{theta1, theta2}
    ][[2]];

The Solve form sol may be acceptable as is, but the OP showed an equation soleq for the expected solution:

sol = jacT //
    Det //
   Simplify //
  Solve[# == 0, Sin@theta1, Reals] &

soleq = sol[[1, 1]] /. Rule -> Equal //
 Simplify[#, n1 > 0] &

(*
  {{Sin[theta1] -> (n2 Sin[theta2])/n1}}  <-- sol
  n1 Sin[theta1] == n2 Sin[theta2]        <-- soleq
*)