Artifact 9190ec946618d9b77a8bd266fe02e34b1fd8bc6c35ddd940877b2ca205a8458e:
- Executable file
r37/packages/tps/tps.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: 12454) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/tps/tps.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: 12454) [annotate] [blame] [check-ins using]
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;