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