123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123 |
- module groebrst;
-
- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- %
- % restrictions for polynomials during Groebner base calculation
- %
- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- fluid '(groebrestriction!*);
-
- symbolic procedure groebTestrestriction (h,arg);
- if groebrestriction!* = 'NONNEGATIVE then groebNonneg(h,arg)
- else
- if groebrestriction!* = 'POSITIVE then groebPos(h,arg)
- else
- if groebrestriction!* = 'ZEROPOINT then groebZero(h,arg)
- else
- rerror(groebnr2,9,
- "Groebner: general restrictions not yet implemented");
- symbolic procedure groebNonneg(h,arg);
- % test if h is a polynomial which can have the value zero with
- % only nonnegative variable settings.
- begin scalar x,break,vev1,vevl,problems,problems1,r;
- if vdpzero!? h then return nil
- else
- if vevzero!? vdpevlmon h then goto finish;
- % first test the coefficients
- if vdpredZero!? h then return nil; % simple monomial
- break := nil;
- x := h;
- while not vdpzero!? x and not break do
- <<vev1 := vdpevlmon x;
- if not vbcplus!? vdpLbc x then break := t;
- if not break then x := vdpred x>>;
- if break then return nil; % at least one negative coeff
- if vevzero!? vev1 then goto finish; % nonneg. solution imposs.
- % homogenous polynomial: find combinations of
- % variables which are solutions
- x := h;
- vev1 := vdpevlmon x;
- vevl := vevsplit(vev1);
- problems := for each x in vevl collect list x;
- x := vdpred x;
- while not vdpzero!? x do
- << vev1 := vdpevlmon x;
- vevl := vevsplit(vev1);
- problems1 := nil;
- for each e in vevl do
- for each p in problems do
- <<r := if not member(e,p) then e . p else p;
- problems1 := union(list r, problems1)>>;
- problems := problems1;
- x := vdpred x;
- >>;
- problems := % lift vevs to polynomials
- for each p in problems collect
- for each e in p collect
- vdpfmon(a2vbc 1,e);
- % rule out problems contained in others
- for each x in problems do
- for each y in problems do
- if not eq(x,y) and subset!?(x,y) then
- problems := delete (y,problems);
-
- % rule out some by cdr
- problems1 := nil;
- while problems do
- <<if vdpDisjoint!? (car problems,arg)
- then problems1 := car problems . problems1;
- problems := cdr problems;
- >>;
- finish:
- groebmess24(h,problems1,arg);
- return
- if null problems1 then 'CANCEL
- else 'restriction . problems1;
- end;
- symbolic procedure groebpos(h,dummy);
- % test if h is a polynomial which can have the value zero with
- % only positive (nonnegative and nonzero) variable settings.
- begin scalar x,break,vev1;
- dummy := nil;
- if vdpzero!? h then return nil
- else
- if vevzero!? vdpevlmon h then return nil;
- % a simple monomial can never have pos. zeros
- if vdpredzero!? h then return groebposcancel(h);
- break := nil;
- x := h;
- % test coefficients
- while not vdpzero!? x and not break do
- <<vev1 := vdpevlmon x;
- if not vbcplus!? vdpLbc x then break := t;
- if not break then x := vdpred x>>;
- if not break then return groebPosCancel(h);
- if not groebposvevaluate h then groebPosCancel(h);
- return nil;
- end;
- symbolic procedure groebposvevaluate h; <<h := nil; t>>;
- % test if a polynomial can become zero under user restrictions
- % here a dummy to be rplaced elsewhere
- symbolic procedure groebzero(h,dummy);
- begin scalar l;
- dummy := nil;
- l:=vdplastmon h;
- if l and vevzero!? cdr l then return groebPosCancel h;
- return nil;
- end;
- symbolic procedure groebPosCancel(h);
- << groebmess24(h,nil,nil); 'CANCEL>>;
- endmodule;
-
- end;
|