```(* ----------------------------------------------------------------------------
* \$Id: RRUADOM.mi,v 1.1 1994/03/11 15:21:52 pesch Exp \$
* ----------------------------------------------------------------------------
* This file is part of MAS.
* ----------------------------------------------------------------------------
* Copyright (c) 1993 Universitaet Passau
* ----------------------------------------------------------------------------
* Revision 1.1  1994/03/11  15:21:52  pesch
* Counting real roots of multivariate polynomials, Diplomarbeit F. Lippold
*
* ----------------------------------------------------------------------------
*)

(* Real Root Univariate Arbitrary Domain Implementation Module *)

(* Import lists and declarations. *)

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

FROM SACLIST IMPORT CINV, SUFFIX, REDUCT, CONC, LIST2, LIST3, MEMBER, OWRITE;

FROM DIPC IMPORT DIPDEG, DIPMAD, DIPMRD, DIPFMO;

FROM DIPADOM IMPORT DIPNEG, DIPQR, DIPROD;

FROM MASBIOS IMPORT BLINES, SWRITE;

CONST rcsidi = "\$Id: RRUADOM.mi,v 1.1 1994/03/11 15:21:52 pesch Exp \$";

(* Real root univariate arbitrary domain polynomial to vector.
g is an univariate polynomial of domain D with degree less than d.
If a(i) is the coefficient of X**i in g then the list (a(p-1),...,a(0))
is returned. *)
VAR v,a,t: LIST;
BEGIN
v := SIL; d:= d-1;
WHILE g <> 0 DO
IF g = SIL THEN g := 0 END;
WHILE d > FIRST(t) DO v := COMP(ADFI(D,0),v); d:= d-1 END;
v := COMP(a,v); d := d-1;
END;
WHILE d >= 0 DO v := COMP(ADFI(D,0),v); d:= d-1 END;
RETURN(INV(v));

(* Real root univariate arbitrary domain structure constants.
f and h are univariate polynomials of domain D.
f is monic with degree p > 0. A matrix beta with entries beta[i,j]
from D for 0 le i le p-1 and 0 le j le 3*p-3 is created, such that
h * X**j = beta[0,j]+beta[1,j]*X+...+beta[p-1,j]X**(p-1) modulo f.
beta is represented columnwise. *)
VAR beta,p,i,v,w,b,q,r: LIST;
BEGIN
beta := SIL;
p := DIPDEG(f);
IF p <= 0 THEN RETURN(beta) END;
(* r = h modulo f *)
DIPQR(h,f,q,r);
(* create vector representation of -red(f) and r *)
(* compute structure constants *)
beta := LIST1(CINV(w));
FOR i := 1 TO 3*p-3 DO
END;
beta := COMP(CINV(w),beta);
END;
beta := INV(beta);
RETURN(beta);

(* Real root univariate arbitrary domain quadratic form.
beta is the set of structure constants as computed by RRUADSTRCONST.
Let s(k) = tr(M(h)*M(X**k))=beta[0,k]+beta[1,k+1]+...+beta[p-1,k+p-1].
The matrix Q=(q(i,j)) with q(i,j) = s(i+j-2) is computed. *)
VAR Q,s,v,vs,w,x,y,i,p: LIST;
BEGIN
Q := SIL; s := SIL;
IF beta = SIL THEN RETURN(Q) END;
p := LENGTH(FIRST(beta)); i := 0; vs := SIL;
(* create the list s containing the sums of the diagonal elements of beta *)
WHILE beta <> SIL DO
ADV(beta,w,beta); i := i+1; v := INV(vs);
IF i >= 2*p THEN w := REDUCT(w,i+1-2*p); vs := SIL;
ELSE ADV(w,y,w); vs := LIST1(y) END;
WHILE v <> SIL DO
END;
IF i >= p THEN ADV(vs,x,vs); s := COMP(x,s); END;
END;
(* creating the matrix Q *)
v := SIL; i := 0;
WHILE s <> SIL DO
ADV(s,x,s); i := i+1; vs := SIL;
WHILE v <> SIL DO
vs := COMP(y,vs);
END;
IF i <= p THEN vs := COMP(LIST1(x),vs) END;
v := INV(vs);
IF i >= p THEN ADV(v,y,v); Q := COMP(y,Q) END;
END;
RETURN(Q);

(* Real root univariate arbirary domain count.
f is a monic univariate polynomial of domain D with degree p > 0.
H is a list of univariate polynomials of length s. v is a vector of signs
with length not greater than s. tf is the trace flag.
ZNL is a list of pairs (z,n) with n is an element of {-1,0,+1}**s and z > 0
is the number of real zeroes of f wrt the sign condition n for the elements
of H. ZNL is sorted wrt the invers lexicographical order of the n. If there
does not exist any real zero or a zero satisfiing the sign condition v,
then the empty list is returned. *)
VAR ZNL,e,S,S1,S2,g,g0,g1,g2,gd,q,h,N,A,W,s,i: LIST;
BEGIN
e := DIPFMO(ADFI(D,1),LIST1(0));  (* e = polynomial(1) *)
IF s = 0 THEN RETURN(SIL) END;
IF H = SIL THEN ZNL := LIST1(LIST2(s,SIL)); RETURN(ZNL) END;
S := LIST1(s); g := LIST1(e); N := LIST1(SIL);
A := LIST1(LIST1(1)); W := LIST3(LIST3(1,1,1),LIST3(-1,0,1),LIST3(1,0,1));
i := 0;
REPEAT
IF tf = 1 THEN BLINES(1);
SWRITE("Condition No. "); OWRITE(i); BLINES(0) END;
(* expanding the system *)
N := RRVTEXT(N,LIST3(-1,0,1));
A := IMRTPROD(W,A);
S1 := SIL; S2 := SIL; g1 := SIL; g2 := SIL; g0 := g;
WHILE g0 <> SIL DO
DIPQR(DIPROD(gd,h),f,q,gd); g1 := COMP(gd,g1);
DIPQR(DIPROD(gd,h),f,q,gd); g2 := COMP(gd,g2);