%2:%
%line 64 "tools.web"
symbolic$
write"Algebraic operator tools for REDUCE 3.4, $Revision: 1.4 $"$terpri()$
algebraic$

%:2%%7:%
%line 129 "tools.web"
lisp procedure get_first_kernel(form,oplist);
gfk(form,if null oplist then oplist else if atom
oplist then list oplist else if
car oplist= 'list then cdr oplist else oplist,nil)$

lisp procedure gfk(form,oplist,l);
if l or domainp form then l
else gfk(red form,oplist,
gfk(lc form,oplist,
if not atom x and member(car x,oplist)
then x else l))
where x=mvar form$

%:7%%8:%
%line 146 "tools.web"

%line 147 "tools.web"
lisp procedure get_all_kernels(form,oplist);
gak(form,if null oplist then oplist else if atom
oplist then list oplist else if
car oplist= 'list then cdr oplist else oplist,nil)$

lisp procedure gak(form,oplist,l);
if domainp form
then l
else gak(red form,oplist,
gak(lc form,oplist,
if not atom x and member(car x,oplist)and not member(x,l)
then l:=aconc(l,x)else l))
where x=mvar form$

%:8%%9:%
%line 163 "tools.web"

%line 164 "tools.web"
lisp procedure get_recursive_kernels(form,oplist);
grk(form,if null oplist then oplist else if atom
oplist then list oplist else if
car oplist= 'list then cdr oplist else oplist,nil)$

lisp procedure grk(form,oplist,l);
if domainp form
then l else grk(red form,oplist,
grk(lc form,oplist,
%10:%
%line 177 "tools.web"

%line 178 "tools.web"
if not atom x
then begin scalar y;
for each arg in cdr x do
if(y:=simp arg)neq 0 then
l:=grk(numr y,oplist,l);
return if member(car x,oplist)and not member(x,l)
then x . l else l end
else l

%:10%
%line 171 "tools.web"
))
where x=mvar form$

%:9%%14:%
%line 280 "tools.web"

%line 281 "tools.web"
lisp procedure split_f(form,oplist,fact,kc_list);
if null form then kc_list
else if domainp form then
addf(multf(fact,form),
car kc_list) . cdr kc_list
else if not atom mvar form and member(car mvar form,oplist)then
if not ldeg form=1 or get_first_kernel(lc form,oplist)then

msgpri("SPLIT_F: expression not linear w.r.t.",
 'list . oplist,nil,nil,t)
else split_f(red form,oplist,fact,
update_kc_list(kc_list,mvar form,multf(fact,lc form)))
else split_f(red form,oplist,fact,
split_f(lc form,oplist,
multf(fact,!*p2f lpow form),kc_list))$

%:14%%15:%
%line 300 "tools.web"

%line 301 "tools.web"
lisp procedure split_form(form,oplist);
split_f(form,oplist,1,nil . nil)$

%:15%%16:%
%line 309 "tools.web"
lisp procedure list_assoc(car_exprn,a_list);
%line 310 "tools.web"
if null a_list then a_list else if caar a_list=car_exprn then a_list
else list_assoc(car_exprn,cdr a_list)$

%:16%%17:%
%line 322 "tools.web"
lisp procedure update_kc_list(kc_list,kernel,coefficient);
%line 323 "tools.web"
(if rest_list then <<rplaca(rest_list,caar rest_list . addf(cdar
rest_list,coefficient));kc_list>> else
car kc_list . (kernel . coefficient) . cdr kc_list)
where rest_list=list_assoc(kernel,cdr kc_list)$

%:17%%18:%
%line 347 "tools.web"

%line 348 "tools.web"
put( 'operator_coeff, 'psopfn, 'operator_coeff_1)$

lisp procedure operator_coeff_1 u;
if length u neq 2 then rederr("OPERATOR_COEFF: wrong number of arguments")
else operator_coeff(car u,reval cadr u)$

%:18%%19:%
%line 370 "tools.web"

%line 371 "tools.web"
lisp procedure operator_coeff(exprn,oplist);
begin scalar numr_ex,denr_ex,kc_list;
oplist:=if null oplist then oplist else if atom
oplist then list oplist else if
car oplist= 'list then cdr oplist else oplist;
exprn:=simp!* exprn;numr_ex:=numr exprn;denr_ex:=denr exprn;
kc_list:=split_form(numr_ex,oplist);
return 'list . !*ff2a(car kc_list,denr_ex) . 
for each kc_pair in cdr kc_list collect
list( 'list,car kc_pair,!*ff2a(cdr kc_pair,denr_ex));
end$

%:19%%20:%
%line 402 "tools.web"

%line 403 "tools.web"
lisp procedure dump_operators(form,oplist,fact);
if null form then nil
else if domainp form then multf(fact,form)
else if not atom mvar form and member(car mvar form,oplist)then
dump_operators(red form,oplist,fact)
else
addf(dump_operators(red form,oplist,fact),
dump_operators(lc form,oplist,multf(fact,!*p2f lpow form)))$

%:20%%21:%
%line 413 "tools.web"

%line 414 "tools.web"
put( 'independent_part, 'psopfn, 'independent_part_1)$

lisp procedure independent_part_1 u;
if length u neq 2 then rederr("INDEPENDENT_PART: wrong number of arguments")
else independent_part(car u,reval cadr u)$

lisp procedure independent_part(exprn,oplist);
begin scalar numr_ex,denr_ex;
oplist:=if null oplist then oplist else if atom
oplist then list oplist else if
car oplist= 'list then cdr oplist else oplist;
exprn:=simp!* exprn;numr_ex:=numr exprn;denr_ex:=denr exprn;
return !*ff2a(dump_operators(numr_ex,oplist,1),denr_ex);
end$

%:21%%22:%
%line 464 "tools.web"

lisp procedure multi_split_f(form,kernel_list,multi_power,fact,pc_list);
if null form then pc_list
else if domainp form then
if multi_power then update_kc_list(pc_list,multi_power,multf(fact,form))
else addf(multf(fact,form),car pc_list) . cdr pc_list
else multi_split_f(red form,kernel_list,multi_power,fact,
if member(mvar form,kernel_list)then
multi_split_f(lc form,kernel_list,lpow form . multi_power,fact,pc_list)
else multi_split_f(lc form,kernel_list,multi_power,
multf(fact,!*p2f lpow form),pc_list))$


%:22%%23:%
%line 481 "tools.web"

lisp procedure multi_split_form(form,kernel_list);
multi_split_f(form,kernel_list,nil,1,nil . nil)$

%:23%%24:%
%line 496 "tools.web"

%line 497 "tools.web"
put( 'multi_coeff, 'psopfn, 'multi_coeff_1)$

lisp procedure multi_coeff_1 u;
if length u neq 2 then rederr("MULTI_COEFF: wrong number of arguments")
else multi_coeff(car u,reval cadr u)$

%:24%%25:%
%line 509 "tools.web"
lisp procedure multi_coeff(exprn,kernel_list);
%line 510 "tools.web"
begin scalar numr_ex,denr_ex,pc_list;
kernel_list:=if null kernel_list then kernel_list else if atom
kernel_list then list kernel_list else if
car kernel_list= 'list then cdr kernel_list else kernel_list;
exprn:=simp!* exprn;
numr_ex:=numr exprn;denr_ex:=denr exprn;
for each generator in kernel_list do if depends(denr_ex,generator)
then
msgpri("MULTI_COEFF: expression is not polynomial w.r.t. ",
 'list . kernel_list,nil,nil,t);
pc_list:=multi_split_form(numr_ex,kernel_list);
return 'list . !*ff2a(car pc_list,denr_ex) . 
for each pc_pair in cdr pc_list collect
list( 'list,convert_multi_power car pc_pair,!*ff2a(cdr pc_pair,denr_ex));
end$

%:25%%26:%
%line 529 "tools.web"

%line 530 "tools.web"
lisp procedure convert_multi_power multi_power;
 'times . for each power in multi_power collect
if cdr power=1 then car power else list( 'expt,car power,cdr power)$

%:26%%28:%
%line 588 "tools.web"

%line 589 "tools.web"
lisp procedure split_arguments(arg_list,oplist,splitted_list);
if null arg_list then splitted_list
else split_arguments(cdr arg_list,oplist,
multf(denr first_arg,car splitted_list) . 
split_form(numr first_arg,oplist) . 
cdr splitted_list)where first_arg=simp!* car arg_list$

%:28%%29:%
%line 604 "tools.web"
lisp procedure split_operator u;
%line 605 "tools.web"
split_arguments(cdr u,get(car u, 'oplist),1 . nil)$

%:29%%31:%
%line 669 "tools.web"
lisp procedure process_arg_stack(arg_stack,op_name,arg_list,fact);
%line 670 "tools.web"
if null arg_stack then multsq(!*f2q fact,
apply1(get(op_name, 'resimp_fn),op_name . arg_list))
else process_comp_list(car arg_stack,cdr arg_stack,op_name,arg_list,fact)$

%:31%%32:%
%line 678 "tools.web"

%line 679 "tools.web"
lisp procedure process_comp_list(comp_list,arg_stack,op_name,arg_list,fact);
addsq(process_independent_part(car comp_list,arg_stack,op_name,arg_list,fact),
process_components(cdr comp_list,arg_stack,op_name,arg_list,fact))$

%:32%%33:%
%line 691 "tools.web"
lisp procedure process_independent_part(independent_part,arg_stack,
%line 692 "tools.web"
op_name,arg_list,fact);
if null independent_part then nil . 1
else
process_arg_stack(arg_stack,op_name,1 . arg_list,multf(fact,independent_part))$


%:33%%34:%
%line 701 "tools.web"
lisp procedure process_components(comp_list,arg_stack,op_name,arg_list,fact);
%line 702 "tools.web"
if null comp_list then nil . 1
else
addsq(process_components(cdr comp_list,arg_stack,op_name,arg_list,fact),
process_arg_stack(arg_stack,op_name,caar comp_list . arg_list,
multf(fact,cdar comp_list)))$

%:34%%35:%
%line 713 "tools.web"
lisp procedure build_sum(op_name,arg_stack);
%line 714 "tools.web"
process_arg_stack(arg_stack,op_name,nil,1)$

%:35%%36:%
%line 727 "tools.web"
lisp procedure simp_multilinear u;
%line 728 "tools.web"
quotsq(build_sum(car u,cdr splitted_list),!*f2q car splitted_list)
where splitted_list=split_operator u$

%:36%%38:%
%line 750 "tools.web"

%line 751 "tools.web"
put( 'multilinear, 'stat, 'rlis)$

lisp procedure multilinear u;
for each decl in u do
begin scalar op_name,resimp_fn;
if length decl neq 2 and length decl neq 3 then

msgpri(nil,decl,"invalid multilinear declaration",nil,t);
if not idp(op_name:=car decl)then

msgpri(nil,op_name,"invalid as operator",nil,t);
put(op_name, 'oplist,if null cadr decl then cadr decl else if atom
cadr decl then list cadr decl else if
car cadr decl= 'list then cdr cadr decl else cadr decl);
if(length decl=3 and(resimp_fn:=caddr decl))or
(resimp_fn:=get(op_name, 'resimp_fn))or
(resimp_fn:=get(op_name, 'simpfn))then put(op_name, 'resimp_fn,resimp_fn)
else put(op_name, 'resimp_fn, 'simpiden);
put(op_name, 'simpfn, 'simp_multilinear);
flag(list(op_name), 'full);
end$

%:38%%41:%
%line 795 "tools.web"

%line 796 "tools.web"
put( 'linear_solve, 'psopfn, 'linear_solve_1)$

lisp procedure linear_solve_1 u;
if length u neq 2 then
rederr("LINEAR_SOLVE: wrong number of arguments")
else linear_solve(car u,cadr u)$

%:41%%43:%
%line 845 "tools.web"

%line 846 "tools.web"
lisp procedure linear_solve(exprn,kernel);
begin scalar kord!*,form;
kernel:=!*a2k kernel;
%42:%
%line 814 "tools.web"

%line 815 "tools.web"
exprn:=fctrf numr simp!* exprn;
exprn:=if domainp car exprn then cdr exprn else(car exprn . 1) . cdr exprn;
form:=for each factor in exprn join
if depends(factor,kernel)then list factor;
if length form=1 then form:=numr car form else

msgpri("LINEAR_SOLVE: expression not linear with respect to",
kernel,nil,nil,t)

%:42%
%line 849 "tools.web"
;
setkorder list kernel;
form:=reorder form;
if(mvar form=kernel)and(ldeg form=1)and
not depends(lc form,kernel)and not depends(red form,kernel)then
return !*ff2a(negf red form,lc form)
else
msgpri("LINEAR_SOLVE: expression not linear with respect to",
kernel,nil,nil,t);
end$

%:43%%44:%
%line 863 "tools.web"

%line 864 "tools.web"
put( 'linear_solve_and_assign, 'psopfn, 'linear_solve_and_assign_1)$

lisp procedure linear_solve_and_assign_1 u;
if length u neq 2 then
rederr("LINEAR_SOLVE_AND_ASSIGN: wrong number of arguments")
else linear_solve_and_assign(car u,cadr u)$

lisp procedure linear_solve_and_assign(exprn,kernel);
setk(kernel,linear_solve(exprn,kernel))$

%:44%%47:%
%line 926 "tools.web"

%line 927 "tools.web"
put( 'solvable_kernels, 'psopfn, 'solvable_kernels_1)$

lisp procedure solvable_kernels_1 u;
if length u neq 3 then
rederr("SOLVABLE_KERNELS: wrong number of arguments")
else solvable_kernels(car u,cadr u,caddr u)$

%:47%%49:%
%line 964 "tools.web"

%line 965 "tools.web"
lisp procedure list_merge(element,merge_list);
if member(element,merge_list)then merge_list else element . 
merge_list$

%:49%%50:%
%line 984 "tools.web"
lisp procedure mk_kernel_list(form,k_oplist,c_oplist,forbidden,kernel_list);
%line 985 "tools.web"
if domainp form then kernel_list
else(
if not atom kernel then
mk_kernel_list(red form,k_oplist,c_oplist,forbidden,
mk_kernel_list(lc form,k_oplist,c_oplist,
if member(car kernel,c_oplist)then t else forbidden,
if member(car kernel,k_oplist)then
if not forbidden and ldeg form=1 and
not get_first_kernel(lc form,c_oplist)then
list_merge(kernel,car kernel_list) . cdr kernel_list
else
car kernel_list . list_merge(kernel,cdr kernel_list)
else kernel_list))
else mk_kernel_list(red form,k_oplist,c_oplist,forbidden,
mk_kernel_list(lc form,k_oplist,c_oplist,forbidden,kernel_list))
)where kernel=mvar form$

%:50%%51:%
%line 1012 "tools.web"

%line 1013 "tools.web"
lisp procedure solvable_kernels(exprn,k_oplist,c_oplist);
begin scalar form,kernel_list,forbidden_kernels;
form:=numr simp!* exprn;
k_oplist:=if null k_oplist then k_oplist else if atom
k_oplist then list k_oplist else if
car k_oplist= 'list then cdr k_oplist else k_oplist;
c_oplist:=if null c_oplist then c_oplist else if atom
c_oplist then list c_oplist else if
car c_oplist= 'list then cdr c_oplist else c_oplist;
kernel_list:=mk_kernel_list(form,k_oplist,c_oplist,nil,nil . nil);
forbidden_kernels:=cdr kernel_list;
kernel_list:=car kernel_list;
for each kernel in forbidden_kernels do kernel_list:=delete(kernel,kernel_list);
return 'list . kernel_list;
end$

%:51%%52:%
%line 1027 "tools.web"
end;
%line 1028 "tools.web"

%:52%