(* ----------------------------------------------------------------------------
 * $Id: SUBST.mi,v 1.1 1995/11/05 15:57:36 pesch Exp $
 * ----------------------------------------------------------------------------
 * This file is part of MAS.
 * ----------------------------------------------------------------------------
 * Copyright (c) 1995 Universitaet Passau
 * ----------------------------------------------------------------------------
 * $Log: SUBST.mi,v $
 * Revision 1.1  1995/11/05 15:57:36  pesch
 * Diplomarbeit Manfred Goebel, Reduktion G-symmetrischer Polynome fuer
 * beliebige Permutationsgruppen G, slightly edited.
 *
 * ----------------------------------------------------------------------------
 *)

IMPLEMENTATION MODULE SUBST;
(* Substitution Group Polynomial System Implementation Module. *)

FROM MASELEM	IMPORT	GAMMAINT;

FROM MASSTOR	IMPORT	ADV, COMP, FIRST, INV, LENGTH, LIST, LIST1, SIL;

FROM MASBIOS	IMPORT	BLINES, SWRITE;

FROM SACLIST	IMPORT	EQUAL, LELT, MEMBER, OWRITE;

FROM SACRN	IMPORT	RNINT;

FROM LINALGRN	IMPORT	RNMDET, RNMPROD, RNMREAD; 

FROM DIPRN	IMPORT	DIRPDF, DIRPEX, DIRPPR, DIRPRP, DIRPRQ, DIRPSM;

FROM DIPC	IMPORT	DIPFMO, DIPMAD, EVCADD, EVDEL, EVTDEG;

FROM GSYMFUIN	IMPORT	GSYSPG;

FROM GSYMFURN	IMPORT	GRNCHKBAS;

FROM NOETHER	IMPORT	MERGE, NOEL32, NOEPIP, NOEPPR, NOEPRM, NOEPSM,
			NOESRT;

CONST rcsidi = "$Id: SUBST.mi,v 1.1 1995/11/05 15:57:36 pesch Exp $";
CONST copyrighti = "Copyright (c) 1995 Universitaet Passau";

PROCEDURE SUBINF();
BEGIN
BLINES(1);
SWRITE("Substitution Group Polynomial System Package:");
BLINES(0);
SWRITE("---------------------------------------------");
BLINES(1);
SWRITE("               SG := SUBSGR(Number_of_Variables).");
BLINES(0);
SWRITE("            Order := SUBORD(SG).");
BLINES(0);
SWRITE("            Orbit := SUBORP(SG, Polynom).");
BLINES(0);
SWRITE("           0_or_1 := SUBSYM(SG, Polynom).");
BLINES(0); 
SWRITE("       Orbit_List := SUBOPL(SG, Monom_List).");
BLINES(0);
SWRITE("          Polynom := SUBCHK(SG, Base, Base_Polynom).");
BLINES(0); 
SWRITE("     SK_Power_Sum := SUBPOW(SG, Degree).");
BLINES(1);
SWRITE("SUBRED(SG, Polynom, Base, Base_Polynom, Remainder_Polynom).");
BLINES(0);
SWRITE("SUBINF().");	
BLINES(0);
SWRITE("SUBSGW(SG).");
END SUBINF;

PROCEDURE SUBSGR(N: GAMMAINT): LIST;
VAR SG, NSG, XSG, YSG, XX, YY, VEC, T: LIST;
    I, K, N: GAMMAINT;
