reduce-historical/r38/packages/assist/hcvctors.red

module hcvctors;

% The following set of symbolic procedures allow to manipulate 
% indices of vectors in the same way as for lists. Coercion from array
% to vectors is also allowed. 
% Module necessary to handle DUMMY.RED
% Only functions available in the algebraic mode are commented in 
% the TeX file.

symbolic smacro procedure mkve n;
mkvect(n-1);

symbolic smacro procedure mkve!* n;
% n is an integer
% as mkvect but initialize to 0 instead of nil.
% for general tables, use mkarray1(list(i1,...),'algebraic).
mkarray1(list(n),'algebraic);

symbolic smacro procedure putve(ve,i,elt);
% To identify numerology to the one of lists.
% Use: for i:=1:upbve tri  do putve(tri,i,i); ==> [1 2 3 4]
putv(ve,i-1,elt);

symbolic smacro procedure  venth(u,i);
% To identify numerology to the one of lists.
getv(u,i-1);

symbolic smacro procedure array_to_vect u;
% For the use in the algebraic mode, it may be useful to coerce to
% ARRAYS and vice-versa
% Use: array_to_vect algebraic <array>
  cadr get(u,'avalue);

symbolic procedure mkrandtabl(u,base,ar);
% u is a list of 2 integers which determine the dimensions of the array
% base is integer  or decimal.
% Output is a table of random numbers
if not fixp base and not !*rounded then
                              rederr("ROUNDED should be on") else
begin scalar ve; integer lu;
 lu:=length(u:=alg_to_symb u);
 % if lu > 2 then typerr(u,"one or two integer list");
 ve:=mkarray1(u,'algebraic);
  if lu=1 then
    for i:=1:car u do
       putve(ve,i, if not fixp base then
         mk!*sq((make!:rd random(cdr base)) . 1)
                              else random(base)) else
  if lu=2 then <<
                  for i:=1:car u do putve(ve,i,mkve!* cadr u);
                  for i:=1:car u do for j:=1:cadr u do
                         putve(venth(ve,i),j, if not fixp base then
                               mk!*sq((make!:rd random(cdr base)) . 1)
                                               else random(base))>>
  else return typerr(u,"one or two integer list");
  vect_to_array(list(ve,ar),u);
  return symb_to_alg lengthreval list ar
end;

flag('(mkrandtabl),'opfn);

symbolic procedure upbve u;
% Should be used in FOR ... DO loops.
if null upbv u then 0 else upbv u +1;

% ILLUSTRATION of use of the above macros and function.
%for i:=1:upbve tri do
%        for j:=1:upbve venth(tri,i) do
%               putve(venth(tri,i),j,i*j);

symbolic procedure dimvect u;
% u is a vector or vector of vector or ..
% Gives the dimension of each level.
% Valid only for rectangular patterns.
% May also be used for Young tableaux to get the dimensions of the
% FIRST row and column.
if null u then nil else
  (upbv u + 1) . dimvect ((if not vectorp x then nil
  else x) where x=getv(u,0));

 symbolic procedure index_elt(elt,u);
 % elt is an atom or a number
 % return the position index.
 begin scalar idx; integer ii;
  ii:=1;
  repeat   <<if elt = venth(u,ii) then idx:=ii else nil; ii:=ii+1;>>
  until not null idx or ii=upbve u + 1;
  return idx
 end;

 symbolic procedure vect2list u;
 % Coerce a vector into a list at any level. Suitable for the
 % symbolic mode.
 for i := 0 : upbv u collect
 (if null upbv x then x
       else vect2list x) where x= getv(u,i);

symbolic procedure list_str u;
% generates the list of dimensions for the array construction.
%if not listp u  then
%          rederr "Argument to 'list_str' must be a list"
% it is supposed  to pass the test of homo_lst.
 if not listp car u  then length u  . nil
  else length u  . list_str car u;

symbolic procedure n_first_lst(u,n);
if n=0 then nil else
car u  . n_first_lst(cdr u,n-1);

symbolic procedure homo_lst(u,n);
% n indicates the level of homogeneity.
% u is the list.
% It should be filtered by depth which gives n+1 and
% generated by alg_to_symb <algebraic list>
if not listp u then
  rederr " Argument to 'homo_lst' has not the correct dimension"
else
  if n=0 then  1 else
   begin integer nl;
         scalar su;
   su:=u; nl:=length car su;
  % It is supposed here that car su is also a list.
   su:=cdr su ;
   if null su then 1;
   while su and nl= length car su do su:=cdr su;
   if null su then return
     for each i in u product homo_lst(i,n-1)
   else return 0
end;

symbolic procedure list_to_array(u,n,arr);
% Suitable for the algebraic mode.
% Defines n-dimensional arrays.
begin scalar lu;
lu:=alg_to_symb u;
<<vect_to_array(list(list2vectn(lu,n), arr),
   n_first_lst(list_str lu,n));
   remflag(list arr,'used!*)>>;
end;

flag('(list_to_array,array_to_list),'opfn);

symbolic procedure array_to_list u;
% Transforms an array into a list.
% Suitable for the algebraic mode.
% Works at all levels.
symb_to_alg vect2list array_to_vect u;

symbolic procedure list2vectn(u,n);
if n=1 then list2vect u else
begin scalar ll,x;
 if homo_lst(u,n-1)=1 then ll:=list_str u else
 rerror(alg,1,list(n,"Too large to coerce to an array"));
 x:=mkvect (first ll -1); ll:=cdr ll;
 for i:=1: upbv x +1 do putve(x,i,list2vectn(nth(u,i),n-1));
 return x
end;

symbolic procedure list2vect u; list2vect!*(u,'algebraic);

symbolic procedure list2vect!*(u,v); % replaces list2vect
% Coerce a list into a vector
% v may be either SYMBOLIC or ALGEBRAIC
  begin scalar x;
      x:=mkvect(length u -1);
         for i:=1:upbv x +1 do putve(x,i,
            if v = 'algebraic then symb_to_alg nth(u,i) else nth(u,i));
  return x end;

symbolic procedure vect_to_array(u,dim);
% u is a list (vector, array_id)
<<typechk(cadr u,'array); put(cadr u,'rtype,'array);
   put(cadr u , 'avalue, list('array, car u));
      put(cadr u, 'dimension, dim)>>;

symbolic procedure vectappend(v1,v2);
 if not vectorp v1 then typerr(v1,"vector") else
 if not vectorp v2 then vectappend1(v1,v2) else
  begin scalar new;integer dim;
    new:=mkvect(upbv v1 + upbv v2 +1 );
    dim:=upbv v1 + 1;
    for i:=1:dim do putve(new,i,venth(v1,i));
    for i:=(dim+1):(upbv new + 1) do putve(new,i,venth(v2,i-dim));
   return new
end;

symbolic procedure vectappend1(v1,v2);
   begin scalar new; integer dim;
      new:=mkvect(dim:=upbv v1 +1);
      for i:=1:dim do putve(new,i,venth(v1,i));
      putve(new,dim+1,v2);
  return new end;

symbolic procedure vectadd(v1,v2);
% v1 and v2 are supposed to be two numeric vectors.
% So we use PLUS and not SIMPPLUS.
 if not vectorp v1 or not vectorp v2 then
                                rederr("arguments must be vectors")
  else
    begin scalar vadd;
     vadd:=mkvect upbv v1;
     for i:=1:upbve v1 do putve(vadd,i, venth(v1,i)+venth(v2,i));
     return vadd
  end;

 symbolic procedure setelve(ve,l,val);
 % Sets any elements of ve, at any level to val.
 % Example of use:
 % for i:=1:upbve tri do
 %        for j:=1:upbve venth(tri,i) do
 %               setelve(tri,list(i,j),i+j);
  if null l then nil else
  if null cdr l then putve(ve,car l, val) else
  setelve(venth(ve,car l),cdr l,val);

 symbolic procedure ltrident n;
 % Constructs a lower triangular matrix of unit vectors
   begin scalar a;
    a:=mkve!* n;
    for i:=1:n do
    << putve(a,i,mkve!* i);
         for j:=1:i-1 do putve(venth(a,i), j, 0);
        putve(venth(a,i),i,1);>>;
     return a
   end;

endmodule;

end;