%5:% %line 70 "supervf.web" symbolic$ write"Super vectorfield package for REDUCE 3.4, $Revision: 1.1 $"$terpri()$ %7:% %line 120 "supervf.web" %line 121 "supervf.web" put( 'ext, 'simpfn, 'simpiden)$ %:7%%37:% %line 685 "supervf.web" %line 686 "supervf.web" global '(!*natural_wedges)$ !*natural_wedges:=nil$ flag( '(natural_wedges), 'switch)$ put( 'natural_wedges, 'simpfg, '((t(natural_wedges_handler t))(nil(natural_wedges_handler nil))))$ %:37% %line 73 "supervf.web" algebraic$ %:5%%8:% %line 146 "supervf.web" lisp operator super_vectorfield; lisp procedure super_vectorfield(operator_name,even_variables,odd_variables); begin scalar odd_dimension; if not idp operator_name then msgpri("SUPER_VECTORFIELD:",operator_name,"is not an identifier",nil,t); put(operator_name, 'simpfn, 'super_der_simp); flag(list(operator_name), 'full); even_variables:=if null even_variables then even_variables else if atom even_variables then list even_variables else if car even_variables= 'list then cdr even_variables else even_variables; odd_variables:=if null odd_variables then odd_variables else if atom odd_variables then list odd_variables else if car odd_variables= 'list then cdr odd_variables else odd_variables;odd_dimension:=0; %9:% %line 167 "supervf.web" for each kernel in odd_variables do if length kernel neq 2 or car kernel neq 'ext or not fixp cadr kernel then msgpri("SUPER_VECTORFIELD:",kernel,"not a valid odd variable",nil,t) else odd_dimension:=max(odd_dimension,cadr kernel) %:9% %line 155 "supervf.web" ; put(operator_name, 'variables,even_variables); put(operator_name, 'even_dimension,length even_variables); put(operator_name, 'odd_dimension,odd_dimension); put(operator_name, 'setkfn, 'setk_super_vectorfield); return list( 'list,length even_variables,odd_dimension); end$ %:8%%10:% %line 177 "supervf.web" lisp operator vectorfield; %line 178 "supervf.web" lisp procedure vectorfield(operator_name,variables); super_vectorfield(operator_name,variables,nil)$ %:10%%11:% %line 184 "supervf.web" %line 185 "supervf.web" lisp operator add_variables_to_vectorfield; lisp procedure add_variables_to_vectorfield(operator_name,variables); if get(operator_name, 'simpfn)neq 'super_der_simp then msgpri("ADD_VARIABLE_TO_VECTORFIELD:",operator_name, "not a vectorfield",nil,t) else << variables:=append(get(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); put(operator_name, 'variables,variables); put(operator_name, 'even_dimension,length variables)>> $ %:11%%12:% %line 196 "supervf.web" %line 197 "supervf.web" lisp operator add_odd_variables_to_vectorfield; lisp procedure add_odd_variables_to_vectorfield(operator_name,odd_variables); if get(operator_name, 'simpfn)neq 'super_der_simp then msgpri("ADD_VARIABLE_TO_VECTORFIELD:",operator_name, "not a vectorfield",nil,t) else begin scalar odd_dimension; odd_variables:=if null odd_variables then odd_variables else if atom odd_variables then list odd_variables else if car odd_variables= 'list then cdr odd_variables else odd_variables; odd_dimension:=get(operator_name, 'odd_dimension); %9:% %line 167 "supervf.web" for each kernel in odd_variables do if length kernel neq 2 or car kernel neq 'ext or not fixp cadr kernel then msgpri("SUPER_VECTORFIELD:",kernel,"not a valid odd variable",nil,t) else odd_dimension:=max(odd_dimension,cadr kernel) %:9% %line 205 "supervf.web" ; return put(operator_name, 'odd_dimension,odd_dimension); end$ %:12%%13:% %line 261 "supervf.web" lisp procedure merge_lists(x1,x2); %line 262 "supervf.web" begin scalar cx1,cx2,lx2,clx2,oddskip,sign; %14:% %line 268 "supervf.web" %line 269 "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 cx10 then return nil; if cx1>clx2 then goto b1; %16:% %line 290 "supervf.web" %line 291 "supervf.web" x2:=clx2 . x2; lx2:=cdr lx2; oddskip:=not oddskip; goto b %:16% %line 286 "supervf.web" ; b1:%17:% %line 297 "supervf.web" %line 298 "supervf.web" x2:=cx1 . x2; x1:=cdr x1; if oddskip and cx1>0 then sign:=-sign; if x1 then cx1:=car x1; goto b %:17% %line 287 "supervf.web" %:15% %line 264 "supervf.web" ; end$ %:13%%18:% %line 311 "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)$ %:18%%19:% %line 332 "supervf.web" lisp procedure super_der_simp u; if length u=2 then%20:% %line 357 "supervf.web" %line 358 "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; %22:% %line 407 "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) %:22% %line 364 "supervf.web" ; return subtrsq( quotsq(addsq(even_action(even_components,splitted_numr), odd_action(odd_components,splitted_numr)),denr u ./ 1), quotsq(super_product_sq(even_action(even_components,splitted_denr), numr u ./ 1), multf(denr u,denr u) ./ 1)); end %:20% %line 334 "supervf.web" else simpiden u$ %:19%%21:% %line 391 "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$ %:21%%23:% %line 425 "supervf.web" %line 426 "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$ %:23%%24:% %line 439 "supervf.web" %line 440 "supervf.web" lisp procedure even_action_sf(components,sf,ext_kernel,fac); begin scalar action; action:=nil ./ 1; while not domainp sf do <> ; return action; end$ %:24%%25:% %line 461 "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)))$ %:25%%26:% %line 472 "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; %27:% %line 484 "supervf.web" %line 485 "supervf.web" if(component:=assoc(kernel,components))then return <> %:27% %line 476 "supervf.web" ; %31:% %line 552 "supervf.web" %line 553 "supervf.web" active_components:=find_active_components(kernel,components,nil) %:31% %line 477 "supervf.web" ; %32:% %line 560 "supervf.web" %line 561 "supervf.web" action:=nil ./ 1; for each component in active_components do <> ; return multsq(action,fac) %:32% %line 478 "supervf.web" ; end$ %:26%%28:% %line 504 "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$ %:28%%29:% %line 526 "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$ %:29%%30:% %line 541 "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$ %:30%%33:% %line 581 "supervf.web" %line 582 "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 <> >> ; return action; end$ %:33%%34:% %line 620 "supervf.web" %line 621 "supervf.web" lisp procedure setk_super_vectorfield(val,value); begin scalar vectorfield,var,variables,i,tuple; if length val neq 2 then return let2(val,value,nil,t); vectorfield:=car val; var:=cadr val; %35:% %line 635 "supervf.web" %line 636 "supervf.web" tuple:= if not atom var and car var= 'ext and length var=2 then list(1,cadr var) else <> ; if null variables then msgpri("SETK_SUPER_VECTORFIELD:",var, "not a valid variable for",vectorfield,t) else list(0,i)>> %:35% %line 626 "supervf.web" ; return let2(vectorfield . tuple,value,nil,t); end$ %:34%%36:% %line 654 "supervf.web" %line 655 "supervf.web" lisp operator super_product; lisp procedure super_product(x,y); mk!*sq subs2 super_product_sq(simp x,simp y)$ lisp procedure super_product_sq(x,y); begin scalar splitted_x,splitted_y,product; splitted_x:=split_ext(x, '(ext)); splitted_y:=split_ext(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 product; end$ %:36%%38:% %line 694 "supervf.web" %line 695 "supervf.web" lisp procedure natural_wedges_handler on_off; begin scalar save_switch; if on_off then <> else <> end$ %:38%%39:% %line 714 "supervf.web" %line 715 "supervf.web" lisp procedure wedge_print ext_kernel; if length ext_kernel leq 2 then print_alias ext_kernel else inprint( 'super_product,0,kernels_on_list) where kernels_on_list= for each arg in cdr ext_kernel collect list( 'ext,arg)$ %:39%%40:% %line 723 "supervf.web" end; %line 724 "supervf.web" %:40%