reduce-historical/r37/packages/solve/modsolve.red

module modsolve; % Solve modular.

% Author:       Herbert Melenk <melenk@zib-berlin.dbp.de>

% Algebraic interface: m_solve(eqn/eqnlist [,variables]).

% Some routines from solve and factor(modpoly) are needed.

fluid '(!*trnonlnr );

load!-package 'solve;
load!-package 'factor;

put('m_solve,'psopfn,'msolve);

symbolic procedure msolve(u);
  begin scalar s,s1,v,v1,w;
   s:=reval car u;
   s:=if eqcar(s,'list) then cdr s else {s};
   if cdr u then
   <<v:= reval cadr u;
     v:=if eqcar(v,'list) then cdr v else {v};
   >>;
   % test, collect variables.
   s1:=for each q in s collect
   <<if eqcar(q,'equal) then q:='difference.cdr q;
     w:=numr simp q ./ 1; v1:=union(v1,solvevars{w});
     numr w>>;
   if null v then v:=v1;
   return msolve!-result
      if length s1 = 1
                  then msolve!-poly(car s1,v)
                  else msolve!-psys(s1,v);
  end;

symbolic procedure msolve!-result u;
 if u='failed then u else
  'list . for each v in u collect
     'list . for each w in v collect {'equal,car w,cdr w};

symbolic procedure msolvesys(s1,v,tg);
 % Interface for the Solve package.
  begin scalar w,fail;
   if null cdr s1 then
     <<w:= msolve!-poly(car s1,v); goto done>>;
     % Reject parametric modular equation system.
   for each p in s1 do
     for each x in kernels p do
       if not member(x,v) then fail:=t;
   if fail then
    << if !*trnonlnr
         then lprim "cannot solve parametric modular system";
       go to failed>>;
   w:= msolve!-psys(s1,v);
   if w='failed then go to failed;
 done:
   w:=for each q in w collect
     {for each r in q collect simp cdr r,
      for each r in q collect car r, 1};
   return if tg then t.w else w;
 failed:
   return if tg then '(failed) else 'failed;
  end;

symbolic procedure msolve!-poly1(f,x);
  % polynomial f(x);
 begin scalar w,l;
  if ldeg f = 1 then
   <<w:=safe!-modrecip  lc f;
     erfg!*:=nil;
     if null w then go to enum;
     w:=moduntag multf(w,negf red f);
     if w and (w< 0 or w>current!-modulus)
             then w:=general!-modular!-number w;
     w:={w};
     go to done;
    >>;
 enum:
    l := lowestdeg(f,x,0);
    if l>0 then f:=quotf(f,numr simp {'expt,x,l});
    f:=general!-reduce!-mod!-p moduntag f;
    w:=for i:=1:current!-modulus -1 join
      if null general!-evaluate!-mod!-p(f,x,i) then {i};
    if l>0 then w:=append(w,{nil});
 done:
    return for each q in w collect {x.prepf q};
 end;

symbolic procedure msolve!-poly(f,l);
  % Solve one polynomial wrt several variables.
  begin scalar x,vl;
   vl := kernels f;
   for each x in l do
    <<if not member(x,vl) then l:=delete(x,l);
      vl := delete(x,vl)>>;
   if null l then return nil;
   if vl then return msolve!-polya(f,l);
   return msolve!-polyn(f,l);
  end;

symbolic procedure msolve!-polyn(f,l);
  ( if null cdr l then msolve!-poly1(f,car l) else
   for i:=0: current!-modulus -1 join
      for each s in msolve!-polyn(numr subf(f,{x.i}),cdr l)
         collect (x.i).s) where x=car l;

symbolic procedure msolve!-polya(f,l);
  % F is a polynomial with variables in l and at least one more
  % formal parameter. F can be solved only if f is linear in one of the
  % variables with an invertible coefficient. Otherwise we must return
  % a root-of expression.
  begin scalar x,c,w;
    for each y in l do if null x then
      if 1=ldeg ((w:=reorder f) where kord!* = {y}) then x:=y;
    if null x then goto none;
    c:=lc w; w:=red w;
    if not domainp c then goto none;
    c:=safe!-modrecip c;
    if null c then goto none;
    return {{x.prepf multf(negf w,c)}};
  none:
    return {{car l. mk!*sq caaar mkrootsof(f./1,car l,1)}};
  end;

symbolic procedure msolve!-psys(s,v);
  % Solve system s for variables v. S has no additional free parameters.
  begin scalar b,o,z,w;
    if current!-modulus * length s >1000
        and primep current!-modulus then
    << % Domain is a field and big problem - compute a GB first.
       load!-package 'groebner; load!-package 'groebnr2;
       o:=apply1('torder,{'list.v,'lex});
       b:=groebnereval{'list.for each p in s collect prepf p};
       z:=gzerodimeval {b};
       % The reverse basis for increasing variable number.
       s:=reversip for each p in cdr b collect numr simp p;
       apply1('torder,cdr o);
    >>
     else
    << % Rearrange system for increasing variable number.
       w:=for each p in s collect
         length(for each x in v join if smemq(x,p) then {x}).p;
       w:= for each p in sort(w,'lesspcar) collect cdr p
    >>;
    return msolve!-psys1(s,v);
  end;

symbolic procedure msolve!-psys1(s,v);
  % Solve system by successive substitution.
  begin scalar w,w1,f,f1;
    w:={nil};
    for each f in s do
    <<w1:=nil;
      for each s in w do
      <<f1:=general!-reduce!-mod!-p moduntag numr subf(f,s);
        if null f1 then w1:=s.w1
        else if domainp f1 then nil
        else for each ns in msolve!-poly(f1,v) do
                 w1:=append(s,ns) . w1
      >>;
      w:=w1;
    >>;
    return w;
  end;

endmodule;

end;