reduce-historical/r38/packages/poly/cpxrn.red

module cpxrn; % *** Support for Complex Rationals.

% Authors: Anthony C. Hearn and Stanley L. Kameny.

% Copyright (c) 1989 The RAND Corporation.  All rights reserved.

Comment this module defines a complex rational as:

      (<tag>. (<structure> . <structure>>).

The <tag> is '!:crn!: and the <structure> is (n . d) where n and d are
integers;

fluid '(!:prec!:);

global '(bfone!* epsqrt!*);

fluid '(dmode!* !*bfspace !*numval);

switch bfspace,numval; !*bfspace := !*numval := t;

global '(domainlist!*);

domainlist!* := union('(!:crn!:),domainlist!*);

fluid '(!*complex!-rational);

put('complex!-rational,'tag,'!:crn!:);
put('!:crn!:,'dname,'complex!-rational);
flag('(!:crn!:),'field);
put('!:crn!:,'i2d,'i2crn!*);
put('!:crn!:,'plus,'crn!:plus);
put('!:crn!:,'times,'crn!:times);
put('!:crn!:,'difference,'crn!:differ);
put('!:crn!:,'quotient,'crn!:quotient);
put('!:crn!:,'zerop,'crn!:zerop);
put('!:crn!:,'onep,'crn!:onep);
put('!:crn!:,'prepfn,'crn!:prep);
put('!:crn!:,'prifn,'crn!:prin);
put('!:crn!:,'minus,'crn!:minus);
put('!:crn!:,'factorfn,'crn!:factor);
put('!:crn!:,'rationalizefn,'girationalize!:);
put('!:crn!:,'!:rn!:,'!*crn2rn);
put('!:rn!:,'!:crn!:,'!*rn2crn);
put('!:rd!:,'!:crn!:,'!*rd2crn);
put('!:crn!:,'!:rd!:,'!*crn2rd);
put('!:gi!:,'!:crn!:,'!*gi2crn);
put('!:crn!:,'cmpxfn,'mkcrn);
put('!:crn!:,'ivalue,'mkdcrn);
put('!:crn!:,'intequivfn,'crnequiv);
put('!:crn!:,'realtype,'!:rn!:);
put('!:rn!:,'cmpxtype,'!:crn!:);

put('!:crn!:,'minusp,'crn!:minusp);

symbolic procedure crn!:minusp u; caddr u=0 and minusp caadr u;

symbolic procedure mkcrn(u,v); '!:crn!: . u . v;

symbolic smacro procedure crntag x; '!:crn!: . x;

symbolic smacro procedure rntag x; '!:rn!: . x;

symbolic smacro procedure crnrl x; cadr x;

symbolic smacro procedure crnim x; cddr x;

symbolic procedure crn!:simp u; (crntag u) ./ 1;

put('!:crn!:,'simpfn,'crn!:simp);

symbolic procedure mkdcrn u;
   ('!:crn!: . ((0 . 1) . (1 . 1))) ./ 1;

symbolic procedure i2crn!* u; mkcrn(u . 1,0 . 1);
   %converts integer U to tagged crn form.

symbolic procedure !*crn2rn n;
   % Converts a crn number n into a rational if possible.
   if not(car crnim n=0) then cr2rderr() else '!:rn!: . crnrl n;

symbolic procedure !*rn2crn u; mkcrn(cdr u,0 . 1);
   % Converts the (tagged) rational u/v into a (tagged) crn.

symbolic procedure !*crn2rd n;
   if not(car crnim n=0) then cr2rderr() else
     mkround chkrn!* r2bf crnrl n;

symbolic procedure !*rd2crn u; mkcrn(realrat x,0 . 1) where x=round!* u;

symbolic procedure !*gi2crn u; mkcrn((cadr u) . 1,(cddr u) . 1);

symbolic procedure crn!:plus(u,v);
   mkcrn(cdr rnplus!:(rntag crnrl u,rntag crnrl v),
         cdr rnplus!:(rntag crnim u,rntag crnim v));

symbolic procedure crn!:differ(u,v);
   mkcrn(cdr rndifference!:(rntag crnrl u,rntag crnrl v),
         cdr rndifference!:(rntag crnim u,rntag crnim v));

symbolic procedure crn!:times(u,v);
   mkcrn(cdr rndifference!:(rntimes!:(ru,rv),rntimes!:(iu,iv)),
         cdr rnplus!:(rntimes!:(ru,iv),rntimes!:(rv,iu)))
   where ru=rntag crnrl u,iu=rntag crnim u,
         rv=rntag crnrl v,iv=rntag crnim v;

symbolic procedure crn!:quotient(u,v);
 <<v := rnplus!:(rntimes!:(rv,rv),rntimes!:(iv,iv));
  mkcrn(cdr rnquotient!:(rnplus!:(rntimes!:(ru,rv),rntimes!:(iu,iv)),v),
cdr rnquotient!:(rndifference!:(rntimes!:(iu,rv),rntimes!:(ru,iv)),v))>>
  where ru=rntag crnrl u,iu=rntag crnim u,
        rv=rntag crnrl v,iv=rntag crnim v;

symbolic procedure crn!:minus u;
   mkcrn((-car ru) . cdr ru,(-car iu) . cdr iu)
   where ru=crnrl u,iu=crnim u;

symbolic procedure crn!:zerop u; car crnrl u=0 and car crnim u=0;

symbolic procedure crn!:onep u;  car crnim u=0 and crnrl u='(1 . 1);

symbolic procedure crn!:prep u;
   crnprep1((rntag crnrl u) . rntag crnim u);

symbolic procedure crn!:factor u;
   (begin scalar m,n,p,x,y;
     setdmode('rational,nil) where !*msg = nil;
     x := subf(u,nil);
     y := fctrf numr x;
     n := car y;
     setdmode('rational,t) where !*msg = nil;
     y := for each j in cdr y collect
           <<p := numr subf(car j,nil);
             n := multd(n,m := exptf(lnc ckrn p,cdr j));
             quotfd(p,m) . cdr j>>;
     return int!-equiv!-chk quotfd(n,denr x) . y
   end) where dmode!*=dmode!*;

symbolic procedure crnprimp u;
   if rnonep!: u then 'i
   else if rnonep!: rnminus!: u then list('minus,'i)
   else list('times,rnprep!: u,'i);

symbolic procedure crnprep1 u;
   if rnzerop!: cdr u then rnprep!: car u
   else if rnzerop!: car u then crnprimp cdr u
   else if rnminusp!: cdr u
      then list('difference,rnprep!: car u,crnprimp rnminus!: cdr u)
   else list('plus,rnprep!: car u,crnprimp cdr u);

symbolic procedure crn!:prin u;
   (if atom v or car v eq 'times or car v memq domainlist!*
      then maprin v
    else <<prin2!* "("; maprin v; prin2!* ")">>) where v=crn!:prep u;

symbolic procedure crnequiv u;
   % Returns an equivalent integer if possible.
   if cadr(u := cdr u) = 0 and cdar u = 1 then caar u else nil;

initdmode 'complex!-rational;

endmodule;

end;