reduce-historical/r37/packages/groebner/groebmes.red

module groebmes;
 
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  trace messages for the algorithms
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

fluid '(vdpvars!* !*trgroeb !*trgroebs !*trgroeb1 !*trgroebr hcount!*
          hzerocount!* factorlevel!* basecount!* groetime!* pcount!*);

symbolic procedure groebpairprint (p);
  <<groebmessff(" pair(",cadr p,nil);
    groebmessff(",",caddr p,nil);
    prin2 "), ";
    prin2 " lcm = ";print car p>>;

symbolic procedure groetimeprint;
   << prin2 ">> accum. cpu time:";
      prin2  (time() - groetime!*);
      prin2t " ms">>;

symbolic procedure groebmessff (m1,f,m2);
      << prin2 m1; prin2 vdpnumber f; 
         if !*gsugar then <<prin2 "/";prin2 gsugar f>>;
         if m2 then prin2t m2 >>;

symbolic procedure groebmess0 (p);
    if !*trgroeb then vdpprint p;

symbolic procedure groebmess1 (g,d);
        if !*trgroeb then <<
               g := g; d := d;
               prin2 " variables: "; print vdpvars!*;
               printbl();
               prin2t " Start of ITERATION "; terpri (); >>;

symbolic procedure groebmess2 f;
  if !*trgroeb then << terpri();
                 groebmessff ("polynomial ",f," eliminated");
                 groetimeprint()>>;

symbolic procedure groebmess2a(f,cf,fn);
  if !*trgroeb then << terpri();
        groebmessff ("polynomial ",f,nil);
        groebmessff (" elim. with cofactor ",cf," to");
        vdpprint fn; terpri(); groetimeprint()>>;

symbolic procedure groebmess3(p,s);
     if !*trgroebs then <<
                       prin2 "S-polynomial from ";
                       groebpairprint p;
                       vdpprint s; terpri();
                            groetimeprint(); terprit 3 >>;

symbolic procedure groebmess4 (p,d);
    << hcount!* := hcount!*+1;
       hzerocount!* := hzerocount!*+1;
      if !*trgroeb then << terpri(); printbl();
                       groebmessff(" reduction (",cadr p,nil);
                       groebmessff(",", caddr p,nil);
                       prin2 ") leads to 0; ";
                       << prin2 n; 
                          prin2 if n=1 then " pair" else " pairs">>
                            where n=length d;
                       prin2t " left";
                       printbl(); groetimeprint()>>; >>;

symbolic procedure groebmess41 (p);
    << hcount!* := hcount!*+1;
       hzerocount!* := hzerocount!*+1;
      if !*trgroeb then << terpri(); printbl();
                       groebmessff(" polynomial(", p,nil);
                       prin2 ") reduced to 0;";
                       terpri(); printbl(); groetimeprint()>> >>;
        
symbolic procedure groebmess5(p,h);
   if car p then 
  << hcount!* := hcount!* + 1;
     if !*trgroeb then << terpri(); prin2  "H-polynomial ";
                       prin2 pcount!*;
                       prin2 " ev:"; prin2 vdpevlmon h;
                       groebmessff(" from pair (",cadr p,nil);
                       groebmessff(",", caddr p,")");
                       vdpprint h; terpri(); groetimeprint() >> >>
     else
     if !*trgroeb then << prin2t "from actual problem input:";
                       vdpprint h; groetimeprint() >>;

