(* ----------------------------------------------------------------------------
 * $Id: MASYMDIP.mi,v 1.7 1995/11/04 22:14:42 pesch Exp $
 * ----------------------------------------------------------------------------
 * This file is part of MAS.
 * ----------------------------------------------------------------------------
 * Copyright (c) 1989 - 1995 Universitaet Passau
 * ----------------------------------------------------------------------------
 * $Log: MASYMDIP.mi,v $
 * Revision 1.7  1995/11/04 22:14:42  pesch
 * New procedures EVOWRITE and EvordWrite.
 *
 * Revision 1.6  1993/05/11  10:56:36  kredel
 * Added modules MASUGB DIPIDGB DIPDDGB
 *
 * Revision 1.5  1993/03/23  12:13:51  kredel
 * Improved linear form processing
 *
 * Revision 1.4  1992/10/16  14:23:30  kredel
 * Change in DIPVDEF
 *
 * Revision 1.3  1992/10/15  16:30:44  kredel
 * Changed rcsid variable
 *
 * Revision 1.2  1992/02/12  17:32:57  pesch
 * Moved CONST definition to the right place
 *
 * Revision 1.1  1992/01/22  15:12:23  kredel
 * Initial revision
 *
 * ----------------------------------------------------------------------------
 *)

IMPLEMENTATION MODULE MASYMDIP;
 
(* MAS Symbol to DIP Implementation Module. *)



(* Import lists and declarations. *)

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

FROM MASERR	IMPORT	ERROR, severe;


FROM MASBIOS	IMPORT	BKSP, BLINES, CREADB, LISTS, MASORD, SWRITE;

FROM MASBIOSU	IMPORT	CLTIS;

FROM SACLIST	IMPORT	CCONC, CINV, CLOUT, COMP2, LIST2, LIST3;

FROM SACSET	IMPORT	USDIFF, USUN;

FROM MASSYM2	IMPORT	ENTER, EXPLOD, GET, PUT, SYMBOL;

FROM MASSYM	IMPORT	ELEMP, UWRITE;

FROM MASLISPU	IMPORT	Compiledf0, Compiledf1, Compiledf2, Compiledp0,
			Compiledp1, Compiledp2, Declare, EXPR, EXTYP;

FROM MASLISP	IMPORT	ADD, DF, ENV, MUL, POW, QUOT, QUOTE, STRNG, SUB;

FROM MASSPEC	IMPORT	EVALUATE;

FROM SACRN	IMPORT	RNCOMP, RNDEN, RNINT, RNNEG, RNNUM, RNRED;

FROM MASAPF	IMPORT	RNDRD;

FROM SACPOL	IMPORT	PFDP, VLREAD, VLSRCH, VLWRIT;

FROM DIPC	IMPORT	DILFPL, DIPFMO, DIPFP, DIPMAD, DIPMPV, EVORD,
			EVOWRITE, IGRLEX, INVLEX, PFDIP, PLFDIL, VALIS;

FROM DIPI	IMPORT	DIIFRP, DIILFR, DIILFRCD, DIILRD, DIILWR;

FROM DIPRN	IMPORT	DIRFIP, DIRLRD, DIRLWR, DIRPDF, DIRPEX, DIRPNG,
			DIRPPR, DIRPSM;

FROM DIPTOO	IMPORT	LFCHECK;



CONST rcsidi = "$Id: MASYMDIP.mi,v 1.7 1995/11/04 22:14:42 pesch Exp $";
CONST copyrighti = "Copyright (c) 1989 - 1995 Universitaet Passau";



(* Procedure declarations. *)

(* --- bios - dip interface --- *)

PROCEDURE dirlwr(a, b, c: LIST): LIST;
(*write polynomial list. *)
BEGIN 
(*1*) DIRLWR(a,b,c); 
      RETURN(c);  
(*2*) END dirlwr;


PROCEDURE pdread(): LIST;
(*read polynomial descriptor, i.e. variable list and term order. *)
VAR   P, T, V, E, Q, r, X: LIST;
BEGIN P:=SIL;
(*1*) REPEAT V:=VLREAD(); BLINES(1);
             UNTIL V <> SIL;
      VALIS:=V;
