Artifact 5e70471ced7b43e1b9118ae4385701f0fa20230ea00f0b33ea6b23bc216f25c4:
- Executable file
r37/packages/algint/precoats.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: 7931) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/algint/precoats.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: 7931) [annotate] [blame] [check-ins using]
module precoats; % Author: James H. Davenport. fluid '(!*tra basic!-listofallsqrts basic!-listofnewsqrts sqrt!-intvar taylorvariable thisplace); exports precoates; imports mksp,algint!-subf,subzero2,substitutesq,removeduplicates, printsq,basicplace,extenplace,interr,get!-correct!-sqrts, printplace,simptimes,subzero,negsq,addsq,involvesq,taylorform, taylorevaluate,mk!*sq,!*exptsq,!*multsq,!*invsq,sqrt2top, jfactor,sqrtsave,antisubs; symbolic procedure infsubs(w); if caar w = thisplace then (cdar w).(cdr w) else (thisplace.(car w)).(cdr w); % thisplace is (z quotient 1 z) so we are moving to infinity. symbolic procedure precoates(residues,x,movedtoinfinity); begin scalar answer,placeval,reslist,placelist,placelist2,thisplace; reslist:=residues; placelist:=nil; while reslist do << % car reslist = <substitution list>.<value>; placeval:=algint!-subf((mksp(x,1) .* 1) .+ nil,caar reslist); if 0 neq cdar reslist then if null numr subzero2(denr placeval,x) then << if null answer then answer:='infinity else if answer eq 'finite then answer:='mixed; if !*tra then printc "We have an residue at infinity" >> else << if null answer then answer:='finite else if answer eq 'infinity then answer:='mixed; placelist:=placeval.placelist; if !*tra then printc "This is a finite residue" >>; reslist:=cdr reslist >>; if answer eq 'mixed then return answer; if answer eq 'infinity then << thisplace:=list(x,'quotient,1,x); % maps x to 1/x. answer:=precoates(for each u in residues collect infsubs u,x,t); % derivative of 1/x is -1/x**2. if atom answer then return answer else return substitutesq(answer,list(thisplace)) >>; placelist2:=removeduplicates placelist; answer := 1 ./ 1; % the null divisor. if !*tra then << printc "The divisor has elements at:"; for each j in placelist2 collect printsq j>>; while placelist2 do begin scalar placelist3,extrasubs,u,bplace; % loop over all distinct places. reslist:=residues; placelist3:=placelist; placeval:=nil; while reslist do << if car placelist2 = car placelist3 then << placeval:=(cdar reslist).placeval; thisplace:= caar reslist; % the substitutions defining car placelist. u:=caar reslist; bplace:=basicplace u; u:=extenplace u; extrasubs:=u.extrasubs >>; reslist:=cdr reslist; placelist3:=cdr placelist3 >>; % placeval is a list of all the residues at this place. if !*tra then << princ "List of multiplicities at this place:"; printc placeval; princ "with substitutions:"; superprint extrasubs >>; if 0 neq mapply(function plus2,placeval) then interr "Divisor not effective"; get!-correct!-sqrts bplace; u:=pbuild(x,extrasubs,placeval); sqrtsave(basic!-listofallsqrts,basic!-listofnewsqrts,bplace); if atom u then << placelist2:=nil; % set to terminate loop. answer:=u >> else << answer:=substitutesq(!*multsq(answer,u),antisubs(thisplace,x)); placelist2:=cdr placelist2 >> end; % loaded in pbuild to check for poles at the correct places. return answer end; symbolic procedure dlist(u); % Given a list of lists,converts to a list. if null u then nil else if null car u then dlist cdr u else append(car u,dlist cdr u); symbolic procedure debranch(extrasubs,reslist); begin scalar substlist; % remove spurious substitutions. for each u in dlist extrasubs do if not ((car u) member substlist) then substlist:=(car u).substlist; % substlist is a list of all the possible substitutions). while substlist do begin scalar tsqrt,usqrt; scalar with1,with2,without1,without2,wres; scalar a1,a2,b1,b2; % decide if tsqrt is redundant. tsqrt:=car substlist; substlist:=cdr substlist; wres:=reslist; for each place in extrasubs do << usqrt:=assoc(tsqrt,place); % usqrt is s.s' or s.(minus s'). if null usqrt then interr "Places not all there"; if cadr usqrt eq 'sqrt then<< with2:=(car wres).with2; with1:=delete(usqrt,place).with1>> else<< if not (cadr usqrt eq 'minus) then interr "Ramification format error"; without2:=(car wres).without2; without1:=delete(usqrt,place).without1 >>; wres:=cdr wres>>; % first see if one item appears passim. if null with1 then go to itswithout; if null without1 then go to itswith; % Now must see if WITH2 matches WITHOUT2 in order WITH1/WITHOUT1. a1:=with1; a2:=with2; outerloop: b1:=without1; b2:=without2; innerloop: if (car a1) = (car b1) then << if (car a2) neq (car b2) then return nil else go to outeriterate >>; b1:=cdr b1; b2:=cdr b2; if null b1 then return nil else go to innerloop; % null b1 => lists do not match at all. outeriterate: a1:=cdr a1; a2:=cdr a2; if a1 then go to outerloop; if !*tra then << princ "Residues reduce to:"; printc without2; printc "at "; mapc(without1,function printplace) >>; extrasubs:=without1; reslist:=without2; return; itswithout: % everything is in the "without" list. with1:=without1; with2:=without2; itswith: % remove usqrt from the with lists. extrasubs:=for each u in with1 collect delete(assoc(tsqrt,u),u); if !*tra then << printc "The following appears throughout the list "; printc tsqrt >>; reslist:=with2 end; return extrasubs.reslist end; symbolic procedure pbuild(x,extrasubs,placeval); begin scalar multivals,u,v,answer; u:=debranch(extrasubs,placeval); extrasubs:=car u; placeval:=cdr u; % remove spurious entries. if (length car extrasubs) > 1 then return 'difficult; % hard cases not allowed for. multivals := mapovercar dlist extrasubs; u:=simptimes removeduplicates multivals; answer:= 1 ./ 1; while extrasubs do << v:=substitutesq(u,car extrasubs); v:=!*addsq(u,negsq subzero(v,x)); v:=mkord1(v,x); if !*tra then << princ "Required component is "; printsq v >>; answer:=!*multsq(answer,!*exptsq(v,car placeval)); % place introduced with correct multiplicity. extrasubs:=cdr extrasubs; placeval:=cdr placeval >>; if length jfactor(denr sqrt2top !*invsq answer,x) > 1 then return 'many!-poles else return answer end; symbolic procedure findord(v,x); begin scalar nord,vd; %given v(x) with v(0)=0, makes v'(0) nonzero. nord:=0; taylorvariable:=x; while involvesq(v,sqrt!-intvar) do v:=substitutesq(v,list(x.list('expt,x,2))); vd:=taylorform v; loop: nord:=nord+1; if null numr taylorevaluate(vd,nord) then go to loop; return nord end; symbolic procedure mkord1(v,x); begin scalar nord; nord:=findord(v,x); if nord iequal 1 then return v; if !*tra then << princ "Order reduction: "; printsq v; princ "from order "; princ nord; printc " to order 1" >>; % Note that here we do not need to simplify, since SIMPLOG will % remove all these SQRTs or EXPTs later. return !*p2q mksp(list('nthroot,mk!*sq v,nord),1) end; endmodule; end;