Artifact 916fc75c9455f2a459eea567d944737313f31bb25a04d94f4316eaa41efbfa94:
- Executable file
r37/packages/dipoly/expvec.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 6468) [annotate] [blame] [check-ins using] [more...]
module expvec; % /*Specific support for distributive polynomial exponent vectors*/ % /* Authors: R. Gebauer, A. C. Hearn, H. Kredel */ % We assume here that an exponent vector is a list of integers. This % version uses small integer arithmetic on the individual exponents % and assumes that a compiled function can be dynamically redefined*/ % Modification H. Melenk (August 1988) % 1. Most ev-routines handle exponent vectors with variable length: % the convention is, that trailing zeros may be omitted. % 2. evcompless!? is mapped to evcomp such that each term order mode % is supported by exactly one procedure entry. % 3. complete exponent vector compare collected in separate module % TORDER (TORD33) fluid '(dipsortmode!* dipvars!*); symbolic procedure evperm (e1,n); % /* Exponent vector permutation. e1 is an exponent vector, n is a % index list , a list of digits. evperm(e1,n) returns a list e1 % permuted in respect to n. */ if null n then nil else evnth(e1, car n) . evperm(e1, cdr n); symbolic procedure evcons (e1,e2); % /* Exponent vector construct. e1 and e2 are exponents. evcons(e1,e2) % constructs an exponent vector. */ e1 . e2; symbolic procedure evnth (e1,n); % /* Exponent vector n-th element. e1 is an exponent vector, n is a % digit. evnth(e1,n) returns the n-th element of e1, an exponent. */ if null e1 then 0 else if n = 1 then evfirst e1 else evnth(evred e1, n - 1); symbolic procedure evred e1; % /* Exponent vector reductum. e1 is an exponent vector. evred(e1) % returns the reductum of the exponent vector e1. */ if e1 then cdr e1 else NIL; symbolic procedure evfirst e1; % /* Exponent vector first. e1 is an exponent vector. evfirst(e1) % returns the first element of the exponent vector e1, an exponent. */ if e1 then car e1 else 0; symbolic procedure evsum0(n,p); % exponent vector sum version 0. n is the length of dipvars!*. % p is a distributive polynomial. if dipzero!? p then evzero1 n else evsum(dipevlmon p, evsum0(n,dipmred p)); symbolic procedure evzero1 n; % Returns the exponent vector power representation % of length n for a zero power. begin scalar x; for i:=1: n do << x := 0 . x >>; return x end; symbolic procedure indexcpl(ev,n); % returns a list of indexes of non zero exponents. if null ev then ev else ( if car ev = 0 then indexcpl(cdr ev,n + 1) else ( n . indexcpl(cdr ev,n + 1)) ); symbolic procedure evzer1!? e; % returns a boolean expression. true if e is null else false. null e; symbolic procedure evzero!? e; % /* Returns a boolean expression. True if all exponents are zero*/ null e or car e = 0 and evzero!? cdr e; symbolic procedure evzero; % /* Returns the exponent vector representation for a zero power*/ % for i := 1:length dipvars!* collect 0; begin scalar x; for i := 1:length dipvars!* do <<x := 0 . x>>; return x end; symbolic procedure mkexpvec u; % /* Returns an exponent vector with a 1 in the u place*/ if not(u member dipvars!*) then typerr(u,"dipoly variable") else for each x in dipvars!* collect if x eq u then 1 else 0; symbolic procedure evlcm (e1,e2); % /* Exponent vector least common multiple. e1 and e2 are % exponent vectors. evlcm(e1,e2) computes the least common % multiple of the exponent vectors e1 and e2, and returns % an exponent vector. */ % for each lpart in e1 each rpart in e2 collect % if lpart #> rpart then lpart else rpart; begin scalar x; while e1 and e2 do <<x := (if car e1 #> car e2 then car e1 else car e2) . x; e1 := cdr e1; e2 := cdr e2>>; return reversip x end; symbolic procedure evmtest!? (e1,e2); % /* Exponent vector multiple test. e1 and e2 are compatible exponent % vectors. evmtest!?(e1,e2) returns a boolean expression. % True if exponent vector e1 is a multiple of exponent % vector e2, else false. */ if e1 and e2 then not(car e1 #< car e2) and evmtest!?(cdr e1,cdr e2) else evzero!? e2 ; symbolic procedure evsum (e1,e2); % /* Exponent vector sum. e1 and e2 are exponent vectors. % evsum(e1,e2) calculates the sum of the exponent vectors. % e1 and e2 componentwise and returns an exponent vector. */ % for each lpart in e1 each rpart in e2 collect lpart #+ rpart; begin scalar x; while e1 and e2 do <<x := (car e1 #+ car e2) . x; e1 := cdr e1; e2 := cdr e2>>; x := reversip x; return if e1 then nconc(x,e1) else if e2 then nconc(x,e2) else x; end; symbolic procedure evdif (e1,e2); % /* Exponent vector difference. e1 and e2 are exponent % vectors. evdif(e1,e2) calculates the difference of the % exponent vectors e1 and e2 componentwise and returns an % exponent vector. */ % for each lpart in e1 each rpart in e2 collect lpart #- rpart; begin scalar x; while e2 do <<if null e1 then e1 := '(0); x := (car e1 #- car e2) . x; e1 := cdr e1; e2 := cdr e2>>; return nconc (reversip x,e1); end; symbolic procedure intevprod(n,e); % /* Multiplies each element of the exponent vector u by the integer n*/ for each x in e collect n #* x; symbolic procedure expvec2a e; % /* Returns list of prefix equivalents of exponent vector e*/ expvec2a1(e,dipvars!*); symbolic procedure expvec2a1(u,v); % /* Sub function of expvec2a */ if null u then nil else if car u = 0 then expvec2a1(cdr u,cdr v) else if car u = 1 then car v . expvec2a1(cdr u,cdr v) else list('expt,car v,car u) . expvec2a1(cdr u,cdr v); symbolic procedure dipevlpri(e,v); % /* Print exponent vector e in infix form. V is a boolean variable % which is true if an element in a product has preceded this one*/ dipevlpri1(e,dipvars!*,v); symbolic procedure dipevlpri1(e,u,v); % /* Sub function of dipevlpri */ if null e then nil else if car e = 0 then dipevlpri1(cdr e,cdr u,v) else <<if v then dipprin2 "*"; if atom car u or null get(caar u,'dipprifn) then dipprin2 car u else apply1(get(caar u,'dipprifn),car u); if car e #> 1 then <<dipprin2 "**"; dipprin2 car e>>; dipevlpri1(cdr e,cdr u,t)>>; endmodule; end;