(*2*) REPEAT E:=CREADB(); BLINES(1);
             UNTIL    (E = MASORD("(")) 
                   OR (E = MASORD("L")) 
                   OR (E = MASORD("G"));
      IF E = MASORD("L") THEN EVORD:=INVLEX END;
      IF E = MASORD("G") THEN EVORD:=IGRLEX END;
      IF E = MASORD("(") THEN BKSP; T:=LIST1(LIST1(MASORD("T"))); 
         X:=EVORD; EVORD:=INVLEX;
         P:=DIRLRD(T); 
         P:=DIILFRCD(P); (* jetzt richtig, ist auf hauptnenner *)
         PLFDIL(P, r,Q); 
         EVORD:=X;
         IF LENGTH(Q) <> LENGTH(V) THEN 
            SWRITE("Wrong number of polynomials."); BLINES(0);
            ELSE IF LFCHECK(Q,1) THEN EVORD:=INV(Q) END
                 END;
         END;
       RETURN(COMP(V,LIST1(EVORD)))
(*3*) END pdread;


PROCEDURE preadd(D: LIST): LIST;
(*read polynomial list, for given variable list and term order. *)
VAR   P, V: LIST;
BEGIN P:=SIL;
(*1*) V:=FIRST(D);
(*3*) REPEAT P:=DIRLRD(V); 
             UNTIL P <> SIL;
      RETURN(P)
(*9*) END preadd;


PROCEDURE pread(): LIST;
(*read polynomial list, including variable list and term order. *)
VAR   P, V, X: LIST;
BEGIN P:=SIL;
(*1*) X:=pdread(); V:=FIRST(X);
(*3*) REPEAT SWRITE("Enter polynomial list: "); P:=DIRLRD(V); BLINES(0);
             UNTIL P <> SIL;
      RETURN(P)
(*9*) END pread;


PROCEDURE preadi(): LIST;
(*read polynomial list, including variable list and term order. *)
VAR   P, V, X: LIST;
BEGIN P:=SIL;
(*1*) X:=pdread(); V:=FIRST(X);
(*3*) REPEAT SWRITE("Enter polynomial list: "); P:=DIILRD(V); BLINES(0);
             UNTIL P <> SIL;
      RETURN(P)
(*9*) END preadi;


PROCEDURE pdwrite(D: LIST);
(*write polynomial descriptor, i.e. variable list and term order. *)
VAR   V, E, L, T, X: LIST;
BEGIN ADV(D, V, E); E:=FIRST(E);
(*1*) SWRITE("Polynomial in the variables: "); VLWRIT(V); BLINES(1);
(*2*) SWRITE("Term ordering: "); 
      EVOWRITE(E);
      BLINES(1);
(*3*) END pdwrite;


PROCEDURE pwrite(P: LIST);
(*write polynomial list, including variable list and term order. *)
VAR   D, L, T, X: LIST;
BEGIN 
(*1*) D:=COMP(VALIS,LIST1(EVORD)); pdwrite(D);
(*3*) SWRITE("Polynomial list: "); DIRLWR(P,VALIS,-1); BLINES(1);
(*9*) END pwrite;


PROCEDURE pwritei(P: LIST);
(*write polynomial list, including variable list and term order. *)
VAR   D, L, T, X: LIST;
BEGIN 
(*1*) D:=COMP(VALIS,LIST1(EVORD)); pdwrite(D);
(*3*) SWRITE("Polynomial list: "); DIILWR(P,VALIS); BLINES(1);
(*9*) END pwritei;


PROCEDURE pwrited(D, P: LIST);
(*write polynomial list, not including variable list and term order. *)
VAR   V: LIST;
BEGIN 
(*1*) V:=FIRST(D);
(*3*) DIRLWR(P,V,-1); BLINES(0);
(*9*) END pwrited;


(* --- sym - dip interface --- *)

PROCEDURE DIPVDEF(V: LIST): LIST;
(*DIP define distributive polynomial variable list. 
V is a variable list. The new variable list is returned. *)
VAR   VP, v: LIST;
BEGIN 
(*1*) VP:=SIL;
      WHILE V <> SIL DO ADV(V, v, V);
            IF v <> SIL THEN (*remove STRING tag *) 
               IF FIRST(v) >= SIL THEN v:=RED(v) END; 
               END;
            VP:=COMP(v,VP); END;  
      VP:=INV(VP); 
      VALIS:=VP; RETURN(VP);
(*9*) END DIPVDEF;


PROCEDURE DIPTODEF(T: LIST): LIST;
(*DIP define distributive polynomial term order. 
V is a term order indicator. The old term order indicator 
is returned. *)
VAR   TP: LIST;
BEGIN 
(*1*) TP:=EVORD; EVORD:=T;
      RETURN(TP);
(*9*) END DIPTODEF;


