Artifact 9263918451476c8be6349f8029e41b91dde73ee6144506e17cb972acdade4d5c:
- Executable file
r37/packages/assist/contrtns.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 16637) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/assist/contrtns.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 16637) [annotate] [blame] [check-ins using]
module contrtns; 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!* !*distribute)); % g_dvnames is a vector. switch onespace; !*onespace:=t; % working inside a unique space is the default. fluid('(indxl_tens!* dummy_id!* g_dvnames)); % g_dvnames is a vector. % This module contains the procedures which enhances the % capabilities of 'canonical' which is the master function of DUMMY.RED. % That function is now able to make tensor-like expressions contractions % and to find the normal form of an expression containing "tensors" % and derivatives of these and of operators. % auxiliary functions to canonical: symbolic procedure no_dum_varp u; % u is the mvar of a msf % returns t if the indices are all variables or if % no indices. % this is a variation on 'nodum_varp' which should still % be improved. if null cdr u or (splitlist!:(cdr u,'list)=cdr u) then t else nil; %symbolic procedure no_dum_varp u; % u is the mvar of a msf % returns t if the indices are all variables % or if % covariant and contravariant indices are the same. % this is a variation on 'nodum_varp' which should still % be improved. % it was aimed to avoid elimination of powers for traces but % it does not work because they are treated as operators % in sep-tens_from_other % if null cdr u or (splitlist!:(cdr u,'list)=cdr u) then t % else % begin scalar ll; % ll:= splitlist!:(cdr u,'list); % if ll then % <<ll:=car ll; % ll:= for each y in split_cov_cont_ids cdr u collect ordn delete(ll,y)>> % else % ll:=for each y in split_cov_cont_ids cdr u collect ordn y; % if car ll = cadr ll then return t % end; symbolic procedure sep_tens_from_other u; % u is a standard form which describes a monomial. % output is list(<ordered list of tensor kernels>,<standard form without tensors>) % does NOT change ordering since multiplication is not necessarily % commutative. begin scalar mv,tel,other,y; other:= !*n2f 1; l: if numberp u then return list(reversip tel, multf(other,!*n2f u)) else if atom mvar u then other:=multf(other,!*p2f lpow u) else << if y:=get(car mvar u, 'Translate1) then << u:=fullcopy u; (mvar u:= apply1(y,mvar u)) >>; % if tensorp mvar u then tel:=mvar u . tel % else other :=multf(other,!*p2f lpow u)>>; if tensorp(mv:=mvar u) then if null no_dum_varp mv or flagp(car mv,'noncom) then tel:=mvar u . tel else other :=multf(other,!*p2f lpow u) else other :=multf(other,!*p2f lpow u) >>; u:= lc u; go to l; end; symbolic procedure all_index_lst u; % u is a list of tensor kernels. % output is the list of all indices % example: % cc:= car sep_tens_from_other bb; % ((te r b (minus c)) (te r (minus s) (minus d)) (te (minus r) c d)) % gives (r b (minus c) r (minus s) (minus d) (minus r) c d) if null u then nil else append( ((if listp car y and caar y = 'list then cdr y else y ) where y=cdar u), all_index_lst cdr u); symbolic procedure del_affin_tens u; % u is a list of tensor kernels if null u then nil else if affinep car u then del_affin_tens cdr u else car u . del_affin_tens cdr u; symbolic procedure dv_canon_covcont(sf); % for Riemanian spaces, places contravariant dummy indices first % in place. if domainp sf then sf else begin scalar tenslist,idlist,dummyid; dummyid:=dummy_id!*; tenslist:=car sep_tens_from_other(sf); % get tensor list; % y:=del_affin_tens y; if null tenslist then return restorealldfs sf; idlist:=all_index_lst tenslist; %get list of all indexes; for each z in tenslist do if (get(car z,'partic_tens)='simpdel) or affinep z then for each y in cdr z do dummyid:=delete(raiseind!: y, dummyid); for each z in idlist do if atom z then (if z memq dummyid % first dummy index is high. no more to do with it. then dummyid:=delete(z,dummyid)) else if careq_minus z and memq(cadr z,dummyid) then % first dummy index is low, change this. << sf:=subst(list('minus,cadr z),cadr z,sf); dummyid:=delete(cadr z,dummyid)>>; return restorealldfs sf; end; symbolic procedure cov_contp(u,v); % u and v are lists of tensors indices % verify if one has expressions of the form % (a,b,c,...) and ((minus a')(minus b')(minus c')...) % for u and v or for v and u. % IMPORTANT for epsilon products. cov_lst_idsp u and cont_lst_idsp v or cont_lst_idsp u and cov_lst_idsp v; symbolic procedure belong_to_spacep(u,sp); % u is a list of indices % sp is the name of a space % t if ALL INDICES belong to sp. % I do not think it is still needed. **** if null u or sp = 'wholespace then t else if get(car u,'space) eq sp then belong_to_spacep (cdr u,sp); symbolic procedure extract_tens(tel,sp_tens); % tel is a list of tensor kernels as given by the car of the % output of 'sep_tens_from_other' % sp_tens is the name of a special tensor % result is a list of these tensors found in tel if null tel then nil else if caar tel = sp_tens then car tel . extract_tens(cdr tel,sp_tens) else extract_tens(cdr tel,sp_tens); symbolic procedure treat_dummy_ids(sf); % manage all dummy indices by interfacing with dummy.red % Creates bags of ids belonging to same space, and them call % the simplification procedure form dummy. if !*onespace then begin scalar user_g_dvnames,res; user_g_dvnames:=g_dvnames; dummy_nam dummy_id!*; res:=dv_canon_monomial sf; g_dvnames:=user_g_dvnames; return if g_dvnames then dv_canon_covcont dv_canon_monomial res else dv_canon_covcont res; end else begin scalar res,partit_space_lst,idxl,sp,user_g_dvnames,bool; partit_space_lst:=nil; user_g_dvnames:=g_dvnames; partit_space_lst:=for each y in spaces!* collect car y . nil; % Put each index with the ones belonging to same space for each z in dummy_id!* do if sp:=space_of_idx z then % dummy indices which have not been declared to belong to a (sub)space % are assumed to belong to 'wholespace' % and no error statement is generated iff 'wholespace' has been defined. if idxl:=assoc(sp,partit_space_lst) then cdr idxl:= z . cdr idxl else rerror(cantens,14, list("Index ",z," does not belong to a defined space")); res:=sf; for each z in partit_space_lst do if (idxl:=cdr z) then <<bool:=t; dummy_nam idxl; res:=dv_canon_monomial(res)>>; if not bool then res:=dv_canon_monomial res; %% added g_dvnames:=user_g_dvnames; return if g_dvnames then dv_canon_covcont dv_canon_monomial res else dv_canon_covcont res; end; % % the dummy user procedure modified to perform tens calculations % symbolic procedure canonical sq; begin scalar sf, denom, !*distribute; sq := simp!* car sq; denom := denr sq; on distribute; sf := distri_pol numr sq; % Check coherence of dummy and free indices and generate dummy_id!*.. %% simplify the whole thing, and return return simp!*( {'!*sq, canonical1(sf, cadr check_ids(sf)) ./ denom, nil} ); end; symbolic procedure canonical1 (sf, dumlist); begin scalar dummy_id!*, res; dummy_id!*:=dumlist; % WE MUST BE SURE THAT FURTHER SIMPLIFICATIONS WILL % NOT REPLACE AN ST BY SEVERAL ST's % IF RULES ARE APPLIED THEY SHOULD HAVE ACTED BY NOW. % IF SEVERAL TENSORS ARE OF THE EPSI KIND THEY MUST ANALYZED % AND, POSSIBLY, REPLACED BY 'DEL' OR EXPANSIONS OF IT. % FOR INSTANCE e(-a,-b)*e(c,d)= % del(-a,c)*delt(-b,d) - del(-a,d)*delt(-b,c) % then we must generate a SUM of standard forms % This is HERE that products of epsilon tensors should be dealt with % => SIMPEPSE.RED. % Epsi simplification. while not domainp sf do << res:=addf(res,simpepsi_mon_expr(lt sf .+ nil)); sf:=red sf; >>; sf:= distri_pol addf(res,sf); res:=nil; while not domainp(sf) do << (if length car y >=2 then res:= addf(res,dv_canon_tensor y) else res := addf(res, treat_dummy_ids(lt sf .+ nil))) where y=sep_tens_from_other (lt sf .+ nil); sf:=red sf; >>; clearallnewids(); % Now add the domainp term: return res := addf(res,sf); end; symbolic procedure tensor_has_dummy_idx(dum,te); % dum is a list of dummy indices % te is a tensor in prefix form. % T(rue) if one of the indices of te belongs to dum. if null dum then nil else if smember(car dum, te) then t else tensor_has_dummy_idx(cdr dum,te); symbolic procedure tens_list_is_generic tel; % tel is a list of tensors % output is T(rue) if ALL tensors are generic if null tel then t else if null get(caar tel,'partic_tens) then tens_list_is_generic cdr tel; symbolic procedure mk_delta_first tel; % input is a list of tensor kernels. % output is an equivalent list with % all delta-like tensors placed first % and eta-like tensors second. begin scalar x,y,z; x:=extract_tens(tel,get('delta,'name)); z:=setdiff(tel,x); y:=extract_tens(z,get('eta,'name)); z:=setdiff(z,y); return append(x,append(y,z)) end; symbolic procedure dv_canon_tensor u; % u is list(<list of tensor kernels>,<standard form without tensors>) % output is a standard form given to dv_canon_monomial. % First take the list of tensor kernels and make the contractions % if necessary. begin scalar x,tel,tel_dum,tel_free,notens; tel:=car u; tel_free:=!*n2f 1; notens:=cadr u; % replace the list tel by tel_dum % where tel_dum contains tensors with dummy indices. % and put the rest in tel_free for each y in tel do if tensor_has_dummy_idx(dummy_id!*,y) then tel_dum:=y . tel_dum else tel_free:=multf(!*k2f y,tel_free); tel_dum:=tel_dum; % to restitute the order % now tel_dum must eventually be transformed by contractions. % Two cases appear: % all tensors in tel_dum are generic: return if tens_list_is_generic tel_dum then <<x:=!*n2f 1; if tel_dum then tel_dum:=for each y in tel_dum collect !*k2f y; while tel_dum do << x:=multf(car tel_dum, x);tel_dum:=cdr tel_dum; >>; multf(restorealldfs tel_free,treat_dummy_ids multf(x,notens)) >> % one or several tensors are particular ones: else % simptensexpr must output a standard form. multf(restorealldfs tel_free, treat_dummy_ids multf(simptensexpr( mk_delta_first tel_dum,dummy_id!*,1),notens)); end; symbolic procedure simptensexpr(tel,dum,i); % tel is the list of tensor kernels % dum is the associated list of dummy variable % output should be the standard form of the contracted tensors. begin scalar res; res:=!*n2f 1; return if numberp tel then !*n2f tel else if atom tel or length tel=1 then !*k2f car tel else if i>=length tel + 1 then <<for each i in tel do res:=multf(res,!*k2f i);res>> else (if y memq list('simpdelt,'simpeta,'simpmetric) then simpdeltetaexpr(tel,dum,i) else simptensexpr(tel,dum,i+1) % here the epsi tensors should NOT be considered % since they are already simplified. )where y=get(car nth(tel,i),'partic_tens); end; symbolic procedure simpdeltetaexpr(tel,dum,i); % output is the result of contraction of the ith tensor % with the other ones. % tensor with the other-ones (at least one is present). % The SAME procedure appears to be valid for BOTH 'delta' and 'eta'. begin scalar itel,rtel,res,old,new; % itel is delta tensor kernel. % rtel is the list of the other tensors % res is the new list of kernels. itel:=nth(tel,i); if (id_switch_variance cadr itel) neq caddr itel and intersection(flatindxl cdr itel,dum) then << rtel:=remove(tel,i); % let us identify where the dummy index in itel is: % and define substitution variables: if (old:=raiseind!: cadr itel) memq dum then << old:=id_switch_variance cadr itel; new:=caddr itel >> else << old:=id_switch_variance caddr itel; new:=cadr itel >>; res:=subst(new,old,rtel); return simptensexpr(res,dum,i) >> else return simptensexpr(tel,dum,i+1); end; symbolic procedure select_epsi_pairs ep; % result is a list of PAIRS of contractible (to DEL) % epsilon-pairs. % if there are 3 or more epsilons of a given kind, % they are eliminated. So contractions will NOT be done. % to allow for this, generalize THIS procedure. % the problem however is which two among the three of % should we choose. if null ep then nil else (if length x = 2 and cov_contp(cdar x,cdadr x) then x . select_epsi_pairs cdr ep else select_epsi_pairs cdr ep) where x=car ep; symbolic procedure mk_eps_lst tkl; % tkl is a list of tensor kernels % extract the list of contractible epsilon pairs from tkl % and substracts them from tkl. % returns list(<epsilon pair list>,<new tkl>) or nil. begin scalar eps_lst; eps_lst:= if !*onespace and get('epsilon,'name) then list extract_tens(tkl,find_name('epsilon)) else if epsilon!* then for each i in epsilon!* collect extract_tens(tkl,car i) else nil; eps_lst:=select_epsi_pairs eps_lst; if null eps_lst then return list(nil,tkl); for each j in eps_lst do tkl:=setdiff(tkl,j); return list(eps_lst,tkl) end; symbolic procedure get_sign_space!: u; if null u then signature '? else get_sign_space u; symbolic procedure epsi_to_del(ep); % ep is a list of contractible epsilon pairs. % returns a standard form which represents the product of % the DEL-like objects % First task: replace all eps-products by DEL-like objects % taking properly into account the space signature. % Second task: reconstruct the SF-product. if null ep then nil else begin scalar del_prd,x,y; % del_prd is the SF which results from application of SIMPDEL del_prd:=!*n2f 1; for each j in ep do <<x:=all_index_lst j; if get_sign_space!:(if y:=assoc(caar j,epsilon!*) then cdr y else nil) = 1 then del_prd:=multf(negf apply1('simpdel,find_name('del) . x), del_prd) else del_prd:=multf(apply1('simpdel,find_name('del) . x), del_prd)>>; return del_prd end; symbolic procedure simpepsi_mon_expr msf; % msf is a monomial standard form. % result is a NEW STANDARD FORM after simplifications on epsilon products % presently, we limit simplification to the case of TWO epsilons % for each defined space . % since more general products are usually not encountered. if domainp msf then msf else begin scalar tens_msf,notens,x,del_prd; % First see if some simplifications are possible. tens_msf:=sep_tens_from_other msf; notens:=cadr tens_msf; notens:=if notens then notens else !*n2f 1; tens_msf:=car tens_msf; if null tens_msf then return msf; % we have to extract relevant epsilon products from tens_msf % and construct the DEL-like product x:=mk_eps_lst tens_msf; tens_msf:=reverse cadr x; % function epsi_to_del returns an SF del_prd:= epsi_to_del car x; % we do the product of DEL-like tensors and operators. x:=if del_prd then multf(del_prd,notens) else notens; for each j in tens_msf do x:=multf(!*k2f j,x); % returns tne new SF which is NO LONGER a monomial. return x end; endmodule; end;