1module ctintro;
2
3% Redistribution and use in source and binary forms, with or without
4% modification, are permitted provided that the following conditions are met:
5%
6%    * Redistributions of source code must retain the relevant copyright
7%      notice, this list of conditions and the following disclaimer.
8%    * Redistributions in binary form must reproduce the above copyright
9%      notice, this list of conditions and the following disclaimer in the
10%      documentation and/or other materials provided with the distribution.
11%
12% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
13% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
14% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
15% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
16% CONTRIBUTORS
17% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
18% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
19% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
20% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
21% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
22% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
23% POSSIBILITY OF SUCH DAMAGE.
24%
25
26
27fluid('(dummy_id!* g_dvnames));
28
29% g_dvnames is a vector.
30
31
32% patches and extensions of some functions of the packages ASSIST and
33% DUMMY
34
35%
36load_package dummy;
37%
38
39
40% function REMSYM is generalised to take account of partial symmetries
41
42symbolic procedure remsym u;
43% ALLOWS TO ELIMINATE THE DECLARED SYMMETRIES.
44 for each j in u do
45   if flagp(j,'symmetric) then remflag(list j,'symmetric)
46     else
47   if flagp(j,'antisymmetric) then remflag(list j,'antisymmetric)
48     else remprop(j,'symtree);
49
50% function SYMMETRIZE is generalized for total antisymmetrization
51% and for lists of (cyclic-)permutations.
52
53symbolic procedure sym_sign u;
54% u is a standard form for the kernel of a tensor.
55% if the permutation sign  of indices is + then returns u else
56% returns negf u.
57 (if permp(ordn y,y) then u else negf u)where y=car select_vars mvar u;
58
59symbolic procedure simpsumsym(u);
60% The use is SYMMETRIZE(LIST(A,B,...J),operator,perm_function,[perm_sign])
61% or SYMMETRIZE(LIST(LIST(A,B,C...)),operator,perm_function,[perm_sign]).
62% [perm_sign] is optional for antisymmetric sums.
63% works even if tensors depend explicitly on variables.
64% Works both for OPFN and symbolic procedure functions.
65% Is not valid for general expressions.
66 if length u geq 5 then rederr("less than 5 arguments required for symmetrize")
67 else
68 begin scalar ut,uu,x,res,oper,fn,sym,bool,boolfn;
69  integer n, thesign;
70  thesign := 1;
71  fn:= caddr u;
72  oper:=cadr u;
73  if not idp oper then typerr(oper,"operator") else
74  if null flagp(oper,'opfn) then
75     if null get(oper,'simpfn) then put(oper,'simpfn,'simpiden);
76     flag(list oper, 'listargp);
77  sym:=if cdddr u then
78          if cadddr u eq 'perm_sign then t;
79  if sym and null permp(cdar u, ordn cdar u) then thesign:=-thesign;
80if not(gettype fn memq '(procedure algebraic_procedure)) then typerr(fn,"procedure");
81  ut:= select_vars car u;
82  uu:=(if flagp(fn,'opfn) then <<boolfn:=t; reval x>>
83          else  if car reval x eq 'minus then cdadr reval x
84                 else cdr reval x) where x=oper . car ut;
85   n:=length uu;
86  x:=if listp  car uu and null flagp(oper,'tensor) and not boolfn then
87                <<bool:=t;apply1(fn, cdar uu)>> else
88     if boolfn and listp cadr uu and null flagp(oper,'tensor) then
89                <<bool:=t;apply1(fn,cadr uu)>>
90       else  apply1(fn,uu); % this applies to tensors
91  if flagp(fn,'opfn) then x:=alg_to_symb x;
92  n:=length x -1;
93  if not bool then <<
94     res:= if sym then sym_sign(!*kk2f(
95                 if cadr ut then oper . (cadr ut . car x)
96                   else oper . car x))
97             else !*kk2f
98          (if cadr ut then  oper . (cadr ut . car x)
99            else oper . car x);
100  for i:=1:n do
101   << uu:=cadr x; aconc(res, if sym then  car sym_sign(!*kk2f
102                   (if cadr ut then oper . (cadr ut . uu)
103                     else oper . uu))
104                              else mksp
105      (if cadr ut then  oper . (cadr ut . uu)
106          else oper . uu, 1) . 1); delqip(uu,x);>>;
107                    >>
108  else
109 << res:=if sym then sym_sign(!*kk2f(oper . list('list .
110      for each i in car x collect mk!*sq simp!* i)))
111           else !*kk2f
112        (oper . list('list .
113         for each i in car x collect mk!*sq simp!* i));
114   for i:=1:n do << uu:=cadr x;
115    aconc(res, if sym then car sym_sign(!*kk2f(oper . list('list .
116                  for each j in uu collect simp!* j)))
117                else mksp(oper . list('list .
118                 for each i in uu collect mk!*sq simp!* i), 1) . 1 );
119     delqip(uu,x);>>;
120 >>;
121  return
122  if get(oper,'tag) eq 'list then
123        simp!*('list . for each w in res collect caar w)
124   else
125     resimp (multf(!*n2f thesign,res) ./ 1)
126end;
127
128%load_package dummyn;
129
130% modifications to dummy.red:
131
132% patch to dummy.red
133
134symbolic procedure dummy_nam u;
135% creates the required global vector for dummy.red
136% A variant of dummy_names from  DUMMY.
137% No declaration flag(..,'dummy) here since
138% it is done inside 'mk_dummy_ids'
139 <<g_dvnames := list2vect!*(ordn u,'symbolic);t>>;
140
141
142% This part redefines some of the dummy procedures
143% to make it tolerate the covariant-contravariant indices.
144% and tensors with NO indices.
145
146symbolic procedure dv_skelsplit(camb);
147  begin scalar  var_camb,skel, stree, subskels;
148        integer count, ind, maxind, thesign;
149  thesign := 1;
150  var_camb:=if listp camb  then
151              if listp cadr camb and caadr camb = 'list then cadr camb;
152    if (ind := dummyp(camb)) then
153      return {1, ind, ('!~dv . {'!*, ind})}
154     else
155    if not listp camb  or (var_camb and null cddr camb)
156                                      then  return {1, 0, (camb . nil)};
157  stree := get(car camb, 'symtree);
158   if not stree then
159    <<
160    stree := for count := 1 : length(if var_camb then cddr camb      %%
161                                       else cdr camb) collect count;  %%
162    if flagp(car  camb, 'symmetric) then
163      stree := '!+ . stree
164    else if flagp(car camb, 'antisymmetric) then
165      stree := '!- . stree
166    else
167      stree := '!* . stree
168    >>;
169  subskels := mkve(length(if var_camb then cddr camb else cdr camb)); %%
170  count := 0;
171  for each arg in (if var_camb then cddr camb else cdr camb) do   %%
172    <<
173    count := count + 1;
174    if (ind := dummyp(arg)) then
175      <<
176      maxind := max(maxind, ind);
177    if idp arg then  putve(subskels, count, ('!~dv . {'!*, ind}))
178                else putve(subskels, count, ('!~dva . {'!*, ind}))
179      >>
180    else
181      putve(subskels, count, (arg . nil));
182    >>;
183  stree := st_sorttree(stree, subskels, function idcons_ordp);
184  if stree and (car stree = 0) then return nil;
185  thesign := car stree;
186  skel := dv_skelsplit1(cdr stree, subskels);
187  stree := st_consolidate(cdr skel);
188  skel := if var_camb then (car camb) . var_camb . car skel    %%
189           else car camb . car skel;                            %%
190  return {thesign, maxind, skel . stree};
191  end;
192
193
194symbolic procedure dummyp(var);
195% takes into account the new features i.e.
196% some indices may be !0, !1 ....
197% others are covariant indices i.e. (minus !<integer>), (minus a) etc ...
198  begin scalar varsplit;
199        integer count, res;
200  if listp var then
201    if ( careq_minus var) then var:= cadr var
202      else return nil;
203  if numberp(var) or (!*id2num var)
204    then return nil;
205  count := 1;
206  while count <= upbve(g_dvnames) do
207    <<
208   if var = venth(g_dvnames, count) then
209    <<
210      res := count;
211      count := upbve(g_dvnames) + 1
212      >>
213    else
214      count := count + 1;
215    >>;
216  if res = 0 then
217    <<
218    varsplit := ad_splitname(var);
219    if (car varsplit eq g_dvbase) then
220      return cdr varsplit
221    >>
222  else return res;
223  end;
224
225
226symbolic procedure dv_skel2factor1(skel_kern, dvars);
227% Take into account of the two sets of generic dummy variables.
228% One for the ordinary and contravariant dummy variables, another for
229% covariant variables.
230% !~dva regenerate COVARIANT dummy variables.
231 begin scalar dvar,scr;
232   if null skel_kern then return nil;
233  return
234   if listp skel_kern then
235    <<scr:=dv_skel2factor1(car skel_kern, dvars);
236         scr:=scr . dv_skel2factor1(cdr skel_kern, dvars)
237    >>
238    else
239   if skel_kern eq '!~dv then
240       <<
241         dvar := car dvars;
242         if cdr dvars then
243           <<
244               rplaca(dvars, cadr dvars); rplacd(dvars, cddr dvars);
245            >>;
246       dvar
247       >>
248    else
249   if skel_kern eq '!~dva then
250      <<
251        dvar := car dvars;
252        if cdr dvars then
253          <<
254            rplaca(dvars, cadr dvars); rplacd(dvars, cddr dvars);
255        >>;
256      ('minus . dvar . nil)
257      >>
258    else
259       skel_kern;
260  end;
261
262
263% end of patch to dummy
264
265endmodule;
266end;
267