File r38/packages/int/trialdiv.red artifact 9fe0b6a42c part of check-in 1feb677270

module trialdiv;  % Trial division routines.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(!*trint intvar loglist tanlist);

exports countz,findsqrts,findtrialdivs,trialdiv,simp,mksp;

imports !*multf,printsf,quotf;

symbolic procedure countz dl;
% DL is a list of S.F.s;
    begin         scalar s,n,rl;
loop2:  if null dl then return arrangelistz rl;
        n:=1;
loop1:  n:=n+1;
        s:=car dl;
        dl:=cdr dl;
        if not null dl and (s eq car dl) then
            go to loop1
        else rl:=(s.n).rl;
        go to loop2
    end;

symbolic procedure arrangelistz d;
    begin         scalar n,s,rl,r;
        n:=1;
        if null d then return rl;
loopd:  if (cdar d)=n then s:=(caar d).s
        else r:=(car d).r;
        d:=cdr d;
        if not null d then go to loopd;
        d:=r;
        rl:=s.rl;
        s:=nil;
        r:=nil;
        n:=n+1;
        if not null d then go to loopd;
        return reversip rl
    end;

symbolic procedure findtrialdivs zl;
   % zl is list of kernels found in integrand. result is a list
   % giving things to be treated specially in the integration
   % namely, exps and tans.
   % Result is list of form ((a . b) ...)
   % with a a kernel and car a=expt or tan
   % and b a standard form for either expt or (1+tan**2).
   begin scalar dlists1,args1;
      for each z in zl do
	 if exportan z
	   then <<if car z eq 'tan
		    then <<args1 := (mksp(z,2) .* 1) .+ 1;
			   tanlist := (args1 ./ 1) . tanlist>>
		   else args1 := !*kk2f z;  % z is not unique here.
		  dlists1 := (z . args1) . dlists1>>;
      return dlists1
   end;

symbolic procedure exportan dl;
    if atom dl then nil
     else begin
    % extract exp or tan fns from the z-list.
	if eq(car dl,'tan) then return t;
   nxt: if not eq(car dl,'expt) then return nil;
        dl:=cadr dl;
%       if atom dl then return t;
%       if atom dl or constant_exprp dl then return t;
	if atom dl or not smember(intvar,dl) then return t;
% Make sure we find nested exponentials?
        go to nxt
    end;

symbolic procedure findsqrts z; 
    begin  scalar r; 
        while not null z do << 
            if eqcar(car z,'sqrt) then r:=(car z) . r; 
            z:=cdr z >>; 
        return r 
    end; 

symbolic procedure trialdiv(x,dl);
    begin         scalar qlist,q;
    while not null dl do
        if not null(q:=quotf(x,cdar dl)) then <<
            if (caaar dl='tan) and not eqcar(qlist,cdar dl) then
                loglist:=('iden . simp cadr caar dl) . loglist;
                         %tan fiddle!
            qlist:=(cdar dl).qlist;
            x:=q >>
        else dl:=cdr dl;
    return qlist.x
    end;

endmodule;

end;