
(*Clears some variables*)
Clear[s,F,G,ff,D2,c1,c2,c3];

(*inverse stereographic projection*)
s[x_, y_] := {(2*x)/(1 + x*x + y*y), (2*y)/(1 + x*x + y*y), 1 - 2/(1 + x*x + y*y)};


(*These are the two basic functions making up the energy potential function*)

F[x1_,y1_,EXP_]:=(
a=s[x1,y1];
b={0,0,1};
c=(a-b).(a-b);
Power[4-c,EXP])

G[x1_,y1_,x2_,y2_,EXP_]:=(
a=s[x1,y1];
b=s[x2,y2];
c=(a-b).(a-b);
Power[4-c,EXP])

(*Here is the energy function*)

ff[x0_,x1_,y1_,x2_,y2_,x3_,y3_,EXP_]:=(
list1={
F[x0,0,EXP],
F[x1,y1,EXP],
F[x2,y2,EXP],
F[x3,y3,EXP],
G[x0,0,x1,y1,EXP],
G[x0,0,x2,y2,EXP],
G[x0,0,x3,y3,EXP],
G[x1,y1,x2,y2,EXP],
G[x1,y1,x3,y3,EXP],
G[x2,y2,x3,y3,EXP]};
Sum[list1[[j]],{j,1,10}])



(**this function computes the second partial derivatives**)

D2[i_,j_,EXP_]:=(
(*The basic expression*)
A=ff[x0,x1,y1,x2,y2,x3,y3,EXP];
(*The variable list*)
VAR={x0,x1,y1,x2,y2,x3,y3};
(*The point corresponding to the TBP*)
special={1,0,0,-1/2,Sqrt[3]/2,-1/2,-Sqrt[3]/2};
(*suitable second derivative*)
a1=D[A,VAR[[i]],VAR[[j]]];
{x0,x1,y1,x2,y2,x3,y3}={1,0,0,-1/2,Sqrt[3]/2,-1/2,-Sqrt[3]/2};
a2=a1;
Clear[x0,x1,y1,x2,y2,x3,y3];
a2)


(*computes the hessian and its minimum eigenvalues.
  The matrices for the paper are:
c1[3]
c1[4]
c1[5]
c1[6]
c1[10] + 28 c1[5] + 102 c1[2]

You can have Mathematica compute the minimum eigenvalue of
these matrices, but if you want to check rigorously
(without floating point error) that the minimum
eigenvalue of the matrix m exceeds a, then you
compute the characteristic polynomial p(t) and
then substitute in the value t=u+a and see if
the coefficients of the polynomial as a function
of u are alternating. The function CheckMin does
this automatically.
*)

c1[k_]:=Table[Table[D2[i,j,k],{i,1,7}],{j,1,7}]

(*This computes the characteristic polynomial of
  the Hessian*)

CheckMin[m_,a_]:=(
p0=Det[m - t IdentityMatrix[7]];
t=u+a;
p1=Expand[p0];
Clear[t];
p1)


(*Uncomment these routines to do the tests from
  Chapter 6*)

(*
CheckMin[c1[3],10]
CheckMin[c1[4],24]
CheckMin[c1[5],36]
CheckMin[c1[6],43]
CheckMin[c1[10]+28 c1[5]+ 102 c1[2],1448]
*)