PROCEDURE SYM2DIP(T: LIST): LIST;
(*Symbol term list to distributive rational polynomial list. *)
VAR   D, DP, TP, VP, V, v, n: LIST;
BEGIN 
(*1*) VP:=TVARS(T); V:=SIL;
      WHILE VP <> SIL DO ADV(VP,v,VP);
            n:=EXPLOD(v);
            V:=COMP(n,V); 
            END;
      V:=INV(V); 
      V:=USDIFF(V,VALIS);
      IF V <> SIL THEN VP:=V;
         BLINES(0); SWRITE("Variable(s) added to VALIS: "); 
         WHILE V <> SIL DO ADV(V,v,V); CLOUT(v);
               IF V <> SIL THEN SWRITE(", ") END;
               END;
         BLINES(0); VALIS:=CCONC(VALIS,VP);
         END;
(*2*) D:=SIL;
      WHILE T <> SIL DO ADV(T,TP,T);
            DP:=DIRPFT(TP,VALIS); D:=COMP(DP,D); 
            END;
      D:=INV(D); RETURN(D);
(*9*) END SYM2DIP;


PROCEDURE DIP2SYM(D: LIST): LIST;
(*Distributive rational polynomial list to symbol term list. *)
VAR   DP, TP, T, V, VP, v, n: LIST;
BEGIN 
(*1*) V:=VALIS; VP:=SIL;
      WHILE V <> SIL DO ADV(V,n,V);
            v:=ENTER(n);
            VP:=COMP(v,VP); 
            END;
      VP:=INV(VP);
(*2*) T:=SIL;
      WHILE D <> SIL DO ADV(D,DP,D);
            TP:=TFDIRP(DP,VP); T:=COMP(TP,T); 
            END;
      T:=INV(T);  
      RETURN(T);
(*9*) END DIP2SYM;


PROCEDURE TVARS(T: LIST): LIST;
(*Term variables. T is a term. The list of variables 
occuring in T is returned. *)
VAR   V, v, t, TP: LIST;
BEGIN 
(*1*) (*recursion base. *) V:=SIL; 
      IF T <= BETA THEN RETURN(V) END;
      IF SYMBOL(T) THEN 
         IF GET(T,EXTYP) <> SIL THEN RETURN(V) END; 
         V:=LIST1(T); RETURN(V) END;
(*2*) (*list. *) TP:=T;
      WHILE TP <> SIL DO ADV(TP,t,TP);
            v:=TVARS(t); 
            IF v <> SIL THEN V:=USUN(v,V) END;
            END;
      RETURN(V);
(*9*) END TVARS;


PROCEDURE DIRPFT(T, V: LIST): LIST; 
(*Distributive rational polynomial from term. T is a term,
V is a variable list. A distributive rational polynomial 
A in r variables, where r=length(V), r ge 0, is formed 
from term T. *)
VAR   A, A1, AP, TP, t, tp, v, IL, JL, RL, ES: LIST; 
BEGIN
(*1*) (*r=0 or a=0.*) A:=0;  
      IF T = 0 THEN RETURN(A); END; 
(*2*) (*initialise.*)  
      RL:=LENGTH(V); ES:=SIL; 
      FOR IL:=1 TO RL DO ES:=COMP(0,ES); END; 
(*3*) (*base.*)  
      IF ELEMP(T) THEN A:=DIPFMO(RNINT(T),ES); RETURN(A) END;
      A1:=DIPFMO(RNINT(1),ES); 
      IF SYMBOL(T) THEN v:=EXPLOD(T); JL:=VLSRCH(v,V);
         IF JL = 0 THEN SWRITE("variable: "); CLOUT(v); BLINES(0);
            ERROR(severe,"DIRPFT variable not defined.") END;
         A:=DIPMPV(A1,JL,1); RETURN(A) END;
(*4*) (*functional term. determine next action. *) ADV(T,t,TP); 
      IF    t = ADD THEN A:=0;
                    WHILE TP <> SIL DO ADV(TP,t,TP); 
                          AP:=DIRPFT(t,V); A:=DIRPSM(A,AP);
                          END;
      ELSIF t = SUB THEN ADV(TP,t,TP); AP:=DIRPFT(t,V);
                    IF TP = SIL 
                       THEN A:=DIRPNG(AP);
                       ELSE A:=AP;
                       WHILE TP <> SIL DO ADV(TP,t,TP); 
                             AP:=DIRPFT(t,V); A:=DIRPDF(A,AP);
                            END;
                       END;
      ELSIF t = MUL THEN A:=A1;
                    WHILE TP <> SIL DO ADV(TP,t,TP); 
                          AP:=DIRPFT(t,V); A:=DIRPPR(A,AP);
                          END;
      ELSIF t = QUOT THEN ADV(TP,t,TP); tp:=FIRST(TP);
                          AP:=RNRED(t,tp); A:=DIPFMO(AP,ES);
      ELSIF t = POW THEN ADV(TP,t,TP); A:=DIRPFT(t,V);
                    t:=FIRST(TP); A:=DIRPEX(A,t);
      ELSIF t = STRNG THEN TP:=CCONC(TP,LISTS(" ")); 
                      CLTIS(TP); AP:=RNDRD();
                      A:=DIPFMO(AP,ES);
       ELSE BLINES(0); SWRITE("name="); UWRITE(t); 
            ERROR(severe,"DIRPFT, no allowed function.");
            END;
      RETURN(A); 