BEGIN
SG := SIL;
NSG := SIL;
XSG := SIL;
XX := RNMREAD();
WHILE XX # SIL DO
     IF LENGTH(XX) # N THEN SWRITE("Length error, try again! ");
     ELSE IF MEMBER(XX, XSG) = 0 THEN I := 1;
               YY := XX;
               LOOP IF YY = SIL THEN EXIT; END;
                    ADV(YY, VEC, YY);
                    IF LENGTH(VEC) # N THEN EXIT; END;
                    I := I + 1;
                    END; (* of loop *)
               IF (I >= N) AND (RNMDET(XX) # 0) THEN XSG := COMP(XX, XSG);
               ELSE SWRITE("No substitution, try again! "); END;
               END; (* of if *)
          END; (* of if *)
     XX := RNMREAD();
     END; (* of while *)
SG := XSG;
K := 0;
BLINES(0); 
REPEAT
    K := K + 1;
    NSG := SG; 
    N := LENGTH(SG);
    WHILE NSG # SIL DO
         ADV(NSG, XX, NSG);
         YSG := XSG;
         WHILE YSG # SIL DO
              ADV(YSG, YY, YSG);
              T := RNMPROD(XX, YY);
              IF (MEMBER(T, SG) = 0) THEN 
                   SG := COMP(T, SG); 
                   OWRITE(K); SWRITE(" "); 
                   END; (* of if *)
              END; (* of while *)
         END; (* of while *)
UNTIL (LENGTH(SG) = N) OR (K > 50); (* of repeat *)
RETURN(SG);
END SUBSGR;

PROCEDURE SUBSGW(SG: LIST);
VAR PI: LIST;
    I: GAMMAINT;
BEGIN
I := 0;
WHILE SG # SIL DO
    ADV(SG, PI, SG);
    I := I + 1;
    BLINES(1); OWRITE(I); SWRITE(")  "); OWRITE(PI);
    END; (* of while *);    
END SUBSGW;

PROCEDURE SUBORD(SG: LIST): GAMMAINT;
BEGIN
RETURN(LENGTH(SG));
END SUBORD;

PROCEDURE PERM(PI, POL: LIST): LIST;
VAR RES, FF, XX, SUM, VEC, HK, HT, NFF, PROD: LIST;
    I, J, N: GAMMAINT;
BEGIN
RES := 0;
IF (PI = SIL) OR (POL = 0) THEN RETURN(RES); END;
N := LENGTH(FIRST(PI));
FF := SIL;
WHILE PI # SIL DO
    ADV(PI, VEC, PI);
    SUM := 0;
    FOR I := 1 TO N DO
         IF LELT(VEC, I) # 0 THEN
              XX := SIL;
              FOR J := 1 TO N DO
                   IF I = J THEN XX := COMP(1, XX); 
                   ELSE XX := COMP(0, XX); END;
                   END; (* of for *)
              SUM := DIRPSM(SUM, DIPFMO(LELT(VEC, I), XX));  
              END; (* of if *)
         END; (* of for *)
    FF := COMP(SUM, FF);	
    END; (* of while *)
WHILE POL # SIL DO
    DIPMAD(POL, HK, HT, POL);
    PROD := DIRPEX(DIPFMO(HK, HT), 0);
    NFF := FF;
    WHILE HT # SIL DO
         ADV(HT, XX, HT);
         ADV(NFF, SUM, NFF);
         PROD := DIRPPR(PROD, DIRPEX(SUM, XX));
         END; (* of while *)
    RES := DIRPSM(RES, DIRPRP(PROD, HK));
    END; (* of while *)
RETURN(RES);
END PERM;

PROCEDURE SUBORP(SG, POL: LIST): LIST;
VAR RES, PI: LIST;
    ORDER: GAMMAINT;
BEGIN
RES := 0;
IF (SG = SIL) OR (POL = 0) THEN RETURN(RES); END;
ORDER :=SUBORD(SG);
WHILE SG # SIL DO
    ADV(SG, PI, SG);
    RES := DIRPSM(RES, PERM(PI, POL));
    END; (* of while *)
RES := DIRPRQ(RES, RNINT(ORDER));
RETURN(RES);
END SUBORP;

PROCEDURE SUBSYM(SG, POL: LIST): GAMMAINT;
VAR PI: LIST;
BEGIN
WHILE SG # SIL DO
    ADV(SG, PI, SG);
    IF DIRPDF(POL, PERM(PI, POL)) # 0 THEN RETURN(0); END;
    END; (* of while *)
RETURN(1);
END SUBSYM;

PROCEDURE SUBOPL(SG, ML: LIST): LIST;
VAR HM, RES: LIST;
BEGIN
RES := SIL;
WHILE ML # SIL DO
    ADV(ML, HM, ML);
    RES := COMP(SUBORP(SG, HM), RES);
    END; (* of while *)
RETURN(INV(RES));
END SUBOPL;

PROCEDURE SUBCHK(SG, BASE, POL: LIST): LIST;
VAR RES, HK, HT, BASEORBIT, PROD: LIST;
    I, N: GAMMAINT;
BEGIN
RES := 0;
IF POL = 0 THEN RETURN(RES); END;
N := LENGTH(BASE);
IF N = 0 THEN RETURN(RES); END;
BASEORBIT := SUBOPL(SG, BASE);
WHILE POL # 0 DO
    DIPMAD(POL, HK, HT, POL);
    IF POL = SIL THEN POL := 0; END;
    PROD := DIRPEX(LELT(BASEORBIT, 1), 0);
    FOR I := 1 TO N DO
         PROD := DIRPPR(PROD, DIRPEX(LELT(BASEORBIT, I), LELT(HT, I)));
         END; (* of for *)
    RES := DIRPSM(RES, DIRPRP(PROD, HK));
    END; (* of while *)
RETURN(RES);
END SUBCHK;

PROCEDURE SUBPOW(SG: LIST; K: GAMMAINT): LIST;
VAR POL, XPOL, HKPOL, HKBASE, XHK, HK, HT, XX: LIST;
    I, J, N, ORDER: GAMMAINT;
BEGIN
POL := 0;
IF SG = SIL THEN RETURN(POL); END;
XPOL := 0;
N := LENGTH(FIRST(FIRST(SG)));
ORDER := SUBORD(SG);
FOR I := 1 TO N DO
    HT := SIL;
    FOR J := 1 TO N DO
         IF I = J THEN HT := COMP(1, HT);
              ELSE HT := COMP(0, HT); END; (* of if *)
         END; (* of for *)
    XPOL := DIRPSM(XPOL, DIPFMO(RNINT(1), HT));
    END; (* of for *)
XPOL := DIRPEX(XPOL, K);
POL := SIL;
WHILE XPOL # SIL DO
    DIPMAD(XPOL, HK, HT, XPOL);
    XX := DIPFMO(RNINT(1), HT);
    IF SUBORP(SG, XX) # 0 THEN 
         HKPOL := DIRPRP(DIPFMO(RNINT(ORDER), LIST1(1)), HK);
         HKBASE := LIST1(XX);
         XHK := SIL;
         XHK := COMP(HKPOL, COMP(HKBASE, XHK));
         POL := COMP(HT, COMP(XHK, POL));
         END; (* of if *)
    END; (* of while *)
POL := NOESRT(POL);
RETURN(POL);
END SUBPOW;

PROCEDURE COMPARE(SG, SKL, SKP, TERM: LIST; VAR BASE, POL: LIST);
VAR HK, HT, XHK, XHT, XX, YY, PROD, RES, NSKL, DUMMY: LIST;
    I, J, N, ORDER: GAMMAINT;
BEGIN
BASE := SIL; POL := 0;
IF SG = SIL THEN RETURN; END;
YY := SUBORP(SG, DIPFMO(RNINT(1), TERM));
IF YY = 0 THEN RETURN; END;
ORDER := SUBORD(SG);
IF SKP = 0 THEN RETURN; END;
N := LENGTH(SKL);
IF N = 0 THEN RETURN; END;
NSKL := SIL;
FOR I := N TO 1 BY -1 DO NSKL := COMP(NOEPRM(LELT(SKL, I), TERM), NSKL); END;
RES := SIL;
BLINES(0); SWRITE("SKP "); OWRITE(SKP);
WHILE SKP # SIL DO
    DIPMAD(SKP, HK, HT, SKP);
    BLINES(0); SWRITE("HT = "); OWRITE(HT);
    PROD := SIL;
    FOR I := 1 TO N DO
         FOR J := 1 TO LELT(HT, I) DO
              PROD := NOEPPR(PROD, LELT(NSKL, I), TERM); END;
         END; (* of for *)
    RES := NOEPSM(RES, NOEPIP(PROD, HK));
    END; (* of while *)
LOOP IF RES = SIL THEN RETURN; END;
    DIPMAD(RES, XHK, XHT, RES);
    IF EQUAL(XHT, TERM) = 1 THEN
         DIPMAD(XHK, BASE, POL, DUMMY);
         EXIT;
         END; (* of if *)
    END; (* of loop *)
XX := SUBCHK(SG, BASE, POL);
IF XX = 0 THEN RETURN; END;
DIPMAD(XX, HK, HT, DUMMY);
POL := DIRPRQ(POL, HK);
DIPMAD(YY, HK, HT, DUMMY);
POL := DIRPRP(POL, HK);
END COMPARE;

PROCEDURE SUBBRM(SG: LIST; VAR BASE, POL: LIST);
VAR XBASE, NBASE, NPOL, NHT, HT, HK, XX, YY, EL, DUMMY: LIST;
    I, K, N: GAMMAINT;
BEGIN
IF POL = 0 THEN BASE := SIL; END;
IF BASE = SIL THEN RETURN; END;
NBASE := BASE; 
BASE := SIL;
N := 0;
WHILE NBASE # SIL DO
    ADV(NBASE, XX, NBASE);
    BASE := COMP(XX, BASE);
    N := N + 1;	
    XBASE := SIL;
    K := 0;
    FOR I := 1 TO LENGTH(NBASE) DO	
         YY := LELT(NBASE, I);	
         IF (DIRPDF(SUBORP(SG, XX), SUBORP(SG, YY)) = 0) THEN
              NPOL := POL;
              POL := 0;
              WHILE NPOL # SIL DO
                   DIPMAD(NPOL, HK, HT, NPOL);
                   EVDEL(HT, N+I-K, NHT, EL);
                   EVCADD(NHT, N, EL, HT, DUMMY);
                   POL := DIRPSM(POL, DIPFMO(HK, HT));
                   END; (* of while *)
              K := K + 1;
         ELSE XBASE := COMP(YY, XBASE); END; (* of if *)
         END; (* of for *)
    NBASE := INV(XBASE);              
    END; (* of while *)
BASE := INV(BASE);
END SUBBRM;

PROCEDURE SUBRED(SG, POL: LIST; VAR BASE, BASEPOL, REMPOL: LIST);
VAR HK, HT, SKL, SKP, PSM, BASE1, BASEPOL1, XX, DUMMY: LIST;
    ORDER, DEGREE, KK, I: GAMMAINT;
BEGIN
BASE := SIL;
BASEPOL := SIL;
REMPOL := 0;
IF (POL = 0) OR (SG = SIL) THEN RETURN; END;
ORDER := LENGTH(SG);
IF (SUBSYM(SG, POL) # 1) THEN REMPOL := POL; 
ELSE SKL := SIL;
     FOR I := 1 TO ORDER DO SKL := COMP(SUBPOW(SG, I), SKL); END;
     WHILE POL # SIL DO
          DIPMAD(POL, HK, HT, POL);
          DEGREE := EVTDEG(HT);
          IF DEGREE <= ORDER THEN
               BASE1 := LIST1(DIPFMO(RNINT(1), HT));
               BASEPOL1 := DIPFMO(HK, LIST1(1));
          ELSE SKP := NOEL32(ORDER, DEGREE);
               COMPARE(SG, SKL, SKP, HT, BASE1, BASEPOL1);
               BASEPOL1 := DIRPRP(BASEPOL1, HK);
               END; (* of if *)
          MERGE(TRUE, BASE1, BASEPOL1, BASE, BASEPOL);
          END; (* of while *)
     END; (* of if *)
SUBBRM(SG, BASE, BASEPOL);
GRNCHKBAS(BASE, BASEPOL);
BLINES(1); SWRITE("SUBRED exit (BASE): "); OWRITE(BASE);
BLINES(0); SWRITE("SUBRED exit (BASEPOL): "); OWRITE(BASEPOL);
BLINES(0); SWRITE("SUBRED exit (REMPOL): "); OWRITE(REMPOL);
END SUBRED;

END SUBST.

(* -EOF- *)