--*- M2 -*-

-- This crashes!  Fixed, 9/11/2006
-- HOWEVER: still doesn't finish...! 9/11/2006

--Date: Sat, 2 Sep 2006 18:14:58 +0200 (CEST)
--Subject: Groebner basis computation
--From: "Michael Joswig" <joswig@mathematik.tu-darmstadt.de>
--To: dan@math.uiuc.edu
--Content-Type: text/plain;charset=iso-8859-1
--Content-Transfer-Encoding: 8bit
--Importance: Normal
--
--Dear Dan,
--
--As we discussed in the morning, I am interested in eliminating
--systems (in characteristic zero) like
--
--   1 + s^2 x1 x3 + s^8 x2 x3 + s^19 x1 x2 x4
--   x1 + s^8 x1 x2 x3 + s^19 x2 x4
--   x2 + s^10 x3 x4 + s^11 x1 x4
--   x3 + s^4 x1 x2 + s^19 x1 x3 x4 + s^24 x2 x3 x4
--   x4 + s^31 x1 x2 x3 x4
--
--for the elimination order x4 > x3 > x2 > x1 > s.  In this particular
--(test) case the discriminant polynomial in s is of degree 444 and has 2
--real roots.
--
--Systems of this type (we can produce more, if you like this one)
--occur in http://front.math.ucdavis.edu/math.CO/0508180.  This paper
--is to appear in Adv. Math.
--
--With kind regards,
--Michael
--
----
--Prof. Dr. Michael Joswig <joswig@mathematik.tu-darmstadt.de>
--TU Darmstadt, Fachbereich Mathematik, AG7
--64289 Darmstadt, Germany

R = ZZ[x4,x3,x2,x1,s,MonomialOrder=>Eliminate 4]
peek R
I = ideal (
   1 + s^2  * x1 * x3 + s^8 * x2 * x3 + s^19 * x1 * x2 * x4,
   x1 + s^8 * x1 * x2 * x3 + s^19 * x2 * x4,
   x2 + s^10 * x3 * x4 + s^11 * x1 * x4,
   x3 + s^4 * x1 * x2 + s^19 * x1 * x3 * x4 + s^24 * x2 * x3 * x4,
   x4 + s^31 * x1 * x2 * x3 * x4
   )
gbTrace = 3
gb I
gb(I, DegreeLimit=>37);
gb(I, DegreeLimit=>38);


-- Using this ring doesn't crash, but doesn't work well either.
R = QQ[x4,x3,x2,x1,s,t,MonomialOrder=>Eliminate 4]

R = ZZ/32003[x4,x3,x2,x1,s,t]
R = ZZ/32003[x4,x3,x2,x1,s,t, MonomialOrder=>Eliminate 4]

R = ZZ[s,x1,x2,x3,x4]
I = ideal (
   1 + s^2  * x1 * x3 + s^8 * x2 * x3 + s^19 * x1 * x2 * x4,
   x1 + s^8 * x1 * x2 * x3 + s^19 * x2 * x4,
   x2 + s^10 * x3 * x4 + s^11 * x1 * x4,
   x3 + s^4 * x1 * x2 + s^19 * x1 * x3 * x4 + s^24 * x2 * x3 * x4,
   x4 + s^31 * x1 * x2 * x3 * x4
   )
gbTrace = 3
J = substitute(I,{x4=>0})
1//(gens J)
(gens I) * oo
J = trim J


decompose J

--------------------------------------------------------
-- Let's find an element in s, if possible, in the ideal.
facs = (f) -> (g := factor f; facs := apply(toList g, h -> h#0); select(facs, f -> size f > 1))
L = apply(subsets(0..4,2), x -> saturate(ideal resultant(I_(x#0),I_(x#1),x1), product gens R))
L = L/(i -> i_0)
L1 = L/facs
L1/length
L1 = flatten L1
-- at this point we have a bunch of polynomials not involving x1

M = apply(subsets(L,2), x -> saturate(ideal resultant(x#0,x#1,x4), product gens R));
M = M/(i->i_0);
M1 = M/facs;
M1/length

N = apply(M1, g -> select(g, f -> size f > 2));
tally(N/length)
N = flatten N;
resultant(N_-5,N_-2,x3)
N/toString/print;

-- all lead coeffs are 1 or -1.
N' = unique apply(N, f -> (leadCoefficient f) * f)
#N'
N'/toString/print;

N'/size
P = select(N',f ->size f == 5)
Q = select(N',f ->size f == 6)
resultant(P_0,P_1,x2)
resultant(P_0,P_1,x3)
resultant(Q_0,Q_1,x3)

facs oo
-----------------------------------
-- OK, well almost worked...
-- Let's compute a GB in the lex order
facs = (f) -> (g := factor f; apply(toList g, h -> h#0))
R = ZZ/32003[x2,x4,x3,x1,s,MonomialOrder=>Lex]
I = ideal (
   1 + s^2  * x1 * x3 + s^8 * x2 * x3 + s^19 * x1 * x2 * x4,
   x1 + s^8 * x1 * x2 * x3 + s^19 * x2 * x4,
   x2 + s^10 * x3 * x4 + s^11 * x1 * x4,
   x3 + s^4 * x1 * x2 + s^19 * x1 * x3 * x4 + s^24 * x2 * x3 * x4,
   1 + s^31 * x1 * x2 * x3
   )
ideal(I_2,I_4)
gens gb oo
gbTrace=3
gens gb I

I1 = ideal compress gens substitute(I, {x2 => - s^10*x3*x4 - s^11*x1*x4})
(first entries gens I1)/facs
R = ZZ/32003[x4,x3,x1,s,MonomialOrder=>Lex]
I1 = substitute(I1,R)
gens gb I1;
---------------------------------

L/factor
oo/print;
#L
L_8
L_7
resultant(L_7,L_8,x4)
resultant(L_7,L_9,x4)
M = apply(subsets(L,2), x -> saturate(ideal resultant(x#0,x#1,x4), product gens R));
M = M/(i -> i_0);
M/factor/print;
factor M_0
# oo
#oo
M = apply(M, f -> (toList(factor f))/toList)
M/toString/print


facsM = M/facs;
apply(facsM, g -> select(g, f -> size f <= 2))
flatten oo
unique oo
facs M_0
-- one of the factors that appears: 
f = s^8*x2*x3+1
f = -s^9*x2^2+x3
-- this forces a monomial to be in I (if f = 0).

I_0 % f
I_1 % f
I_2 % f
I_4 % f
facs oo
g = s^31*x1*x2*x3+1
f = -s^9*x2^2+x3

substitute(g, {x3 => s^9 * x2^2})

N = apply(facsM, g -> select(g, f -> size f > 2))
N = N/first
#N
resultant(N_44,N_43,x3)
factor oo
