Does Mathematica have build-in function to compute dimension of square polynomial system?

Question

I'm working with square polynomial systems and wish to know if a (small) system has a finite number of solutions. That is, if it's zero-dimensional. I'm not aware of any built-in function to do this so attempted to write my own but not that familiar with the concept and was wondering if others might have any comments about my routine below? Some background for the reader:

One way to compute the dimension is to compute a Groebner basis and then check if some element of the basis has a leading monomial (monomial with highest precedence described below) that is a pure power of each variable, i.e., a leading monomial with only one variable. My understanding is one first settles on a monomial ordering. Two of which is lexicographic or graded lexicographic. In lexicographic, the ordering of the variables defined by say $f(x,y,z)$ take precedence: $x$ has a higher precedence than say $y^2$. In the case of say $x^2 y$ and $x^2 y^2$, the ordering is in terms of overall degree so $x^2 y^2>x^2y$ and so forth.

The build-in function CoefficientRules will lexigraphically order the monomial exponent vectors from highest precedence to lowest. So that a Groebner basis is computed and then the list of exponent vectors is computed. The leading terms of each vector set is then checked for a pure power of each variable. In the case of 3 variables, this would be checking for the set $\text{{{0,0,_},{0,_,0},{_,0,0}}}$. If this set is found, the sysem is zero-dimensional.

Here is a 3-variable example using a known zero-dimensional system:

f[{x_, y_, z_}] = {x^2 - 2 x z + 5, x y^2 + y z^3, 3 y^2 - 8 z^3};

isZeroDimensional[f_] := Module[{gBasis, cRules, leadingC, p1, p2, 
   p3},
   
   gBasis = GroebnerBasis[f[{x, y, z}], {x, y, z}];
   (*
    get coefficient rules.  
    This will order the exponent vectors lexicographically from 
    highest precedence to lowest
   *)
   cRules = (CoefficientRules[#, {x, y, z}] & /@ gBasis);
   (*
    get the highest precedent monomial of each basis element
   *)
   leadingC = cRules[[All, 1]][[All, 1]];
   (*
   now check the list of leading monomials for the set {{0,0,_}, 
   {0,_,0},{_,0,0}}.  This represents a set of pure powers of x,y,z
   *)
   If[MemberQ[leadingC, {0, 0, _}] && MemberQ[leadingC, {0, _, 0}] 
     && MemberQ[leadingC, {_, 0, 0}],
    True
    ,
    False
    ]
   ];  

isZeroDimensional[f]

Out[150]= True

Answer 1

I wish to follow up with this post: The reference above: idealDimension

written by Daniel does answer this question in terms of Ideal Dimension and I tested it in ver. 12.0.0. All credit goes to him. I'll re-post the code here to save the interested reader some time:

firstContainsSecond[l1_, l2_] := (Union[l1, l2] === l1);
isIndependentSet[set_, sets_] := 
  Map[! firstContainsSecond[set, #] &, sets];
getMaxIndependentSets[vars_, inset_, heds_, maxlen_, indx_, sets_] := 
  Module[{currentset, vlen = Length[vars], ilen = Length[inset], 
    enlarged = False, newmax = maxlen, maxsets = sets}, 
   Do[If[ilen + vlen - i + 1 <= maxlen, Break[]];
    currentset = Append[inset, vars[[i]]];
    If[And @@ 
      isIndependentSet[currentset, heds], {maxsets, enlarged, 
       newmax} = 
      getMaxIndependentSets[vars, currentset, heds, newmax, i + 1, 
       maxsets];
     If[! enlarged, maxsets = Append[maxsets, currentset];
      newmax = Max[newmax, Length[currentset]];
      enlarged = True;];], {i, indx, vlen}];
   {maxsets, enlarged, newmax}];

idealDimension[ideal_, vars_] := 
  Module[{ord = DegreeReverseLexicographic, gb, pheads, heds, maxsets,
     el, mlen}, gb = GroebnerBasis[ideal, vars, MonomialOrder -> ord];
   pheads = Map[First[MonomialList[#, vars, ord]] &, gb];
   heds = Map[Variables[#] &, pheads];
   {maxsets, el, mlen} = 
    getMaxIndependentSets[vars, {}, heds, 0, 1, {}];
   mlen];

And here are some test cases correctly analyzed by idealDimension that I have verified from on-line sources.

polys1 = {x y - z, y z - x, z x - y};
vars1 = {x, y, z};
idealDimension[polys1, vars1]
(*
 From Maple isZeroDimensional
*)
polys2 = {x^2 - 2 x z + 5, x y^2 + y z^3, 3 y^2 - 8 z^3};
vars2 = {x, y, z};
idealDimension[polys2, vars2]
(*
 From Wolfram MathGroup archive:  \
forums.wolfram.com/mathgroup/archive/1999/Jul/msg00150.html
*)
polys3 = {x^2*y + 3*w*x*z - 4, t*y^2 - w^2*x*y + t*z + 2*x - 3, 
   w*x^2*y + 2*t^2*x*z^2 - 5*w*y*z^2 + 7};
vars3 = {t, w, x, y, z};
idealDimension[polys3, vars3]
(*
 some others
*)
polys3b = {x^2 y + 3 x z - 4, y^2 - x y + z + 2};
vars3b = {x, y, z};
idealDimension[polys3b, vars3b]

polys4 = {y^2 - x y - 2 z x, y^3 + z^2 + 1, x^2 y z - z y};
vars4 = {x, y, z};
idealDimension[polys4, vars4]

poly5 = {x y^2 + 2 x z - y z, x^2 y z + y^2};
vars5 = {x, y, z};
idealDimension[poly5, vars5]

0

0

2

1

0

1

Answer 2

@Daniel:

Regarding your comments above. I am working with iterated polynomial systems in which idealDimension quickly become CPU-bound after only a few iterations. Here is a benchmark running on a 4.5 GHz quad-core machine running in parallel. Maybe would be interesting to see if your probabilistic method would improve the performance (I stopped the calc for n=10 after around 30 min or so):

(*
 create simple square system in 2 variables
*)
g0[{z_, w_}] = 1 + 1/4 w + z^2;
h0[{z_, w_}] = z;
vectorF[{z_, w_}] = {g0[{z, w}], h0[{z, w}]};
(*
 fold the system 9 times and compute the ideal dimension
*)
idealTable = ParallelTable[
  timing = AbsoluteTiming[
    poly16 = Nest[vectorF, {z, w}, n];
    vars16 = {z, w};
    id = idealDimension[poly16, vars16];
    ];
  {n, id, timing[[1]]},
  {n, 1, 9}]

$$ \begin{array}{ccc} \text{n} & \text{dim} & \text{Time (sec)} \\ 1 & 0 & 0.0008918 \\ 2 & 0 & 0.0009232 \\ 3 & 0 & 0.001006 \\ 4 & 0 & 0.0025332 \\ 5 & 0 & 0.0065017 \\ 6 & 0 & 0.24913 \\ 7 & 0 & 0.857535 \\ 8 & 0 & 8.11298 \\ 9 & 0 & 178.119 \\ \end{array} $$

Also, you may be interested in this problem regarding their ideals: Ideal of iterated polynomial systems I'm afraid I am a bit handicapped to prove that but suspect someone else can. Might be of interest to you. :)