Artifact 9b4426f8af0ce59955b04e4c89b45cbcc2339718849ac32f54d4abb3af60d631:
- Executable file
r37/packages/assist/partitns.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: 19251) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/assist/partitns.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: 19251) [annotate] [blame] [check-ins using]
module partitns; % definitions of particular tensors. global '(dimex!* sgn!* signat!* spaces!* numindxl!* pair_id_num!*); fluid('(dummy_id!* g_dvnames epsilon!*)); % epsilon!* keeps track of the various epsilon tensors % which may be defined when onespace is OFF % It is a list pairs (<space-name> . <name>) switch exdelt; % default is OFF switch onespace; !*onespace:=t; % working inside a unique space is the default. flag(list('delta,'epsilon,'del,'eta,'metric), 'reserved); % they are keywords. symbolic flag(list('make_partic_tens),'opfn); symbolic procedure make_partic_tens(u,v); % u is a bare identifier (free of properties) % the result is T(rue) when it suceeds to create % the properties of being a particular tensor on u. % can be trivially generalized to other tensors. if v memq {'delta,'eta,'epsilon,'del,'metric} then << if get(u,'avalue) % or (get(u,'reserved) and null flagp(u,'tensor)) or getrtype u or (gettype u eq 'procedure) or % is this necessary? (u memq list('sin,'cos,'tan,'atan,'acos,'asin,'df,'int)) then rerror(cantens,5,list(u,"may not be defined as tensor")) else if flagp(u,'tensor) then <<lpri {"*** Warning:", u,"redefined as particular tensor"}; remprop(u,'kvalue); remprop(u,'simpfn); remprop(u,'bloc_diagonal); remflag(list u,'generic); >>; % the 'name' indicator allows to find % the name chosen for a particular tensor from the keyword % associated to it. % Only ONE tensor of type 'delta' and 'eta' are allowed so: (if x and v memq {'delta,'eta,'del} then rem_tensor1 x)where x=get(v,'name); make_tensor(u,nil); % contains the action of rem_tensor put(u,'partic_tens, if v = 'delta then 'simpdelt else if v = 'eta then 'simpeta else if v = 'epsilon then 'simpepsi else if v = 'del then 'simpdel else if v= 'metric then 'simpmetric); if null !*onespace and v = 'epsilon then if epsilon!* then <<put(v,'name,u); lpri {"*** Warning:", u,"MUST belong to a space"};>> else nil; put(v,'name, u); if v memq {'metric,'delta} then <<flag(list u,'generic); make_bloc_diagonal u>>; t >> else "unknown keyword"; symbolic procedure find_name u; % find the name of a particular tensor whose keyword is u. % Must still be extended for u=epsilon (if null x then rerror(cantens,6,{" no name found for", list u}) else x)where x=get(u,'name); % **** Simplification functions for particular tensors symbolic procedure simpdelt (x,varl); % x is is a list {<tensor> indices} % for instance (tt a (minus b)) for tt(a,-b) % varl is the set of variables {v1,v2, ...} % result is the simplified form of the Dirac delta function if varl is nil % and cdr x is nil. If varl and null cdr x then !*k2f(car x . varl . nil) else if null varl or null cdr varl then begin scalar delt,ind,y,yv,yc; delt := car x; ind:= cdr x; y:=split_cov_cont_ids ind; if (length car y * length cadr y) neq 1 then rerror(cantens,7, "bad choice of indices for DELTA tensor"); yv:=caar y; yc:=caadr y; % The conditional statement below can be suppressed if % 'wholespace' can be defined with an indexrange. % if get(delt,'belong_to_space) eq 'wholespace then % if get_sign_space('wholespace) = 0 then % if yv='!0 or yc ='!0 then % rerror(cantens,2,"bad value of indices for DELTA tensor"); if !*id2num yv and !*id2num yc then return if yv=yc then 1 else 0 else if !*onespace then return if yv eq yc then dimex!* else !*k2f(delt . append(cadr y,lowerind_lst car y)) else return if null get(yv,'space) and yv eq yc then if assoc('wholespace,spaces!*) then !*k2f get_dim_space 'wholespace else "not meaningful" else if yv eq yc then !*k2f space_dim_of_idx yv else !*k2f(delt . append(cadr y,lowerind_lst car y)) end else "not meaningful"; symbolic procedure simpdel u; % u is the list {<del-name> <covariant indices> % <contravariant indices>} % when 'DEL' is used by the system through simpepsi, % indices are already ordered and, when 'canonical' is entered, % they are again ordered after contractions. So ordering is % necessary only if the user enters it from the start. % in spite of this, the procedure is made to order them % in all cases. REFINEMENTS to avoid that are possible. % returns a standard form. begin scalar del,ind,x,idv,idc,idvn,idcn,bool,spweight; integer free_ind,tot_ind,dim_space; del:= car u; ind:=cdr u; spweight:=1; % though it is antisymmetric separately with respect to the cov % and cont indices we do not declare it as such for the time being. x:=split_cov_cont_ids ind; idv:= car x; idc:=cadr x; if length idv neq length idc then rerror(cantens,7, "bad choice of indices for DEL tensor") else if null !*onespace then if null symb_ids_belong_same_space!:( append(idv,idc),nil) then rerror(cantens,7, "all indices should belong to the SAME space") else if repeats idv or repeats idc then return 0 else if length idc =1 then return apply2('simpdelt, find_name('delta) . append(lowerind_lst idv,idc),nil); % here we shall start to find the dummy indices which are internal % to 'del' as in the case del(a,b,a1..an, -a,-b,-c1, ...-cn) which % can be simplified to del(a1,...an,-c1, ...,-cn)*polynomial in the % space-dimension or a number if N_space=number % first arrange each list so that dummy indices are at the beginning % of idv and idc. idv:=for each y in idv collect %au lieu de idvn if null !*id2num y and memq(y,idc) then list('dum,y) else y; idc:=for each y in idc collect if null !*id2num y and memq(y,car x) then list('dum,y) else y; if permp!:(idvn:=ordn idv,idv)=permp!:(idcn:=ordn idc,idc) then bool:=t; % the form of these new lists is ((dum a) (dum b) ..ak..) etc ... % 1. they contain only numeric indices: if num_indlistp append(idvn,idcn) then return simpdelnum(idvn,idcn,bool); % 2. some indices are symbolic: tot_ind:=length idvn; % dummy indices can be present: idv:=splitlist!:(idvn,'dum); % if no dummy indices, it is nil. free_ind:=tot_ind - length idv; % now search the space in which we are working. dim_space:= if idv then %% since, may be, no dummy indices if null spaces!* then dimex!* else !*k2f space_dim_of_idx cadar idv; for i:=free_ind : (tot_ind -1) do <<spweight:=multf(addf(dim_space,negf !*n2f i),spweight); idvn:=cdr idvn; idcn:=cdr idcn; >>; spweight:=!*a2f reval prepf spweight; if null idvn then return if bool then spweight else negf spweight; % left indices can again be all numeric indices if num_indlistp append(idvn,idcn) then return multf(spweight,simpdelnum(idvn,idcn,bool)); % 3. There is no more internal dummy indices, so return % if !*exdelt then % if bool then % multf(spweight,extract_delt(del,idvn,idcn,1)) % else negf multf(spweight,extract_delt(del,idvn,idcn,1)) % else if !*exdelt then if bool then multf(spweight,extract_delt(del,idvn,idcn,'full)) else negf multf(spweight,extract_delt(del,idvn,idcn,'full)) else if length idvn=1 then if bool then multf(spweight, !*k2f(find_name('delta) . append(lowerind_lst idvn,idcn))) else negf multf(spweight, !*k2f(find_name('delta) . append(lowerind_lst idvn,idcn))) else if bool then multf(spweight,!*k2f(del . append(lowerind_lst idvn ,idcn))) else multf(spweight,negf !*k2f(del . append(lowerind_lst idvn , idcn))) end; symbolic procedure simpdelnum(idvn,idcn,bool); % simplification of 'DEL' when all indices are numeric. if idvn=idcn then if bool then 1 else -1 else 0; symbolic procedure extract_delt(del,idvn,idcn,depth); % we deal with already ordered lists. Numeric indices % come first like (!1 !2 a). So, extraction is done from % the left because the result simplify more. if length idcn =1 then apply2(function simpdelt, get('delta,'name) . lowerind car idvn . car idcn . nil,nil) else begin scalar uu,x,ind; ind:=car idcn; idcn:=cdr idcn; if depth =1 then for i:=1:length idvn do <<x:=multf(exptf(-1,i-1), multf(apply2(function simpdelt, get('delta,'name) . (ind . list lowerind nth(idvn,i)),nil), !*q2f mksq((if length idvn=2 then get('delta,'name) else del) . append(idcn, lowerind_lst remove(idvn,i)),1) ) ); uu:=addf(x,uu) >> else if depth='full then for i:=1:length idvn do <<x:= multf(exptf(-1,i-1), multf(apply2(function simpdelt, get('delta,'name) . (ind . list lowerind nth(idvn,i)),nil), extract_delt(del,remove(idvn,i),idcn,depth) ) ); uu:=addf(x,uu) >>; return uu end; symbolic procedure idx_not_member_whosp u; % u is an index (if x then x neq 'wholespace) where x=get(u,'space); symbolic procedure ids_not_member_whosp u; % U is a list of indices. if null u then t else if idx_not_member_whosp car u then ids_not_member_whosp cdr u else nil; symbolic procedure simpeta u; % u is a list {<tensor> indices} % for instance tt(a b) or tt(a -b) or tt(-a,-b) % result is the simplified form of the Minkowski metric tensor. if (!*onespace and signat!*=0) then msgpri(nil,nil, "signature must be defined equal to 1 for ETA tensor",nil,t) else if (null !*onespace and null get_sign_space get(car u,'belong_to_space)) then msgpri(nil,nil, "ETA tensor not properly assigned to a space",nil,nil) else begin scalar eta,ind,x; eta := car u; ind:= cdr u; flag(list eta,'symmetric); x:=split_cov_cont_ids ind; if car x and cadr x then return apply2('simpdelt,find_name('delta) . ind,nil); % Now BOTH indices are up or down, so x:=if null car x then cadr x else car x; if length x neq 2 then rerror(cantens,8, "bad choice of indices for ETA tensor"); x:=for each y in x collect !*id2num y; return if numlis x then num_eta x else if !*onespace then !*k2f(eta . ordn ind) else if ids_not_member_whosp {car ind,cadr ind} and get(car ind,'space) neq get(cadr ind,'space) then 0 else !*k2f(eta . ordn ind) end; symbolic procedure num_eta u; % u is the list of covariant or contravariant indices of ETA. if car u = cadr u then if car u = 0 then sgn!* else negf sgn!* else 0; symbolic procedure simpepsi u; % Simplification procedure for the epsilon tensor. begin scalar epsi,ind,x,spx,bool; epsi := car u; % spx is the space epsi belongs to. % so we can define SEVERAL epsi tensors. spx:= get(epsi,'belong_to_space); % In case several spaces are used. % otherwise it is nil ind:= cdr u; flag(list epsi,'antisymmetric); x:=split_cov_cont_ids ind; if null car x then x:='cont . cadr x else if null cadr x then x:= 'cov . car x else x:= 'mixed . append(car x, cadr x); % If the space has a definite dimension we must take care of the number % of indices: (if fixp y and y neq length cdr x then rerror(cantens,9, list("bad number of indices for ", list car u," tensor")) )where y= if spx then get_dim_space spx else (if fixp z then z)where z=wholespace_dim '?; if repeats x then return 0; % if null !*onespace then one must verify that all % indices belong to the same space as epsi. if null !*onespace and spx then if null ind_same_space_tens(cdr u,car u) then rerror(cantens,9, list("some indices are not in the space of",epsi)); return if car x eq 'mixed or not num_indlistp cdr x then begin scalar xx,xy; xx:=ordn ind; bool:=permp!:(xx,ind); if car x eq 'mixed then <<xy:=cont_before_cov ind; if null permp!:(xy,xx) then bool:=not bool>>; return if bool then !*k2f(epsi . if car x eq 'mixed then xy else xx) else negf !*k2f(epsi . if car x eq 'mixed then xy else xx) end else % cases where all indices are numeric ones must be handled separately % Take the case where either no space is defined or declared. Then % space is euclidean. % look out ! spx is EUCLIDEAN by default. To avoid it, use % 'make_tensor_belong_space'. if !*onespace or null spx then if signat!* =0 then num_epsi_euclid(x) else if signat!* =1 then num_epsi_non_euclid (epsi,x) else nil else if null get_sign_space spx or get_sign_space spx=0 then num_epsi_euclid (cdr x) else if get_sign_space spx =1 then num_epsi_non_euclid (epsi,x) else "undetermined signature or signature bigger then 1"; end; symbolic procedure num_epsi_non_euclid(epsi,ind); % epsi is the name of the epsilon tensor % ind is the list (cont n1 n2 nk) or (cov n1 n2 .. nk) % result is either 0 OR +- (epsi 0 1 2 .... k)) % i.e. in terms of contravariant indices. % So, in case of covariant indices we must take care of the % product eta(0,0)*... *eta(spx,spx) and the convention % sgn!* enters the game. begin scalar x; x:=ordn cdr ind; return if car ind eq 'cont then (if y then y else if permp!:(x,cdr ind) then !*k2f(epsi . x) else negf !*k2f(epsi . x))where y=!*q2f match_kvalue(epsi,x,nil) else if car ind eq 'cov then if sgn!* = 1 then if evenp length cdr x then (if y then y else if permp!:(x,cdr ind) then !*k2f(epsi . x) else negf !*k2f(epsi . x))where y=!*q2f match_kvalue(epsi,x,nil) else (if y then negf y else if permp!:(x,cdr ind) then negf !*k2f(epsi . x) else !*k2f(epsi . x))where y=!*q2f match_kvalue(epsi,x,nil) else if sgn!* =-1 then (if y then negf y else if permp!:(x,cdr ind) then negf !*k2f(epsi . x) else !*k2f(epsi . x))where y=!*q2f match_kvalue(epsi,x,nil) else nil else nil; end; flag({'show_epsilons},'opfn); symbolic procedure show_epsilons(); (if null x then {'list} else 'list . for each y in x collect list('list,mk!*sq !*k2q car y,mk!*sq !*k2q cdr y))where x=epsilon!*; symbolic procedure match_kvalue(te,ind,varl); % te is a tensor, result is nil or a standard form. % Must return a standard quotient. (if x then simp!* cadr x)where x= if varl then assoc(te . varl . ind,get(te,'kvalue)) else assoc(te . ind,get(te,'kvalue)); symbolic procedure num_epsi_euclid(ind); % ind is the list (i1, ...,in), therefore % here epsi(1,2, n)=1=epsi(-1,-2, ... -n) begin scalar x; x:=ordn ind; return if permp!:(x,ind) then 1 else -1 end; symbolic procedure simpmetric(u,var); % generic definition of the metric tensor % covers the possibility of several spaces. % may depend of any number of variables if needed. % 'var' is {x1, .. xn}. % receives an SF and sends back an SQ. % CORRECTED begin scalar g,ind,x; if x:=opmtch u then return simp x; g:=car u; ind:=cdr u; flag(list g,'symmetric); x:=split_cov_cont_ids ind; if car x and cadr x then return apply2('simpdelt,find_name('delta) . ind,nil) ./ 1; % Now BOTH indices are up or down, so x:=if null car x then cadr x else car x; if length x neq 2 then rerror(cantens,10, "bad choice of indices for a METRIC tensor"); % case of numeric indices. x:=for each y in x collect !*id2num y; return if numlis x then if !*onespace then if x:= match_kvalue(g,ordn ind,var) then x else !*k2f(g . if var then var . ordn ind else ordn ind) ./ 1 else mult_spaces_num_metric(g,ind,var) ./ 1 else if !*onespace then if x:= match_kvalue(g,ordn ind,var) then x else !*k2f(g . if var then var . ordn ind else ordn ind) ./ 1 else if get(car ind,'space) neq get(cadr ind,'space) then 0 else if x:= match_kvalue(g,ordn ind,var) then x else !*k2f(g . if var then var . ordn ind else ordn ind) ./ 1 end; symbolic procedure mult_spaces_num_metric(g,ind,var); % g, is the name of the metric tensor % ind its numeric indices (both covariant or contravariant) begin scalar x,y; x:=if pairp car ind then raiseind_lst ind else ind; return if numindxl!* and null numids2_belong_same_space(car x,cadr x,g) then 0 else if y:= match_kvalue(g,if var then var . ordn ind else ordn ind,var) then y else !*k2f(g . if var then var . ordn ind else ordn ind) end; endmodule; end;