Artifact 7e2e51f177d997fd6d68e064e3a1f60be7b8dae394355cd2727e2809367427b4:
- Executable file
r37/packages/assist/ctintro.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: 8008) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/assist/ctintro.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: 8008) [annotate] [blame] [check-ins using]
module ctintro; fluid('(dummy_id!* g_dvnames)); % g_dvnames is a vector. % patches and extensions of some functions of the packages ASSIST and % DUMMY % load_package dummy; % % function REMSYM is generalised to take account of partial symmetries symbolic procedure remsym u; % ALLOWS TO ELIMINATE THE DECLARED SYMMETRIES. for each j in u do if flagp(j,'symmetric) then remflag(list j,'symmetric) else if flagp(j,'antisymmetric) then remflag(list j,'antisymmetric) else remprop(j,'symtree); % function SYMMETRIZE is generalized for total antisymmetrization % and for lists of (cyclic-)permutations. symbolic procedure sym_sign u; % u is a standard form for the kernel of a tensor. % if the permutation sign of indices is + then returns u else % returns negf u. (if permp!:(ordn y,y) then u else negf u)where y=car select_vars mvar u; symbolic procedure simpsumsym(u); % The use is SYMMETRIZE(LIST(A,B,...J),operator,perm_function,[perm_sign]) % or SYMMETRIZE(LIST(LIST(A,B,C...)),operator,perm_function,[perm_sign]). % [perm_sign] is optional for antisymmetric sums. % works even if tensors depend explicitly on variables. % Works both for OPFN and symbolic procedure functions. % Is not valid for general expressions. if length u geq 5 then rederr("less than 5 arguments required for symmetrize") else begin scalar ut,uu,x,res,oper,fn,sym,bool,boolfn; integer n, thesign; thesign := 1; fn:= caddr u; oper:=cadr u; if not idp oper then typerr(oper,"operator") else if null flagp(oper,'opfn) then if null get(oper,'simpfn) then put(oper,'simpfn,'simpiden); flag(list oper, 'listargp); sym:=if cdddr u then if cadddr u eq 'perm_sign then t; if sym and null permp!:(cdar u, ordn cdar u) then thesign:=-thesign; if not(gettype fn eq 'procedure) then typerr(fn,"procedure"); ut:= select_vars car u; uu:=(if flagp(fn,'opfn) then <<boolfn:=t; reval x>> else if car reval x eq 'minus then cdadr reval x else cdr reval x) where x=oper . car ut; n:=length uu; x:=if listp car uu and null flagp(oper,'tensor) and not boolfn then <<bool:=t;apply1(fn, cdar uu)>> else if boolfn and listp cadr uu and null flagp(oper,'tensor) then <<bool:=t;apply1(fn,cadr uu)>> else apply1(fn,uu); % this applies to tensors if flagp(fn,'opfn) then x:=alg_to_symb x; n:=length x -1; if not bool then << res:= if sym then sym_sign(( if cadr ut then oper . (cadr ut . car x) else oper . car x) .** 1 .* 1 .+ nil) else (if cadr ut then oper . (cadr ut . car x) else oper . car x) .** 1 .* 1 .+ nil ; for i:=1:n do << uu:=cadr x; aconc(res, if sym then car sym_sign( (if cadr ut then oper . (cadr ut . uu) else oper . uu) .** 1 .* 1 .+ nil) else (if cadr ut then oper . (cadr ut . uu) else oper . uu) .** 1 .* 1); delqip(uu,x);>>; >> else << res:=if sym then sym_sign((oper . list('list . for each i in car x collect mk!*sq simp!* i)) .** 1 .* 1 .+ nil) else (oper . list('list . for each i in car x collect mk!*sq simp!* i)) .** 1 .* 1 .+ nil; for i:=1:n do << uu:=cadr x; aconc(res, if sym then car sym_sign((oper . list('list . for each j in uu collect simp!* j)) .** 1 .* 1 .+ nil) else (oper . list('list . for each i in uu collect mk!*sq simp!* i)) .** 1 .* 1 ); delqip(uu,x);>>; >>; return if get(oper,'tag) eq 'list then simp!*('list . for each w in res collect caar w) else resimp (multf(!*n2f thesign,res) ./ 1) end; %load_package dummyn; % modifications to dummy.red: % patch to dummy.red symbolic procedure dummy_nam u; % creates the required global vector for dummy.red % A variant of dummy_names from DUMMY. % No declaration flag(..,'dummy) here since % it is done inside 'mk_dummy_ids' <<g_dvnames := list2vect!*(ordn u,'symbolic);t>>; % This part redefines some of the dummy procedures % to make it tolerate the covariant-contravariant indices. % and tensors with NO indices. symbolic procedure dv_skelsplit(camb); begin scalar var_camb,skel, stree, subskels; integer count, ind, maxind, thesign; thesign := 1; var_camb:=if listp camb then if listp cadr camb and caadr camb = 'list then cadr camb; if (ind := dummyp(camb)) then return {1, ind, ('!~dv . {'!*, ind})} else if not listp camb or (var_camb and null cddr camb) then return {1, 0, (camb . nil)}; stree := get(car camb, 'symtree); if not stree then << stree := for count := 1 : length(if var_camb then cddr camb %% else cdr camb) collect count; %% if flagp(car camb, 'symmetric) then stree := '!+ . stree else if flagp(car camb, 'antisymmetric) then stree := '!- . stree else stree := '!* . stree >>; subskels := mkve(length(if var_camb then cddr camb else cdr camb)); %% count := 0; for each arg in (if var_camb then cddr camb else cdr camb) do %% << count := count + 1; if (ind := dummyp(arg)) then << maxind := max(maxind, ind); if idp arg then putve(subskels, count, ('!~dv . {'!*, ind})) else putve(subskels, count, ('!~dva . {'!*, ind})) >> else putve(subskels, count, (arg . nil)); >>; stree := st_sorttree(stree, subskels, function idcons_ordp); if stree and (car stree = 0) then return nil; thesign := car stree; skel := dv_skelsplit1(cdr stree, subskels); stree := st_consolidate(cdr skel); skel := if var_camb then (car camb) . var_camb . car skel %% else car camb . car skel; %% return {thesign, maxind, skel . stree}; end; symbolic procedure dummyp(var); % takes into account the new features i.e. % some indices may be !0, !1 .... % others are covariant indices i.e. (minus !<integer>), (minus a) etc ... begin scalar varsplit; integer count, res; if listp var then if ( careq_minus var) then var:= cadr var else return nil; if numberp(var) or (!*id2num var) then return nil; count := 1; while count <= upbve(g_dvnames) do << if var = venth(g_dvnames, count) then << res := count; count := upbve(g_dvnames) + 1 >> else count := count + 1; >>; if res = 0 then << varsplit := ad_splitname(var); if (car varsplit eq g_dvbase) then return cdr varsplit >> else return res; end; symbolic procedure dv_skel2factor1(skel_kern, dvars); % Take into account of the two sets of generic dummy variables. % One for the ordinary and contravariant dummy variables, another for % covariant variables. % !~dva regenerate COVARIANT dummy variables. begin scalar dvar,scr; if null skel_kern then return nil; return if listp skel_kern then <<scr:=dv_skel2factor1(car skel_kern, dvars); scr:=scr . dv_skel2factor1(cdr skel_kern, dvars) >> else if skel_kern eq '!~dv then << dvar := car dvars; if cdr dvars then << rplaca(dvars, cadr dvars); rplacd(dvars, cddr dvars); >>; dvar >> else if skel_kern eq '!~dva then << dvar := car dvars; if cdr dvars then << rplaca(dvars, cadr dvars); rplacd(dvars, cddr dvars); >>; ('minus . dvar . nil) >> else skel_kern; end; % end of patch to dummy endmodule; end;