groebrst.red 4.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123
  1. module groebrst;
  2. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  3. %
  4. % restrictions for polynomials during Groebner base calculation
  5. %
  6. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  7. fluid '(groebrestriction!*);
  8. symbolic procedure groebTestrestriction (h,arg);
  9. if groebrestriction!* = 'NONNEGATIVE then groebNonneg(h,arg)
  10. else
  11. if groebrestriction!* = 'POSITIVE then groebPos(h,arg)
  12. else
  13. if groebrestriction!* = 'ZEROPOINT then groebZero(h,arg)
  14. else
  15. rerror(groebnr2,9,
  16. "Groebner: general restrictions not yet implemented");
  17. symbolic procedure groebNonneg(h,arg);
  18. % test if h is a polynomial which can have the value zero with
  19. % only nonnegative variable settings.
  20. begin scalar x,break,vev1,vevl,problems,problems1,r;
  21. if vdpzero!? h then return nil
  22. else
  23. if vevzero!? vdpevlmon h then goto finish;
  24. % first test the coefficients
  25. if vdpredZero!? h then return nil; % simple monomial
  26. break := nil;
  27. x := h;
  28. while not vdpzero!? x and not break do
  29. <<vev1 := vdpevlmon x;
  30. if not vbcplus!? vdpLbc x then break := t;
  31. if not break then x := vdpred x>>;
  32. if break then return nil; % at least one negative coeff
  33. if vevzero!? vev1 then goto finish; % nonneg. solution imposs.
  34. % homogenous polynomial: find combinations of
  35. % variables which are solutions
  36. x := h;
  37. vev1 := vdpevlmon x;
  38. vevl := vevsplit(vev1);
  39. problems := for each x in vevl collect list x;
  40. x := vdpred x;
  41. while not vdpzero!? x do
  42. << vev1 := vdpevlmon x;
  43. vevl := vevsplit(vev1);
  44. problems1 := nil;
  45. for each e in vevl do
  46. for each p in problems do
  47. <<r := if not member(e,p) then e . p else p;
  48. problems1 := union(list r, problems1)>>;
  49. problems := problems1;
  50. x := vdpred x;
  51. >>;
  52. problems := % lift vevs to polynomials
  53. for each p in problems collect
  54. for each e in p collect
  55. vdpfmon(a2vbc 1,e);
  56. % rule out problems contained in others
  57. for each x in problems do
  58. for each y in problems do
  59. if not eq(x,y) and subset!?(x,y) then
  60. problems := delete (y,problems);
  61. % rule out some by cdr
  62. problems1 := nil;
  63. while problems do
  64. <<if vdpDisjoint!? (car problems,arg)
  65. then problems1 := car problems . problems1;
  66. problems := cdr problems;
  67. >>;
  68. finish:
  69. groebmess24(h,problems1,arg);
  70. return
  71. if null problems1 then 'CANCEL
  72. else 'restriction . problems1;
  73. end;
  74. symbolic procedure groebpos(h,dummy);
  75. % test if h is a polynomial which can have the value zero with
  76. % only positive (nonnegative and nonzero) variable settings.
  77. begin scalar x,break,vev1;
  78. dummy := nil;
  79. if vdpzero!? h then return nil
  80. else
  81. if vevzero!? vdpevlmon h then return nil;
  82. % a simple monomial can never have pos. zeros
  83. if vdpredzero!? h then return groebposcancel(h);
  84. break := nil;
  85. x := h;
  86. % test coefficients
  87. while not vdpzero!? x and not break do
  88. <<vev1 := vdpevlmon x;
  89. if not vbcplus!? vdpLbc x then break := t;
  90. if not break then x := vdpred x>>;
  91. if not break then return groebPosCancel(h);
  92. if not groebposvevaluate h then groebPosCancel(h);
  93. return nil;
  94. end;
  95. symbolic procedure groebposvevaluate h; <<h := nil; t>>;
  96. % test if a polynomial can become zero under user restrictions
  97. % here a dummy to be rplaced elsewhere
  98. symbolic procedure groebzero(h,dummy);
  99. begin scalar l;
  100. dummy := nil;
  101. l:=vdplastmon h;
  102. if l and vevzero!? cdr l then return groebPosCancel h;
  103. return nil;
  104. end;
  105. symbolic procedure groebPosCancel(h);
  106. << groebmess24(h,nil,nil); 'CANCEL>>;
  107. endmodule;
  108. end;