Check-ins Using Download Hex

Artifact 8e072d48cdeff60eea2b68557675370d75290961707ec3894bfb55f737fe7ef0:

module ring; 

COMMENT

               ##################
               ##              ##
               ##    RINGS     ##
               ##              ##
               ##################


Informal syntax :

Ring = ('RING (name list) ((degree list list)) deg_type ecart) 
        with deg_type = 'lex or 'revlex.

The term order is defined at first comparing successively degrees and
then by the name list lex. or revlex. For details consult the manual.

(name list) contains a phantom name cali!=mk for the module
component, see below in module mo.

The variable cali!=basering contains the actual base ring.

The ecart is a list of positive integers (the ecart vector for the
given ring) and has
        length = length names cali!=basering.
It is used in several places for optimal strategies (noetherina term
orders ) or to guarantee termination (local term orders).
All homogenizations are executed with respect to that list.

END COMMENT;

symbolic procedure ring_define(n,to1,type,ecart);
    list('ring,'cali!=mk . n, to1, type,ecart);

symbolic procedure setring!* c;
  begin 
     if !*noetherian and not ring_isnoetherian c then
        rederr"term order is not noetherian";
     cali!=basering:=c; 
     setkorder ring_all_names c;
     return c;
  end;

symbolic procedure setecart!* e;
  begin scalar r; r:=cali!=basering;
    if not ring_checkecart(e,ring_names r) then
        typerr(e,"ecart vector")
    else cali!=basering:=
        ring_define(ring_names r,ring_degrees r,ring_tag r,e)
  end;          

symbolic procedure ring_2a c;
    makelist {makelist ring_names c,
          makelist for each x in ring_degrees c collect makelist x,
          ring_tag c, makelist ring_ecart c};

symbolic procedure ring_from_a u;
  begin scalar vars,tord,c,r,tag,ecart;
  if not eqcar(u,'list) then typerr(u,"ring") else u:=cdr u;
  vars:=reval car u; tord:=reval cadr u; tag:=reval caddr u;
  if length u=4 then ecart:=reval cadddr u;
  if not(tag memq '(lex revlex)) then typerr(tag,"term order tag");
  if not eqcar(vars,'list) then typerr(vars,"variable list")
  else vars:=cdr vars;
  if tord={'list} then c:=nil
  else if not (c:=ring!=testtord(vars,tord)) then
        typerr(tord,"term order degrees");
  if null ecart then 
     if (null tord)or not ring_checkecart(car tord,vars) then 
                ecart:=for each x in vars collect 1
     else ecart:=car tord
  else if not ring_checkecart(cdr ecart,vars) then
        typerr(ecart,"ecart list")
  else ecart:=cdr ecart;
  r:=ring_define(vars,c,tag,ecart);
  if !*noetherian and not(ring_isnoetherian r) then
        rederr"Term order is non noetherian";
  return r
  end;

symbolic procedure ring!=testtord(vars,u);
% Test the non empty term order degrees for consistency and return
% the symbolic equivalent of u.
  if (ring!=lengthtest(cdr u,length vars +1) 
        and ring!=contenttest cdr u)
            then for each x in cdr u collect cdr x
  else nil;

symbolic procedure ring!=lengthtest(m,v);
% Test, whether m is a list of (algebraic) lists of the length v.
  if null m then t
  else eqcar(car m,'list)
        and (length car m = v)
        and ring!=lengthtest(cdr m,v);

symbolic procedure ring!=contenttest m;
% Test, whether m is a list of (algebraic) number lists.
  if null m then t
  else numberlistp cdar m and ring!=contenttest cdr m;

symbolic procedure ring_names r; % User names only
        cdadr r;

symbolic procedure ring_all_names r; cadr r; % All names

symbolic procedure ring_degrees r; caddr r;

symbolic procedure ring_tag r; cadddr r;

symbolic procedure ring_ecart r; nth(r,5);

% --- Test the term order for the chain condition ------

symbolic procedure ring!=trans d;
% Transpose the degree matrix.
  if (null d)or(null car d) then nil
  else (for each x in d collect car x) . 
                ring!=trans(for each x in d collect cdr x);

symbolic procedure ring!=testlex d;
   if null d then t
   else ring!=testlex1(car d) and ring!=testlex(cdr d);

symbolic procedure ring!=testlex1 d;
   if null d then t
   else if car d=0 then ring!=testlex1(cdr d)
   else (car d>0);

symbolic procedure ring!=testrevlex d;
   if null d then t
   else ring!=testrevlex1(car d) and ring!=testrevlex(cdr d);

symbolic procedure ring!=testrevlex1 d;
   if null d then nil
   else if car d=0 then ring!=testrevlex1(cdr d)
   else (car d>0);

symbolic procedure ring_isnoetherian r;
% Test, whether the term order of the ring r satisfies the chain
% condition.
  if ring_tag r ='revlex then 
                ring!=testrevlex ring!=trans ring_degrees r
  else ring!=testlex ring!=trans ring_degrees r;

symbolic procedure ring!=degpos d;
  if null d then t
  else (car d>0) and ring!=degpos cdr d;

symbolic procedure ring_checkecart(e,vars);
  (length e=length vars) and ring!=degpos e;

% ---- Test noetherianity switching noetherian on : 

put('noetherian,'simpfg,'((t (ring!=test))));

symbolic procedure ring!=test;
  if not ring_isnoetherian cali!=basering then
    << !*noetherian:=nil; 
       rederr"Current term order is not noetherian" 
    >>;

% ---- Different term orders -------------

symbolic operator eliminationorder;
symbolic procedure eliminationorder(v1,v2);
% Elimination order : v1 = all variables; v2 = variables to eliminate.
  if !*mode='algebraic then
	makelist for each x in 
		eliminationorder!*(cdr reval v1,cdr reval v2)  
			collect makelist x
  else eliminationorder!*(v1,v2);

symbolic operator degreeorder;
symbolic procedure degreeorder(vars);
  if !*mode='algebraic then
	makelist for each x in degreeorder!*(cdr reval vars) collect
		makelist x 
  else degreeorder!*(vars);

symbolic operator localorder;
symbolic procedure localorder(vars);
  if !*mode='algebraic then
	makelist for each x in localorder!*(cdr reval vars) collect
		makelist x 
  else localorder!*(vars);

symbolic operator blockorder;
symbolic procedure blockorder(v1,v2);
  if !*mode='algebraic then
	makelist for each x in 
		blockorder!*(cdr reval v1,cdr reval v2)  
			collect makelist x
  else blockorder!*(v1,v2);

symbolic procedure blockorder!*(vars,l);
% l is a list of integers, that sum up to |vars|. 
% Returns the degree vector for the corresponding block order.
  if neq(for each x in l sum x,length vars) then
	rederr"block lengths sum doesn't match variable number"
  else begin scalar u; integer pre,post;
  pre:=0; post:=length vars;
  for each x in l do
  << u:=(append(append(for i:=1:pre collect 0,for i:=1:x collect 1), 
		for i:=1:post-x collect 0)) . u; 
     pre:=pre+x; post:=post-x
  >>;
  return reversip u;
  end;  

symbolic procedure eliminationorder!*(v1,v2);
% Elimination order : v1 = all variables
% v2 = variables to eliminate. 
  { for each x in v1 collect
        if x member v2 then 1 else 0,
    for each x in v1 collect
        if x member v2 then 0 else 1};

symbolic procedure degreeorder!*(vars);
  {for each x in vars collect 1};

symbolic procedure localorder!*(vars);
  {for each x in vars collect -1};

% ---------- Ring constructors -----------------

symbolic procedure ring_rlp(r,u);
% u is a subset of ring_names r. Returns the ring r with the block order
% "first degrevlex on u, then the order on r"
  ring_define(ring_names r,
  (for each x in ring_names r collect if x member u then 1 else 0)
  . append(reverse for each x in u collect 
	for each y in ring_names r collect if x=y then -1 else 0, 
		ring_degrees r), ring_tag r, ring_ecart r);

symbolic procedure ring_lp(r,u);
% u is a subset of ring_names r. Returns the ring r with the block order
% "first lex on u, then the order on r"
  ring_define(ring_names r,
  append(for each x in u collect for each y in ring_names r collect
                if x=y then 1 else 0, ring_degrees r), 
	ring_tag r, ring_ecart r);

symbolic procedure ring_sum(a,b);
% Returns the direct sum of two base rings with degree matrix at
% first b then a and ecart=appended ecart lists.
  begin scalar vars,zeroa,zerob,degs,ecart;
  if not disjoint(ring_names a,ring_names b) then
    rederr"RINGSUM only for disjoint variable sets";
  vars:=append(ring_names a,ring_names b);
  ecart:=append(ring_ecart a,ring_ecart b);
  zeroa:=for each x in ring_names a collect 0;
  zerob:=for each x in ring_names b collect 0;
  degs:=append(
    for each x in ring_degrees b collect append(zeroa,x),
    for each x in ring_degrees a collect append(x,zerob));
  return ring_define(vars, degs, ring_tag a,ecart);
  end;

% --------- First initialization :

setring!* ring_define('(t x y z),'((1 1 1 1)),'revlex,'(1 1 1 1));

!*noetherian:=t;

% -------- End of first initialization ----------------

endmodule;  % ring

end;
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]