1module bas;
2
3% Redistribution and use in source and binary forms, with or without
4% modification, are permitted provided that the following conditions are met:
5%
6%    * Redistributions of source code must retain the relevant copyright
7%      notice, this list of conditions and the following disclaimer.
8%    * Redistributions in binary form must reproduce the above copyright
9%      notice, this list of conditions and the following disclaimer in the
10%      documentation and/or other materials provided with the distribution.
11%
12% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
13% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
14% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
15% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
16% CONTRIBUTORS
17% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
18% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
19% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
20% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
21% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
22% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
23% POSSIBILITY OF SUCH DAMAGE.
24%
25
26
27COMMENT
28
29              #######################
30              ####               ####
31              ####  IDEAL BASES  ####
32              ####               ####
33              #######################
34
35
36Ideal bases are lists of vector polynomials (with additional
37information), constituting the rows of a dpmat (see below).  In a
38rep. part there can be stored vectors representing each base element
39according to a fixed basis. Usually rep=nil.
40
41Informal syntax :
42
43 <bas>          ::= list of base elements
44 <base element> ::= list(nr dpoly length ecart rep)
45
46END COMMENT;
47
48
49% -------- Reference operators for the base element b ---------
50
51symbolic procedure bas_dpoly b; cadr b;
52symbolic procedure bas_dplen b; caddr b;
53symbolic procedure bas_nr b; car b;
54symbolic procedure bas_dpecart b; cadddr b;
55symbolic procedure bas_rep b; nth(b,5);
56
57% ----- Elementary constructors for the base element be --------
58
59symbolic procedure bas_newnumber(nr,be);
60% Returns be with new number part.
61   nr . cdr be;
62
63symbolic procedure bas_make(nr,pol);
64% Make base element with rep=nil.
65   list(nr,pol, length pol,dp_ecart pol,nil);
66
67symbolic procedure bas_make1(nr,pol,rep);
68% Make base element with prescribed rep.
69   list(nr,pol, length pol,dp_ecart pol,rep);
70
71symbolic procedure bas_getelement(i,bas);
72% Returns the base element with number i from bas (or nil).
73  if null bas then list(i,nil,0,0,nil)
74  else if eqn(i,bas_nr car bas) then car bas
75  else bas_getelement(i,cdr bas);
76
77% ---------- Operations on base lists ---------------
78
79symbolic procedure bas_sort b;
80% Sort the base list b.
81  sort(b,function red_better);
82
83symbolic procedure bas_print u;
84% Prints a list of distributive polynomials using dp_print.
85  begin terpri();
86     if null u then print 'empty
87     else for each v in u do
88            << write bas_nr v, " -->  "; dp_print2 bas_dpoly v >>
89  end;
90
91symbolic procedure bas_renumber u;
92% Renumber base list u.
93  if null u then nil
94  else begin scalar i; i:=0;
95      return for each x in u collect <<i:=i+1; bas_newnumber(i,x) >>
96  end;
97
98symbolic procedure bas_setrelations u;
99% Set in the base list u the relation part rep of base element nr. i
100% to e_i (provided i>0).
101  for each x in u do
102        if bas_nr x > 0 then rplaca(cddddr x, dp_from_ei bas_nr x);
103
104symbolic procedure bas_removerelations u;
105% Remove relation parts.
106  for each x in u do rplaca(cddddr x, nil);
107
108symbolic procedure bas_getrelations u;
109% Returns the relations of the base list u as a separate base list.
110  begin scalar w;
111  for each x in u do w:=bas_make(bas_nr x,bas_rep x) . w;
112  return reversip w;
113  end;
114
115symbolic procedure bas_from_a u;
116% Converts the algebraic (prefix) form u to a base list clearing
117% denominators. Only for lists.
118   bas_renumber for each v in cdr u collect
119        bas_make(0,dp_from_a prepf numr simp v);
120
121symbolic procedure bas_2a u;
122% Converts the base list u to its algebraic prefix form.
123    append('(list),for each x in u collect dp_2a bas_dpoly x);
124
125symbolic procedure bas_neworder u;
126% Returns reordered base list u (e.g. after change of term order).
127    for each x in u collect
128        bas_make1(bas_nr x,dp_neworder bas_dpoly x,
129                                dp_neworder bas_rep x);
130
131symbolic procedure bas_zerodelete u;
132% Returns base list u with zero elements deleted but not renumbered.
133    if null u then nil
134    else if null bas_dpoly car u then bas_zerodelete cdr u
135    else car u.bas_zerodelete cdr u;
136
137symbolic procedure bas_simpelement b;
138% Returns (b_new . z) with
139%       bas_dpoly b_new having leading coefficient 1 or
140%       gcd(dp_content bas_poly,dp_content bas_rep) canceled out
141% and dpoly_old = z * dpoly_new , rep_old= z * rep_new.
142
143  if null bas_dpoly b then b . cali_bc_fi 1
144  else begin scalar z,z1,pol,rep;
145    if (z:=cali_bc_inv (z1:=dp_lc bas_dpoly b)) then
146        return bas_make1(bas_nr b,
147                dp_times_bc(z,bas_dpoly b),
148                dp_times_bc(z,bas_rep b))
149                        . z1;
150
151    % -- now we assume that base coefficients are a gcd domain ----
152
153    z:=cali_bc_gcd(dp_content bas_dpoly b,dp_content bas_rep b);
154    if cali_bc_minus!? z1 then z:=cali_bc_neg z;
155    pol:=for each x in bas_dpoly b collect
156                car x . car cali_bc_divmod(cdr x,z);
157    rep:=for each x in bas_rep b collect
158                car x . car cali_bc_divmod(cdr x,z);
159    return bas_make1(bas_nr b,pol,rep) . z;
160    end;
161
162symbolic procedure bas_simp u;
163% Applies bas_simpelement to each dpoly in the base list u.
164   for each x in u collect car bas_simpelement x;
165
166symbolic procedure bas_zero!? b;
167% Test whether all base elements are zero.
168   null b or (null bas_dpoly car b and bas_zero!? cdr b);
169
170symbolic procedure bas_sieve(bas,vars);
171% Sieve out all base elements from the base list bas with leading
172% term containing a variable from the list of var. names vars and
173% renumber the result.
174   begin scalar m;  m:=mo_zero();
175   for each x in vars do
176       if member(x,ring_names cali!=basering) then
177            m:=mo_sum(m,mo_from_a x)
178       else typerr(x,"variable name");
179   return bas_renumber for each x in bas_zerodelete bas join
180        if mo_zero!? mo_gcd(m,dp_lmon bas_dpoly x) then {x};
181   end;
182
183symbolic procedure bas_homogenize(b,var);
184% Homogenize the base list b using the var. name var.
185% Note that the rep. part is correct only upto a power of var !
186  for each x in b collect
187      bas_make1(bas_nr x,dp_homogenize(bas_dpoly x,var),
188                dp_homogenize(bas_rep x,var));
189
190symbolic procedure bas_dehomogenize(b,var);
191% Set the var. name var in the base list b equal to one.
192  begin scalar u,v;
193  if not member(var,v:=ring_all_names cali!=basering) then
194    typerr(var,"dpoly variable");
195  u:=setdiff(v,list var);
196  return for each x in b collect
197                bas_make1(bas_nr x,dp_seed(bas_dpoly x,u),
198                            dp_seed(bas_rep x,u));
199  end;
200
201% ---------------- Special tools for local algebra -----------
202
203symbolic procedure bas!=factorunits p;
204  if null p then nil
205    else bas!=delprod
206        for each y in cdr (fctrf numr simp dp_2a p where !*factor=t)
207            collect (dp_from_a prepf car y . cdr y);
208
209symbolic procedure bas!=delprod u;
210  begin scalar p; p:=dp_fi 1;
211     for each x in u do
212        if not dp_unit!? car x then p:=dp_prod(p,dp_power(car x,cdr x));
213     return p
214  end;
215
216symbolic procedure bas!=detectunits p;
217  if null p then nil
218  else if listtest(cdr p,dp_lmon p,
219        function(lambda(x,y);not mo_vdivides!?(y,car x))) then p
220  else list dp_term(cali_bc_fi 1,dp_lmon p);
221
222symbolic procedure bas_factorunits b;
223  bas_make(bas_nr b,bas!=factorunits bas_dpoly b);
224
225symbolic procedure bas_detectunits b;
226  bas_make(bas_nr b,bas!=detectunits bas_dpoly b);
227
228
229endmodule;  % bas
230
231end;
232