File r38/packages/tps/tps.red artifact 9190ec9466 part of check-in 12412d85b9


module tps; % Extendible Power Series.

% Author: Alan Barnes <barnesa@aston.ac.uk>.
% Version 1.54 January 1996.
% 
% A power series object is a tagged tuple of the following form:
%
% (:ps: . [<order>,
%          <last-term>,
%          <variable>,
%          <expansion-point>,
%          <value>,
%          <terms>,
%          <ps-expression
%          <simplification flag>])
%
% <order> is the exponent of the first term of the series and is also   
%          used to modify the index when accessing components of the 
%          series which are addressed by power
%
% <last-term> the power of the last term generated in the series so far
%             used in evaluator when computing new terms
%
% <variable> is the dependent variable of this expansion, needed, in
%          particular, for printing and when combining two series
%
% <expansion!-point> is self-explanatory except that
%          ps!:inf denotes expansion about infinity
%
% <value>  is the originating prefix form which is needed to allow for
%          power series variables appearing inside other power series
%          expressions
%
% <terms>  is an alist containing the terms of the series computed so
%          far, access is controlled using <order> as an index base.
%
% <ps-expression> is a power series object corresponding to the prefix
%          form of which the expansion was requested, the first element
%          of which is the ps!:operator and the rest of which are the
%          ps!:operands which may themselves be pso's
%
% <simplification flag> used to indicate whether power series object 
%                       needs re-simplifying = sqvar
%
% In addition we have the following degenerate forms of power series
% object:
%        <number>
%        (!:ps!: . <identifier>)  the value of <identifier> is a vector
%        as above(used in automatically generated recurrence relations)
%        <identifier>   2nd argument of DF, INT etc.
%
% The last two should never appear at top-level in any power series
% object

create!-package('(tps tpscomp tpseval tpsdom tpsfns tpsrev 
                  tpssum tpsmisc tpsconv),
                '(contrib tps));

fluid '(ps!:exp!-lim  knownps ps!:level  ps!:max!-order);

% Some structure selectors and referencers.

symbolic smacro procedure rands e;
  cdr e;

symbolic smacro procedure rand1 e;
   cadr e;

symbolic smacro procedure rand2 e;
   caddr e;

symbolic smacro procedure rator e;
  car e;

symbolic smacro procedure ps!:domainp u;
   atom u or (car u neq '!:ps!:) and not listp u;

symbolic smacro procedure ps!:p u;
  pairp u and (car u = '!:ps!:);

symbolic smacro procedure ps!:atom u;
   atom u or (car u neq '!:ps!: and get(car u,'dname));

symbolic smacro procedure ps!:numberp u;
   numberp u or (pairp u and car u neq '!:ps!: and get(car u,'dname));

symbolic procedure constantpsp u;
     ps!:numberp u or ps!:expression u eq 'psconstant;

