groebf.red 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654
  1. module groebf;
  2. Comment
  3. ##############################
  4. ### ###
  5. ### GROEBNER FACTORIZER ###
  6. ### ###
  7. ##############################
  8. The Groebner algorithm with factorization and constraint lists.
  9. New in version 2.2 :
  10. syntax for groebfactor
  11. listgroebfactor!*
  12. extendedgroebfactor!*
  13. There are two versions of the extended groebner factorizer.
  14. One needs the lex. term order, the other supports arbitrary ones (the
  15. default). Switch between both versions via switch lexefgb.
  16. Internal data structure
  17. result::={dpmat, constraint list }
  18. extendedresult::=
  19. {dpmat, constraint list, (dimension | indepvarset) }
  20. problem::={dpmat, constraint list, pair list, easydim}
  21. aggregate::=
  22. { (list of problems) , (list of results) }
  23. For a system with constraints m=(b,c) V(m)=V(b,c) denotes the zero set
  24. V(b)\setminus D(c).
  25. The Groebner algorithm supports only the classical reduction
  26. principle.
  27. end Comment;
  28. % --- The side effect switching lexefgb on or off :
  29. put('lexefgb,'simpfg,'((t (put 'cali 'efgb 'lex))
  30. (nil (remprop 'cali 'efgb))));
  31. symbolic procedure groebf!=problemsort(a,b);
  32. % Sorted by ascending easydim to force depth first search.
  33. (nth(a,4)<nth(b,4))
  34. or (nth(a,4)=nth(b,4)) and (length second a<= length second b);
  35. symbolic procedure groebf!=resultsort(a,b);
  36. % Sort extendedresults by descending true dimension, assuming the
  37. % third part being the dimension.
  38. third a > third b;
  39. put('groebfactor,'psopfn,'intf!=groebfactor);
  40. symbolic procedure intf!=groebfactor m;
  41. begin scalar bas,con;
  42. bas:=dpmat_from_a reval first m;
  43. if length m=1 then con:=nil
  44. else if length m=2 then
  45. con:=for each x in cdr reval second m collect dp_from_a x
  46. else rederr("Syntax : GROEBFACTOR(base list [,constraint list])");
  47. return makelist
  48. for each x in groebfactor!*(bas,con) collect dpmat_2a first x;
  49. end;
  50. symbolic operator listgroebfactor;
  51. symbolic procedure listgroebfactor l;
  52. % l is a list of polynomial systems. We look for the union of the
  53. % solution sets.
  54. if !*mode='algebraic then
  55. makelist for each x in listgroebfactor!*
  56. for each y in cdr reval l collect dpmat_from_a y
  57. collect dpmat_2a x
  58. else listgroebfactor!* l;
  59. symbolic procedure listgroebfactor!* l;
  60. % Proceed a whole list of dpmats at once.
  61. begin scalar gbs;
  62. gbs:=for each x in
  63. groebf!=preprocess(nil,for each x in l collect {x,nil})
  64. collect groebf!=initproblem x;
  65. gbs:=sort(gbs,function groebf!=problemsort);
  66. return for each x in groebf!=masterprocess(gbs,nil) collect first x;
  67. end;
  68. symbolic procedure groebfactor!*(bas,poly);
  69. % Returns a list l of results (b,c) such that
  70. % V(bas,poly) = \union { V(b,c) : (b,c) \in l }
  71. if dpmat_cols bas > 0 then
  72. rederr "GROEBFACTOR only for ideal bases"
  73. else if null !*noetherian then
  74. rederr "GROEBFACTOR only for noetherian term orders"
  75. else if dpmat_zero!? bas then list({bas,poly})
  76. else begin scalar gbs;
  77. if cali_trace() > 5 then
  78. << write"GROEBFACTOR the system "; dpmat_print bas >>;
  79. gbs:=for each x in groebf!=preprocess(nil,list {bas,poly}) collect
  80. groebf!=initproblem x;
  81. gbs:=sort(gbs,function groebf!=problemsort);
  82. return groebf!=masterprocess(gbs,nil);
  83. end;
  84. put('extendedgroebfactor,'psopfn,'intf!=extendedgroebfactor);
  85. symbolic procedure intf!=extendedgroebfactor m;
  86. begin scalar bas,con;
  87. bas:=dpmat_from_a reval first m;
  88. if length m=1 then con:=nil
  89. else if length m=2 then
  90. con:=for each x in cdr reval second m collect dp_from_a x
  91. else rederr
  92. "Syntax : EXTENDEDGROEBFACTOR(base list [,constraint list])";
  93. return makelist
  94. for each x in extendedgroebfactor!*(bas,con) collect
  95. makelist {first x,makelist second x,makelist third x};
  96. end;
  97. symbolic procedure extendedgroebfactor!*(bas,poly);
  98. % Returns a list l of extendedresults (b,c,vars) in prefix form such
  99. % that V(bas,poly) = \union { V(b,c) : (b,c) \in l }
  100. % and b:<\prod c> is puredimensional with independent variable set vars.
  101. if dpmat_cols bas > 0 then
  102. rederr "EXTENDEDGROEBFACTOR only for ideal bases"
  103. else if null !*noetherian then
  104. rederr "EXTENDEDGROEBFACTOR only for noetherian term orders"
  105. else if dpmat_zero!? bas then
  106. list({dpmat_2a bas,nil,ring_names cali!=basering})
  107. else begin scalar gbs;
  108. if cali_trace() > 5 then
  109. << write"EXTENDEDGROEBFACTOR the system "; dpmat_print bas >>;
  110. gbs:=for each x in groebf!=preprocess(nil,list {bas,poly}) collect
  111. groebf!=initproblem x;
  112. return groebf!=extendedmasterprocess gbs;
  113. end;
  114. symbolic procedure groebf!=extendedmasterprocess gbs;
  115. % gbs is a list of problems to process. Returns a list of
  116. % extendedresults in prefix form.
  117. % If {m,con,vars} is such an extendedresult then m:<\prod con> is the
  118. % (puredimensional) recontraction of m\tensor k(vars).
  119. begin scalar res,res1,u;
  120. while gbs or res do
  121. if gbs then
  122. % The hard postprocessing is done only at the end.
  123. << gbs:=sort(gbs,function groebf!=problemsort);
  124. % Convert results to extendedresults and sort them :
  125. res:=for each x in groebf!=masterprocess(gbs,res) collect
  126. if (length x=3) then x
  127. else {first x,second x,dim!* first x};
  128. res:=sort(res,function groebf!=resultsort);
  129. gbs:=nil
  130. >>
  131. else % Do the first (hard) postprocessing
  132. << % process result by result :
  133. u:=groebf!=postprocess2 car res; res:=cdr res;
  134. % Extract and preprocess new problems from u.
  135. % This needs descent by dimension of the results proceeded.
  136. gbs:=for each x in groebf!=preprocess(res,second u)
  137. collect groebf!=initproblem x;
  138. % Extract extendedresults from u.
  139. % They may be non-GB wrt t h i s term order, see above.
  140. res1:=nconc(first u,res1);
  141. >>;
  142. return res1;
  143. end;
  144. % --------- Another version of the extended Groebner factorizer -------
  145. put('extendedgroebfactor1,'psopfn,'intf!=extendedgroebfactor1);
  146. symbolic procedure intf!=extendedgroebfactor1 m;
  147. begin scalar bas,con;
  148. bas:=dpmat_from_a reval first m;
  149. if length m=1 then con:=nil
  150. else if length m=2 then
  151. con:=for each x in cdr reval second m collect dp_from_a x
  152. else rederr
  153. "Syntax : EXTENDEDGROEBFACTOR1(base list [,constraint list])";
  154. return makelist
  155. for each x in extendedgroebfactor1!*(bas,con) collect
  156. makelist {first x,makelist second x,makelist third x};
  157. end;
  158. symbolic procedure extendedgroebfactor1!*(bas,poly);
  159. % Returns a list l of extendedresults (b,c,vars) in prefix form such
  160. % that V(bas,poly) = \union { V(b,c) : (b,c) \in l }
  161. % and b:<\prod c> is puredimensional with independent variable set vars.
  162. if dpmat_cols bas > 0 then
  163. rederr "EXTENDEDGROEBFACTOR1 only for ideal bases"
  164. else if null !*noetherian then
  165. rederr "EXTENDEDGROEBFACTOR1 only for noetherian term orders"
  166. else if dpmat_zero!? bas then
  167. list({dpmat_2a bas,nil,ring_names cali!=basering})
  168. else begin scalar gbs;
  169. if cali_trace() > 5 then
  170. << write"EXTENDEDGROEBFACTOR1 the system "; dpmat_print bas >>;
  171. gbs:=for each x in groebf!=preprocess(nil,list {bas,poly}) collect
  172. groebf!=initproblem x;
  173. return for each x in groebf!=extendedmasterprocess1 gbs collect
  174. nth(x,4);
  175. end;
  176. symbolic procedure groebf!=extendedmasterprocess1 gbs;
  177. % Version that computes the retraction of each intermediate result
  178. % to apply FGB shortcuts. gbs is a list of problems to process.
  179. % Returns a list of extendedresults in prefix form.
  180. % If {m,con,vars} is such an extendedresult then m:<\prod con> is the
  181. % (puredimensional) recontraction of m\tensor k(vars).
  182. % internally they are incorporated into res as
  183. % {dpmat, nil (since no constraints), dim, prefix form}.
  184. begin scalar res,u,v,p;
  185. while gbs or
  186. (p:=listtest(res,nil,function (lambda(x,y); length x<4))) do
  187. if gbs then
  188. % The hard postprocessing is done only at the end.
  189. << gbs:=sort(gbs,function groebf!=problemsort);
  190. % Convert results to extendedresults and sort them :
  191. res:=for each x in groebf!=masterprocess(gbs,res) collect
  192. if (length x>2) then x
  193. else {first x,second x,dim!* first x};
  194. res:=sort(res,function groebf!=resultsort);
  195. gbs:=nil
  196. >>
  197. else % Do the first (hard) postprocessing
  198. << % process result by result :
  199. u:=groebf!=postprocess2 p; res:=delete(p,res);
  200. % Extract extendedresults from u and convert them
  201. % with postprocess3 to quotient ideals.
  202. v:=for each x in first u collect
  203. {groebf!=postprocess3 x, nil, length third x,x};
  204. for each y in v do
  205. if not groebf!=redtest(res,y) then
  206. res:=merge({y},groebf!=sieve(res,y),
  207. function groebf!=resultsort);
  208. % Extract and preprocess new problems from u.
  209. gbs:=for each x in groebf!=preprocess(res,second u) collect
  210. groebf!=initproblem x;
  211. >>;
  212. return res;
  213. end;
  214. % ------- end of the second version ------------------------
  215. symbolic procedure groebf!=masterprocess(gbs,res);
  216. % gbs = list of problems, res = list of results (since several times
  217. % involved in the extendedmasterprocess).
  218. % Returns a list of results already postprocessed with (the easy)
  219. % groebf!=postpocess1 where the elements surviving from res may
  220. % change only in the constraints part.
  221. begin scalar u,v;
  222. while gbs do
  223. << if cali_trace()>10 then
  224. print for each x in gbs collect nth(x,4);
  225. u:=groebf!=slave car gbs; gbs:=cdr gbs;
  226. if u then % u is an aggregate.
  227. << % postprocess the result part returning a list of aggregates.
  228. v:=for each x in second u collect groebf!=postprocess1(res,x);
  229. % split up into the problems u and results v
  230. u:=nconc(car u,for each x in v join car x);
  231. v:=for each x in v join second x;
  232. for each y in v do
  233. if cali_trace() > 5 then
  234. << write"partial result :"; terpri();
  235. dpmat_print car y ;
  236. prin2"constraints : ";
  237. for each x in second y do dp_print2 x;
  238. >>;
  239. for each y in v do
  240. if not groebf!=redtest(res,y) then
  241. res:=y . groebf!=sieve(res,y);
  242. for each x in u do
  243. if not groebf!=redtest(res,x) then
  244. gbs:=merge({x},groebf!=sieve(gbs,x),
  245. function groebf!=problemsort);
  246. if cali_trace()>20 then
  247. << terpri(); write length gbs," remaining branches. ",
  248. length res," partial results"; terpri()
  249. >>;
  250. >>
  251. else % branch discarded
  252. if cali_trace()>20 then print"Branch discarded";
  253. >>;
  254. return res;
  255. end;
  256. symbolic procedure groebf!=initproblem x;
  257. % Converts a result into a problem.
  258. list(car x,second x, groeb_makepairlist(dpmat_list car x,t),
  259. easydim!* car x);
  260. % The following two procedures make destructive changes
  261. % on the cdr of some of the list elements.
  262. symbolic procedure groebf!=redtest(a,c);
  263. % Ex. u \in a : car u \submodule car c ?
  264. % If so, update the constraints of u.
  265. begin scalar u;
  266. u:=listtest(a,c,function(lambda(x,y); submodulep!*(car x,car y)));
  267. if u then cdr u:=intersection(second u,second c).cddr u;
  268. return u;
  269. end;
  270. symbolic procedure groebf!=sieve(a,c);
  271. % Remove u \in a with car c \submodule car u
  272. % and update the constraints of c.
  273. for each x in a join if not submodulep!*(car c,car x) then {x}
  274. else << cdr c:=intersection(second x,second c).cddr c; >>;
  275. symbolic procedure groebf!=test(con,m);
  276. % nil <=> ex. f \in con : f mod m = 0. m is a baslist.
  277. if null m then t
  278. else if dp_unit!? bas_dpoly first m then nil
  279. else if null con then t
  280. else begin scalar p; p:=t;
  281. while p and con do
  282. << p:=p and bas_dpoly car red_redpol(m,bas_make(0,car con));
  283. con:=cdr con
  284. >>;
  285. return p;
  286. end;
  287. symbolic procedure groebf!=newcon(r,d);
  288. % r=(m,c) is a result, d a list of polynomials. Returns the
  289. % (slightly optimized) result list ( (m+(p),c+(q|q<p)) | p \in d ).
  290. begin scalar m,c,u;
  291. m:=first r; c:=second r;
  292. return for each p in d join
  293. if not member(p,c) then
  294. << u:={matsum!* {m, dpmat_from_dpoly(p)}, c}; c:=p.c; {u} >>;
  295. end;
  296. symbolic procedure groebf!=preprocess(a1,b);
  297. % Try to split (factor) each polynomial in each problem of the list b.
  298. % Returns a list of results.
  299. % a1 is a list of results already computed.
  300. begin scalar a,c,d,back,u;
  301. if cali_trace()>20 then prin2"preprocessing started";
  302. while b do
  303. << if cali_trace()>20 then
  304. << terpri(); write length a," ready. ";
  305. write length b," left."; terpri()
  306. >>;
  307. c:=car b; b:=cdr b;
  308. if not (null groebf!=test(second c,dpmat_list car c)
  309. or groebf!=redtest(a1,c)
  310. or groebf!=redtest(a,c)) then
  311. << d:=dpmat_list car c; back:=nil;
  312. while d and not back do
  313. << u:=((fctrf numr simp dp_2a bas_dpoly car d)
  314. where !*factor=t);
  315. if (length u>2) or (cdadr u>1) then
  316. << back:=t;
  317. b:=append(groebf!=newcon(c,
  318. for each y in cdr u collect
  319. dp_from_a prepf car y),b);
  320. >>
  321. else d:=cdr d
  322. >>;
  323. if not back then
  324. << if cali_trace()>20 then
  325. << terpri(); write"Subproblem :"; dpmat_print car c >>;
  326. if not groebf!=redtest(a,c) then a:=c . groebf!=sieve(a,c);
  327. >>
  328. >>
  329. >>;
  330. if cali_trace()>20 then prin2"preprocessing finished...";
  331. return a;
  332. end;
  333. symbolic procedure groebf!=slave c;
  334. % Proceed upto the first splitting. Returns an aggregate.
  335. begin scalar be,back,p,u,v,a,b,gb,pl,nr,pol,con;
  336. back:=nil;
  337. gb:=bas_sort dpmat_list first c;
  338. con:=second c; pl:=third c; nr:=length gb;
  339. while pl and not back do
  340. << p:=car pl; pl:=cdr pl;
  341. if cali_trace() > 10 then groeb_printpair(p,pl);
  342. pol:=groeb_spol p;
  343. if cali_trace() > 70 then
  344. << terpri(); write"S.-pol : "; dp_print2 bas_dpoly pol >>;
  345. pol:=bas_dpoly car red_redpol(gb,pol);
  346. if cali_trace() > 70 then
  347. << terpri(); write"Reduced S.-pol. : "; dp_print2 pol >>;
  348. if pol then
  349. << if !*bcsimp then pol:=car dp_simp pol;
  350. if dp_unit!? pol then
  351. << if cali_trace()>20 then print "unit ideal";
  352. back:=t
  353. >>
  354. else
  355. << % -- factorize pol
  356. u:=((fctrf numr simp dp_2a pol) where !*factor=t);
  357. nr:=nr+1;
  358. if length cdr u=1 then % only one factor
  359. << pol:=dp_from_a prepf caadr u;
  360. be:=bas_make(nr,pol);
  361. u:=be.gb;
  362. if null groebf!=test(con,u) then
  363. << back:=t;
  364. if cali_trace()>20 then print" zero constraint";
  365. >>
  366. else
  367. << if cali_trace()>20 then
  368. << terpri(); write nr,". "; dp_print2 pol >>;
  369. pl:=groeb_updatePL(pl,gb,be,t);
  370. if cali_trace() > 30 then
  371. << terpri(); groeb_printpairlist pl >>;
  372. gb:=merge(list be,gb,function red_better);
  373. >>
  374. >>
  375. else % more than one factor
  376. << for each x in cdr u do
  377. << pol:=dp_from_a prepf car x;
  378. be:=bas_make(nr,pol);
  379. a:=be.gb;
  380. if groebf!=test(con,a) then
  381. << if cali_trace()>20 then
  382. << terpri(); write nr; write". "; dp_print2 pol >>;
  383. p:=groeb_updatePL(append(pl,nil),gb,be,t);
  384. if cali_trace() > 30 then
  385. << terpri(); groeb_printpairlist p >>;
  386. b:=merge(list be,append(gb,nil),
  387. function red_better);
  388. b:=dpmat_make(length b,0,b,nil,nil);
  389. v:={b,con,p}.v;
  390. >>
  391. else if cali_trace()>20 then print" zero constraint";
  392. if not member(pol,con) then con:=pol . con;
  393. >>;
  394. if null v then
  395. << if cali_trace()>20 then print "Branch canceled";
  396. back:=t
  397. >>
  398. else if length v=1 then
  399. << c:=car v; gb:=dpmat_list first c; con:=second c;
  400. pl:=third c; v:=nil;
  401. >>
  402. else
  403. << back:=t;
  404. if cali_trace()>20 then
  405. << write" Branching into ",length v," parts ";
  406. terpri();
  407. >>;
  408. >>;
  409. >>;
  410. >>;
  411. >>;
  412. >>;
  413. if not back then % pl exhausted => new partial result.
  414. return
  415. {nil,list {groeb_mingb dpmat_make(length gb,0,gb,nil,t),con}}
  416. else if v then return
  417. {for each x in v collect
  418. {first x,second x,third x,easydim!* first x},
  419. nil}
  420. else return nil;
  421. end;
  422. symbolic procedure groebf!=postprocess1(res,x);
  423. % Easy postprocessing a result. Returns an aggregate.
  424. % res is a list of results, already obtained.
  425. begin scalar p,r,v;
  426. % ---- interreduce and try factorization once more.
  427. if !*red_total then
  428. << v:=groebf!=preprocess(res,
  429. list {dpmat_make(dpmat_rows car x,0,
  430. red_straight dpmat_list car x,nil,
  431. dpmat_gbtag car x),
  432. second x});
  433. if (length v=1) and dpmat_gbtag caar v then r:=v
  434. else p:=for each x in v collect groebf!=initproblem x;
  435. >>
  436. else r:={x};
  437. return {p,r};
  438. end;
  439. symbolic procedure groebf!=postprocess2 m;
  440. (begin scalar d,vars,u,v,c1,m1,m1a,m2,p,con;
  441. con:=second m; d:=third m; m:=first m;
  442. v:=moid_goodindepvarset m;
  443. if neq(length v,d) then
  444. rederr"In POSTPROCESS2 the dimension is wrong";
  445. if null v then return
  446. {for each x in groebf!=zerosolve(m,con)
  447. collect {x,nil,nil},nil};
  448. % -- Prepare data for change to dimension zero :
  449. % Recompute gbases wrt. the elimination order for u and
  450. % take only those components for which v remains independent.
  451. vars:=ring_names(c1:=cali!=basering);
  452. u:=setdiff(vars,v);
  453. if get('cali,'efgb)='lex then setring!* ring_lp(c1,u)
  454. else setring!* ring_rlp(c1,u);
  455. m1:=for each u in groebfactor!*(dpmat_neworder(m,nil),
  456. for each x in con collect dp_neworder x) collect
  457. {first u,second u,dim!* first u};
  458. for each x in m1 do
  459. if (third x = d) and member(v,indepvarsets!* car x)
  460. then m1a := x . m1a
  461. else m2:=x.m2;
  462. % m1a : components with indepvarset v
  463. % m2 : components with v being dependent variables.
  464. % -- Change to dimension zero.
  465. m1:=for each x in m1a collect
  466. {dpmat_2a first x,for each p in second x collect dp_2a p};
  467. if get('cali,'efgb)='lex then
  468. setring!* ring_define(u,nil,'lex,for each x in u collect 1)
  469. else setring!* ring_define(u,degreeorder!* u,'revlex,
  470. for each x in u collect 1);
  471. m1:=for each x in m1 collect
  472. {groeb_mingb dpmat_from_a first x,
  473. for each p in second x collect dp_from_a p};
  474. % Extract the lc's of the lifted Groebner bases and save them
  475. % for NewCon on the list m1a, since in the zerodimensional part
  476. % lc's are assumed to be invertible.
  477. m1a:=pair(m1a,for each x in m1 collect groebf!=elcbe first x);
  478. % Compute the zerodimensional TriangSets from m1 and their lists
  479. % of lc's and prepare them for lifting.
  480. m1:=for each x in m1 join groebf!=zerosolve(first x,second x);
  481. m1:=for each x in m1 collect {x,groebf!=elcbe dpmat_from_a x};
  482. % -- Lift all stuff back to c1.
  483. setring!* c1;
  484. % Extract the TriangSets as extendedresults in prefix form (!).
  485. m1:=for each x in m1 collect {first x,second x,v};
  486. % List of new problems found during recomputation of GB :
  487. m2:=for each x in m2 collect
  488. {dpmat_neworder(first x,nil),
  489. for each y in second x collect dp_neworder y};
  490. % List of new problems, derived from nonzero conditions for
  491. % lc's in dimension zero.
  492. m1a:=for each x in m1a join
  493. groebf!=newcon({dpmat_neworder(first car x,nil),
  494. for each p in second car x collect dp_neworder p},
  495. for each p in cdr x collect dp_from_a p);
  496. Comment The list of results :
  497. m1 : The list of TriangSets wrt. v produced in this run. They are in
  498. alg. prefix form to remember that they are Groebner bases only
  499. wrt. the pure lex. term order.
  500. m2 : Results (in prefix form), for which v is dependent.
  501. m1a : Branches, where some of the critical lc's of the TriangSets
  502. vanish.
  503. Both m2 and m1a should be returned in the pool of problems.
  504. end comment;
  505. return {m1,nconc(m1a,m2)};
  506. end)
  507. where cali!=degrees:=cali!=degrees,
  508. cali!=basering:=cali!=basering;
  509. symbolic procedure groebf!=elcbe(m);
  510. % Extract list of leading coefficients in algebraic prefix form
  511. % from base elements of the dpmat m.
  512. for each x in dpmat_list m join
  513. if domainp dp_lc bas_dpoly x then {}
  514. else {bc_2a dp_lc bas_dpoly x};
  515. symbolic procedure groebf!=postprocess3 u;
  516. % Compute for the extendedresult u={m,con,vars} in prefix form
  517. % m:<\prod con>.
  518. matqquot!*(dpmat_from_a first u,
  519. groebf!=prod for each x in second u collect dp_from_a x);
  520. symbolic procedure groebf!=prod l;
  521. begin scalar p; p:=dp_fi 1;
  522. l:=listminimize(for each x in l join dp_factor x,function equal);
  523. for each x in l do p:=dp_prod(x,p);
  524. return p;
  525. end;
  526. symbolic procedure groebf!=zerosolve(m,con);
  527. % Hook for the zerodimensional solver.
  528. % Input : m = zerodimensional dpmat (not to be checked),
  529. % con = list of dpoly constraints.
  530. % Output : a list of dpmats in prefix form.
  531. begin scalar u;
  532. % Look up the constraints, since during the change to dimension zero
  533. % some of them may trivialize :
  534. con:=for each x in con join if not dp_unit!? x then {x};
  535. % Factorized radical computation.
  536. u:=groebf_zeroprimes1(m,con);
  537. % Apply the zerosolver to each of these results.
  538. return for each x in u join
  539. if get('cali,'efgb)='lex then zerosolve!* x else zerosolve1!* x;
  540. end;
  541. symbolic procedure groebf_zeroprimes1(m,con);
  542. % Returns a list of gbases for the zerodimensional ideal m,
  543. % incorporating as in the Groebner factorizer the factors of the
  544. % univariate polynomials in m according to such variables, that don't
  545. % appear as leading terms in m.
  546. begin scalar m1,m2,p,u,l;
  547. l:=list {m,con};
  548. for each x in ring_names cali!=basering do
  549. << m1:=m2:=nil;
  550. for each y in l do
  551. % The following checks, whether x is a leading term of first
  552. % y. Such x may be skipped, since embedding dimension may be
  553. % reduced. On the other hand, computing univariate polynomials
  554. % for them is often quite nasty.
  555. if not member(x,for each v in dpmat_list first y join
  556. {mo_linear dp_lmon bas_dpoly v}) then
  557. << p:=odim_up(x,first y); u:=dp_factor p;
  558. if (length u>1) or not equal(first u,p) then
  559. m1:=nconc(groebf!=newcon(y,u),m1)
  560. else m2:=y.m2;
  561. >>
  562. else m2:=y.m2;
  563. l:=groebf!=masterprocess(
  564. sort(for each x in m1 collect groebf!=initproblem x,
  565. function groebf!=problemsort),
  566. m2);
  567. >>;
  568. return for each x in l join
  569. if second x then {matqquot!*(first x,groebf!=prod second x)}
  570. % Here one can use the linear algebra quotient algorithm, since
  571. % first x is known to be zerodimensional radical.
  572. else {first x};
  573. end;
  574. endmodule; % groebf
  575. end;