Artifact c5afe1eceda880cb96f4fe287cfcd8dd15924bdde1358a083d4d6380cc1836d6:
- Executable file
r38/packages/matrix/nestdom.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: 5170) [annotate] [blame] [check-ins using] [more...]
module nestdom; % nested domain: domain elements are standard quotients % coefficients are taken from the integers or another % dnest. % Original version by Herbert Melenk, 1993(?) % Improved version with Rainer mod. % Changes to nestlevel, nestdmode and nestsq by Winfried Neun, 1998. %%%%%%%%% % Adaption to allow convertion between arnum and nested. %%%%%%%%% symbolic procedure ident(x);x; put('!:ar!:,'!:nest!:,'ident); %%%%%%%%% % data structure: % a domain element is a list % ('!:nest!: level# dmode* . sq) smacro procedure nestlevel u; if fixp u then 0 else cadr u; smacro procedure nestdmode u; if fixp u then nil else caddr u; smacro procedure nestsq u; if fixp u then simp u else cdddr u; global '(domainlist!*); fluid '(alglist!* nestlevel!*); nestlevel!* := 0; switch nested; domainlist!* := union('(!:nest!:),domainlist!*); put('nested,'tag,'!:nest!:); put('!:nest!:,'dname,'nested); flag('(!:nest!:),'field); flag('(!:nest!:),'convert); put('!:nest!:,'i2d,'!*i2nest); %put('!:nest!:,'!:bf!:,'nestcnv); %put('!:nest!:,'!:ft!:,'nestcnv); %put('!:nest!:,'!:rn!:,'nestcnv); put('!:nest!:,'!:bf!:,mkdmoderr('!:nest!:,'!:bf!:)); put('!:nest!:,'!:ft!:,mkdmoderr('!:nest!:,'!:ft!:)); put('!:nest!:,'!:rn!:,mkdmoderr('!:nest!:,'!:rn!:)); put('!:nest!:,'minusp,'nestminusp!:); put('!:nest!:,'plus,'nestplus!:); put('!:nest!:,'times,'nesttimes!:); put('!:nest!:,'difference,'nestdifference!:); put('!:nest!:,'quotient,'nestquotient!:); put('!:nest!:,'divide,'nestdivide!:); % put('!:nest!:,'gcd,'nestgcd!:); put('!:nest!:,'zerop,'nestzerop!:); put('!:nest!:,'onep,'nestonep!:); % put('!:nest!:,'factorfn,'factornest!:); put('!:nest!:,'prepfn,'nestprep!:); put('!:nest!:,'prifn,'prin2); put('!:rn!:,'!:nest!:,'rn2nest); symbolic procedure !*i2nest u; %converts integer u to nested form; if domainp u then u else '!:nest!: . 0 . dmode!* . (u ./ 1); symbolic procedure rn2nest u; %converts integer u to nested form; if domainp u then u else '!:nest!: . 0 . dmode!* . (cdr u); symbolic procedure nestcnv u; rederr list("Conversion between `nested' and", get(car u,'dname),"not defined"); symbolic procedure nestminusp!: u; nestlevel u = 0 and minusf car nestsq u; symbolic procedure sq2nestedf sq; '!:nest!: . nestlevel!* . dmode!* . sq; symbolic procedure nest2op!:(u,v,op); (begin scalar r,nlu,nlv,nlr,dm,nestlevel!*; nlu := if not eqcar (u,'!:nest!:) then 0 else nestlevel u; nlv := if not eqcar (v,'!:nest!:) then 0 else nestlevel v; if nlu = nlv then goto case1 else if nlu #> nlv then goto case2 else goto case3; case1: % same level for u and v dm := nestdmode u; if dm then setdmode(dm,t); nlr := nlu; nestlevel!* := nlu - 1; r := apply(op,list(nestsq u,nestsq v)); goto ready; case2: % v below u dm := nestdmode u; if dm then setdmode(dm,t); nlr := nlu; nestlevel!* := nlv; r := apply(op,list (nestsq u, v ./ 1)); goto ready; case3: % u below v dm := nestdmode v; if dm then setdmode(dm,t); nlr := nlv; nestlevel!* := nlu; r := apply(op,list (u ./ 1,nestsq v)); ready: r := if null numr r then nil % The next line was commented out for a while, but is % needed for the normform tests. else if domainp numr r and denr r = 1 then numr r else '!:nest!: . nlr . dm . r; if dm then setdmode (dm,nil); return r; end ) where dmode!* = nil; symbolic procedure nestplus!:(u,v); nest2op!:(u,v,'addsq); symbolic procedure nesttimes!:(u,v); nest2op!:(u,v,'multsq); symbolic procedure nestdifference!:(u,v); nest2op!:(u,v,function (lambda(x,y); addsq(x,negsq y))); symbolic procedure nestdivide!:(u,v); nest2op!:(u,v,'quotsq) . 1; % symbolic procedure nestgcd!:(u,v); !*i2nest 1; symbolic procedure nestquotient!:(u,v); nest2op!:(u,v,'quotsq); symbolic procedure nestzerop!: u; null numr nestsq u; symbolic procedure nestonep!: u; (car v = 1 and cdr v = 1) where v = nestsq u; initdmode 'nested; % nested routines are defined in the gennest nestule with the exception % of the following: symbolic procedure setnest u; begin u := reval u; if not fixp u then typerr(u,"nestulus"); nestlevel!* := u; end; flag('(setnest),'opfn); %to make it a symbolic operator; flag('(setnest),'noval); algebraic operator co; symbolic procedure simpco u; % conmvert an expression to a nested coefficient begin scalar sq,lev; if not (length u = 2 and fixp car u) then typerr(u,"nested coefficient"); sq := simp cadr u; lev := car u; return (if null numr sq then nil else ('!:nest!: . lev . dmode!* . sq)) ./ 1; end; put('co,'simpfn,'simpco); symbolic procedure nestprep!: u; list('co,nestlevel u,prepsq nestsq u); endmodule; end;