symbolic procedure ps!:getv(ps,i);
   if eqcar(ps,'!:ps!:) then
        if idp cdr ps then getv(eval cdr ps,i)
        else getv(cdr ps,i)
   else rerror(tps,1,list("PS:GETV: not a ps",ps));

symbolic procedure ps!:putv(ps,i,v);
     if eqcar(ps,'!:ps!:) then
        if idp cdr ps then putv(eval cdr ps,i,v)
        else putv(cdr ps,i,v)
     else rerror(tps,2,list("PS:PUTV: not a ps",ps));

symbolic procedure ps!:order ps;
   if ps!:atom ps then 0
   else ps!:getv(ps,0);

symbolic smacro procedure ps!:set!-order(ps,n);
   ps!:putv(ps,0,n);

symbolic procedure ps!:last!-term ps;
   if ps!:atom ps then ps!:max!-order
   else  ps!:getv(ps,1);

symbolic (ps!:max!-order:= 2147483647);
% symbolic here seems to be essential in Cambridge Lisp systems

symbolic smacro procedure ps!:set!-last!-term (ps,n);
   ps!:putv(ps,1,n);

symbolic procedure ps!:depvar ps;
   if ps!:atom ps then nil
   else ps!:getv(ps,2);

symbolic smacro procedure ps!:set!-depvar(ps,x);
   ps!:putv(ps,2,x);

symbolic procedure ps!:expansion!-point ps;
   if ps!:atom ps then nil
   else ps!:getv(ps,3);

symbolic smacro procedure ps!:set!-expansion!-point(ps,x);
   ps!:putv(ps,3,x);

symbolic procedure ps!:value ps;
   if ps!:atom ps then if ps then ps else 0
   else ps!:getv(ps,4);

symbolic smacro procedure ps!:set!-value(ps,x);
   ps!:putv(ps,4,x);

symbolic smacro procedure ps!:terms ps;
   if ps!:atom ps then list (0 . ( ps . 1))
   else ps!:getv(ps,5);

symbolic smacro procedure ps!:set!-terms(ps,x);
   ps!:putv(ps,5,x);

symbolic procedure ps!:expression ps;
   if ps!:atom ps then ps
   else ps!:getv(ps,6);

symbolic smacro procedure ps!:set!-expression(ps,x);
   ps!:putv(ps,6,x);

symbolic smacro procedure ps!:operator ps;
   car ps!:getv(ps,6);

symbolic smacro procedure ps!:operands ps;
   cdr ps!:getv(ps,6);

symbolic procedure ps!:get!-term(ps,i);
    (lambda(psorder, pslast);
       if i<psorder then nil ./ 1
       else if i>pslast then nil
       else begin scalar term;
               term:=assoc(i-psorder, ps!:terms ps);
               return if term then cdr term
                      else nil ./ 1;
            end)
    (ps!:order ps, ps!:last!-term ps);

symbolic procedure ps!:set!-term(ps,n,x);
% it is only safe to set terms of order >= order of series
% and order > last!-term of series, otherwise mathematical
% inconsistencies could arise.  
% Value of last!-term now updated automatically by this procedure
begin scalar psorder, terms;
   psorder := ps!:order ps;
   if n < psorder then
      rerror(tps,3,list (n, "less than the order of ", ps))
   else if n <= ps!:last!-term ps then
      rerror(tps,4,list (n, "less than power of last term of ", ps));
   terms := ps!:terms ps;
   if atom x or (numr x neq nil) then
      % atom test is relevant only for ps!:generating!-series
      if terms then nconc(terms,list((n-psorder).x))
      else ps!:set!-terms(ps,list((n-psorder).x))
   else if n=psorder then
      ps!:set!-order(ps,n+1);
   ps!:set!-last!-term(ps,n);
end;

symbolic operator pstruncate;

symbolic procedure pstruncate(ps,n);
<< n := ieval n;
   ps := prepsqxx simp!* ps;
   if ps!:numberp ps then
       if n geq 0 then 
         if atom ps then ps else apply1(get(car ps, 'prepfn), ps)
       else 0
   else if ps!:p ps then
      prep!:ps(ps, n)    
   else typerr(ps, "power series:  truncate")
>>;

put('psexplim, 'simpfn, 'simppsexplim);

symbolic (ps!:exp!-lim := 6); % default depth of expansion
% symbolic here seems to be essential in Cambridge Lisp systems

symbolic procedure simppsexplim u;
 begin integer n;
    n:=ps!:exp!-lim;
    if u then ps!:exp!-lim := ieval carx(u,'psexplim);
    return (if n=0 then nil ./ 1 else n ./ 1);
 end;

symbolic procedure simpps a;
    if length a = 3 then apply('simpps1,a)
    else rerror(tps,5,
          "Args should be <FORM>,<depvar>, and <point>:  simpps");

put('ps,'simpfn,'simpps);

symbolic procedure simpps1(form,depvar,about);
  if form=nil then
     rerror(tps,6,"Args should be <FORM>,<depvar>, and <point>: simpps")
  else if not kernp simp!* depvar then
     typerr(depvar, "kernel:  simpps")
  else if  smember(depvar,(about:=prepsqxx simp!* about)) then
     rerror(tps,7,"Expansion point depends on depvar:  simpps")
  else 
     begin scalar knownps, ps!:level;
        ps!:level := 0;
        return ps!:compile(ps!:presimp form, depvar,
                           if about='infinity then 'ps!:inf else about)
                    ./ 1
     end;

put('psterm,'simpfn,'simppsterm);

symbolic procedure simppsterm a;
  if length a=2 then apply('simppsterm1, a)
  else
     rerror(tps,8,
            "Args should be of form <power series>,<term>: simppsterm");

symbolic procedure simppsterm1(p,n);
 << n := ieval n;
    p := prepsqxx simp!* p;
    if ps!:numberp p then
       if n neq 0 or p=0 then nil ./ 1 else p ./ 1
    else if ps!:p p then
       << ps!:find!-order p; ps!:evaluate(p,n)>>
    else typerr(p, "power series:  simppsterm1")
 >>;

put('psorder,'simpfn,'simppsorder);
put('pssetorder,'simpfn,'simppssetorder);

symbolic procedure simppsorder u;
  << u := prepsqxx simp!* carx(u,'psorder);
     if ps!:numberp u then
        if u=0 then !*k2q 'undefined else nil ./ 1
     else if ps!:p u then
        !*n2f ps!:find!-order u ./ 1
     else typerr(u,"power series:  simppsorder")
  >>;

symbolic procedure simppssetorder u;
  (lambda (psord,ps);
    if not ps!:p ps then typerr(ps,"power series: simppssetorder")
    else if not fixp psord then
        typerr(psord, "integer: simppssetorder")
    else <<u := ps!:order ps;
           ps!:set!-order(ps,psord);
           (if u=0 then nil else u) ./ 1>>)
  (prepsqxx simp!* carx(cdr u,'pssetorder), prepsqxx simp!* car u);

put('psexpansionpt,'simpfn,'simppsexpansionpt);

symbolic procedure simppsexpansionpt u;
  << u:=prepsqxx simp!* carx(u,'psexpansionpt);
     if ps!:numberp u then !*k2q 'undefined
     else if ps!:p u then
        (lambda about;
                if about neq 'ps!:inf then
                   if about then simp!* about else !*k2q 'undefined
                else !*k2q 'infinity )
        (ps!:expansion!-point u)
     else typerr(u,"power series:  simppsexpansionpt")
  >>;

put('psdepvar,'simpfn,'simppsdepvar);

symbolic procedure simppsdepvar u;
  << u := prepsqxx simp!* carx(u,'psdepvar);
     if ps!:numberp u then !*k2q 'undefined
     else if ps!:p u then 
            if (u:=ps!:depvar u) then !*k2q u else !*k2q 'undefined
     else typerr(u,"power series:  simppsdepvar")
  >>;

put('psfunction,'simpfn,'simppsfunction);

symbolic procedure simppsfunction u;
  << u := prepsqxx simp!* carx(u,'psfunction);
     if ps!:numberp u then u ./ 1
     else if ps!:p u then simp!* ps!:value u
     else typerr(u,"power series:  simppsfunction")
  >>;

symbolic procedure ps!:presimp form;
 if (pairp form) and
    ((rator form = 'expt) or (rator form = 'int)) then
        list(rator form, prepsort rand1 form, prepsort rand2 form)
 else prepsort form;

symbolic procedure prepsort u;
  % Improves log handling if logsort is defined.  S.L. Kameny.
  if getd 'logsort then logsort u else prepsqxx simp!* u;

symbolic procedure !*pre2dp u;
begin scalar x;
    u:=simp!* u;
    return  if fixp denr u then
               if denr u = 1 and domainp(x := numr u) then x
            else if fixp numr u then mkrn(numr u, denr u)
end;

flag('(!:ps!:),'full);

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

symbolic procedure simp!:ps!: ps;
      simp!:ps1 ps ./ 1;

symbolic procedure simp!:ps1 ps;
 if atom ps or car ps neq '!:ps!: or idp cdr ps then ps
 else if car getv(cdr ps,7) and null !*resimp then ps
 else
    begin scalar terms, simpfn, ex;
      ex := ps!:expression ps;
      if (pairp ex and rator ex ='psgen) then
           simpfn:= 'simp!:ps1
      else simpfn:= 'resimp;
      terms:=ps!:terms ps;
      % next operation depends on fact that terms are stored in an
      % association list
      ps!:set!-terms(ps,
                     foreach term in terms
                       collect (car term . apply1(simpfn, cdr term)));
      if atom ex or rator ex = 'ps!:summation then nil
      else<<ps!:set!-expression(ps,
                      (rator ex) . mapcar(cdr ex, 'simp!:ps1));
            ps!:set!-value(ps,prepsqxx simp!* ps!:value ps)>>;
      putv(cdr ps,7,!*sqvar!*);
      return ps
    end;

put('pschangevar,'simpfn,'simppschangevar);

symbolic procedure simppschangevar u;
  (lambda (newvar, ps, oldvar);
     if not ps!:p ps then
        typerr(ps,"power series: simppschangevar")
     else if not kernp newvar then
        typerr(prepsqxx newvar, "kernel: simppschangevar")
     else
        <<oldvar:= ps!:depvar ps; 
          newvar:= prepsqxx newvar;
          if smember(newvar,ps!:value ps) and newvar neq oldvar then
               rerror(tps,9,"Series depends on new variable")
          else if oldvar then
             <<ps!:set!-depvar(ps,newvar);
               ps!:set!-value(ps, subst(newvar,oldvar,ps!:value ps));
               ps ./ 1
             >>
          else rerror(tps,10,"Can't change variable of constant series")
        >>)
   (simp!* carx(cdr u,'pschangevar), prepsqxx simp!* car u,nil);

endmodule;

end;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]