restart:
with(PolynomialIdeals):# Critical points at infinity for the QRW example only occur when c or lambda
# take boundary values
Q := 1-c*y+c*x*y-x*y^2;
with(PolynomialIdeals):
Qt := numer(subs(x=x/t,y=y/t,Q)):
II := <Y2*x*diff(Qt,x)-Y1*y*diff(Qt,y),Qt>:
subs(t=0,Y2=1,Y1=lambda,Generators(Saturate(II,t))):
solve(%);# Input: Polynomial Q and positivedirection r with V(Q) smooth
# Output: An ideal I in the variables of Q and two new variables Z and h
# such that there is a critical point at infinity iff the generators
# of I have a non-zero solution in the variables of Q. The values of
# h at such a solution give the potential heights of critical points at
# infinity
CPatInfinity := proc(Q,r)
local Qt,CPeqs,CPsub, vars, R:
vars := convert(indets(Q),list):
Qt := numer(subs(seq(k=k/Z,k=vars),Q));
CPeqs := seq(R[j]*vars[1]*diff(Qt,vars[1])-R[1]*vars[j]*diff(Qt,vars[j]),j=2..nops(vars)):
CPsub := subs(seq(R[j]=r[j],j=1..nops(r)),Saturate(<Qt,CPeqs,h*Z^nops(vars)-mul(k,k=vars)>,Z)):
return Groebner[Basis]([Z,op(Generators(CPsub))],plex(op(vars),Z,h)):
end:# Input: Polynomial Q and positive integer direction vector r with V(Q) smooth
# Output: An ideal I in the variables of Q and two new variables Z and h
# such that there is a critical point at infinity iff the generators
# of I have a non-zero solution in the variables of Q. The values of
# h at such a solution give the potential heights of critical points at
# infinity
CPatInfinity := proc(Q,r)
local Qt,CPeqs,CPsub, vars, R:
vars := convert(indets(Q),list):
Qt := numer(subs(seq(k=k/Z,k=vars),Q));
CPeqs := seq(R[j]*vars[1]*diff(Qt,vars[1])-R[1]*vars[j]*diff(Qt,vars[j]),j=2..nops(vars)):
CPsub := subs(seq(R[j]=r[j],j=1..nops(r)),Saturate(<Qt,CPeqs,h*Z^add(k,k=r)-mul(vars[k]^r[k],k=1..nops(vars))>,Z)):
return Groebner[Basis]([Z,op(Generators(CPsub))],plex(op(vars),Z,h)):
end:#########################################################
# An example with a weak but not actual critical point
# (also has z_n -> infinity, not affecting gradient flow
#########################################################
Q := 1-x-y-z-x*y;
solve([diff(Q,x),diff(Q,y),diff(Q,z),Q]);# There is a "weak" critical point at infinity
vars := convert(indets(Q),list):
Qt := numer(subs(seq(k=k/Z,k=vars),Q));
CPeqs := seq(r[j]*vars[1]*diff(Qt,vars[1])-r[1]*vars[j]*diff(Qt,vars[j]),j=2..nops(vars)):
Groebner[Basis]([Z,Qt,CPeqs],plex(op(vars),Z,h));# No actual critical point at infinity
CPatInfinity(Q,[1,1,1]);
solve(%);# Write in local coordinates (a,b,c) = (y/x,z/x,Z/x) at infinity
solve([a = y/x, b=z/x, c=Z/x],[x,y,z])[1];
factor(subs(%,Qt));
Qinf := a*c+b*c-c^2+a+c;# The height function is h = -log(xyz/Z^3) = -log(a*b/c^3)
solve([Qinf,hexp-a*b/c^3],[hexp,a]);# This is finite height when b=c^2 -> 0
-log(abs(subs(b=c^2,c=0,-b*(b-c+1)/(c^2*(c+1)))));# We can even construct a sequence of points in the variety going to finity staying at finite height
pt := [t,-(t^2-t+1)/(t*(t+1)),1/t];
normal(subs(x=pt[1],y=pt[2],z=pt[3],Q));
log(abs(limit(mul(k,k=pt),t=infinity)));# Log gradient doesn't go to (1,1,1)
# This point will not screw up the normal Morse deformations
normal(subs(x=pt[1],y=pt[2],z=pt[3],[diff(Q,x)*x,diff(Q,y)*y,diff(Q,z)*z]));############################################################
# Another example with actual critical point at infinity
############################################################# Function with critical point at infinity: (x:y:Z) = (0:1:0)
# Since y <> 0, h = -1 and the height is -log(|-1|) = 0
Q := 1-x-y-x*y^2;
factor(CPatInfinity(Q,[1,1]));# There are finite critical points, of larger height
s1,s2 := solve([diff(Q,x)*x-diff(Q,y)*y,Q],explicit);
evalf(subs(s1,-log(abs(x*y))));# In this case only the finite critical points are minimal (they are smooth and minimal)
# The point at infinity cannot be reached by a limit of minimal points############################################################
# Another example
############################################################# Critical points at infinity have height -log|1| = 0
Q := 2-x*y^2-2*x*y-x+y;
factor(CPatInfinity(Q,[1,1]));############################################################
# Another example
############################################################# Function with critical point at infinity: (x:y:z:Z) = (0:1:0:0)
# Critical point has height -log|-1/2| = log(2)
Q := 1-x-y-z-2*x*y^2*z;
factor(CPatInfinity(Q,[1,1,1]));############################################################
# Additional examples
############################################################
Q1 := 1-x-y-2*x*y*z;
Q2 := 2-x*y^2-2*x*y-x+y;
Q3 := 1-x-y-x*y^2;
Q4 := 1-x-y-z-x*y;
for k from 1 to 4 do
factor(CPatInfinity(Q||k,[seq(1,k=1..nops(indets(Q||k)))]));
od;##############################
# Code for general (non-smooth) case
##############################
with(LinearAlgebra):
with(PolynomialIdeals):
with(Groebner):
with(combinat):
# Takes matrix M and computed r-by-r minors
matMinor := proc(M,r) local LST,j,k,rows,cols,row,col:
LST := []:
row,col := op(1,M):
rows := map(sort,combinat:-choose(row,r));
cols := map(sort,combinat:-choose(col,r));
for j in rows do
for k in cols do
LST := [op(LST),Determinant(SubMatrix(M,j,k))];
od:
od:
end:
# Calculate log gradient
logGrad := proc(H,vars)
return [seq(diff(H,k)*k,k=vars)]:
end:
# Finds critical points at infinity on the strata defined by connected components of V(P) \134 V(T)
# in direction r, where P and T are polynomial ideals and *we assume P is prime*
CPatInfinityStrata := proc(P,T,r)
local Qt,CPeqs,CPsub,vars,R,COMPS,c,J,C,Ct,Pt,SAT,k:
vars := convert(indets(P),list):
# Homogenize P
Pt := numer(subs(seq(k=k/Z,k=vars),P)):
# Form log gradient matrix
J := Matrix([seq(logGrad(k,vars),k=Pt),[seq(R[k],k=1..nops(r))]]):
# Find matrix minors defining critical points
c := nops(vars) - HilbertDimension([op(P)],{op(vars)});
C := [op(Pt),op(matMinor(J,c+1))]:
SAT := Saturate(<op(C),h*Z^add(k,k=r)-mul(vars[k]^r[k],k=1..nops(vars))>,Z):
for k in T do
SAT := Saturate(SAT,k):
od:
CPsub := subs(seq(R[j]=r[j],j=1..nops(r)),SAT):
return Groebner[Basis]([Z,op(Generators(CPsub))],plex(op(vars),Z,h)):
end:P := [1-x-y-z-x*y*z^2];
T := [1-x];CPatInfinityStrata(P,T,[1,1,1]);