1module ring;
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               ##    RINGS     ##
32               ##              ##
33               ##################
34
35
36Informal syntax :
37
38Ring = ('RING (name list) ((degree list list)) deg_type ecart)
39        with deg_type = 'lex or 'revlex.
40
41The term order is defined at first comparing successively degrees and
42then by the name list lex. or revlex. For details consult the manual.
43
44(name list) contains a phantom name cali!=mk for the module
45component, see below in module mo.
46
47The variable cali!=basering contains the actual base ring.
48
49The ecart is a list of positive integers (the ecart vector for the
50given ring) and has
51        length = length names cali!=basering.
52It is used in several places for optimal strategies (noetherina term
53orders ) or to guarantee termination (local term orders).
54All homogenizations are executed with respect to that list.
55
56END COMMENT;
57
58symbolic procedure ring_define(n,to1,type,ecart);
59    list('ring,'cali!=mk . n, to1, type,ecart);
60
61symbolic procedure setring!* c;
62  begin
63     if !*noetherian and not ring_isnoetherian c then
64        rederr"term order is not noetherian";
65     cali!=basering:=c;
66     setkorder ring_all_names c;
67     return c;
68  end;
69
70symbolic procedure setecart!* e;
71  begin scalar r; r:=cali!=basering;
72    if not ring_checkecart(e,ring_names r) then
73        typerr(e,"ecart vector")
74    else cali!=basering:=
75        ring_define(ring_names r,ring_degrees r,ring_tag r,e)
76  end;
77
78symbolic procedure ring_2a c;
79    makelist {makelist ring_names c,
80          makelist for each x in ring_degrees c collect makelist x,
81          ring_tag c, makelist ring_ecart c};
82
83symbolic procedure ring_from_a u;
84  begin scalar vars,tord,c,r,tag,ecart;
85  if not eqcar(u,'list) then typerr(u,"ring") else u:=cdr u;
86  vars:=reval car u; tord:=reval cadr u; tag:=reval caddr u;
87  if length u=4 then ecart:=reval cadddr u;
88  if not(tag memq '(lex revlex)) then typerr(tag,"term order tag");
89  if not eqcar(vars,'list) then typerr(vars,"variable list")
90  else vars:=cdr vars;
91  if tord={'list} then c:=nil
92  else if not (c:=ring!=testtord(vars,tord)) then
93        typerr(tord,"term order degrees");
94  if null ecart then
95     if (null tord)or not ring_checkecart(car tord,vars) then
96                ecart:=for each x in vars collect 1
97     else ecart:=car tord
98  else if not ring_checkecart(cdr ecart,vars) then
99        typerr(ecart,"ecart list")
100  else ecart:=cdr ecart;
101  r:=ring_define(vars,c,tag,ecart);
102  if !*noetherian and not(ring_isnoetherian r) then
103        rederr"Term order is non noetherian";
104  return r
105  end;
106
107symbolic procedure ring!=testtord(vars,u);
108% Test the non empty term order degrees for consistency and return
109% the symbolic equivalent of u.
110  if (ring!=lengthtest(cdr u,length vars +1)
111        and ring!=contenttest cdr u)
112            then for each x in cdr u collect cdr x
113  else nil;
114
115symbolic procedure ring!=lengthtest(m,v);
116% Test, whether m is a list of (algebraic) lists of the length v.
117  if null m then t
118  else eqcar(car m,'list)
119        and (length car m = v)
120        and ring!=lengthtest(cdr m,v);
121
122symbolic procedure ring!=contenttest m;
123% Test, whether m is a list of (algebraic) number lists.
124  if null m then t
125  else numberlistp cdar m and ring!=contenttest cdr m;
126
127symbolic procedure ring_names r; % User names only
128        cdadr r;
129
130symbolic procedure ring_all_names r; cadr r; % All names
131
132symbolic procedure ring_degrees r; caddr r;
133
134symbolic procedure ring_tag r; cadddr r;
135
136symbolic procedure ring_ecart r; nth(r,5);
137
138% --- Test the term order for the chain condition ------
139
140symbolic procedure ring!=trans d;
141% Transpose the degree matrix.
142  if (null d)or(null car d) then nil
143  else (for each x in d collect car x) .
144                ring!=trans(for each x in d collect cdr x);
145
146symbolic procedure ring!=testlex d;
147   if null d then t
148   else ring!=testlex1(car d) and ring!=testlex(cdr d);
149
150symbolic procedure ring!=testlex1 d;
151   if null d then t
152   else if car d=0 then ring!=testlex1(cdr d)
153   else (car d>0);
154
155symbolic procedure ring!=testrevlex d;
156   if null d then t
157   else ring!=testrevlex1(car d) and ring!=testrevlex(cdr d);
158
159symbolic procedure ring!=testrevlex1 d;
160   if null d then nil
161   else if car d=0 then ring!=testrevlex1(cdr d)
162   else (car d>0);
163
164symbolic procedure ring_isnoetherian r;
165% Test, whether the term order of the ring r satisfies the chain
166% condition.
167  if ring_tag r ='revlex then
168                ring!=testrevlex ring!=trans ring_degrees r
169  else ring!=testlex ring!=trans ring_degrees r;
170
171symbolic procedure ring!=degpos d;
172  if null d then t
173  else (car d>0) and ring!=degpos cdr d;
174
175symbolic procedure ring_checkecart(e,vars);
176  (length e=length vars) and ring!=degpos e;
177
178% ---- Test noetherianity switching noetherian on :
179
180put('noetherian,'simpfg,'((t (ring!=test))));
181
182symbolic procedure ring!=test;
183  if not ring_isnoetherian cali!=basering then
184    << !*noetherian:=nil;
185       rederr"Current term order is not noetherian"
186    >>;
187
188% ---- Different term orders -------------
189
190symbolic operator eliminationorder;
191symbolic procedure eliminationorder(v1,v2);
192% Elimination order : v1 = all variables; v2 = variables to eliminate.
193  if !*mode='algebraic then
194        makelist for each x in
195                eliminationorder!*(cdr reval v1,cdr reval v2)
196                        collect makelist x
197  else eliminationorder!*(v1,v2);
198
199symbolic operator degreeorder;
200symbolic procedure degreeorder(vars);
201  if !*mode='algebraic then
202        makelist for each x in degreeorder!*(cdr reval vars) collect
203                makelist x
204  else degreeorder!*(vars);
205
206symbolic operator localorder;
207symbolic procedure localorder(vars);
208  if !*mode='algebraic then
209        makelist for each x in localorder!*(cdr reval vars) collect
210                makelist x
211  else localorder!*(vars);
212
213symbolic operator blockorder;
214symbolic procedure blockorder(v1,v2);
215  if !*mode='algebraic then
216        makelist for each x in
217                blockorder!*(cdr reval v1,cdr reval v2)
218                        collect makelist x
219  else blockorder!*(v1,v2);
220
221symbolic procedure blockorder!*(vars,l);
222% l is a list of integers, that sum up to |vars|.
223% Returns the degree vector for the corresponding block order.
224  if neq(for each x in l sum x,length vars) then
225        rederr"block lengths sum doesn't match variable number"
226  else begin scalar u; integer pre,post;
227  pre:=0; post:=length vars;
228  for each x in l do
229  << u:=(append(append(for i:=1:pre collect 0,for i:=1:x collect 1),
230                for i:=1:post-x collect 0)) . u;
231     pre:=pre+x; post:=post-x
232  >>;
233  return reversip u;
234  end;
235
236symbolic procedure eliminationorder!*(v1,v2);
237% Elimination order : v1 = all variables
238% v2 = variables to eliminate.
239  { for each x in v1 collect
240        if x member v2 then 1 else 0,
241    for each x in v1 collect
242        if x member v2 then 0 else 1};
243
244symbolic procedure degreeorder!*(vars);
245  {for each x in vars collect 1};
246
247symbolic procedure localorder!*(vars);
248  {for each x in vars collect -1};
249
250% ---------- Ring constructors -----------------
251
252symbolic procedure ring_rlp(r,u);
253% u is a subset of ring_names r. Returns the ring r with the block order
254% "first degrevlex on u, then the order on r"
255  ring_define(ring_names r,
256  (for each x in ring_names r collect if x member u then 1 else 0)
257  . append(reverse for each x in u collect
258        for each y in ring_names r collect if x=y then -1 else 0,
259                ring_degrees r), ring_tag r, ring_ecart r);
260
261symbolic procedure ring_lp(r,u);
262% u is a subset of ring_names r. Returns the ring r with the block order
263% "first lex on u, then the order on r"
264  ring_define(ring_names r,
265  append(for each x in u collect for each y in ring_names r collect
266                if x=y then 1 else 0, ring_degrees r),
267        ring_tag r, ring_ecart r);
268
269symbolic procedure ring_sum(a,b);
270% Returns the direct sum of two base rings with degree matrix at
271% first b then a and ecart=appended ecart lists.
272  begin scalar vars,zeroa,zerob,degs,ecart;
273  if not disjoint(ring_names a,ring_names b) then
274    rederr"RINGSUM only for disjoint variable sets";
275  vars:=append(ring_names a,ring_names b);
276  ecart:=append(ring_ecart a,ring_ecart b);
277  zeroa:=for each x in ring_names a collect 0;
278  zerob:=for each x in ring_names b collect 0;
279  degs:=append(
280    for each x in ring_degrees b collect append(zeroa,x),
281    for each x in ring_degrees a collect append(x,zerob));
282  return ring_define(vars, degs, ring_tag a,ecart);
283  end;
284
285% --------- First initialization :
286
287setring!* ring_define('(t x y z),'((1 1 1 1)),'revlex,'(1 1 1 1));
288
289!*noetherian:=t;
290
291% -------- End of first initialization ----------------
292
293endmodule;  % ring
294
295end;
296