symbolic procedure groebmess50(g);
     if !*trgroeb1 then << prin2 "list of active polynomials:";
                      for each d1 in g do 
                           <<prin2 vdpgetprop(d1,'number);
                             prin2 " ">>; terprit 2 >>;

symbolic procedure groebmess51(d);
     if !*trgroeb1 then <<
                      prin2t "Candidates for pairs in this step:";
                      for each d1 in d do groebpairprint (d1);
                            terprit 2 >>;

symbolic procedure groebmess52(d);
     if !*trgroeb1 then <<
                       prin2t "Actual new pairs from this step:";
                       for each d1 in d do groebpairprint (d1);
                            terprit 2 >>;

symbolic procedure groebmess7 h;
   if !*trgroebs then
          <<prin2t "Testing factorization for "; vdpprint h>>;

symbolic procedure groebmess8 (g,d);
        if !*trgroeb1 then <<
            g := g; prin2t " actual pairs: ";
            if null d then prin2t "null"
                      else for each d1 in d do groebpairprint d1;
            groetimeprint() >>
          else if !*trgroeb then <<
              prin2 n; prin2t if n=1 then " pair" else " pairs" >>
                                          where n=length d;

symbolic procedure groebmess13(g,problems);
   if !*trgroeb or !*trgroebr then <<
      if g then << basecount!* := basecount!* +1;
         printbl(); printbl();          
         prin2  "end of iteration ";
         for each f in reverse factorlevel!* do 
                <<prin2 f; prin2 ".">>;
         prin2 "; basis "; prin2 basecount!*; prin2t ":";
         prin2 "{"; for each g1 in g do vdpprin3t g1; prin2t "}";
         printbl(); printbl(); groetimeprint() >>
        else
      << printbl(); prin2  "end of iteration branch ";
         for each f in reverse factorlevel!* do
                      <<prin2 f; prin2 ".">>;
         prin2t "  "; printbl(); groetimeprint()>>;
      if problems and !*trgroeb then
      <<    groetimeprint(); terpri(); printbl();
            prin2 " number of partial problems still to be solved:";
            prin2t length problems; terpri();
            prin2 " preparing  next problem ";
            if car car problems = 'file then prin2 cdr car problems
            else if cadddr car problems then
            vdpprint car cadddr car problems; terpri(); >> >>;

symbolic procedure groebmess14 (h,hf);
   if !*trgroeb then <<
              prin2 "******************* factorization of polynomial ";
               (if x then prin2t x else terpri() )
                           where x = vdpnumber(h);
               prin2t " factors:";
               for each g in hf do vdpprint car g; groetimeprint()>>;

symbolic procedure  groebmess15 f;
    if !*trgroeb then
          <<prin2t "***** monomial factor reduced:";
                   vdpprint vdpfmon(a2vbc 1,f)>>;

symbolic procedure groebmess19(p,restr,u);
    if !*trgroeb then <<
                u := u; restr := restr; printbl();
                prin2  "calculation branch ";
                for each f in reverse factorlevel!* do
                      <<prin2 f; prin2 ".">>;
                prin2t " cancelled because"; vdpprint p;
                prin2t "is member of an actual abort condition";
                printbl(); printbl()>>;

symbolic procedure groebmess19a(p,u);
    if !*trgroeb then << u := u; printbl();
                prin2  "during branch preparation ";
                for each f in reverse u do <<prin2 f; prin2 ".">>;
                prin2t " cancelled because"; vdpprint p;
                prin2t "was found in the ideal branch"; printbl()>>;

symbolic procedure groebmess20 (p);
    if !*trgroeb then <<
               terpri(); prin2 "secondary reduction starting with";
               vdpprint p>>;

symbolic procedure groebmess21(p1,p2);
    if !*trgroeb then <<
               prin2 "polynomial "; prin2 vdpnumber p1;
               prin2 " replaced during secondary reduction by ";
               vdpprint p2>>;

symbolic procedure groebmess22(factl,abort1,abort2);
   if null factl then nil
            else
    if !*trgroeb then
           begin integer n;
               prin2t "BRANCHING after factorization point";
               n := 0; for each x in reverse factl do
                << n := n+1; prin2 "branch ";
                   for each f in reverse factorlevel!* do
                      <<prin2 f;prin2 ".">>;
                   prin2t n; for each y in car x do vdpprint y;
                  prin2t "simple IGNORE restrictions for this branch:";
                   for each y in abort1 do vdpprint y;
                   for each y in cadr x do vdpprint y;
                   if abort2 or caddr x then
                  <<prin2t
                      "set type IGNORE  restrictions for this branch:";
                     for each y in abort2 do vdpprintset y;
                     for each y in caddr x do vdpprintset y >>;
                   printbl()>>;
          end;

symbolic procedure  groebmess23 (g0,rest1,rest2);
    if !*trgroeb then
            if null factorlevel!* then
     prin2t "** starting calculation ******************************"
            else << prin2 "** resuming calculation for branch ";
                 for each f in reverse factorlevel!* do
                      <<prin2 f; prin2 ".">>;
                     terpri(); if rest1 or rest2 then
                       <<
               prin2t "-------IGNORE restrictions for this branch:";
                      g0 := g0; for each x in rest1 do vdpprint x;
                      for each x in rest2 do vdpprintset x>> >>;

symbolic procedure groebmess24(h,problems1,restr);
 %  if !*trgroeb then
      <<prin2t "**********polynomial affected by branch restriction:";
        vdpprint h; if restr then prin2t "under current restrictions";
        for each x in restr do vdpprint x;
        if null problems1 then prin2t "        CANCELLED"
           else <<prin2t "partitioned into";
             vdpprintset car problems1>> >>;

symbolic procedure groebmess25 (h,abort2);
    <<prin2t "reduction of set type cancel conditions by";
      vdpprint h; prin2t "remaining:";
      for each x in abort2 do vdpprintset x>>;

symbolic procedure groebmess26 (f1,f2);
  if !*trgroebs and not vdpequal(f1,f2) then
    <<terpri(); prin2t  "during final reduction";
      vdpprint f1; prin2t "reduced to";
      vdpprint f2; terpri()>>;

symbolic procedure groebmess27 r;
  if !*trgroeb then <<terpri();
      prin2t  "factor ignored (considered already):"; vdpprint r>>;

symbolic procedure groebmess27a (h,r);
  if !*trgroeb then
    <<terpri();   vdpprint h;
      prin2t  "     reduced to zero by factor"; vdpprint r>>;

symbolic procedure groebmess28 r;
  if !*trgroeb then
    <<writepri("interim content reduction:", 'first);
      writepri(mkquote prepsq r, 'last)>>;

symbolic procedure groebmess29 omega;
   if !*trgroeb then
    <<terpri(); prin2 "actual weight vector: [";
      for each x in omega do <<prin2 " "; prin2 x>>; prin2 "]";
     terpri(); terpri()>>;

symbolic procedure groebmess30 gomegaplus;
    if !*trgroeb and gomegaplus then
     <<terpri(); prin2 "new head term (or full) basis "; terpri();
       for each x in gomegaplus do <<vdpprint x; terpri()>> >>;

symbolic procedure groebmess31 gg;    
     if !*trgroeb then <<prin2 "full basis"; terpri();
       for each x in gg do <<vdpprint x; terpri(); terpri() >> >>;

symbolic procedure groebmess32 g;
     if !*trgroeb then <<terpri();
       prin2 "***** start of iteation with"; terpri();
       for each x in g do vdpprint x;
       prin2 "****************************";
       terpri()>>;
   
symbolic procedure groebmess33 g;
      if !*trgroeb then
      <<terpri(); prin2 "***** resulting system *****"; terpri();
        for each x in g do vdpprint x;
        prin2 "****************************"; terpri()>>;

symbolic procedure groebmess34 mx;
       if !*trgroeb then
       <<terpri(); prin2 "sum of weight vector "; print mx;
         terpri()>>;

symbolic procedure groebmess35 omega;
       if !*trgroeb then
       <<terpri(); prin2 "next weight vector "; print omega;
         terpri()>>;

symbolic procedure groebmess36 tt;
       if !*trgroeb then
       <<terpri(); prin2 "new weight: "; print tt>>;

symbolic procedure groebmess37 s;
       if !*trgroeb then
       <<if not s then prin2 "NOT "; prin2 "taking initials";
         terpri(); terpri()>>;

symbolic procedure printbl(); printb (linelength nil #- 2); 

symbolic procedure printb n; <<for i:=1:n do prin2 "-"; terpri()>>;

symbolic procedure vdpprintset l;
   if l then << prin2 "{"; vdpprin2 car l;
        for each x in cdr l do <<prin2 "; "; vdpprin2 x>>;
      prin2t "}";>>;

symbolic procedure vdpprin2l u;
     <<prin2 "("; vdpprin2 car u;
       for each x in cdr u do <<prin2 ","; vdpprin2 x;>>;
            prin2 ")";>>;

endmodule;
end;