% ----------------------------------------------------------------------
% $Id: gbsc.red,v 1.2 2003/10/21 16:07:17 gilch Exp $
% ----------------------------------------------------------------------
% Copyright (c) 2003 Andreas Dolzmann and Lorenz Gilch
% ----------------------------------------------------------------------
% $Log: gbsc.red,v $
% Revision 1.2 2003/10/21 16:07:17 gilch
% Added fluid declartions.
%
% Revision 1.1 2003/10/21 10:24:10 gilch
% Moved from rlprojects/rrcqe to gb.
% Changed module name to gbsc.
% Changed accordingly prefix to gbsc.
% Removed unused procedures betastat, rrcmatlcm, rrcmatgcd and
% related switches.
% Changed rlverbose to cgbverbose.
% Removed switch rlrqverbose and used cgbverbose instead.
% Removed switch rrcfast.
%
% Revision 1.7 2003/06/28 15:24:12 gilch
% Added verbose messages.
%
% Revision 1.6 2003/06/25 13:07:59 gilch
% Removed unnecessary local variables.
%
% Revision 1.5 2003/05/02 09:05:11 gilch
% Changed prrc_strconst, so it can handle Groebner Bases, which needn't be
% reduced.
%
% Revision 1.4 2003/04/29 14:41:12 gilch
% Imported structure constants procedure from prrc and prrcbeta.
%
% Revision 1.3 2003/04/22 14:11:32 gilch
% Fixed a bug in strconst_strconst.
%
% Revision 1.2 2003/04/22 14:10:15 gilch
% Fixed a bug in strconst_reduce.
%
% Revision 1.1 2003/04/16 11:33:05 gilch
% Initial check-in.
%
% ----------------------------------------------------------------------
lisp <<
fluid '(gbsc_rcsid!* gbsc_copyright!*);
gbsc_rcsid!* := "$Id: gbsc.red,v 1.2 2003/10/21 16:07:17 gilch Exp $";
gbsc_copyright!* := "Copyright (c) 2003 by A. Dolzmann and L. Gilch"
>>;
module gbsc;
% Groebner bases combined structure constants.
fluid '(!*cgbverbose cgb_hashsize!*);
procedure gbsc_strconst(rt,gb,n);
% Parametric real root counting structure constant. [rt] is a list
% of TERM's; [gb] is a list of VDP's; [n] is an integer. Returns a
% BETA, containing the generalized combined structure constants.
begin scalar w,g,ul,beta; integer l;
ul := reversip vdp_lsort gbsc_vdpsetprod(rt,n);
beta := gbsc_betainit();
if !*cgbverbose then <<
l := length ul;
ioto_tprin2t "Combined structure constants:"
>>;
for each u in ul do <<
if !*cgbverbose then <<
if remainder(l,10) = 0 then
ioto_prin2 {"[",l,"] "};
l := l - 1
>>;
if u member rt then
for each v in rt do
beta := gbsc_betaset(beta,u,v,if u=v then simp 1 else simp 0)
else if (w := gbsc_hmmember(u,gb)) then <<
%g := car w;
g := gb_reduce(u,gb);
for each v in rt do
beta := gbsc_betaset(beta,u,v,
%negsq quotsq(gbsc_getlincombc(v,g),vdp_lbc g))
gbsc_getlincombc(v,g))
>>
else <<
w := gbsc_goodfctr(u,rt);
for each v in rt do
beta := gbsc_betaset(beta,u,v,
gbsc_sumbeta(beta,car w,cdr w,v,rt))
>>
>>;
if !*cgbverbose then
ioto_prin2t "done";
return beta
end;
procedure gbsc_vdpsetprod(vdpl,n);
% Parametric real root countig VDP set product. [vdpl] is a list of
% VDP's. Returns a list of VDP's $v_1 v_2... v_n$ with $v_i$ in
% $[vdpl]$.
begin scalar prodl;
if n = 1 then
return vdpl;
for each x in gbsc_vdpsetprod(vdpl,n-1) do
for each y in vdpl do
prodl := lto_insert(vdp_prod(x,y),prodl);
return prodl
end;
procedure gbsc_hmmember(u,gb);
% Parametric real root counting head monomial member. [u] is a VDP
% representing a monomial; [gb] is a list of VDP's. Returns [nil],
% if there is no $f$ in [gb] with $[u]=HM(f)$ else returns a list
% of VDP's such that $[u]=HM(g)$ for the first VDP $g$.
begin scalar htu;
htu := vdp_evlmon u;
while gb and vdp_evlmon car gb neq htu do
gb := cdr gb;
return gb
end;
procedure gbsc_getlincombc(b,p);
% Parametric real root counting get linear combination coefficient.
% [b] is a TERM an element of a basis of $K[X_1,...,X_n]/I$; [p] is
% a VDP, an eleemnt of $K[X_1,...,X_n]/I$. Returns an SQ, the
% coefficient of [b] in [p].
begin scalar bt;
b := vdp_poly b;
p := vdp_poly p;
bt := dip_evlmon b;
while not null p and dip_evlmon p neq bt do
p := dip_mred p;
if null p then
return simp 0;
return bc_2sq dip_lbc p
end;
procedure gbsc_goodfctr(u,rt);
% Parametric real root counting good factorization. [u] is a VDP
% representing a term; [rt] is a list of VDP's representing terms,
% too. Write $[u]=u'X_i$ such that $u'$ is not in [rt]. Returns a
% pair $(u' . X_i ) with $u'$ and $X_i$ are VDP's.
begin scalar htu,fctr,cand,candt,n,i;
htu := vdp_evlmon u;
n := length htu;
i := 1;
while i <= n do <<
candt := for each x in htu collect x; % TODO: Muesste nach EV.
if nth(candt,i) > 0 then <<
nth(candt,i) := nth(candt,i) - 1; % TODO; Muesste nach EV.
cand := vdp_fmon(simp 1,candt);
if not (cand member rt) then <<
fctr := cand . vdp_fmon(simp 1,gbsc_mkvar(i,n)); % TODO Abbruch
i := n + 1
>>
>>;
i := i + 1
>>;
if i neq n + 2 then rederr {"bug in gbsc_goodfctr"};
return fctr
end;
procedure gbsc_mkvar(i,n); % TODO nach EV.
% Parametric real root counting make variable. [i] and [n] are
% integers, such that [i] is between 1 and [n]. Returns an EV,
% representing $X_1$ in the polynomial ring $K[X_1,...,X_n]$.
begin scalar m;
for j := 1:i-1 do
m := 0 . m;
m := 1 . m;
for j := i+1:n do
m := 0 . m;
return reversip m
end;
procedure gbsc_sumbeta(beta,up,xi,v,rt);
% Parametric real root counting sum beta. [beta] is a BETA; [up],
% [xi], and [a] are VDP's; [rt] is a list of VDP's. Returns a SQ,
% the sum $sum_{w\in [rt], w<[up]}
% \beta_{[up]w}}beta_{(w[xi])[v]}$.
begin scalar res,betaupline;
res := simp 0;
betaupline := gbsc_betagetline(beta,up);
for each w in rt do
if ev_compless!?(vdp_evlmon w,vdp_evlmon up) then
res := addsq(res,multsq(gbsc_betalineget(betaupline,w),
gbsc_betaget(beta,vdp_prod(w,xi),v)));
return res
end;
% endmodule;
% module prrcbeta;
% Parametric real root counting beta. Implements an efficient data structue for
% storing generalized combined structure constants.
%DS BETA
% BETA represents a $m\times n% matrix indexed by TERM's. We organize
% BETA as an hashtable for all lines of beta. Each hash table entry is
% an alist mapping the line index to a matrix line. The matrix lines
% are simply organized as ALISTS, mapping the column index to the
% entry. All entries are SQ's. Note that in our case $m$ is
% $|RT(I)|^3$ and $n$ is $|RT(I)|$, and therefore we have in general
% $m>>n$.
procedure gbsc_betainit();
% Parametric real root counting beta init. [m], [n] are INTEGERS;
% Returns an empty BETA $\beta$.
mkvect(cgb_hashsize!* - 1);
procedure gbsc_betaset(beta,u,v,sc);
% Parametric real root counting beta set. [beta] is a BETA; [u] and
% [v] are VDP's; [sc] is a SQ. Returns a BETA, the updated and
% inplace modiefied [beta]. Stores the generalized combined
% structure constant [sc] of [u] and [v] in [beta]. It is forbidden
% to overwrite an existing entry in [beta].
begin scalar w,i,slot;
i := gbsc_hashfunction u;
slot := getv(beta,i);
if null slot then <<
putv(beta,i,{u . {v . sc}});
return beta
>>;
w := assoc(u,slot);
if null w then <<
putv(beta,i,(u . {v . sc}) . slot);
return beta
>>;
if not assoc(v,cdr w) then
cdr w := (v . sc) . cdr w
else
rederr "bug in gbsc_betaset (gbsc_strconst)";
return beta
end;
procedure gbsc_hashfunction(term);
% Parametric real root counting hash functions. [term] is a TERM.
% Returns an integer between 0 and [cgb_hashsize!*].
begin integer w;
for each x in vdp_evlmon term do
w := 10*w + x; % TODO: remainder
return remainder(w,cgb_hashsize!*)
end;
procedure gbsc_betagetline(beta,u);
% Parametric real root counting beta getline. [beta] is a BETA; [u]
% is a VDP. Returns the line of [beta] which is indexed by [u].
begin scalar w;
w := assoc(u,getv(beta,gbsc_hashfunction u));
if null w then rederr "bug in gbsc_betagetline";
return cdr w
end;
procedure gbsc_betalineget(betaline,v);
% Parametric real root counting beta line get. [betaline] is a line
% of a BETA; [v] is a VDP. Returns a SQ, the entry of betaline
% indexed by [v].
begin scalar w;
w := atsoc(v,betaline);
if null w then rederr "bug in gbsc_betalineget";
return cdr w
end;
procedure gbsc_betaget(beta,u,v);
% Parametric real root counting betaget. [beta] is a BETA; [u] and
% [v] are VDP's. Returns a SQ the entry of [beta] indexed by [u]
% and [v].
begin scalar w;
w := assoc(u,getv(beta,gbsc_hashfunction u));
if null w then rederr "bug in gbsc_betaget (1)";
w := atsoc(v,cdr w);
if null w then rederr "bug in gbsc_betaget (2)";
return cdr w
end;
endmodule; [gbsc]
end; % of file