File r38/packages/ncpoly/ncout.red artifact f0ef76768e part of check-in trunk

module nout; % Output of noncom polynomials.

% Author: H. Melenk, ZIB Berlin, J. Apel, University of Leipzig

% Copyright: Konrad-Zuse-Zentrum Berlin, 1994

symbolic procedure nc_compact u;
 % write a polynomial in factored form.
 begin scalar vl,t1,t2,y,r,d,w;
  vl := intersection(kord!*,for each y in ncpi!-names!* collect car y);
  for each x in vl do
    <<y:=gensym();t1:=(x.y).t1;t2:=(y.x).t2>>;
  w:=simp u where !*factor=nil,!*factors=nil,!*exp=t;
  d:=denr w; 
  r:=nc_compactr(numr w,reverse vl,t1,t2);
  return mk!*sq (r./d)end;

symbolic procedure nc_compactr(u,vl,t1,t2);
  begin scalar x,xn,y,q,w,r,s;
    integer n,m;
  x:=car vl; vl := cdr vl;
  w:=nc_compactd u;
  n:=-1;
loop:if null w then goto done;
  n:=n+1;
  xn:=if n=0 then 1 else x .** n .* 1 .+ nil;
  q:=nc_compactx(w,x,xn);
  w:=cdr q;q:=car q;
  if q then
  begin scalar !*factor,!*exp; 
     if null vl or null cdr vl or 2>
       <<m:=0;for each y in vl do if smember(y,q) then m:=m+1;m>>  
     then
      <<q:='plus.for each s in q collect prepf sublis(t1,s); 
        !*factor:=t;
        q:=reorder sublis(t2,numr simp reval1(q,nil))>>
     else
      <<s:=nil; for each f in q do s:=addf(s,f);
        q:=nc_compactr(s,vl,t1,t2)>>;
     r:=addf(multf(q,xn),r)end;
  goto loop;
done:return r end;
  
symbolic operator nc_compact;

symbolic procedure nc_compactd u;
  % convert standard form into list (=sum) of monomials.
    if domainp u then {u} else
    append(for each s in nc_compactd lc u collect lpow u .* s .+nil, 
           red u and nc_compactd red u);
    
symbolic procedure nc_compactx(u,x,xn);
  % Extract sum of terms which contain multiples of power xn. Divide xn out.
 begin scalar yes,no,w;
   for each r in u do
    if xn=1 and not smember(x,r) then yes:=r.yes 
       else
    if (w:=quotf(r,xn)) and not smember(x,w) then yes:=w.yes else no:=r.no;
   return yes.no end;

endmodule;;end;