-- geometry example restart R = QQ[u_1,u_2,u_3,x_1,x_2,x_3,x_4, MonomialOrder=>Lex] S = R[y,MonomialOrder=>Lex] use R I = ideal (x_1-u_1-u_2,x_2-u_3,x_1*x_4-x_2*x_3, x_4*(u_2-u_1)-u_3*(x_3-u_1)) Ibar1 = substitute(I,S) + ideal (1-y*(x_3^2+x_4^2-(x_3-x_1)^2-(x_4-x_2)^2)) Ibar1GB = gb Ibar1 netList entries transpose gens Ibar1GB Ibar2 = substitute(I,S) + ideal (1-y*((x_3-u_1)^2+x_4^2-(u_2-x_3)^2-(u_3-x_4)^2)) Ibar2GB = gb Ibar2 netList entries transpose gens Ibar2GB primaryDecomposition I -- uhoh! lets look closer. What if we work over the fraction field QQ(u_1,u_2,u_3)? restart kk = frac(QQ[u_1,u_2,u_3]) R = kk[x_1,x_2,x_3,x_4] S = R[y,MonomialOrder=>Lex] use R I = ideal (x_1-u_1-u_2,x_2-u_3,x_1*x_4-x_2*x_3, x_4*(u_2-u_1)-u_3*(x_3-u_1)) Ibar1 = substitute(I,S) + ideal (1-y*(x_3^2+x_4^2-(x_3-x_1)^2-(x_4-x_2)^2)) Ibar1GB = gb Ibar1 netList entries transpose gens Ibar1GB Ibar2 = substitute(I,S) + ideal (1-y*((x_3-u_1)^2+x_4^2-(u_2-x_3)^2-(u_3-x_4)^2)) Ibar2GB = gb Ibar2 netList entries transpose gens Ibar2GB -- alternate method via saturation for more complicated examples restart R = QQ[x_1,x_2,x_3,x_4,u_1,u_2,u_3,MonomialOrder=>{4,3}] S = R[y,MonomialOrder=>Lex] use R I = ideal (x_1-u_1-u_2,x_2-u_3,x_1*x_4-x_2*x_3, x_4*(u_2-u_1)-u_3*(x_3-u_1)) primaryI = primaryDecomposition I I' = first primaryI Igb = gb I netList entries transpose gens Igb I'' = saturate(I,u_1*u_3) Ibar1 = substitute(I'',S) + ideal (1-y*(x_3^2+x_4^2-(x_3-x_1)^2-(x_4-x_2)^2)) Ibar1GB = gb Ibar1 netList entries transpose gens Ibar1GB Ibar2 = substitute(I'',S) + ideal (1-y*((x_3-u_1)^2+x_4^2-(u_2-x_3)^2-(u_3-x_4)^2)) Ibar2GB = gb Ibar2 netList entries transpose gens Ibar2GB -- Apollonius' circle theorem restart R = QQ[x_1..x_8,u_1,u_2, MonomialOrder=>{8,2}] S = R[y,MonomialOrder=>Lex] use R I = ideal (2*x_1-u_1,2*x_2-u_2,2*x_3-u_1,2*x_4-u_2,x_5*u_1-x_6*u_2,x_5*u_2+x_6*u_1-u_1*u_2, (x_1-x_7)^2+x_8^2-x_7^2-(x_8-x_2)^2, (x_1-x_7)^2+x_8^2-(x_3-x_7)^2-(x_4-x_8)^2) netList I_* Ibar1 = substitute(I,S) + ideal (1-y*((x_1-x_7)^2+x_8^2-(x_5-x_7)^2-(x_6-x_8)^2)) Ibar1GB = gb Ibar1 netList entries transpose gens Ibar1GB -- same problem as before. Let's fix it using saturation. Igb = gb I netList entries transpose gens Igb leadCoeff = u_1*u_2 I' = saturate(I,leadCoeff) Ibar1' = substitute(I',S) + ideal (1-y*((x_1-x_7)^2+x_8^2-(x_5-x_7)^2-(x_6-x_8)^2)) Ibar1GB' = gb Ibar1' netList entries transpose gens Ibar1GB' -- success! -- over the rational function field restart kk = frac(QQ[u_1,u_2]) R = kk[x_1..x_8] S = R[y,MonomialOrder=>Lex] use R J = ideal (2*x_1-u_1,2*x_2-u_2,2*x_3-u_1,2*x_4-u_2,x_5*u_1-x_6*u_2,x_5*u_2+x_6*u_1-u_1*u_2) I = J + ideal ((x_1-x_7)^2+x_8^2-x_7^2-(x_8-x_2)^2, (x_1-x_7)^2+x_8^2-(x_3-x_7)^2-(x_4-x_8)^2) Ibar1 = substitute(I,S) + ideal (1-y*((x_1-x_7)^2+x_8^2-(x_5-x_7)^2-(x_6-x_8)^2)) Ibar1GB = gb Ibar1 netList entries transpose gens Ibar1GB -- colorability of graphs -- easy example, K_3 restart getRels = (R,edges) -> (list1 := apply(flatten entries vars R, x -> x^3-1); list2 := apply(edges, e -> x_(e#0)^2+x_(e#0)*x_(e#1)+x_(e#1)^2); ideal (list1 | list2)) kk = QQ[a]/ideal(a^3-1) R = kk[x_1,x_2,x_3] edges = {(1,2),(1,3),(2,3)} I = getRels(R,edges) Igb = gb I netList entries transpose gens Igb -- 3-colorable -- easy example, K_4 restart getRels = (R,edges) -> (list1 := apply(flatten entries vars R, x -> x^3-1); list2 := apply(edges, e -> x_(e#0)^2+x_(e#0)*x_(e#1)+x_(e#1)^2); ideal (list1 | list2)) kk = QQ[a]/ideal(a^3-1) R = kk[x_1,x_2,x_3,x_4] edges = {(1,2),(1,3),(1,4),(2,3),(2,4),(3,4)} I = getRels(R,edges) Igb = gb I netList entries transpose gens Igb -- not 3-colorable -- figure 2.1, Adams and Loustannau book restart getRels = (R,edges) -> (list1 := apply(flatten entries vars R, x -> x^3-1); list2 := apply(edges, e -> x_(e#0)^2+x_(e#0)*x_(e#1)+x_(e#1)^2); ideal (list1 | list2)) kk = QQ[a]/ideal(a^3-1) R = kk[x_1..x_8] edges = {(1,2),(1,5),(1,6),(2,3),(2,4),(2,8),(3,4),(3,8),(4,5),(4,7),(5,6),(5,7),(6,7),(7,8)} I = getRels(R,edges) time Igb = gb I netList entries transpose gens Igb -- 3-colorable -- figure 2.1, Adams and Loustannau book, with an edge added. restart getRels = (R,edges) -> (list1 := apply(flatten entries vars R, x -> x^3-1); list2 := apply(edges, e -> x_(e#0)^2+x_(e#0)*x_(e#1)+x_(e#1)^2); ideal (list1 | list2)) kk = QQ[a]/ideal(a^3-1) R = kk[x_1..x_8] edges = {(1,2),(1,5),(1,6),(2,3),(2,4),(2,8),(3,4),(3,8),(4,5),(4,7),(5,6),(5,7),(6,7),(7,8)} edges = edges | {(2,5)} I = getRels(R,edges) Igb = gb I netList entries transpose gens Igb -- not 3-colorable -- easy example, K_4, 4-colorability restart getRels = (R,edges) -> (list1 := apply(flatten entries vars R, x -> x^4-1); list2 := apply(edges, e -> x_(e#0)^3+x_(e#0)^2*x_(e#1)+x_(e#0)*x_(e#1)^2+x_(e#1)^3); ideal (list1 | list2)) kk = QQ[a]/ideal(a^4-1) R = kk[x_1,x_2,x_3,x_4] edges = {(1,2),(1,3),(1,4),(2,3),(2,4),(3,4)} I = getRels(R,edges) Igb = gb I netList entries transpose gens Igb -- 4-colorable -- integer programming restart R = QQ[t_1,t_2,x_1..x_4, MonomialOrder=>Lex] K = ideal (x_1-t_1^3*t_2^4, x_2-t_1^2*t_2, x_3-t_1*t_2,x_4-t_1) time Kgb = gb K netList transpose entries gens Kgb t_1^10*t_2^5 % Kgb restart R = QQ[t_1,t_2,w,x_1..x_4,MonomialOrder=>Lex] K = ideal (x_1-t_1^3*t_2^4, x_2-t_2^3*w^2, x_3-t_1^2*w,x_4-t_2*w, t_1*t_2*w-1) Kgb = gb K netList transpose entries gens Kgb t_2^6*w % Kgb -- using the cost function restart R = QQ[t_1,t_2,w,x_1..x_4,MonomialOrder=>{3,{Weights=>{1000,1,1,1000},Lex}}] K = ideal (x_1-t_1^3*t_2^4, x_2-t_2^3*w^2, x_3-t_1^2*w,x_4-t_2*w, t_1*t_2*w-1) Kgb = gb K netList transpose entries gens Kgb t_2^6*w % Kgb restart R = QQ[t_1,t_2,w,x_1..x_4,MonomialOrder=>{3,{Weights=>{1,1000,1,1},Lex}}] K = ideal (x_1-t_1^3*t_2^4, x_2-t_2^3*w^2, x_3-t_1^2*w,x_4-t_2*w, t_1*t_2*w-1) Kgb = gb K netList transpose entries gens Kgb t_2^6*w % Kgb -- symmetric polynomials restart R = QQ[x,y,z, MonomialOrder => Lex] s1 = x + y + z s2 = x*y+x*z+y*z s3 = x*y*z f = (x^3+y^3)*(x^3+z^3)*(y^3+z^3) f1 = f - s1^3*s2^3 f2 = f1 - (-3)*s1^4*s2*s3 f3 = f2 - (-3)*s1*s2^4 f4 = f3 - 9*s1^2*s2^2*s3 f5 = f4 - 3*s1^3*s3^2 f6 = f5 - 3*s2^3*s3 f7 = f6 - (-18)*s1*s2*s3^2 f8 = f7 - 8*s3^3 -- check! g = s1^3*s2^3 - 3*s1^4*s2*s3 - 3*s1*s2^4 + 9*s1^2*s2^2*s3 + 3*s1^3*s3^2 + 3*s2^3*s3 - 18*s1*s2*s3^2 + 8*s3^3 f == g -- using Grobner bases restart S = QQ[x,y,z,a,b,c, MonomialOrder => {3,3}] s1 = x + y + z s2 = x*y+x*z+y*z s3 = x*y*z I = ideal (s1 - a, s2 - b, s3 - c) Igb = gb I f = (x^3+y^3)*(x^3+z^3)*(y^3+z^3) fbar = f % Igb support fbar substitute(fbar, {a => s1,b => s2,c => s3}) oo == f f = (x^35 + y^35 + z^35) time fbar = f % Igb; fbar support fbar time substitute(fbar, {a => s1,b => s2,c => s3}) oo == f -- generators and relations of invariant rings of finite matrix groups restart kk = QQ[a]/ideal(a^2-2) kk = frac(kk) R = kk[x,y] M = a^(-1) * substitute(matrix{{1, -1}, {1,1}}, R) apply(9, i -> M^i) phi = map(R,R,transpose (M*(transpose vars R))) phiList = {map(R,R,matrix{{x,y}})} | apply(toList (1..7), i -> phi^i) netList phiList rho = (f,phiList) -> (1/(#phiList))*sum(apply(phiList, phij -> phij(f))) reynolds = (R,rho,phiList) -> (basisList := flatten entries basis(1,#phiList,R); temp := select(apply(basisList, m -> (m,rho(m,phiList))), (m,rm) -> rm != 0); apply(temp, (m,rm) -> (m, (1/leadCoefficient(rm))*rm))) myGens = reynolds(R,rho,phiList) netList myGens myGens = unique(apply(myGens, i -> last i)) netList myGens #myGens T = kk[t_1..t_7] psi = map(R,T,matrix{myGens}) J = ker psi netList J_* -- so we see that t_2,t_3,t_7 are unneeded, so try again T' = kk[u_1..u_4] psi' = map(R,T',(matrix{myGens})_{0,3,4,5}) J' = ker psi' -- it seems we dont need u_4 = t_6 anymore either T'' = kk[s_1..s_3] psi'' = map(R,T'',(matrix{myGens})_{0,3,4}) J'' = ker psi''