1module groeb; 2 3% Redistribution and use in source and binary forms, with or without 4% modification, are permitted provided that the following conditions are met: 5% 6% * Redistributions of source code must retain the relevant copyright 7% notice, this list of conditions and the following disclaimer. 8% * Redistributions in binary form must reproduce the above copyright 9% notice, this list of conditions and the following disclaimer in the 10% documentation and/or other materials provided with the distribution. 11% 12% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 13% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 14% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 15% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 16% CONTRIBUTORS 17% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 18% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 19% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 20% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 21% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 22% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 23% POSSIBILITY OF SUCH DAMAGE. 24% 25 26 27COMMENT 28 29 ############################## 30 ## ## 31 ## GROEBNER PACKAGE ## 32 ## ## 33 ############################## 34 35This is now a common package, covering both the noetherian and the 36local term orders. 37 38The trace intensity can be managed with cali_trace() by the following 39rules : 40 41 cali_trace() >= 0 no trace 42 2 show actual step 43 10 show input and output 44 20 show new base elements 45 30 show pairs 46 40 show actual pairlist 47 50 show S-polynomials 48 49Pair lists have the following informal syntax : 50 51 <spairlist>::= list of spairs 52 < spair > ::= (komp groeb!=weight lcm p_i p_j) 53 with lcm = lcm(lt(bas_dpoly p_i),lt(bas_dpoly p_j)). 54 55 56The pair selection strategy is by first matching in the pair list. 57It can be changed overloading groeb!=better, the relation according to 58what pair lists are sorted. Standard is the sugar strategy. 59 60cali!=monset : 61 62One can manage a list of variables, that are allowed to be canceled 63out, if they appear as common factors in a dpoly. This is possible if 64these variables are non zero divisors (e.g. for prime ideals) and 65affects "pure" Groebner basis computation only. 66 67END COMMENT; 68 69 70% ############ The outer Groebner engine ################# 71 72put('cali,'groeb!=rf,'groeb!=rf1); % First initialization. 73 74symbolic operator gbtestversion; 75symbolic procedure gbtestversion n; % Choose the corresponding driver 76 if member(n,{1,2,3}) then 77 put('cali,'groeb!=rf,mkid('groeb!=rf,n)); 78 79symbolic procedure groeb!=postprocess pol; 80% Postprocessing for irreducible H-Polynomials. The switches got 81% appropriate local values in the Groebner engine. 82 begin 83 if !*bcsimp then pol:=car bas_simpelement pol; 84 if not !*noetherian then 85 if !*factorunits then pol:=bas_factorunits pol 86 else if !*detectunits then pol:=bas_detectunits pol; 87 if cali!=monset then pol:=bas_make(bas_nr pol, 88 car dp_mondelete(bas_dpoly pol,cali!=monset)); 89 return pol 90 end; 91 92symbolic procedure groeb_stbasis(bas,comp_mgb,comp_ch,comp_syz); 93 groeb!=choose_driver(bas,comp_mgb,comp_ch,comp_syz, 94 function groeb!=generaldriver); 95 96symbolic procedure 97 groeb!=choose_driver(bas,comp_mgb,comp_ch,comp_syz,driver); 98% Returns { mgb , change , syz } with 99% dpmat mgb = (if comp_mgb=true the minimal) 100% Groebner basis of the dpmat bas. 101% dpmat change defined by mgb = change * bas 102% if comp_ch = true. 103% dpmat syz = (not interreduced) syzygy matrix of the dpmat bas 104% if comp_syz = true. 105% Changes locally !*factorunits, !*detectunits and cali!=monset. 106 107 if dpmat_zero!? bas then 108 {bas,dpmat_unit(dpmat_rows bas,nil), 109 dpmat_unit(dpmat_rows bas,nil)} 110 else (begin scalar u, gb, syz, change, syz1; 111 112 % ------- Syzygies for the zero base elements. 113 if comp_syz then 114 << u:=setdiff(for i:=1:dpmat_rows bas collect i, 115 for each x in 116 bas_zerodelete dpmat_list bas collect bas_nr x); 117 syz1:=for each x in u collect bas_make(0,dp_from_ei x); 118 >>; 119 120 % ------- Initialize the Groebner computation. 121 gb:=bas_zerodelete dpmat_list bas; 122 % makes a copy (!) of the base list. 123 if comp_ch or comp_syz then 124 << !*factorunits:=!*detectunits:=cali!=monset:=nil; 125 bas_setrelations gb; 126 >>; 127 if cali_trace() > 5 then 128 << terpri(); write" Compute GBasis of"; bas_print gb >> 129 else if cali_trace() > 0 then 130 << terpri(); write" Computing GBasis ";terpri() >>; 131 u:=apply(driver,{dpmat_rows bas,dpmat_cols bas,gb,comp_syz}); 132 syz:=second u; 133 if comp_mgb then 134 << u:=groeb_mingb car u; 135 if !*red_total then 136 u:=dpmat_make(dpmat_rows u,dpmat_cols u, 137 red_straight dpmat_list u, 138 cali!=degrees,t); 139 >> 140 else u:=car u; 141 cali!=degrees:=dpmat_rowdegrees bas; 142 if comp_ch then 143 change:=dpmat_make(dpmat_rows u,dpmat_rows bas, 144 bas_neworder bas_getrelations dpmat_list u, 145 cali!=degrees,nil); 146 bas_removerelations dpmat_list u; 147 if comp_syz then 148 << syz:=nconc(syz,syz1); 149 syz:= dpmat_make(length syz,dpmat_rows bas, 150 bas_neworder bas_renumber syz,cali!=degrees,nil); 151 >>; 152 cali!=degrees:=dpmat_coldegs u; 153 return {u,change,syz} 154 end) where cali!=degrees:=dpmat_coldegs bas, 155 !*factorunits:=!*factorunits, 156 !*detectunits:=!*detectunits, 157 cali!=monset:=cali!=monset; 158 159% ######### The General Groebner driver ############### 160 161COMMENT 162 163It returns {gb,syz,trace} with change on the relation part of gb, 164where 165 INPUT : r, c, gb = rows, columns, base list 166 OUTPUT : 167 <dpmat> gb is the Groebner basis 168 <base list> syz is the dpmat_list of the syzygy matrix 169 <spairlist> trace is the Groebner trace. 170 171There are three different versions of the general driver that branche 172according to a reduction function 173 rf : {pol,simp} |---> {pol,simp} 174found with get('cali,'groeb!=rf): 175 1761. Total reduction with local simplifier lists. For local term orders 177 this is (almost) Mora's first version for the tangent cone. 178 1792. Total reduction with global simplifier list. For local term orders 180 this is (almost) Mora's SimpStBasis. 181 1823. Total reduction with bounded ecart. This needs no extra simplifier 183 list. 184 185end Comment; 186 187symbolic procedure groeb!=generaldriver(r,c,gb,comp_syz); 188 begin scalar u, q, syz, p, pl, pol, trace, return_by_unit, 189 simp, rf, ccrit; 190 ccrit:=(not comp_syz) and (c<2); % don't reduce main syzygies 191 simp:=sort(listminimize(gb,function red!=cancelsimp), 192 function red_better); 193 pl:=groeb_makepairlist(gb,ccrit); 194 rf:=get('cali,'groeb!=rf); 195 if cali_trace() > 30 then groeb_printpairlist pl; 196 if cali_trace() > 5 then 197 <<terpri(); write" New base elements :";terpri() >>; 198 199 % -------- working out pair list 200 while pl and not return_by_unit do 201 << % ------- Choose a pair 202 p:=car pl; pl:=cdr pl; 203 204 % ------ compute S-polynomial (which is a base element) 205 if cali_trace() > 10 then groeb_printpair(p,pl); 206 u:=apply2(rf,groeb_spol p,simp); 207 pol:=first u; simp:=second u; 208 if cali_trace() > 70 then 209 << terpri(); write" Reduced S.-pol. : "; 210 dp_print2 bas_dpoly pol 211 >>; 212 213 if bas_dpoly pol then 214 % --- the S-polynomial doesn't reduce to zero 215 << pol:=groeb!=postprocess pol; 216 r:=r+1; 217 pol:=bas_newnumber(r,pol); 218 219 % --- update the tracelist 220 q:=bas_dpoly pol; 221 trace:=list(groeb!=i p,groeb!=j p,r,dp_lmon q) . trace; 222 223 if cali_trace() > 20 then 224 << terpri(); write r,". ---> "; dp_print2 q >>; 225 if ccrit and (dp_unit!? q) then return_by_unit:=t; 226 227 % ----- update 228 if not return_by_unit then 229 << pl:=groeb_updatepl(pl,gb,pol,ccrit); 230 if cali_trace() > 30 then 231 << terpri(); groeb_printpairlist pl >>; 232 gb:=pol.gb; 233 simp:=red_update(simp,pol); 234 >>; 235 >> 236 237 else % ------ S-polynomial reduces to zero 238 if comp_syz then 239 syz:=car bas_simpelement(bas_make(0,bas_rep pol)) . syz 240 >>; 241 242 % -------- updating the result 243 if cali_trace()>0 then 244 << terpri(); write " Simplifier list has length ",length simp >>; 245 if return_by_unit then return 246 % --- no syzygies are to be computed 247 {dpmat_from_dpoly pol,nil,reversip trace}; 248 gb:=dpmat_make(length gb,c,gb,cali!=degrees,t); 249 return {gb,syz,reversip trace} 250 end; 251 252% --- The different reduction functions. 253 254symbolic procedure groeb!=rf1(pol,simp); {red_totalred(simp,pol),simp}; 255 256symbolic procedure groeb!=rf2(pol,simp); 257 if (null bas_dpoly pol) or (null simp) then {pol,simp} 258 else begin scalar v,q; 259 260 % Make first reduction with bounded ecart. 261 pol:=red_topredbe(simp,pol); 262 263 % Now loop into reduction with minimal ecart. 264 while (q:=bas_dpoly pol) and (v:=red_divtest(simp,dp_lmon q)) do 265 << v:=red_subst(pol,v); 266 % Updating the simplifier list could make sense even 267 % for the noetherian case, since it is a global list. 268 simp:=red_update(simp,pol); 269 pol:=red_topredbe(simp,v); 270 >>; 271 272 % Now make tail reduction 273 if !*red_total and bas_dpoly pol then pol:=red_tailred(simp,pol); 274 return {pol,simp}; 275 end; 276 277symbolic procedure groeb!=rf3(pol,simp); 278% Total reduction with bounded ecart. 279 if (null bas_dpoly pol) or (null simp) then {pol,simp} 280 else begin 281 pol:=red_topredbe(simp,pol); 282 if bas_dpoly pol then 283 pol:=red_tailreddriver(simp,pol,function red_topredbe); 284 return {pol,simp}; 285 end; 286 287% ######### The Lazy Groebner driver ############### 288 289COMMENT 290 291The lazy groebner driver implements the lazy strategy for local 292standard bases, i.e. stepwise reduction of S-Polynomials according to 293a refinement of the (ascending) division order on leading terms. 294 295end Comment; 296 297 298symbolic procedure groeb_lazystbasis(bas,comp_mgb,comp_ch,comp_syz); 299 groeb!=choose_driver(bas,comp_mgb,comp_ch,comp_syz, 300 function groeb!=lazydriver); 301 302symbolic procedure groeb!=lazymocompare(a,b); 303% A dpoly with leading monomial a should be processed before dpolys 304% with leading monomial b. 305 mo_ecart a < mo_ecart b; 306 307symbolic procedure groeb!=queuesort(a,b); 308% Sort criterion for the queue. 309 groeb!=lazymocompare(dp_lmon bas_dpoly a,dp_lmon bas_dpoly b); 310 311symbolic procedure groeb!=nextspol(pl,queue); 312% True <=> take first pl next. 313 if null queue then t 314 else if null pl then nil 315 else groeb!=lazymocompare(nth(car pl,3),dp_lmon bas_dpoly car queue); 316 317symbolic procedure groeb!=lazydriver(r,c,gb,comp_syz); 318% The lazy version of the driver. 319 begin scalar syz, ccrit, queue, v, simp, p, pl, pol, return_by_unit; 320 simp:=sort(listminimize(gb,function red!=cancelsimp), 321 function red_better); 322 ccrit:=(not comp_syz) and (c<2); % don't reduce main syzygies 323 pl:=groeb_makepairlist(gb,ccrit); 324 if cali_trace() > 30 then groeb_printpairlist pl; 325 if cali_trace() > 5 then 326 <<terpri(); write" New base elements :";terpri() >>; 327 328 % -------- working out pair list 329 330 while (pl or queue) and not return_by_unit do 331 if groeb!=nextspol(pl,queue) then 332 << p:=car pl; pl:=cdr pl; 333 if cali_trace() > 10 then groeb_printpair(p,pl); 334 pol:=groeb_spol p; 335 if bas_dpoly pol then % back into the queue 336 if ccrit and dp_unit!? bas_dpoly pol then 337 return_by_unit:=t 338 else queue:=merge(list pol, queue, 339 function groeb!=queuesort) 340 else if comp_syz then % pol reduced to zero. 341 syz:=bas_simpelement bas_make(0,bas_rep pol).syz; 342 >> 343 else 344 << pol:=car queue; queue:=cdr queue; 345 % Try one top reduction step 346 if (v:=red_divtestbe(simp,dp_lmon bas_dpoly pol, 347 bas_dpecart pol)) then () 348 % do nothing with simp ! 349 else if (v:=red_divtest(simp,dp_lmon bas_dpoly pol)) then 350 simp:=red_update(simp,pol); 351 % else v:=nil; 352 if v then % do one top reduction step 353 << pol:=red_subst(pol,v); 354 if bas_dpoly pol then % back into the queue 355 queue:=merge(list pol, queue, 356 function groeb!=queuesort) 357 else if comp_syz then % pol reduced to zero. 358 syz:=bas_simpelement bas_make(0,bas_rep pol).syz; 359 >> 360 else % no reduction possible 361 << % make a tail reduction with bounded ecart and the 362 % usual postprocessing : 363 pol:=groeb!=postprocess 364 if !*red_total then 365 red_tailreddriver(gb,pol,function red_topredbe) 366 else pol; 367 if dp_unit!? bas_dpoly pol then return_by_unit:=t 368 else % update the computation 369 << r:=r+1; pol:=bas_newnumber(r,pol); 370 if cali_trace() > 20 then 371 << terpri(); write r,". --> "; dp_print2 bas_dpoly pol>>; 372 pl:=groeb_updatepl(pl,gb,pol,ccrit); 373 simp:=red_update(simp,pol); 374 gb:=pol.gb; 375 >> 376 >> 377 >>; 378 379 % -------- updating the result 380 381 if cali_trace()>0 then 382 << terpri(); write " Simplifier list has length ",length simp >>; 383 if return_by_unit then return {dpmat_from_dpoly pol,nil,nil} 384 else return 385 {dpmat_make(length simp,c,simp,cali!=degrees,t), syz, nil} 386 end; 387 388% ################ The Groebner Tools ############## 389 390% ---------- Critical pair criteria ----------------------- 391 392symbolic procedure groeb!=crita(p); 393% p is a pair list {(i.k):i running} of pairs with equal module 394% component number. Choose those pairs among them that are minimal wrt. 395% division order on lcm(i.k). 396 listminimize(p,function groeb!=testa); 397 398symbolic procedure groeb!=testa(p,q); mo_divides!?(nth(p,3),nth(q,3)); 399 400symbolic procedure groeb!=critb(e,p); 401% Delete pairs from p, for which testB is false. 402 for each x in p join if not groeb!=testb(e,x) then {x}; 403 404symbolic procedure groeb!=testb(e,a); 405% e=lt(f_k). Test, whether for a=pair (i j) 406% komp(a)=komp(e) and Syz(i,j,k)=[ 1 * * ]. 407 (mo_comp e=car a) 408 and mo_divides!?(e,nth(a,3)) 409 and (not mo_equal!?(mo_lcm(dp_lmon bas_dpoly nth(a,5),e), 410 nth(a,3))) 411 and (not mo_equal!?(mo_lcm(dp_lmon bas_dpoly nth(a,4),e), 412 nth(a,3))); 413 414symbolic procedure groeb!=critc(p); 415% Delete main syzygies. 416 for each x in p join if not groeb!=testc1 x then {x}; 417 418symbolic procedure groeb!=testc1 el; 419 mo_equal!?( 420 mo_sum(dp_lmon bas_dpoly nth(el,5), 421 dp_lmon bas_dpoly nth(el,4)), 422 nth(el,3)); 423 424symbolic procedure groeb_updatepl(p,gb,be,ccrit); 425% Update the pairlist p with the new base element be and the old ones 426% in the base list gb. Discard pairs where both base elements have 427% number part 0. 428 begin scalar p1,k,a,n; n:=(bas_nr be neq 0); 429 a:=dp_lmon bas_dpoly be; k:=mo_comp a; 430 for each b in gb do 431 if (k=mo_comp dp_lmon bas_dpoly b) 432 and(n or (bas_nr b neq 0)) then 433 p1:=groeb!=newpair(k,b,be).p1; 434 p1:=groeb!=crita(sort(p1,function groeb!=better)); 435 if ccrit then p1:=groeb!=critc p1; 436 return 437 merge(p1, 438 groeb!=critb(a,p), function groeb!=better); 439 end; 440 441symbolic procedure groeb_makepairlist(gb,ccrit); 442 begin scalar newgb,p; 443 while gb do 444 << p:=groeb_updatepl(p,newgb,car gb,ccrit); 445 newgb:=car gb . newgb; gb:=cdr gb 446 >>; 447 return p; 448 end; 449 450% -------------- Pair Management -------------------- 451 452symbolic procedure groeb!=i p; bas_nr nth(p,4); 453 454symbolic procedure groeb!=j p; bas_nr nth(p,5); 455 456symbolic procedure groeb!=better(a,b); 457% True if the Spair a is better than the Spair b. 458 if (cadr a < cadr b) then t 459 else if (cadr a = cadr b) then mo_compare(nth(a,3),nth(b,3))<=0 460 else nil; 461 462symbolic procedure groeb!=weight(lcm,p1,p2); 463 mo_ecart(lcm) + min2(bas_dpecart p1,bas_dpecart p2); 464 465symbolic procedure groeb!=newpair(k,p1,p2); 466% Make an spair from base elements with common component number k. 467 list(k,groeb!=weight(lcm,p1,p2),lcm, p1,p2) 468 where lcm =mo_lcm(dp_lmon bas_dpoly p1,dp_lmon bas_dpoly p2); 469 470symbolic procedure groeb_printpairlist p; 471 begin 472 for each x in p do 473 << write groeb!=i x,".",groeb!=j x; print_lf " | " >>; 474 terpri(); 475 end; 476 477symbolic procedure groeb_printpair(pp,p); 478 begin terpri(); 479 write"Investigate (",groeb!=i pp,".",groeb!=j pp,") ", 480 "Pair list has length ",length p; terpri() 481 end; 482 483% ------------- S-polynomial constructions ----------------- 484 485symbolic procedure groeb_spol pp; 486% Make an S-polynomial from the spair pp, i.e. return 487% a base element with 488% dpoly = ( zi*mi*(red) pi - zj*mj*(red) pj ) 489% rep = (zi*mi*rep_i - zj*mj*rep_j), 490% 491% where mi=lcm/lm(pi), mj=lcm/lm(pj) 492% and zi and zj are appropriate scalars. 493% 494%-------------------- 495% There is a symbol called "pi" that is a global variable which 496% has a value 3.14...., and that woulkd clash with trting to use the name 497% "pi" as a local variable. Previous versions of Reduce resolved the attempt 498% to bind the global variable by changing it to be fluid, but that is really 499% not good for consistency across all the source files, so I have renamed 500% the local variable here to be "pi_". This is ugly, and you could argue that 501% with only local use here that the Lisp should allow local re-binding, but 502% declaring something global is intended to give it a chance to interact 503% across procedure calls and overriding it feels dangerout. 504%-------------------- 505 begin scalar pi_,pj,ri,rj,zi,zj,lcm,mi,mj,a,b; 506 a:=nth(pp,4); b:=nth(pp,5); lcm:=nth(pp,3); 507 pi_:=bas_dpoly a; pj:=bas_dpoly b; ri:=bas_rep a; rj:=bas_rep b; 508 mi:=mo_diff(lcm,dp_lmon pi_); mj:=mo_diff(lcm,dp_lmon pj); 509 zi:=dp_lc pj; zj:=cali_bc_neg dp_lc pi_; 510 a:=dp_sum(dp_times_bcmo(zi,mi, cdr pi_), 511 dp_times_bcmo(zj,mj, cdr pj)); 512 b:=dp_sum(dp_times_bcmo(zi,mi, ri), 513 dp_times_bcmo(zj,mj, rj)); 514 a:=bas_make1(0,a,b); 515 if !*bcsimp then a:=car bas_simpelement a; 516 if cali_trace() > 70 then 517 << terpri(); write" S.-pol : "; dp_print2 bas_dpoly a >>; 518 return a; 519 end; 520 521symbolic procedure groeb_mingb gb; 522% Returns the min. Groebner basis dpmat mgb of the dpmat gb 523% discarding base elements with bas_nr<=0. 524 begin scalar u; 525 u:=for each x in car red_collect dpmat_list gb join 526 if bas_nr x>0 then {x}; 527 % Choosing base elements with minimal leading terms only. 528 return dpmat_make(length u,dpmat_cols gb,bas_renumber u, 529 dpmat_coldegs gb,dpmat_gbtag gb); 530 end; 531 532% ------- Minimizing a basis using its syszgies --------- 533 534symbolic procedure groeb!=delete(l,bas); 535% Delete base elements from the base list bas with number in the 536% integer list l. 537 begin scalar b; 538 while bas do 539 << if not memq(bas_nr car bas,l) then b:=car bas . b; 540 bas:= cdr bas 541 >>; 542 return reverse b 543 end; 544 545symbolic procedure groeb_minimize(bas,syz); 546% Minimize the dpmat pair bas,syz deleting superfluous base elements 547% from bas using syzygies from syz containing unit entries. 548 (begin scalar drows, dcols, s,s1,i,j,p,q,y; 549 cali!=degrees:=dpmat_coldegs syz; 550 s1:=dpmat_list syz; j:=0; 551 while j < dpmat_rows syz do 552 << j:=j+1; 553 if (q:=bas_dpoly bas_getelement(j,s1)) then 554 << i:=0; 555 while leq(i,dpmat_cols syz) and 556 (memq(i,dcols) or not dp_unit!?(p:=dp_comp(i,q))) 557 do i:=i+1; 558 if leq(i,dpmat_cols syz) then 559 << drows:=j . drows; 560 dcols:=i . dcols; 561 s1:=for each x in s1 collect 562 if memq(bas_nr x,drows) then x 563 else (bas_make(bas_nr x, 564 dp_diff(dp_prod(y,p),dp_prod(q,dp_comp(i,y)))) 565 where y:=bas_dpoly x); 566 >> 567 >> 568 >>; 569 570 % --- s1 becomes the new syzygy part, s the new base part. 571 572 s1:=bas_renumber bas_simp groeb!=delete(drows,s1); 573 s1:=dpmat_make(length s1,dpmat_cols syz,s1,cali!=degrees,nil); 574 % The new syzygy matrix of the old basis. 575 s:=dpmat_renumber 576 dpmat_make(dpmat_rows bas,dpmat_cols bas, 577 groeb!=delete(dcols,dpmat_list bas), 578 dpmat_coldegs bas,nil); 579 s1:=dpmat_mult(s1,dpmat_transpose cdr s); 580 % The new syzygy matrix of the new basis, but not yet in the 581 % right form since cali!=degrees is empty. 582 s:=car s; % The new basis. 583 cali!=degrees:=dpmat_rowdegrees s; 584 s1:=interreduce!* dpmat_make(dpmat_rows s1,dpmat_cols s1, 585 bas_neworder dpmat_list s1,cali!=degrees,nil); 586 return s.s1; 587 end) where cali!=degrees:=cali!=degrees; 588 589% ------ Computing standard bases via homogenization ---------------- 590 591symbolic procedure groeb_homstbasis(m,comp_mgb,comp_ch,comp_syz); 592 (begin scalar v,c,u; 593 c:=cali!=basering; v:=list make_cali_varname(); 594 if not(comp_ch or comp_syz) then cali!=monset:=append(v,cali!=monset); 595 setring!* ring_sum(c,ring_define(v,nil,'lex,'(1))); 596 cali!=degrees:=mo_degneworder dpmat_coldegs m; 597 if cali_trace()>0 then print" Homogenize input "; 598 u:=(groeb_stbasis(mathomogenize!*(m,car v), 599 comp_mgb,comp_ch,comp_syz) where !*noetherian=t); 600 if cali_trace()>0 then print" Dehomogenize output "; 601 u:=for each x in u collect if x then matdehomogenize!*(x,car v); 602 setring!* c; cali!=degrees:=dpmat_coldegs m; 603 return {if first u then dpmat_neworder(first u,t), 604 if second u then dpmat_neworder(second u,nil), 605 if third u then dpmat_neworder(third u,nil)}; 606 end) where cali!=basering:=cali!=basering, 607 cali!=monset:=cali!=monset, 608 cali!=degrees:=cali!=degrees; 609 610 611% Two special versions for standard basis computations, not included 612% in full generality into the algebraic interface. 613 614symbolic operator homstbasis; 615symbolic procedure homstbasis m; 616 if !*mode='algebraic then dpmat_2a homstbasis!* dpmat_from_a m 617 else homstbasis!* m; 618 619symbolic procedure homstbasis!* m; 620 groeb_mingb car groeb_homstbasis(m,t,nil,nil); 621 622symbolic operator lazystbasis; 623symbolic procedure lazystbasis m; 624 if !*mode='algebraic then dpmat_2a lazystbasis!* dpmat_from_a m 625 else lazystbasis!* m; 626 627symbolic procedure lazystbasis!* m; 628 car groeb_lazystbasis(m,t,nil,nil); 629 630endmodule; % groeb 631 632end; 633