(*9*) END DIRPFT; 


PROCEDURE TFDIRP(A, V: LIST): LIST; 
(*Term from distributive rational polynomial. A is a distributive 
rational polynomial in r variables, where r=length(V), r ge 0,
V is a symbol list. A term T is formed from A. *)
VAR   T, AP, TP, t, tp, VP, v, a, E, EP, e, s: LIST; 
BEGIN
(*1*) IF A = 0 THEN RETURN(0) END;
(*2*) AP:=A; T:=SIL;
      REPEAT DIPMAD(AP,a,E,AP); t:=SIL;
             s:=RNCOMP(a,0);
             IF s < 0 THEN a:=RNNEG(a) END; 
             IF RNDEN(a) <> 1 THEN t:=LIST3(QUOT,RNNUM(a),RNDEN(a))
                              ELSE a:=RNNUM(a);
                                   IF (a <> 1) OR (s < 0) THEN t:=a END; 
                                   END;
             IF s < 0 THEN t:=LIST2(SUB,t) END;
             EP:=CINV(E); VP:=V;
             WHILE EP <> SIL DO ADV(EP,e,EP); ADV(VP,v,VP);
                   IF e > 0 THEN
                      IF e > 1 THEN tp:=LIST3(POW,v,e)
                               ELSE tp:=v END;
                      IF t = SIL THEN t:=tp
                                 ELSE t:=LIST3(MUL,t,tp) END;
                      END;
                   END;
             IF t = SIL THEN t:=1 END;
             IF T = SIL THEN T:=t
                        ELSE T:=LIST3(ADD,T,t) END;
             UNTIL AP = SIL;
      RETURN(T); 
(*9*) END TFDIRP; 


PROCEDURE TERM(P: LIST): LIST;
(*Return quoted term from DIP2SYM. *)
VAR   X: LIST;
BEGIN 
(*1*) X:=DIP2SYM(P);
      X:=LIST2(QUOTE,X); RETURN(X);
(*9*) END TERM;


PROCEDURE mkpoly;
(*Make POLY F-expression. 
(DF POLY (X) (SYM2DIP X)). *)
VAR   X, f, Y, Z: LIST;
BEGIN 
(*1*) Declare(X,"X"); Declare(f,"SYM2DIP");
      Z:=LIST1(X); Y:=COMP(f,Z); 
      Y:=LIST2(Z,Y);
(*2*) Declare(f,"POLY");
      Y:=COMP2(DF,f,Y); 
(*3*) Y:=EVALUATE(Y,ENV);
(*9*) END mkpoly;


PROCEDURE InitExternalsI;
(*Initialize external compiled interface procedures. *)
BEGIN 
(*1*) (*from symbol interface. *)
      Compiledf1(TVARS,"TVARS");
      Compiledf1(DIPVDEF,"DIPVDEF");
      Compiledf1(DIPTODEF,"DIPTODEF");
      Compiledf2(DIRPFT,"DIRPFT");
      Compiledf2(TFDIRP,"TFDIRP");
      Compiledf1(SYM2DIP,"SYM2DIP");
      Compiledf1(DIP2SYM,"DIP2SYM");
      Compiledf1(TERM,"TERM");
      mkpoly;
(*8*) (*from bios interface. *)
      Compiledf0(pread,"PREAD");
      Compiledp1(pwrite,"PWRITE");
      Compiledf0(preadi,"PREADI");
      Compiledp1(pwritei,"PWRITEI");
      Compiledf0(pdread,"PDREAD");
      Compiledp1(pdwrite,"PDWRITE");
      Compiledf1(preadd,"PREADD");
      Compiledp2(pwrited,"PWRITED");
(*9*) END InitExternalsI;


END MASYMDIP.



(* -EOF- *)