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

module gentens;

% This module defines the characteristics of 'generic' tensors.
% 'generic' means: any nimbers of indices, no transformation 
% properties under coordinate transformations assumed, any space 
% assignement allowed.
% TENSOR  calls make_tensor which applies on the list of IDP the
% following properties:
% Flags: tensor, full   
% Properties: indvarprt, xindvarprt_tens  for printing indices.
%           : SIMPTENSOR for simplification.
%           : Presently used to construct a correct list of indices.
% All arguments are NOT supposed to be tensor-indices. So
% dependencies may be either IMPLICIT ir EXPLICIT.

lisp remflag(list 'minus,'intfn);

global '(dimex!* sgn!*  signat!* spaces!* numindxl!* pair_id_num!*) ;


lisp (pair_id_num!*:= '((!0 . 0) (!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4)                      
                        (!5 . 5) (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9)                      
                        (!10 . 10) (!11 . 11) (!12 . 12) (!13 . 13)));

fluid('(dummy_id!* g_dvnames epsilon!*)); 

% g_dvnames is a vector. 


switch onespace;

!*onespace:=t;  % working inside a unique space is the default.

rlistat('(tensor rem_tensor rem_value_tens));

flag('(make_bloc_diagonal),'opfn);

symbolic procedure make_bloc_diagonal te;
% te is a generic tensor. Forces it to be bloc 
% diagonal when several spaces are involved.
<<put(te,'bloc_diagonal,'symb_belong_several_spaces);t>>;

symbolic procedure rem_value_tens u;
% remove values of the components of tensors included in u 
 << for each x in u do 
     if atom x then remprop(x,'kvalue)
      else 
     if listp x then
       begin scalar kval,tens,varl,ind;
         tens:=car x;
         kval:=get(tens,'kvalue);
         remprop(tens,'kvalue);
         varl:= splitlist!:(x,'list);
         ind:=if null varl then cdr x else setdiff(cdr x,varl);
         varl:=if varl then car varl;
         ind:= (lambda y;  
                 (mkindxlist for each z in y collect revalind z)) ind;    
         kval:=delete(assoc(if varl then tens . varl . ind
                                 else tens . ind,kval),kval);
         put(tens,'kvalue,kval);
      end; t>>;

symbolic procedure rem_tensor1 x;
<<remflag(list x,'tensor); elim_names x; 
    remprop(x,'kvalue);
    remprop(x,'klist);
    remprop(x,'simpfn);
    remprop(x,'prifn);
    remprop(x,'fancy!-pprifn);
    remprop(x,'partic_tens);
    remprop(x,'belong_to_space);
    remprop(x,'bloc_diagonal);
    remprop(x,'symtree);
    remflag(list x,'full);
    remflag(list x,'simp0fn);
    remflag(list x,'listargp);
    remflag(list x,'generic);
    remflag(list x, 'symmetric);
    remflag(list x,'antisymmetric);
    (if y then epsilon!*:=delete(y,epsilon!*))where y=assoc(x,epsilon!*);
    >>;

symbolic procedure elim_names u;
% u is the name of a particular tensor
 if get(u,'partic_tens)='simpdelt then remprop('delta,'name)
  else
 if get(u,'partic_tens)='simpdel then remprop('del,'name)
  else
 if get(u,'partic_tens)='simpeta then remprop('eta,'name)
  else
 if get(u,'partic_tens)='simpepsi then remprop('epsilon,'name)
  else
 if get(u,'partic_tens)='metric then remprop('metric,'name);


symbolic procedure tensor u;                                                    
% this is the basic constructor for the tensor object.
 begin;
 u:= for each x in u collect reval x; % correction
  for each x in u do  
 if get(x,'avalue) or (flagp(x,'reserved) and null flagp(x,'tensor))
     or getrtype x  or (gettype x eq 'procedure)
     or (x memq list('sin,'cos,'tan,'atan,'acos,'asin,'int,'df))  
    then rerror(cantens,1,list(x,"may not be defined as tensor"))
   else make_tensor(x,t);
   return t
 end;


symbolic procedure make_tensor(u,v);                                                    
 <<if v and flagp(u,'tensor) then 
    lpri {"*** Warning: ",
                  u,"redefined as generic tensor "};
 rem_tensor list u; 
 flag(list u,'tensor);
 flag(list u,'listargp);
 put(u,'simpfn,'simptensor);
 flag(list u,'simp0fn);
 put(u,'prifn,'indvarprt);                         
 put(u,'fancy!-pprifn,'xindvarprt_tens);
 flag(list u,'full)>>;

symbolic procedure rem_tensor u;
% To erase tensor properties on the list of identifiers u.  
 <<u:=for each x in u collect reval x;
    for each x in u do if flagp(x,'tensor) then
    rem_tensor1 x;
  t>>;

symbolic procedure tensorp u;
% Elementary function to detect tensors. 
 not atom u and flagp(car u,'tensor);

symbolic procedure tensorp!: u;
% u is a list of kernel as it comes from the 
% function list_of_factors applied to a standard term.
% returns the number of tensor kernel present.
  begin integer nt;
  <<while u do if tensorp car u then nt:=nt+1; u:=cdr u>>;
  return nt 
end; 

 flag(list('make_tensor_belong_space),'opfn);

symbolic procedure make_tensor_belong_space(te,sp);
% te must be a tensor identifier
% introduces the indicator 'belong_to_space
% sp is a space name
% First, if no space is defined, it is, by default, unique
% and nothing should be done.
  if !*onespace then nil
   else
   if flagp(te,'tensor) then 
      if get(te,'partic_tens) eq 'simpepsi then 
       <<epsilon!* :=union(list(te . sp),
               delete(assoc(te,epsilon!*),epsilon!*));
          put(te,'belong_to_space,sp) 
       >>
         else  put(te,'belong_to_space,sp);


rlistat '(make_tensor_belong_anyspace);

symbolic procedure make_tensor_belong_anyspace u;
% replace the list of tensors u in the ON ONESPACE 
% environment.  
 <<for each x in u do 
     <<remprop(x,'belong_to_space);
       (if y then 
           epsilon!*:=delete(y,epsilon!*))where y=assoc(x,epsilon!*)
     >>;   
 t>>;

symbolic procedure simptensor u;
% Basic simplification procedure for all tensors.
 begin scalar x,ind,func,varl,bool,lsym; 
    varl:= splitlist!:(u,'list); % gives ((list ...)) or nil.
   if null varl then 
          (if z then <<varl:=z; bool:=t;>>)where z=extract_vars cdr u; 
   ind:=if null varl then cdr u else setdiff(cdr u,varl);
   varl:=if  bool then 'list . varl 
            else 
           if varl then car varl;
    varl:= reval varl;
    x:= (lambda y;  
            mkindxlist for each z in y collect revalind z) ind;
    x:=for each j in x collect reval j; % if substitutions are made.
    x:= (lambda y;  
            mkindxlist for each z in y collect revalind z) x;
   x:=car u . x;
  % identify the possible 'dummy indices':
    ind:=split_cov_cont_ids cdr x;
   % Check numeric indices:
    num_ids_range(ind,car u);
    mk_dummy_ids ind;
   % verify if the set of dummy indices is consistent:
    verify_tens_ids ind; 
   % if u is chosen bloc-diagonal then check the input 
   % and, if symbols belong to different subspaces return 0
    if 
      (if x  then apply1(x,ind))where x=get(car u,'bloc_diagonal)
      then return nil ./ 1; 
   % If u is a special tensor then apply the relevant simplification 
   % function:  
    return if func:=get(car x,'partic_tens) then 
                   if flagp(car u,'generic)  then 
                       if func neq 'simpdelt then apply2(func,x,varl) 
                         else apply2(func,x,varl) ./ 1  
                    else  apply1(func,x) ./ 1
            else 
           if flagp(car x,'symmetric) then 
                            mksq(car x .  
             if null varl then cont_before_cov ordn cdr x
                 else varl .  cont_before_cov ordn cdr x,1)
            else 
           if flagp(car x,'antisymmetric) then 
             if repeats
                  (if null affinep u then 
                      (lambda y; append(car y,cadr y)
                                            )split_cov_cont_ids cdr x 
                     else cdr x)              
                            then nil ./ 1
               else 
             (if not permp!:(z,cdr x) then 
                      negsq mksq(car x . if varl then varl . z
                                          else z,1)
              else mksq(car x . if varl then varl . z 
                                 else z,1)
              )where z= cont_before_cov ordn cdr x 
            else 
           % cases of partial symmetry 
           % when the tensor is 0 it is advantageous to detect it 
           % BEFORE canonical acts:
           if lsym:=get(car u,'symtree) then 
             if symtree_zerop(cdr x,lsym) then nil ./ 1
                  else
                 mksq(if varl then car x . varl . cdr x else x,1)
           else
              mksq(if varl then car x . varl . cdr x else x,1)

 end;

%symbolic procedure current_princ_index_lst(u,v);
 % u is the tensor-kernel, v is its number of indices.
 % it returns a list of the form 
 % ((id_tens1 (index1 . 1) (index2 . 2)...)) 
 % for instance:
 % ((tt (a . 1) ((minus b) . 2) (c . 3) (d . 4)))
 % for the currently handled tensors tt(a,-b,c,d).
 % From it one may extract all informations.
 % subla(v,'tt); ==>
 % ((a . 1) ((minus b) . 2) (c . 3) (d . 4))
 % it is also obtained from the macro 'extract_index_tens'.
% begin integer n; 
%       scalar x,id_tens; 
%    n:=1; 
%    id_tens:=car u;
%    u:=cdr u;
%    while n leq v do 
%           <<x:=nconc(list(car u . n),x);u:=cdr u; n:=n+1>>;
%    return (id_tens . reverse x) . nil
%end;  
	
%symbolic procedure get_n_index(n,u);
 % u is the ouput of the smacro extract_index_tens.
 % n is an integer which corresponds to the index position.
 % gives the corresponding index.
 % it is an atom if contravariant. 
 % it is a list which begins by 'minus' if it is 
 % covariant. 
% if n <= length u then car assoc2(n,u); 

%symbolic procedure index_list u;
 % u is the ouput of extract_index_tens. 
 % gives the list of indices without their positions
 % order in the list corresponds to the order of indices
 % for instance:
 % (a (minus b) c d) for tt(a,-b,c,d)
 % when the tensor is given explicitly in prefix form,
 % it is better to take the cdr of this form.  
 %  begin scalar x;
 %   for i:=1:length u do  x:=get_n_index(i,u) . x;
 %   return reversip x
%end;

symbolic procedure split_cov_cont_ids u;
 % output is the composite list ((cov_indices)(cont_indices))
 % INPUT u is the output of 'index_list' or is simply the cdr 
 % of the prefix form.
 begin scalar xcov,xcont;
 while u do << (if careq_minus y then xcov:= (raiseind y) . xcov 
               else xcont := y . xcont)where y=car u; u:=cdr u>>;
 return list(reversip xcov,reversip xcont)
end; 

symbolic procedure verify_tens_ids u;
% u is the output of split_cov_cont_ids
  begin scalar cov,cnt;
   cov:= car u;
   cnt:=cadr u;
   % eliminate the obviously misplaced dummy indices:
   % i.e. when a dummy index is at least TWICE in cov or cont
      if repeats extract_dummy_ids cov  or 
         repeats extract_dummy_ids cnt then 
   rerror(cantens,2,
            list(list(car u, cadr u),  
             "are inconsistent lists of indices"))
   
   else return  t
                 
 end;

rlistat '(make_variables remove_variables);

symbolic procedure make_variables u;
% u is a list of idp's.
% declare them as variables.
% allow to distinghish them from indices.
 <<for each x in u do flag(list x,'variable);t>>;

symbolic procedure remove_variables u;
% u is a list of idp's.
% declare them as variables.
% allow to distinghish them from indices.
 <<for each x in u do remflag(list x,'variable);t>>;

symbolic procedure extract_vars u;
 if null u then nil 
  else 
 if flagp(raiseind!: car u,'variable) then car u . extract_vars cdr u
  else extract_vars cdr u;

symbolic procedure select_vars u;
% used for SYMMETRIZE.
% use extract_vars 
 begin scalar varl,ind,bool;
    varl:= splitlist!:(u,'list); % gives ((list ...)) or nil.
   if null varl then 
          (if z then <<varl:=z; bool:=t;>>)where z=extract_vars cdr u; 
   ind:=if null varl then cdr u else setdiff(cdr u,varl);
   varl:=if  bool then 'list . varl 
            else 
           if varl then car varl;
    return list(ind,varl)
 end;

symbolic procedure symb_belong_several_spaces ind;
% ind is the list  which comes from split_cov_cont_ids
if !*onespace then nil 
 else
   begin scalar x,sp;	
     x:=clean_numid flattens1 ind;
     while x and 
      (null get(car x,'space) or get(car x,'space) eq 'wholespace)
         do x:= cdr x;
     if null x then return nil 
      else 
        while x and (null get(car x,'space)  or 
                      get(car x,'space) eq 'wholespace) do x:=cdr x;
      sp:=get(car x,'space);
     while x and (null get(car x,'space) or 
             get(car x,'space) eq 'wholespace or 
             get(car x,'space) eq sp) do  x:=cdr x;
    return 
     if null x then nil else t
end;

symbolic procedure num_ids_range(ind,tens);
% this procedure checks the validity of numeric indices in various 
% cases
if !*onespace then  
    if out_of_range(ind,dimex!*,nil) then 
       rerror(cantens,3,"numeric indices out of range")
     else nil 
 else % onespace is OFF. 
      % verify if the tensor belong to a subspace:
if null numindxl!* then 
    if out_of_range(ind,get_dim_space get(tens,'belong_to_space),
         get_sign_space get(tens,'belong_to_space))
       then   rerror(cantens,3,"numeric indices out of range")
    else  nil
 else  (if null lst_belong_interval(x,int) then 
         rerror(cantens,3,"numeric indices do not belong to (sub)-space")
        )where x=extract_numid flattens1 ind,
                int=subla(numindxl!*,get(tens,'belong_to_space));


symbolic procedure restore_tens_idx(u,v);
 % u is a dummy-compatible list, 
 % v is the original list of indices given by 
 % index_list extract_intex_tens <tensor> or cdr <prefix form>.
 % result is the new index_list
 % exemple:
 % u=(d (minus b) a a), v=(a (minus b) c (minus c))
 % restore_tesn_idx(u,v); ==> (d (minus b) a (minus (a)))
 if null u then nil 
  else  
 if null memq(car u,dummy_id!*) then car u . restore_tens_idx(cdr u,cdr v)
  else
 if atom car u and atom car v then car u . restore_tens_idx(cdr u,cdr v)
  else 
 lowerind u . restore_tens_idx(cdr u,cdr v); 
  
symbolic procedure clean_numid u;
 % input is a list of indices.
 % output is a list of 'non-numeric' indices.
 % 11 is the biggest allowed integer 
  if null u then nil 
   else 
 if !*id2num car u then clean_numid cdr u
  else car u . clean_numid cdr u;

symbolic procedure extract_num_id u;
% extract all pseudo-numeric indices from u.
 if null u then nil 
  else 
 if charnump!: car u then car u . extract_num_id cdr u
  else extract_num_id cdr u;

symbolic procedure extract_numid u;
 % input is a list of indices.
 % output is a list of the corresponding 'numeric' indices.
 % 13 is the biggest allowed integer 
  if null u then nil 
   else 
 (if x  then x . extract_numid cdr u
  else extract_numid cdr u)where x=!*id2num car u;
              
symbolic procedure mkindxlist u;                                               
% CONSTRUCTS THE COVARIANT and CONTRAVARIANT numeric INDICES.                   
 for each j in u collect                                                        
   if fixp j then !*num2id j else                                               
       if pairp j and fixp cadr j then list('minus, !*num2id cadr j)            
                                  else j;  

symbolic procedure !*num2id u;                                                  
 %CONVERTS A NUMERIC INDEX TO AN ID;                                             
 %TAKEN FROM EXCALC.                                                             
    if u<12 then intern cdr assoc(u,                                             
              '((0 . !0) (1 . !1) (2 . !2) (3 . !3) (4 . !4)                     
                (5 . !5) (6 . !6) (7 . !7) (8 . !8) (9 . !9)                     
                 (10 . !10) (11 . !11) (12 . !12) (13 . !13)))                                         
   else intern compress append(explode '!!,explode u);                         

symbolic procedure !*id2num u;                                                  
 %CONVERTS AN INDEX TO A NUMBER OR nil IS RETURNED.                              
 begin scalar x ;                                                                
   if x:=  assoc(u, pair_id_num!*) then                                     
    return cdr x 
end;                                                           

symbolic procedure num_indlistp u;
% returns True if the list of indices 
% contains ONLY numeric indices.
 numlis for each y in u collect !*id2num y;

symbolic procedure out_of_range(u,dim,sign);
% dim represents the
% actual space dimension of the space.
% acts only when it is an integer.
% dimsub represents  the subspace signature
% u is the list generated by split_cov_cont_ids
 if fixp dim then 
  begin scalar lu,sign_space;
   lu:=extract_numid flattens1 u;
   sign_space:=if null sign then signat!* else sign;
   while lu and 
        (if sign_space=1 then car lu < dim  
          else 
         if sign_space =0 then car lu <=dim)
                                do lu:=cdr lu;
    return if lu then t else nil
  end;

symbolic procedure revalind u;
 % Pour que -0 ne devienne pas +0:
    begin scalar x,y,alglist!*;
      x := subfg!*;
      subfg!* := nil;
      u := subst('!0,0,u);
      % The above line is used to avoid the simplification of -0 to 0.
      y := prepsq simp u;
      subfg!* := x;
      return y
   end;

symbolic procedure revalindl u;
for each ind in u collect revalind ind;

symbolic procedure indvarprt u;
% An extension of the corresponding function of EXCALC
    if null !*nat then <<prin2!* car u;
                         prin2!* "(";
                         if cddr u then inprint('!*comma!*,0,cdr u)
                          else maprin cadr u;
                         prin2!* ")" >>
     else begin scalar x,y,y2,args,spaceit; integer l,maxposn!*,oldy; 
            l := flatsizec flatindxl u+length cdr u-1;
            if l>(linelength nil-spare!*)-posn!* then terpri!* t;
            %avoid breaking of an indexed variable over a line;
            y := ycoord!*;
            maxposn!*:=0;
            prin2!* car u;
            spaceit := if get(car u,'partic_tens) memq {'simpdelt,'simpdel}
                         then  << x := posn!*; nil>> 
                         else t;
            for each j on cdr u do
              <<oldy:=ycoord!*;
                ycoord!* :=  y + if (atom car j) or (careq_tilde car j) then 1 else -1;
                if null(spaceit) and (oldy neq ycoord!*) then 
                  << if posn!*>maxposn!* then maxposn!*:=posn!*;
                     posn!*:=x;
                  >>;
                if ycoord!*>ymax!* then ymax!* := ycoord!*;
                if ycoord!*<ymin!* then ymin!* := ycoord!*;
                if (atom car j) or (careq_tilde car j)
                  then maprint (car j,0)
                else if careq_minus car j
                  then maprint (cadar j,0)
                else args := car j;
                if cdr j then prin2!* " ">>;
            if null cdr u then
              <<ycoord!* :=  y + 1;
                if ycoord!*>ymax!* then ymax!* := ycoord!*;
                if ycoord!*<ymin!* then ymin!* := ycoord!*;
                maprint ('!(!),0)
              >>;
            ycoord!* := y;
            if (maxposn!*>0) and (posn!*<maxposn!*) then posn!*:=maxposn!*;
            if args then
                << prin2!* "(";
                   obrkp!* := nil;
                   y2 := orig!*;
                   orig!* := if posn!*<18 then posn!* else orig!*+3;
                   if cdr args then inprint('!*comma!*,0,cdr reval args );
                   obrkp!* := t;
                   orig!* := y2;
                   prin2!* ")";
                >>;
          end;

put('indvarprt,'expt,'inbrackets);

symbolic procedure xindvarprt_tens(l,p);
  % An extension of the function XINDVARPRT of  EXCALC.
  fancy!-level
  ( if not(get('expt,'infix)>p) then
      fancy!-in!-brackets({'xindvarprt_tens,mkquote l,0}, '!(,'!))
    else
      begin scalar w,x,s,args,spaceit;
        spaceit:=t;
        w:=(fancy!-prefix!-operator car l) where fancy_lower_digits = nil;
                 if get(car l,'partic_tens) memq {'simpdelt,'simpdel}
                                  then spaceit:=nil;
        if w eq 'failed then return w;
        l := cdr l;
        if l then
          << 
          while l and (w neq 'failed) do
            << if (atom car l) or (careq_tilde car l) then 
                 (if s eq '!^ then 
                    x := car l . x
                  else <<
                    if s then
                      <<if spaceit then fancy!-prin2!*("{}",0);
                      w := fancy!-print!-indexlist1(reversip x,s,nil)>>;
                    x := {car l};
                    s := '!^>> )
               else (
                 if careq_minus(car l) then 
                   ( if s eq '!_
                     then x := cadar l . x
                     else <<
                       if s then
                         <<if spaceit then fancy!-prin2!*("{}",0);
                           w := fancy!-print!-indexlist1(reversip x,s,nil)>>;
                       x := {cadar l};
                       s := '!_>> )
                 else
                   args:=car l);
              l := cdr l>>;
          if x then 
            << if spaceit then fancy!-prin2!*("{}",0);
               w := fancy!-print!-indexlist1(reversip x,s,nil);
               if w eq 'failed then return w >>;
          if args then w:=fancy!-print!-function!-arguments cdr args;
          >>
            else
          <<
             w := fancy!-print!-indexlist1(list('!(,'!)),'!^,nil)
          >>;
       return w;
   end);

endmodule;

end;