%5:%
%line 70 "supervf.web"

symbolic$
write"Super vectorfield package for REDUCE 3.4, $Revision: 0.94 $"$terpri()$
%7:%
%line 120 "supervf.web"

%line 121 "supervf.web"
algebraic operator ext$

%:7%
%line 73 "supervf.web"

algebraic$

%:5%%8:%
%line 144 "supervf.web"
lisp operator super_vectorfield;
lisp procedure super_vectorfield(operator_name,even_dimension,
odd_dimension,variables);
begin
if not idp operator_name then

msgpri("SUPER_VECTORFIELD:",operator_name,"is not an identifier",nil,t);
if not fixp even_dimension or even_dimension<0 or
not fixp odd_dimension or odd_dimension<0 then
rederr("SUPER_VECTORFIELD: improper dimensions");
put(operator_name, 'simpfn, 'super_der_simp);
flag(list(operator_name), 'full);
put(operator_name, 'even_dimension,even_dimension);
put(operator_name, 'odd_dimension,odd_dimension);
put(operator_name, 'variables,if null variables then variables else if atom
variables then list variables else if
car variables= 'list then cdr variables else variables);
end$

%:8%%9:%
%line 212 "supervf.web"
lisp procedure merge_lists(x1,x2);
begin scalar cx1,cx2,lx2,clx2,oddskip,sign;
%10:%
%line 219 "supervf.web"

%line 220 "supervf.web"
sign:=1;
x1:=reverse x1;
if x1 then cx1:=car x1 else goto b;
a:if x2 then cx2:=car x2 else goto b;
if cx1<cx2 then goto b;
lx2:=cx2 . lx2;
oddskip:=not oddskip;
x2:=cdr x2;
goto a

%:10%
%line 214 "supervf.web"
;
b:%11:%
%line 231 "supervf.web"

%line 232 "supervf.web"
if null x1 then return sign . nconc(reversip lx2,x2);
if null lx2 then return sign . nconc(reversip x1,x2);
clx2:=car lx2;
if cx1=clx2 and cx1>0 then return nil;
if cx1>clx2 then goto b1;
%12:%
%line 241 "supervf.web"

%line 242 "supervf.web"
x2:=clx2 . x2;
lx2:=cdr lx2;
oddskip:=not oddskip;
goto b

%:12%
%line 237 "supervf.web"
;
b1:%13:%
%line 248 "supervf.web"

%line 249 "supervf.web"
x2:=cx1 . x2;
x1:=cdr x1;
if oddskip and cx1>0 then sign:=-sign;
cx1:=car x1;
goto b

%:13%
%line 238 "supervf.web"


%:11%
%line 215 "supervf.web"
;
end$

%:9%%14:%
%line 262 "supervf.web"

lisp procedure ext_mult(x1,x2);
(if null x then nil ./ 1
else if null cdr x then 1 ./ 1
else(((!*a2k( 'ext . cdr x) .^ 1) .* car x) .+ nil) ./ 1)
where x=merge_lists(cdr x1,cdr x2)$

%:14%%15:%
%line 283 "supervf.web"

lisp procedure super_der_simp u;
if length u=2 then%16:%
%line 296 "supervf.web"

%line 297 "supervf.web"
 begin scalar derivation_name,variables,even_components,odd_components,
splitted_numr,splitted_denr;
derivation_name:=reval car u;
variables:=get(derivation_name, 'variables);
u:=simp!* cadr u;
%18:%
%line 345 "supervf.web"

splitted_numr:=split_form(numr u, '(ext));
splitted_numr:=
(list( 'ext) . car splitted_numr) . cdr splitted_numr;
splitted_denr:=split_form(denr u, '(ext));
splitted_denr:=
(list( 'ext) . car splitted_denr) . cdr splitted_denr;
even_components:=for i:=1:get(derivation_name, 'even_dimension)collect
(nth(variables,i) . split_ext(component, '(ext)))
where component=simp!* list(derivation_name,0,i);
odd_components:=for i:=1:get(derivation_name, 'odd_dimension)collect
(i . split_ext(component, '(ext)))
where component=simp!* list(derivation_name,1,i)

%:18%
%line 303 "supervf.web"
;
return subtrsq(
quotsq(addsq(even_action(even_components,splitted_numr),
odd_action(odd_components,splitted_numr)),denr u ./ 1),
quotsq(multsq(numr u ./ 1,even_action(even_components,splitted_denr)),
multf(denr u,denr u) ./ 1));
end

%:16%
%line 285 "supervf.web"

else simpiden u$

%:15%%17:%
%line 329 "supervf.web"

lisp procedure split_ext(sq,op_list);
begin scalar denr_sq,splitted_form;
denr_sq:=denr sq;
splitted_form:=split_form(numr sq,op_list);
return(list( 'ext) . cancel(car splitted_form ./ denr_sq)) . 
for each kc_pair in cdr splitted_form collect
(car kc_pair . cancel(cdr kc_pair ./ denr_sq))
end$

%:17%%19:%
%line 363 "supervf.web"

%line 364 "supervf.web"
lisp procedure even_action(components,splitted_form);
begin scalar action;
action:=nil ./ 1;
for each kc_pair in splitted_form do
action:=addsq(action,
even_action_sf(components,cdr kc_pair,car kc_pair,1));
return action;
end$

%:19%%20:%
%line 377 "supervf.web"

%line 378 "supervf.web"
lisp procedure even_action_sf(components,sf,ext_kernel,fac);
begin scalar action;
action:=nil ./ 1;
while not domainp sf do
 <<action:=addsq(action,even_action_term(components,lt sf,ext_kernel,fac));
sf:=red sf>> ;
return action;
end$

%:20%%21:%
%line 399 "supervf.web"

lisp procedure even_action_term(components,term,ext_kernel,fac);
addsq(even_action_pow(components,car term,
ext_kernel,!*f2q multf(fac,cdr term)),
even_action_sf(components,cdr term,
ext_kernel,multf(fac,!*p2f car term)))$

%:21%%22:%
%line 410 "supervf.web"

lisp procedure even_action_pow(components,pow,ext_kernel,fac);
begin scalar kernel,n,component,derivative,action,active_components;
kernel:=car pow;n:=cdr pow;
%23:%
%line 422 "supervf.web"

%line 423 "supervf.web"
if(component:=assoc(kernel,components))then
return
 <<derivative:=if n=1 then 1 ./ 1 else((((kernel .^ n-1) .* n) .+ nil) ./ 1);
action:=component_action(component,ext_kernel,derivative);
multsq(action,fac)>> 

%:23%
%line 414 "supervf.web"
;
%27:%
%line 490 "supervf.web"

%line 491 "supervf.web"
active_components:=find_active_components(kernel,components,nil)

%:27%
%line 415 "supervf.web"
;
%28:%
%line 498 "supervf.web"

%line 499 "supervf.web"
action:=nil ./ 1;
for each component in active_components do
 <<derivative:=diffp(pow,car component);
action:=addsq(action,component_action(component,ext_kernel,derivative))>> ;
return multsq(action,fac)

%:28%
%line 416 "supervf.web"
;
end$

%:22%%24:%
%line 442 "supervf.web"

lisp procedure component_action(component,ext_kernel,coefficient);
begin scalar action;
action:=nil ./ 1;
for each kc_pair in cdr component do
(if numr ext_product then
action:=addsq(action,
multsq(multsq(ext_product,even_coefficient),coefficient)))
where ext_product=ext_mult(car kc_pair,ext_kernel),
even_coefficient=cdr kc_pair;
return action;
end$

%:24%%25:%
%line 464 "supervf.web"

lisp procedure find_active_components(kernel,components,components_found);
begin
components_found:=
update_components(kernel . 
((if depl_entry then cdr depl_entry)where depl_entry=assoc(kernel,depl!*)),
components,components_found)$
if not atom kernel then
for each element in kernel do
components_found:=find_active_components(element,components,components_found);
return components_found;
end$

%:25%%26:%
%line 479 "supervf.web"

lisp procedure update_components(dependencies,components,components_found);
begin scalar component;
for each kernel in dependencies do
if(component:=assoc(kernel,components))
and not assoc(kernel,components_found)then
components_found:=component . components_found;
return components_found;
end$

%:26%%29:%
%line 519 "supervf.web"

%line 520 "supervf.web"
lisp procedure odd_action(components,splitted_form);
begin scalar action,sign,derivative,kernel,coefficient,component;
action:=nil ./ 1;
for each kc_pair in splitted_form do
 <<kernel:=car kc_pair;
coefficient:=!*f2q cdr kc_pair;
sign:=t;
for each i in cdr kernel do
 <<sign:=not sign;
derivative:=!*a2k delete(i,kernel);
component:=assoc(i,components);
action:=addsq(action,
component_action(component,derivative,
if sign then negsq coefficient else coefficient))
>> 
>> ;
return action;
end$

%:29%%30:%
%line 544 "supervf.web"

%line 545 "supervf.web"
lisp operator super_product;
lisp procedure super_product(x,y);
begin scalar splitted_x,splitted_y,product;
splitted_x:=split_ext(simp x, '(ext));
splitted_y:=split_ext(simp y, '(ext));
product:=nil ./ 1;
for each term_x in splitted_x do
for each term_y in splitted_y do
product:=addsq(product,
multsq(multsq(cdr term_x,cdr term_y),
ext_mult(car term_x,car term_y)));
return mk!*sq subs2 product;
end$

%:30%%31:%
%line 561 "supervf.web"
end;
%line 562 "supervf.web"

%:31%