%**********************************************************************
module crackstar$
%**********************************************************************
% Main program
% Authors: Andreas Brand 1995-97,
% Thomas Wolf since 1996
symbolic operator crackshell$
symbolic procedure crackshell$
begin scalar s,ps;
ps:=promptstring!*$
promptstring!*:=""$
terpri()$
if null old_history then <<
write"Please give the name of the file in double quotes"$terpri()$
write"(no ;) from which the session is to be restored: "$
s:=termread()$
old_history:={'rb,s};
>>$
!*batch_mode:=nil;
algebraic(crack({},{},{},{}));
promptstring!*:=ps
end$
symbolic operator crack$
symbolic procedure crack(el,il,fl,vl)$
begin scalar l,l1,l2,n,m,pdes$
if l:=check_globals() then <<
write"The global variable ",l," has an incorrect value, please check!"$
rederr " "
>>$
if print_ and logoprint_ then <<terpri()$
write "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~",
"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"$ terpri()$
write "This is CRACK - a solver for overdetermined partial ",
"differential equations" $ terpri()$
>>$
if not !*batch_mode then <<
if not print_ then <<terpri()$print_:=8>>$
write"Enter `h' for help."$ terpri()$
>>$
%rulelist_:=if pairp userrules_ then
% if pairp crackrules_
% then list('LIST,userrules_,crackrules_)
% else list('LIST,userrules_)
% else
% if pairp crackrules_ then
% list('LIST,crackrules_)
% else nil$
backup_reduce_flags(); % backup of REDUCE flags
% initializations of global CRACK variables
to_do_list:=nil$
fnew_:=nil$
vl_:=nil$
stop_:=nil$
% dec_hist_list:=nil$
level_:=nil$
stepcounter_:=0$
batchcount_:=-1$
recycle_eqns:=nil . nil$
recycle_fcts:=nil$
recycle_ids:=nil$
n:=time()$
m:=gctime()$
if pairp el and (car el='LIST) then el:=cdr el else el:=list el$
if pairp fl and (car fl='LIST) then fl:=cdr fl else fl:=list fl$
if pairp vl and (car vl='LIST) then vl:=cdr vl else vl:=list vl$
if pairp il and (car il='LIST) then il:=cdr il else il:=list il$
ineq_:=nil;
ftem_:=fl; % for addineq and for mkeqlist
for each p in il do addineq(nil,p);
il:=nil$
vl_:=union(reverse argset fl,vl)$ vl:=nil;
orderings_:=make_orderings(fl, vl_)$ % Orderings support!
history_:=nil;
sol_list:=nil;
% necessary initializations in case structural equations are to solve:
if struc_eqn then ini_struc()$
% Orderings Note: orderings_prop_list_all() inserts all the valid
% orderings into each of the initial equations, i.e. all equations
% are in all orderings
% each equation gets a property list
pdes:=mkeqlist(el,fl,vl_,allflags_,t,orderings_prop_list_all(),nil)$
l:=pdes;
while l and get(car l,'linear_) do l:=cdr l;
if l then lin_problem:=nil else lin_problem:=t;
el:=nil$ % to free memory
size_hist:=if size_watch then {get_statistic(pdes,fl)}
else nil$
% the computation:
l:=crackmain(pdes,fl)$
if l=list(nil) then l:=nil$
l:=union(l,nil)$
if !*time or time_ then
<<terpri()$write "CRACK needed : ",time()-n," ms GC time : ",
gctime()-m," ms">>$
l:=for each a in l collect
<<l1:=nil$
l2:=caddr a$
for each b in cadr a do
if (pairp b) and (car b = 'EQUAL) then l1:=cons(b,l1)
else l2:=cons(b,l2)$
list(car a,l1,l2,cadddr a)>>$
if nil and adjust_fnc and null stop_ then <<
m:=nil;
for each a in fl do <<n:=assoc(a,depl!*); if n then m:=cons(n,m)>>$
l:=for each a in l collect if l1:=dropredund(a,fl,vl_) then cdr l1
else a$
for each a in fl do
if freeof(l,a) then m:=delete(assoc(a,m),m);
depl!*:=union(m,depl!*)
>>$
if null collect_sol then save_sol_list()$
% statements to free space to make later crack-calls more natural
nequ_:=1$
recycle_eqns:=nil . nil$
recycle_fcts:=nil$
recycle_ids:=nil$
recover_reduce_flags()$ % giving the REDUCE flags their backup value
if print_ and logoprint_ then <<
terpri()$
write "This is the end of the CRACK run"$
terpri()$
write "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~",
"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"$
terpri()$
>>$
return if l then
cons('LIST,for each a in l collect
list('LIST,cons('LIST,car a),
cons('LIST,cadr a),
cons('LIST,caddr a),
cons('LIST,cadddr a)))
else list('LIST)
end$
symbolic procedure crackmain(pdes,forg)$
% Main program
% > to be called only from crack() or sub_crack_call()
% > it returns
% - nil if no solution
% - {nil} if successful but no solutions are collected (collect_sol=nil)
% - {sol1,sol2,...} list of solutions
% each solution has the form
% {for each a in pdes collect get(a,'val),
% forg,setdiff(ftem_,forg),ineq_ }
%
% > The result that is returned is contained completely in the
% returned value (list) only apart from the variable dependencies
% of the free functions which is contained in depl!*.
% > apply-calls made within must return either
% nil or {pdes,forg} or {{sol1,sol2,...}}
% > In the case of more than one solution of an apply call, all of them
% must be computed because crackmain terminates after such an apply
% call that returns a list with a single element which then always is
% treated as a list of solutions.
% > Currently ftem_, ineq_, vl_ are essential (but hidden) input parameters
% (as well as the properties of the pdes and forg)
% > crackmain() sets the global variable contradiction_.
begin scalar result,l,pl,unsolvable, % dec_hist_list_copy,
s,ps,batch_one_step,expert_mode_copy,fnc_to_adjust,
fnc_adjusted,loopcount,level_length,newli,processes,
full_proc_list_length$
level_length:=length level_;
full_proc_list_length:=length full_proc_list_$
if level_ then
history_:=cons(bldmsg("%w%w","*** Start of level ",level_string(nil)),
cons('cm,history_));
if tr_main and print_ then
<<terpri()$write "start of the main procedure">>$
% depl_copy_:=depl!*$
% dec_hist_list_copy:=dec_hist_list$
fnc_to_adjust:=adjust_fnc;
contradiction_:=nil$
ftem_:=fctlist(ftem_,pdes,forg)$ % global list of free functions
again:
repeat <<
pl:=proc_list_$ % global list of procedures
stop_:=nil$
ftem_:=fctlist(ftem_,pdes,forg)$
vl_:=var_list(pdes,forg,vl_)$
if !*batch_mode or
to_do_list or
batch_one_step or
((batchcount_>=stepcounter_) and
((time_limit=nil) or <<l:=time(); limit_time>=l>>)) then
% automatic part: -----------------------
<<if !*batch_mode then
if print_more then
print_pde_fct_ineq(pdes,ineq_,
append(forg,setdiff(ftem_,forg)),vl_)
$%else print_statistic(pdes,append(forg,setdiff(ftem_,forg)))$
if size_watch then
size_hist:=cons(get_statistic(pdes,append(forg,
setdiff(ftem_,forg))),
size_hist);
stepcounter_:=add1 stepcounter_$
clean_prop_list(pdes)$
%if evenp(stepcounter_) and
% evenp(stepcounter_/2) then
err_catch_readin()$
if to_do_list then batchcount_:=add1 batchcount_;
if print_ then
<<terpri()$write "Step ",stepcounter_,": "$
if print_more then terpri()>>$
batch_one_step:=nil$
expert_mode_copy:=expert_mode$
if (null to_do_list) or
(caar to_do_list neq 'split_into_cases) then expert_mode:=nil$
while pl do <<
if print_ and print_more then
if pairp(l:=get(car pl,'description)) then <<
for each a in l do if a then write a$
write " : "
>> else
write "trying ",car pl," : "$
l:=apply(car pl,list list(pdes,forg,vl_,pdes))$
if (length l = 1) and (null car l) then contradiction_:=t;
if l and not contradiction_ then <<
if length l = 1 % before the test was: if cases_
then result:= car l % car l is a list of crackmain results
% resulting from investigating subcases
else <<pdes:=car l$ forg:=cadr l>>$ % no case-splitting
pl:=nil$
>> else
if contradiction_ then pl:=nil
else <<
pl:=cdr pl$
if print_ and print_more then
<<write " --- "$terpri()>>$
if not pl then unsolvable:=t
>>
>>;
expert_mode:=expert_mode_copy
>>
else % interactive part: -----------------------
<<if print_ and time_limit and (limit_time<l) then <<
write"The time limit for automatic execution has been reached."$
terpri()
>>$
rds nil$wrs nil$
ps:=promptstring!*$
promptstring!*:="next: "$
terpri()$s:=termread()$
% expert_mode:=expert_mode_copy$
if (s='h) or (s='help) or (s='?) or (s=nil) then printmainmenu()
else if s='hd then print_hd()
else if s='hp then print_hp()
else if s='hf then print_hf()
else if s='hc then print_hc()
else if (s='hi) and (getd 'show_id) then print_hi()
else if s='hb then print_hb()
% to inspect data -----------------------
else if s='e then
if expert_mode then print_pdes(selectpdes(pdes,1))
else print_pdes(pdes)
else if s='eo then <<
ps:=print_;print_:=1;
for each s in pdes do <<terpri()$
write s," : "$
typeeq(s)$
plot_non0_coeff_ld(s)
>>$
print_:=ps
>>
else if s='pi then print_ineq(ineq_)
else if s='f then
<<print_fcts(append(forg,setdiff(ftem_,forg)),vl_)$
terpri()>>
else if s='v then
<<print_fcts2(pdes,append(forg,setdiff(ftem_,forg)))$
terpri()>>
else if s='s then <<
print_level(nil)$
print_statistic(pdes,append(forg,setdiff(ftem_,forg)))
>>
else if s='fc then <<
reclaim()$terpri()$ % do garbage collection
write if not unboundp 'gcfree!* then gcfree!*
else known!-free!-space(),
" free cells"$
terpri()$write countids()," identifiers in use"$;
terpri()
>>
else if s='pe then <<
promptstring!*:=""$
terpri()$
write "Which expression do you want to print?"$
terpri()$
write "You can use names of equations, e.g. coeffn(e_12,df(f,x,y),2); "$
terpri()$
write "Terminate the expression with ; "$
terpri()$
l:=termxread()$
for each s in pdes do l:=subst(get(s,'val),s,l)$
l:=reval l;
for each s in forg do
if (pairp s) and (car s='EQUAL) then l:=subst(caddr s,cadr s,l)$
terpri()$
mathprint(reval l)
>>
else if s='ph then <<
terpri()$
prettyprint reverse history_
>>
else if s='pv then <<
write "Type in a variable from which you want to know its value: ";
promptstring!*:=""$
s:=termread()$
if not atom s then write"This is not a variable name." else
if null boundp s then write s," has no value"
else <<write s," = "$print eval s>>
>>
else if s='pd then plot_dependencies(pdes)
else if s='ss then err_catch_subsys(pdes)
else if s='w then write_in_file(pdes,forg)
% to proceed -----------------------
else if s='a then batch_one_step:=t
else if s='g then <<
promptstring!*:="number of steps: "$
s:=termread()$
promptstring!*:="next: "$
if fixp(s) then batchcount_:=sub1 stepcounter_+s
else <<write "wrong input!!!"$terpri()>> >>
else if s='t then <<
expert_mode:=not expert_mode$
if expert_mode then
write"The user will choose equations from now on."
else
write"The program will choose equations from now on.";
expert_mode_copy:=expert_mode
>>
else if s='p1 then printproclist()
else if s='p2 then printfullproclist()
else if s='# then <<
write"Type in a number instead of `#' to ",
"execute a specific module."$
terpri()
>>
else if (s='l) or numberp s then
<<if s='l then <<
repeat_mode:=t;
ps:=promptstring!*$
promptstring!*:=""$
write "Select a method by its number that is to be executed ",
"repeatedly:"$terpri()$
s:=termread()$terpri()$
write "To repeat this method as often as possible, enter `;' "$
terpri()$
write "To repeat this method as often as possible, ",
"but at most a number of n times, enter n :"$
terpri()$
repeat_mode:=termread()$
promptstring!*:=ps$
if not numberp repeat_mode then repeat_mode:=t
>>;
if (s<=0) or (s>full_proc_list_length) then
if print_ then <<
write"The number must be in 1 .. ",full_proc_list_length," ."$
terpri()
>> else else
<<
loopcount:=0;
if size_watch then
size_hist:=cons(get_statistic(pdes,append(forg,
setdiff(ftem_,forg))),
size_hist);
stepcounter_:=add1 stepcounter_$
clean_prop_list(pdes)$
if print_ then
<<terpri()$terpri()$write "Step ",stepcounter_,":"$
terpri()>>$
repeat <<
if to_do_list then loopcount:=sub1 loopcount$
l:=apply(if to_do_list then 'to_do
else nth(full_proc_list_,s),
list list(pdes,forg,vl_,pdes))$
if (length l = 1) and (null car l) then contradiction_:=t;
if l and not contradiction_ then <<
loopcount:=add1 loopcount$
if length l = 1 % before the test was: if cases_
then result:=car l % car l is a list of crackmain results
% resulting from investigating subcases
else <<pdes:=car l$ forg:=cadr l>>$ % no case-splitting
terpri()$
if repeat_mode=1 then repeat_mode:=nil
else if repeat_mode then <<
if numberp repeat_mode then repeat_mode:=sub1(repeat_mode);
if size_watch then
size_hist:=cons(get_statistic(pdes,append(forg,
setdiff(ftem_,
forg))),
size_hist);
stepcounter_:=add1 stepcounter_$
clean_prop_list(pdes)$
if print_ then
<<terpri()$terpri()$write "Step ",stepcounter_,":"$
terpri()>>$
>>
>>
else if (not contradiction_) and (loopcount=0) then
<<write "no success"$terpri()>>
>>
until (not repeat_mode) or (not l) or contradiction_ or
(time_limit and <<ps:=time();limit_time < ps >>);
>>;
repeat_mode:=nil
>>
else if s='sb then backup_to_file(pdes,forg,t)
else if s='rb then <<
l:=restore_backup_from_file(pdes,forg,t)$
pdes:=car l;forg:=cadr l;
if null pvm_able then % assumed not to be started from PVM
batchcount_:=sub1 stepcounter_
>>
else if (s='ep) then <<
pvm_activate()$
terpri()$
if pvm_able then write"Use of PVM is enabled."
else write"PVM is not active on this computer."$
>>
else if (s='dp) then pvm_able:=nil
else if (s='pp) and pvm_active() then
processes:=add_process(processes,pdes,forg)
else if (s='kp) and pvm_active() then processes:=drop_process(processes)
else if s='x then !*batch_mode:=t
else if s='q then stop_:=t
% to change flags & parameters -----------------------
else if s='pl then <<
promptstring!*:="Print length : "$
s:=termread()$
if not s or fixp(s) then print_:=s
else <<
terpri()$write "Print length must be NIL or an integer!!!"$
terpri()
>>
>>
else if s='pm then <<
print_more:=not print_more;
if print_more then write"More details will be printed."
else write"Fewer details will be printed.";
terpri()
>>
else if s='pa then <<
print_all:=not print_all;
if print_all then write"All equation properties will be printed."
else write"No equation properties will be printed.";
terpri()
>>
else if s='cp then changeproclist()
else if s='og then <<
lex_fc:=not lex_fc$
if lex_fc then
write"Lex. ordering of functions has now highest priority."
else
write"Lex. ordering of functions is not of highest priority anymore."$
terpri()$
pdes := change_derivs_ordering(pdes,ftem_,vl_)$
>>
else if s='od then <<
lex_df:=not lex_df$
if lex_df then
write"From now on lexicographic ordering of derivatives."
else
write"From now on total-degree ordering of derivatives.";
terpri()$
pdes := change_derivs_ordering(pdes,ftem_,vl_);
>>
else if s='oi then <<
terpri()$
write "Current variable ordering is : "$
s:=vl_;
while s do <<write car s$ s:=cdr s$ if s then write",">>$
write";"$terpri()$
promptstring!*:="New variable ordering : "$
newli := termlistread()$
if newli then <<
if (not not_included(vl_,newli)) and
(not not_included(newli,vl_)) then <<
vl_ := newli$
for each s in pdes do
put(s,'vars,sort_according_to(get(s,'vars),vl_));
pdes := change_derivs_ordering(pdes,ftem_,vl_)$
if tr_orderings then <<
terpri()$
write "New variable list: ", vl_$
>>
>>$
>>$
>>
else if s='or then <<
terpri()$
write "The current variable ordering is going to be reversed. "$
vl_ := reverse vl_$
for each s in pdes do
put(s,'vars,sort_according_to(get(s,'vars),vl_));
pdes := change_derivs_ordering(pdes,ftem_,vl_)$
if tr_orderings then <<
terpri()$
write "New variable list: ", vl_$
>>
>>
else if s='om then <<
terpri()$
write "The current variable ordering is going to be mixed. "$
s:=vl_; vl_:=nil;
while s do <<
l:=nth(s,add1 random length s)$
s:=delete(l,s);
vl_:=cons(l,vl_);
>>;
for each s in pdes do
put(s,'vars,sort_according_to(get(s,'vars),vl_));
pdes := change_derivs_ordering(pdes,ftem_,vl_)$
if tr_orderings then <<
terpri()$
write "New variable list: ", vl_$
>>
>>
else if s='of then <<
terpri()$
write "Current function ordering is : "$
s:=ftem_;
while s do <<write car s$ s:=cdr s$ if s then write",">>$
write";"$terpri()$
promptstring!*:="New function ordering : "$
newli := termlistread()$
if newli then <<
if (not not_included(ftem_,newli)) and
(not not_included(newli,ftem_)) then
change_fcts_ordering(newli,pdes,vl_)
>>
>>
else if s='op then <<
terpri()$
write "Current orderings are :"$
terpri()$
write "Functions : ", ftem_$
terpri()$
write "Variables : ", vl_$
>>
else if s='ne then <<
promptstring!*:="Equation name : "$
s:=termread()$
if s and idp s then eqname_:=s
else
<<terpri()$write "Equation name must be an identifier!!"$terpri()>>
>>
else if s='nf then <<
promptstring!*:="Function name : "$
s:=termread()$
if s and idp s then fname_:=s
else
<<terpri()$write "Function name must be an identifier!!"$terpri()>>
>>
else if s='ni then <<
promptstring!*:="Identity name : "$
s:=termread()$
if s and idp s then idname_:=s
else
<<terpri()$write "Identity name must be an identifier!!"$terpri()>>
>>
else if s='na then <<!*nat:=not !*nat;
if !*nat then write"NAT is now on."
else write"NAT is now off.">>
else if s='as then <<
write "Type in an assignment in the form ",
"{variable_name,value}; ";terpri()$
promptstring!*:="The expression: "$
s:=termxread()$
if (pairp s) and (car s='LIST) and (idp cadr s)
then set(cadr s, reval caddr s)
>>
else if s='kp then
if keep_parti then <<
keep_parti:=nil;
for each l in pdes do put(l,'partitioned,nil)
>> else keep_parti:=t
else if s='fi then <<
freeint_:=not freeint_;
if freeint_ then write"Integration only if result free ",
"of explicit integral from now on."
else write"Integration result may involve ",
"explicit integral from now on.";
>>
else if s='fa then <<
freeabs_:=not freeabs_;
if freeabs_ then
write"Integration only if result free of abs() from now on."
else
write"Integration result may involve abs() from now on.";
>>
else if s='cs then <<
confirm_subst:=not confirm_subst;
if confirm_subst then
write"The user will confirm substitutions from now on."
else
write"No user confirmation of substitutions from now on.";
>>
else if s='fs then <<
force_sep:=not force_sep;
if force_sep then write"Separation will be inforced from now on."
else write"Separation will not be inforced from now on.";
>>
else if s='ll then <<
write "What is the new line length? ";
promptstring!* :=""$
repeat l:=termread() until fixp l;
promptstring!*:="next: "$
linelength l
>>
else if s='re then <<
do_recycle_eqn:=not do_recycle_eqn$
if do_recycle_eqn then
write"Equation names will be re-used once the equation is dropped."
else
write"Equation names will not be re-used once the equation is dropped."
>>
else if s='rf then <<
do_recycle_fnc:=not do_recycle_fnc$
if do_recycle_fnc then
write"Function names will be re-used once the function",
" is substituted."
else
write"Function names will not be re-used once the function",
" is substituted."
>>
else if s='st then <<
batchcount_:=sub1 stepcounter_$
if time_limit then <<
l:=limit_time - time()$
if l<0 then write"The time-limit has expired."
else <<
l:=algebraic(round(l/60000))$
write"The current CPU time limit for automatic ",
"execution to stop is: "$
s:=algebraic(floor(l/60));
if s>0 then <<terpri()$write s," hours and ">>$
write algebraic(l-60*s)," minutes. "$
>>
>> else write"There is no time-limit set currently."$
terpri()$
ps:=promptstring!*$
promptstring!*:=""$
if yesp "Do you want to impose a CPU time-limit? " then <<
time_limit:=t$
write"How many hours? "$ s:=termread()$
write"How many minutes? "$ l:=termread()$
if not numberp s then s:=0$
if not numberp l then l:=0$
limit_time:=algebraic (round (s*3600000+l*60000+lisp time()))$
>> else time_limit:=nil$
>>
else if s='cm then <<
% do nothing, the input is added as a comment to history_
ps:=promptstring!*$
promptstring!*:=""$
write"Please type your comment in "" "" for the history_ list: "$
terpri()$
l:=termread()$
terpri()$
>>
else if s='lr then <<
ps:=promptstring!*$
promptstring!*:=""$
write"Please type in the new LET-rule in the form like"$terpri()$
write"sqrt(e)**(-~x*log(~y)/~z) => y**(-x/z/2) : "$
terpri()$
l:=termxread()$
userrules_:=cons('LIST,cons(l,cdr userrules_))$
algebraic (write "The new list of user defined rules: ",
lisp userrules_)$
terpri()$
write"Warning: Changes of equations based on LET-rules"$terpri()$
write"are not recorded in the history of equations."$terpri()$
>>
else if s='cr then <<
ps:=promptstring!*$
promptstring!*:=""$
write"These are all the user defined rules: "$ terpri()$
algebraic (write lisp userrules_);
write"Give the number of the rule to be dropped: "$ terpri()$
l:=termread()$
if l > sub1 length userrules_ then <<
write"This number is too big."$terpri()
>> else <<
s:=nil;userrules_:=cdr userrules_;
while l>1 do <<
l:=sub1 l;s:=cons(car userrules_,s);userrules_:=cdr userrules_
>>;
algebraic(clearrules lisp {'LIST,car userrules_});
userrules_:=cons('LIST,append(reverse s,cdr userrules_));
algebraic (write lisp userrules_);
terpri()$
>>
>>
% to change data of equations -----------------------
else if s='r then <<pdes:=replacepde(pdes,ftem_,vl_);
ftem_:=cadr pdes; pdes:=car pdes>>
else if s='n then newinequ(pdes)
else if s='d then pdes:=deletepde(pdes)
else if s='c then change_pde_flag(pdes)
else if s='pt then <<l:=General_Trafo({pdes,forg})$
if l then <<pdes:=car l$ forg:=cadr l>> >>
% to work with identities -----------------------
else if s='i and getd 'show_id then show_id()
else if s='id and getd 'show_id then
if l:=del_red_id(pdes) then pdes:=l else
else if s='iw and getd 'show_id then write_id_to_file(pdes)
else if s='ir and getd 'show_id then remove_idl()
else if s='ia and getd 'show_id then replace_idty()
else if s='ih and getd 'show_id then start_history(pdes)
else if s='ip and getd 'show_id then stop_history(pdes)
else if s='ii and getd 'show_id then
if l:=integrate_idty(nil,pdes,%forg,
ftem_,vl_) then pdes:=l else
<<write " no success"$terpri()>>
else if s='ic then check_history(pdes)
else if s='iy then
for each l in pdes do mathprint {'EQUAL,l,get(l,'histry_)}
% to trace and debug -----------------------
else if s='tm then <<tr_main:=not tr_main;
if tr_main then write"tr_main is now on."
else write"tr_main is now off.">>
else if s='tg then <<tr_gensep:=not tr_gensep;
if tr_gensep then write"tr_gensep is now on."
else write"tr_gensep is now off.">>
else if s='ti then <<tr_genint:=not tr_genint;
if tr_genint then write"tr_genint is now on."
else write"tr_genint is now off.">>
else if s='td then <<tr_decouple:=not tr_decouple;
if tr_decouple then write"tr_decouple is now on."
else write"tr_decouple is now off.">>
else if s='tl then <<tr_redlength:=not tr_redlength;
if tr_redlength then write"tr_redlength is now on."
else write"tr_redlength is now off.">>
else if s='ts then <<tr_short:=not tr_short;
if tr_short then write"tr_short is now on."
else write"tr_short is now off.">>
else if s='to then <<tr_orderings:=not tr_orderings;
if tr_orderings then write"tr_orderings is now on."
else write"tr_orderings is now off.">>
else if s='tr then <<
if 'psl memq lispsystem!* then load_package debug$
ps:=promptstring!*$
promptstring!*:=""$
write"Please type the name of the procedure to trace: "$
l:=termread()$
terpri()$
evtr list l
>>
else if s='ut then <<
ps:=promptstring!*$
promptstring!*:=""$
write"Please type the name of the procedure to trace: "$
l:=termread()$
terpri()$
evuntr list l
>>
else if s='br then <<
terpri()$write"This is Standard Lisp. Return to Reduce by Ctrl D."$
terpri()$
standardlisp()
>>
else if s ='pc then <<
promptstring!* := "The function name: "$
s:=termread();
promptstring!* := "The argument list in the form {arg1,...}; : "$
l:=termxread();
if (pairp l) and (car l = ' list) and idp s then
prin2t list ("Result: ", apply(s,cdr l))
>>
else if s='in then <<
ps:=promptstring!*$
promptstring!*:=""$
write"Please give the name of the file to be read in"$terpri()$
write"double quotes (no ;) : "$
l:=termread()$
terpri()$
in l$
>>
% otherwise -------------------------------------
else <<write "illegal input: '",s,"'"$terpri()>>$
promptstring!*:=ps$
if ifl!* then rds cadr ifl!*$
if ofl!* then wrs cdr ofl!*$
>>;
if (not pdes) and fnc_to_adjust then
if fnc_adjusted then <<adjust_fnc:=t; % back to original value
fnc_to_adjust:=nil>> else
if contradiction_ or result then fnc_to_adjust:=nil else
<<to_do_list:=cons(list('del_redundant_fc,list nil),
to_do_list);
adjust_fnc:=nil; % in order not to run in a loop
fnc_adjusted:=t
>>
>>
until contradiction_ or result or stop_ or unsolvable
or (not pdes and not fnc_to_adjust)$
ineq_:=drop_triv_ineq(ineq_);
if not (contradiction_ or result) then <<
if (print_ or null collect_sol) and not stop_ then <<terpri()$
terpri()$ write">>>>>>>>> Solution"$
if level_ then write" of level ",level_string(nil)$
write" : "$
>>$
ftem_:=fctlist(ftem_,pdes,forg)$
forg:=forg_int(forg,ftem_)$
if null collect_sol then <<s:=print_;print_:=100>>$
print_pde_fct_ineq(pdes,ineq_,append(forg,setdiff(ftem_,forg)),vl_)$
if null collect_sol then print_:=s$
if not stop_ then <<
% The following is a procedure the user can define to do
% specific operations with each solution, e.g. substitution of
% original equations, substitution into formulae,...
% This became necessary when for non-linear problems non-solutions
% were introduced.
algebraic
(s:=crack_out(lisp cons('LIST,for each a in pdes collect get(a,'val)),
lisp cons('LIST,setdiff(forg,ftem_)),
lisp cons('LIST,ftem_),
lisp cons('LIST,ineq_) ));
% If s is not null then s is expected to be an algebraic list of
% expressions that should be zero but are not and therefore make
% a new start necessary. This is only relevant for non-linear
% problems.
if s and (cdr s) and null lin_problem then <<
for each l in pdes do
put(l,'val,simplifypde(get(l,'val),ftem_,t,l))$
pl:=pdes;
for each l in cdr s do
pdes:=eqinsert(mkeq(l,ftem_,vl_,allflags_,t,list(0),nil,pdes),pdes)$
if setdiff(pdes,pl) then <<
if print_ then <<
write"Not all conditions are solved."$terpri()$
write" --> RESTART with extra conditions ",setdiff(pdes,pl)$
terpri()>>$
unsolvable:=nil$
goto again
>>
>>
>>$
if session_ and null collect_sol then
save_solution(for each a in pdes collect get(a,'val),
setdiff(forg,ftem_),ftem_,ineq_,nil); % nil:file_name unsp.
result:=if collect_sol then
list list(for each a in pdes collect get(a,'val),
forg,setdiff(ftem_,forg),ineq_)
else list(nil)$
>>$
% dec_hist_list:=dec_hist_list_copy$
if tr_main and print_ then
<<terpri()$write "end of the main procedure"$terpri()>>$
l:=(length level_)+1-level_length;
for s:=1:l do if level_ then level_:=cdr level_$
if level_ then
history_:=cons(bldmsg("%w%w","*** Back to level ",level_string(nil)),
cons('cm,history_));
% delete property lists
for l:=1:(sub1 nequ_) do drop_pde(mkid(eqname_,l),pdes,nil)$
for each l in forg do
if pairp l then setprop(cadr l,nil)
else setprop( l,nil)$
return result$
end$
algebraic procedure crack_out(eqns,assigns,freef,ineq)$
% eqns .. list of remaining unsolved equations
% assigns .. list of computed assignments of the form `function = expression'
% freef .. list of list of functiones either free or in eqns
% ineq .. list of inequalities
begin
end$
symbolic procedure priproli(proclist)$
begin integer i$
scalar l,cpy$
for each a in proclist do <<
cpy:=full_proc_list_;
i:=1;
while a neq car cpy do <<i:=add1 i;cpy:=cdr cpy>>$
if null cpy then i:=0;
terpri()$
if i<10 then write " "$
write i$
write " : "$
if pairp(l:=get(a,'description)) then
(for each s in l do if s then write s)
else write a>>$
terpri()$
end$
symbolic procedure priprolinr(proclist,fullproclist)$
begin integer i,j$
scalar cfpl$
j:=0;
for each a in proclist do <<
j:=j+1;
i:=1;
cfpl:=fullproclist;
while cfpl and (a neq car cfpl) do <<i:=add1 i$cfpl:=cdr cfpl>>$
if cfpl then <<if (j>1) then write ","$
if j>21 then <<j:=1;terpri()>>$
write i>>$
>>$
write";"$terpri()$
end$
symbolic procedure changeproclist()$
begin scalar l,p,ps,err;
terpri()$
write "Please type in a list of the numbers 1 .. ",
length full_proc_list_,", like 1,2,5,4,..,15; which"$
terpri()$
write"will be the new priority list of procedures done by CRACK."$
terpri()$
write"Numbers stand for the following actions:"$terpri()$
priproli(full_proc_list_)$
terpri()$write"The list so far was: "$
priprolinr(proc_list_,full_proc_list_)$
ps:=promptstring!*$
promptstring!*:="The new list: "$
l:=termlistread()$
promptstring!*:=ps$
if null l then err:=t
else <<
while l do <<
if (not fixp car l) or
(car l > length full_proc_list_)
then
<<terpri()$write "Error: ",car l,
" is not one of the possible numbers.";
l:=nil$
err:=t>>
else <<
p:=union(list nth(full_proc_list_,car l),p);
l:=cdr l
>>
>>;
>>;
if not err then
<<proc_list_:=reverse p;
%terpri()$write"The new order of procedures:"$ priproli(proc_list_)
>>
else
<<terpri();write "The procedure list is still unchanged."$terpri()>>
end$
symbolic procedure printproclist()$
begin
terpri()$
write "Procedures used currently for automatic execution:"$
priproli(proc_list_)
end$
symbolic procedure printfullproclist()$
begin
terpri()$
write "The complete list of available procedures:"$
priproli(full_proc_list_)
end$
symbolic procedure printmainmenu()$
<<terpri()$
write "hd : Help to inspect data"$terpri()$
write "hp : Help to proceed"$terpri()$
write "hf : Help to change flags & parameters"$terpri()$
write "hc : Help to change data of equations"$terpri()$
if getd 'show_id then
write "hi : Help to work with identities"$terpri()$
write "hb : Help to trace and debug"$terpri()$
>>$
symbolic procedure print_hd()$
<<terpri()$
write "e : Print equations"$ terpri()$
write "eo : Print overview of functions in equations"$ terpri()$
write "pi : Print inequalities"$ terpri()$
write "f : Print functions and variables"$ terpri()$
write "v : Print all derivatives of all functions"$ terpri()$
write "s : Print statistics"$ terpri()$
write "fc : Print no of free cells"$ terpri()$
write "pe : Print an algebraic expression"$ terpri()$
write "ph : Print history of interactive input"$ terpri()$
write "pv : Print value of any lisp variable"$ terpri()$
write "pd : Plot the occurence of functions in equations"$terpri()$
write "ss : Find and print sub-systems"$ terpri()$
write "w : Write equations into a file"$ terpri()$
>>$
symbolic procedure print_hp()$
<<terpri()$
write "a : Do one step automatically"$ terpri()$
write "g : Go on for a number of steps automatically"$ terpri()$
write "t : Toggle equation selection to : "$
if expert_mode then write "AUTOMATIC"
else write "USER"$ terpri()$
write "p1 : Print a list of all modules in batch mode"$ terpri()$
write "p2 : Print a complete list of all modules"$ terpri()$
write "# : Execute the module with the number `#' once"$ terpri()$
write "l : Execute a specific module repeatedly"$ terpri()$
write "sb : Save complete backup to file"$ terpri()$
write "rb : Read backup from file"$ terpri()$
write "ep : Enable parallelism"$ terpri()$
write "dp : Disable parallelism"$ terpri()$
write "pp : Start an identical parallel process"$ terpri()$
write "kp : Kill a parallel process"$ terpri()$
write "x : Exit interactive mode for good"$ terpri()$
write "q : Quit current level or crack if in level 0"$ terpri()$
>>$
symbolic procedure print_hf()$
<<terpri()$
write "pl : Maximal length of an expression to be printed (",
print_,")"$ terpri()$
write "pm : ",if print_more then "Do not p" else "P",
"rint more information about the pdes"$ terpri()$
write "pa : ",if print_all then "Do not p" else "P",
"rint all information about the pdes"$ terpri()$
write "cp : Change the priorities of procedures"$ terpri()$
write "og : Toggle ordering to ",
if lex_fc then "derivatives > functions"
else "functions > derivatives"$ terpri()$
write "od : Toggle ordering of derivatives to ",
if lex_df then "total-degree"
else "lexicographic"$ terpri()$
write "oi : Interactive change of ordering on variables"$ terpri()$
write "or : Reverse ordering on variables"$ terpri()$
write "om : Mix randomly ordering on variables"$ terpri()$
write "of : Interactive change of ordering on functions"$ terpri()$
write "op : Print current ordering"$ terpri()$
write "ne : Root of the name of new generated equations (",
eqname_,")"$ terpri()$
write "nf : Root of the name of new functions and constants (",
fname_,")"$ terpri()$
write "ni : Root of the name of new identities (",
idname_,")"$ terpri()$
write "na : Change output to "$
if !*nat then write "OFF NAT"
else write "ON NAT"$ terpri()$
write "as : Input of an assignment"$ terpri()$
write "kp : ",if keep_parti then "Do not keep"
else "Keep",
" a partitioned copy of each equation"$ terpri()$
write "fi : ",if freeint_ then "Allow unresolved integrals"
else "Forbid unresolved integrals"$ terpri()$
write "fa : ",if freeabs_ then "Allow solutions of ODEs with ABS()"
else "Forbid solutions of ODEs with ABS()"$ terpri()$
write "cs : ",if confirm_subst then
"No confirmation of intended substitutions/factorizations"
else
"Confirmation of intended substitutions/factorizations"$
terpri()$
write "fs : ",if force_sep
then "Do not enforce direct separation"
else "Enforce direct separation"$ terpri()$
write "ll : change of the line length"$ terpri()$
write "re : ",if do_recycle_eqn then "Do not re-cycle equation names."
else "Do re-cycle equation names."$
terpri()$
write "rf : ",if do_recycle_fnc then "Do not re-cycle function names."
else "Do re-cycle function names."$
terpri()$
write "st : Setting a CPU time limit for un-interrupted run"$
terpri()$
write "cm : Adding a comment to the history_ list"$ terpri()$
write "lr : Adding a LET-rule"$ terpri()$
write "cr : Clearing a LET-rule"$ terpri()$
>>$
symbolic procedure print_hc()$
<<terpri()$
write "r : Replace or add one equation"$ terpri()$
write "n : Add one inequality"$ terpri()$
write "d : Delete equations"$ terpri()$
write "c : Change a flag or property of one pde"$ terpri()$
write "pt : Perform a transformation of functions and variables"$
terpri()$
>>$
symbolic procedure print_hi()$
if getd 'show_id then
<<terpri()$
write "i : Print identities between equations"$ terpri()$
write "id : Delete redundand equations"$ terpri()$
write "iw : Write identities to a file"$ terpri()$
write "ir : Remove list of identities"$ terpri()$
write "ia : Add or replace an identity"$ terpri()$
write "ih : Start recording histories and identities"$ terpri()$
write "ip : Stop recording histories and identities"$ terpri()$
write "ii : Integrate an identity"$ terpri()$
write "ic : Check the consistency of identity data"$ terpri()$
write "iy : Print the history of equations"$ terpri()$
>>$
symbolic procedure print_hb()$
<<terpri()$
write "tm : ",if tr_main then "Do not t" else "T",
"race main procedure"$ terpri()$
write "tg : ",if tr_gensep then "Do not t" else "T",
"race generalized separation"$ terpri()$
write "ti : ",if tr_genint then "Do not t" else "T",
"race generalized integration"$ terpri()$
write "td : ",if tr_decouple then "Do not t" else "T",
"race decoupling process"$ terpri()$
write "tl : ",if tr_redlength then "Do not t" else "T",
"race decoupling length reduction"$ terpri()$
write "ts : ",if tr_short then "Do not t" else "T",
"race algebraic length reduction"$ terpri()$
write "to : ",if tr_orderings then "Do not t" else "T",
"race orderings process"$ terpri()$
write "tr : Trace an arbitrary procedure"$ terpri()$
write "ut : Untrace a procedure"$ terpri()$
write "br : Break"$ terpri()$
write "pc : Do a function call"$ terpri()$
write "in : Reading in a REDUCE file"$ terpri()$
>>$
symbolic procedure to_do(arglist)$
if to_do_list then
begin scalar p,l$
p:=car to_do_list;
to_do_list:=cdr to_do_list;
if tr_main and print_ and print_more then
if pairp(l:=get(car p,'description)) then
<<for each a in l do if a then write a$
write " : ">>
else write "trying ",car p," : "$
% l:=apply(car p,list(list(car arglist,cadr arglist,
% caddr arglist,cadddr cdr p)))$
l:=apply(car p,list(cons(car arglist,cons(cadr arglist,
cons(caddr arglist, cdr p)))))$
if not l then l:=arglist$
return l$
end$
symbolic procedure subst_derivative(arglist)$
% Substitution of a derivative of a function by an new function
% in all pdes and in forg
begin scalar f,l,q,g,h,pdes,forg$
pdes:=car arglist$
forg:=cadr arglist$
l:=check_subst_df(pdes,forg)$
for each d in l do
<<f:=newfct(fname_,fctargs cadr d,nfct_)$
nfct_:=add1 nfct_$
ftem_:=fctinsert(f,delete(cadr d,ftem_))$
if print_ then
<<terpri()$write "replacing "$
fctprint1 d$
write " by "$fctprint list f$terpri()>>$
for each s in pdes do dfsubst_update(f,d,s)$
% integrating f in order to substitute for cadr d
% in ineq_
h:=cddr d;
g:=f;
while h do <<
for r:=1:(if (length h =1) or
((length h > 1) and (not fixp cadr h))
then 1
else (cadr h)
) do
g:=list('PLUS,gensym(),list('INT,g,car h));
h:=cdr h;
if h and (fixp car h) then h:=cdr h
>>;
% now the substitution in ineq_
ineq_:=for each s in ineq_ collect reval subst(g,cadr d,s);
if member(cadr d,forg) then
<<q:=mkeq(list('PLUS,d,list('MINUS,f)),
list(f,cadr d),fctargs f,allflags_,nil,list(0),nil,pdes)$
remflag1(q,'to_eval)$
put(q,'not_to_eval,cons(f,get(q,'not_to_eval)))$
pdes:=eqinsert(q,pdes)>>$
forg:=dfsubst_forg(f,g,cadr d,forg)$
>>$
return if l then list(pdes,forg)
else nil
end$
symbolic procedure undo_subst_derivative(arglist)$
% undo Substitution of a derivative of a function by an new function
% in all pdes and in forg
begin scalar success$
for each p in car arglist do
if get(p,'not_to_eval) then
<<remprop(p,'not_to_eval)$
flag(list p,'to_eval)$
success:=t>>$
return if success then arglist
else nil
end$
%symbolic procedure make_subst(pdes,forg,vl,l1,length_limit,pdelimit,
% less_vars,no_df,no_cases,lin_subst,
% min_growth,cost_limit,keep_eqn,sub_fc)$
symbolic procedure subst_level_0(arglist)$
% Substitution of a function by an expression of at most length subst_0
% depending on less variables than the function,
% not allowing case distinctions,
% ftem-dep. coefficient allowed
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_0,target_limit_0,t,nil,t,nil,nil,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_03(arglist)$
% Substitution of a function by an expression of at most length subst_0
% depending on less variables than the function,
% not allowing case distinctions,
% ftem-dep. coefficient allowed
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_0,target_limit_0,nil,t,t,nil,nil,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_04(arglist)$
% Substitution of a function by an expression of at most length subst_1
% depending on less variables than the function,
% not allowing case distinctions,
% ftem-dep. coefficient allowed
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_1,target_limit_1,nil,t,t,nil,nil,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_05(arglist)$
% Substitution of a function by an expression of at most length subst_4
% depending on less variables than the function,
% not allowing case distinctions,
% ftem-dep. coefficient allowed
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_4,target_limit_0,nil,t,t,nil,nil,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_1(arglist)$
% Substitution of a function by an expression of at most length subst_1
% depending on less variables than the function,
% allowing case distinctions,
% ftem-dep. coefficient allowed
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_1,target_limit_1,t,nil,nil,nil,nil,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_2(arglist)$
% Substitution of a function by an expression of at most length subst_2
% depending on less variables than the function,
% allowing case distinctions,
% ftem-dep. coefficient allowed
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_2,target_limit_0,t,nil,t,nil,nil,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_3(arglist)$
% Substitution of a function by an expression of at most length subst_1
% depending on all variables,
% allowing case distinctions,
% ftem-dep. coefficient allowed
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_3,target_limit_3,nil,nil,nil,nil,nil,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_33(arglist)$
% Substitution of a function by an expression of at most length subst_2
% depending on all variables,
% not giving case distinctions,
% no ftem-dep. coefficient
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_4,target_limit_4,nil,nil,t,t,nil,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_35(arglist)$
% Substitution of a function by an expression of at most length subst_2
% depending on all variables,
% not giving case distinctions,
% ftem-dep. coefficient allowed
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_4,target_limit_4,nil,nil,t,nil,nil,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_4(arglist)$
% Substitution of a function by an expression of at most length subst_2
% depending on all variables,
% allowing case distinctions,
% ftem-dep. coefficient allowed
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_4,target_limit_4,nil,nil,nil,nil,nil,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_45(arglist)$
% Substitution of a function by an expression
% such that the growth of all equations is minimal
% with some penalty for non-linearity increasing substitutions
% no substitutions introducing case distinctions
% no growth of total length of all equations
% good for algebraic problems
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
nil,nil,nil,nil,t,nil,t,cost_limit5,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure subst_level_5(arglist)$
% Substitution of a function by an expression
% such that the growth of all equations is minimal
% with some penalty for non-linearity increasing substitutions
% and substitutions introducing case distinctions
% good for algebraic problems
make_subst(if length arglist > 4 then nth(arglist,5)
else car arglist,
cadr arglist,caddr arglist,cadddr arglist,
subst_4,target_limit_4,nil,nil,nil,nil,t,nil,nil,
if length arglist > 5 then nth(arglist,6)
else nil
)$
symbolic procedure factorize_any(arglist)$
% Factorization of a pde and investigation of the resulting subcases
begin scalar l$
if expert_mode then l:=selectpdes(car arglist,1)
else l:=cadddr arglist$
return split_and_crack(get_fact_pde(l,nil),
car arglist,cadr arglist)$
end$
symbolic procedure factorize_to_substitute(arglist)$
% Factorization of a pde and investigation of the resulting subcases
begin scalar l$
if expert_mode then l:=selectpdes(car arglist,1)
else l:=cadddr arglist$
return split_and_crack(get_fact_pde(l,t),
car arglist,cadr arglist)$
end$
symbolic procedure separation(arglist)$
% Direct separation of a pde
if vl_ then % otherwise not possible --> save time
begin scalar p,l,l1,pdes,forg$
pdes:=car arglist$
forg:=cadr arglist$
if expert_mode then l1:=selectpdes(pdes,1)
else l1:=cadddr arglist$
if (p:=get_separ_pde(l1)) then
<<l:=separate(p,pdes)$
if l and
((length l>1) or
((length l = 1) and (car l neq p))) then
<<pdes:=drop_pde(p,pdes,nil)$
while l do
<<pdes:=eqinsert(car l,pdes)$
l:=cdr l>>$
l:=list(pdes,forg)>> >>$
return l$
end$
symbolic procedure alg_solve_system(arglist)$
begin scalar pdes,l1,l2,l3,l4,l5,l6,fl,vl,zd,pdes2$
pdes:=car arglist$
%l1:=selectpdes(pdes,nil)$
l1:=select_from_list(pdes,nil)$
if null l1 then return nil;
for each l2 in l1 do vl:=union(get(l2,'vars),vl);
for each l2 in l1 do fl:=union(get(l2,'fcts),fl);
l1:=for each l2 in l1 collect get(l2,'val)$
write"Please give a list of constants, functions or derivatives"$
terpri()$
write"of functions to be solved algebraically, like f,g,df(g,x,2);"$
terpri()$
l2:=termlistread()$
if l2 then <<
l3:=cdr solveeval list(cons('LIST,l1),cons('LIST,l2));
if null l3 then <<
write"There is no solution."$
terpri()
>> else
if length l3 > 1 then <<
write"can currently not handle more than 1 solution"$
terpri()
>> else <<
l3:=for each l4 in l3 collect << % for each solution l4
l4:=for each l5 in cdr l4 collect <<
zd:=union(zero_den(reval l5,fl,vl),zd)$
l6:=reval {'PLUS,cadr l5,{'MINUS,caddr l5}}$
if pairp l6 and (car l6 = 'QUOTIENT) then cadr l6
else l6
>> % l4 is now a list of expressions to vanish
>>;
if length l3 = 1 then << %######### 1 solution - a restriction for now
l4:=car l3; % the solution
pdes2:=pdes;
for each l5 in l4 do <<
l5:=mkeq(if zd then cons('TIMES,append(zd,list l5))
else l5,
fl,vl,allflags_,nil,list(0),nil,pdes)$
pdes:=eqinsert(l5,pdes)$
>>;
if print_ then <<
pdes2:=setdiff(pdes,pdes2);
write"New equations: ",pdes2$terpri()$
>>$
return {pdes,cadr arglist}
>>
>>
>>
end$
symbolic procedure alg_solve_single(arglist)$
% Solving an equation that is algebraic for a function
% or a derivative of a function,
% So far no flag is installed to remember a corresponding
% investigation because the check is quick and done very
% rarely with lowest priority.
begin scalar l,l1,pdes,forg$
pdes:=car arglist$
forg:=cadr arglist$
if expert_mode then l1:=selectpdes(pdes,1)
else l1:=cadddr arglist$
if (l:=algsolvederiv(l1)) then
<<pdes:=drop_pde(car l,pdes,nil)$
pdes:=eqinsert(cdr l,pdes)$
to_do_list:=cons(list('factorize_any,%pdes,forg,caddr arglist,
list cdr l),
to_do_list);
l:=list(pdes,forg);
>>$
return l
end$
symbolic procedure alg_for_deriv(p)$
% find the first function with only one sort of derivative
% which in addition occurs non-linear
begin scalar dl,d,f$
dl:=get(p,'derivs);
while dl and null d do << % for each function
d:=car dl$ % d is the leading power of the leading deriv. of f
f:=caar d; % the next function f
if fctlength f < get(p,'nvars) then <<d:=nil;dl:=nil>>
else <<
dl:=cdr dl;
if cdr d = 1 then d:=nil; % must not be linear in lead. deriv.
while dl and (f = caaar dl) do <<
if d and (car d neq caar dl) then d:=nil;
dl:=cdr dl
>>
>>
>>;
return d
end$
symbolic procedure algsolvederiv(l)$
begin scalar d,p,abs_was_not_active$
while l and null (d:=alg_for_deriv(car l)) do l:=cdr l;
if d then <<
p:=cdr d$
algebraic <<
abs_was_not_active:=if !%x neq abs !%x then t else nil$
if abs_was_not_active then let abs_
>>$
d:=solveeval list(get(car l,'val),
if 1=length car d then caar d
else cons('DF,car d));
algebraic <<
if abs_was_not_active then clearrules abs_
>>$
% d:=solveeval list(cons('LIST,get(car l,'val)),
% {'LIST,if 1=length car d then caar d
% else cons('DF,car d)});
if d and (car d='LIST) and (length d = p+1) then
p:=for each el in cdr d collect if car el='EQUAL then
reval {'NUM,
reval {'PLUS,cadr el,{'MINUS,caddr el}}} else d:=nil
else d:=nil;
if d then <<
d:=cons('TIMES,p);
p:=car l;
d:=mkeq(d,get(p,'fcts),get(p,'vars),allflags_,nil,get(p,'orderings),nil,nil)$
% last argument is nil as no new inequalities are to be expected.
if print_ then write p," factorized to ",d
>>
>>;
return if d then p . d
else nil
end$
symbolic procedure quick_integration(arglist)$
% Integration of a short first order de with at most two terms
begin scalar l,l1,pdes,forg$
pdes:=car arglist$
forg:=cadr arglist$
if expert_mode then
<<l1:=selectpdes(pdes,1);flag(l1,'to_int);flag(l1,'to_fullint)>>
else l1:=cadddr arglist$
if (l:=quick_integrate_one_pde(l1)) then
<<pdes:=delete(car l,pdes)$
for each s in l do pdes:=eqinsert(s,pdes)$
for each s in l do
to_do_list:=cons(list('subst_level_35,%pdes,forg,caddr arglist,
list s),
to_do_list)$
l:=list(pdes,forg)>>$
return l$
end$
symbolic procedure full_integration(arglist)$
% Integration of a pde
% only if then a function can be substituted
begin scalar l,l1,pdes,forg$
pdes:=car arglist$
forg:=cadr arglist$
if expert_mode then
<<l1:=selectpdes(pdes,1);flag(l1,'to_int);flag(l1,'to_fullint)>>
else l1:=cadddr arglist$
if (l:=integrate_one_pde(l1,genint_,t)) then
<<pdes:=delete(car l,pdes)$
for each s in l do pdes:=eqinsert(s,pdes)$
for each s in l do
to_do_list:=cons(list('subst_level_35,%pdes,forg,caddr arglist,
list s),
to_do_list)$
l:=list(pdes,forg)>>$
return l$
end$
symbolic procedure integration(arglist)$
% Integration of a pde
begin scalar l,l1,pdes,forg$
pdes:=car arglist$
forg:=cadr arglist$
if expert_mode then
<<l1:=selectpdes(pdes,1);flag(l1,'to_int);flag(l1,'to_fullint)>>
else l1:=cadddr arglist$
if (l:=integrate_one_pde(l1,genint_,nil)) then
<<pdes:=delete(car l,pdes)$
for each s in l do pdes:=eqinsert(s,pdes)$
for each s in cdr l do
to_do_list:=cons(list('subst_level_35,%pdes,forg,caddr arglist,
list s),
to_do_list)$
l:=list(pdes,forg)>>$
return l$
end$
symbolic procedure multintfac(arglist)$
% Seaching of an integrating factor for a set of pde's
begin scalar pdes,forg,l,stem,ftem,vl,vl1$
pdes:=car arglist$
if null pdes or (length pdes=1) then return nil$
forg:=cadr arglist$
for each p in pdes do
if not (get(p,'starde) or get(p,'nonrational)) then
<<stem:=cons(get(p,'val),stem)$
ftem:=union(get(p,'fcts),ftem)$
vl:=union(get(p,'vars),vl)
>>$
vl1:=vl$
fnew_:=nil$
while vl1 do
if (l:=findintfac(stem,ftem,vl,car vl1,nil,nil,nil,nil)) then
<<ftem:=smemberl(ftem,car l)$
vl:=union(smemberl(vl,car l),argset ftem)$
l:=addintco(car l, ftem, nil, vl, car vl1)$
for each f in fnew_ do
ftem_:=fctinsert(f,ftem_)$
ftem:=union(fnew_,ftem)$
fnew_:=nil$
pdes:=eqinsert(mkeq(l,smemberl(ftem_,ftem),vl,
allflags_,t,list(0),nil,pdes),
pdes)$
vl1:=nil$
l:=list(pdes,forg)>>
else vl1:=cdr vl1$
return l$
end$
symbolic procedure diff_length_reduction(arglist)$
% Do one length reduction step
begin scalar l$
l:=dec_and_red_len_one_step(car arglist,ftem_,%cadr arglist,
caddr arglist,0)$
% 0 for ordering
if l then l:=list(l,cadr arglist)$
return l$
end$
symbolic procedure high_prio_decoupling(arglist)$
% Do one decoupling step
begin scalar l$
l:=dec_one_step(car arglist,ftem_,%cadr arglist,
caddr arglist,t,0)$
% 0 for ordering
if l then l:=list(l,cadr arglist)$
return l$
end$
symbolic procedure decoupling(arglist)$
% Do one decoupling step
begin scalar l$
l:=dec_one_step(car arglist,ftem_,%cadr arglist,
caddr arglist,nil,0)$
% 0 for ordering
if l then l:=list(l,cadr arglist)$
return l$
end$
symbolic procedure clean_dec(p,pdes,flg)$
begin scalar propty,el,nl,newpropty$
propty:=get(p,flg)$
for each el in propty do <<
nl:=intersection(cdr el,pdes);
if nl then newpropty:=cons(cons(car el,nl),newpropty)
>>$
put(p,flg,reverse newpropty)
end$
symbolic procedure clean_prop_list(pdes)$
if null car recycle_eqns and
cdr recycle_eqns and
(length cdr recycle_eqns > 50) then
<<for each p in pdes do <<
clean_dec(p,pdes,'dec_with)$
clean_dec(p,pdes,'dec_with_rl)$
% clean_rl(p,pdes) :
put(p,'rl_with,intersection(pdes,get(p,'rl_with)))$
>>$
% recycle_eqns is a pair of 2 lists:
% (ready to use eqn. names) . (free eqn. names which still
% may occur in prob_list)
recycle_eqns:=append(car recycle_eqns,reverse cdr recycle_eqns) . nil;
nil
>>$
symbolic procedure clean_up(pdes)$
begin scalar newpdes;
while pdes do <<
if flagp(car pdes,'to_drop) then
drop_pde(car pdes,nil,nil) else
newpdes:=cons(car pdes,newpdes);
pdes:=cdr pdes
>>;
return reverse newpdes
end$
symbolic procedure add_differentiated_pdes(arglist)$
% all pdes in which the leading derivative of a function of all
% vars occurs nonlinear will be differentited w.r.t all vars and
% the resulting pdes are added to the list of pdes
begin scalar pdes,l,l1,q$
pdes:=car arglist$
if expert_mode then l1:=selectpdes(pdes,1)
else l1:=cadddr arglist$
for each p in l1 do
if flagp(p,'to_diff) then
% --------------- it should be differentiated only once
<<for each f in get(p,'allvarfcts) do
if (cdr ld_deriv(p,f)>1) then
<<if print_ then
<<terpri()$
write "differentiating ",p," w.r.t. "$
listprint fctargs f$
write " we get the new equations : ">>$
for each v in fctargs f do <<
q:=mkeq(list('DF,get(p,'val),v),get(p,'fcts),get(p,'vars),
delete('to_fullint,delete('to_int,delete('to_diff,allflags_))),
t,list(0),nil,pdes)$
prevent_simp(v,p,q)$
if print_ then write q," "$
pdes:=eqinsert(q,pdes)>>$
remflag1(p,'to_diff)$
l:=cons(pdes,cdr arglist)>>
>>$
return l$
end$
symbolic procedure add_diff_ise(arglist)$
% a star-pde is differentiated and then added
begin scalar pdes,l,l1,q,vli$
pdes:=car arglist$
if expert_mode then l1:=selectpdes(pdes,1)
else l1:=cadddr arglist$
for each p in l1 do
if flagp(p,'to_diff)
and (null l)
and get(p,'starde)
then <<
vli:=if expert_mode then select_from_list(get(p,'vars),nil)
else get(p,'vars);
if print_ then
<<terpri()$
write "differentiating ",p," w.r.t. "$
listprint vli$
write " we get the new equations : "
>>$
for each v in vli do
<<q:=mkeq(list('DF,get(p,'val),v),get(p,'fcts),get(p,'vars),
delete('to_fullint,delete('to_int,allflags_)),
t,get(p,'orderings),nil,pdes)$
if null get(q,'starde) then <<
flag(list q,'to_fullint)$
flag(list q,'to_int)$
>>$
prevent_simp(v,p,q)$
%check whether q really includes 'fcts and 'vars: should be ok
if print_ then write q," "$
pdes:=eqinsert(q,pdes)$
>>$
remflag1(p,'to_diff)$
l:=cons(pdes,cdr arglist)$
>>$
return l$
end$
symbolic procedure alg_groebner(arglist)$
begin scalar pdes,forg,sol,n,result,l1$
pdes:=car arglist$
sol:=
if GB_REDUCE = 'GB then
algebraic call_gb(lisp(cons('LIST,ftem_)),
lisp(cons('LIST,for each p in pdes collect(get(p,'val)))),
lisp 'revgradlex)
else
algebraic(groebnerf(lisp(cons('LIST,for each p in pdes collect(get(p,'val)))),
lisp(cons('LIST,ftem_)),
lisp(cons('LIST,ineq_)) ));
if print_ then <<
terpri()$
write"An algebraic Groebner basis computation yields "$
>>$
return
if sol={'LIST,{'LIST,1}} then <<
if print_ then write"a contradiction."$
contradiction_:=t$
nil
>> else <<
while pdes do pdes:=drop_pde(car pdes,pdes,nil)$
sol:=cdr sol;
if null cdr sol then << % only one solution
sol:=cdar sol; % a lisp list of necessarily vanishing expressions
if print_ then <<
terpri()$
write"a single new system of conditions."$
terpri()$
write"All previous equations are dropped."$
terpri()$
write"The new equations are:"$
>>$
pdes:=mkeqlist(sol,ftem_,vl_,allflags_,t,%orderings_prop_list_all()
list(0),nil)$
listprint(pdes)$
if contradiction_ then nil
else {pdes,cadr arglist}
>> else << % more than one solution
if print_ then <<
terpri()$
write length sol," cases. All previous equations are dropped."$
>>$
n:=0$
forg:=cadr arglist$
backup_to_file(pdes,forg,nil)$ % with all pdes deleted
while sol do <<
n:=n+1$
level_:=cons(n,level_)$
if print_ then <<
print_level(t)$
terpri()$write "CRACK is now called with a case resulting "$
terpri()$write "from a Groebner Basis computation : "
>>;
% further necessary step to call crackmain():
recycle_fcts:=nil$ % such that functions generated in the sub-call
% will not clash with existing functions
pdes:=mkeqlist(cdar sol,ftem_,vl_,allflags_,t,
%orderings_prop_list_all()
list(0),nil)$
sol:=cdr sol;
l1:=crackmain(pdes,forg)$
if l1 and not contradiction_ then result:=union(l1,result);
contradiction_:=nil$
if sol then <<
l1:=restore_backup_from_file(pdes,forg,nil)$
pdes:=car l1; forg:=cadr l1;
>>
>>;
delete_backup()$
list result
>>
>>
end$
symbolic procedure split_and_crack(p,pdes,forg)$
% for each factor of p CRACKMAIN is called
if p then
begin scalar l,l1,q,contrad,result,n,h,d,newpdes,newineq$
%,sol,f,newfdep$,bak,s
n:=0$
l:=cdr get(p,'val)$ % list of factors of p
contrad:=t$
if print_ then <<
terpri()$
write "factorizing ",p$
write " we get the alternative equations : "$
deprint(l)>>$
backup_to_file(pdes,forg,nil)$
while l
do <<
if (null confirm_subst) or (length l = 1) then <<d:=car l;l:=cdr l>>
else <<
if n>0 then <<
write"We have the remaining alternative equations : "$
deprint(l)$
>>$
write"Which equation is to be used next? (number, Enter) "$
repeat <<
h:=termread()$
if not fixp h then <<write"This is not a number."$terpri()>>
>> until fixp h;
d:=nth(l,h);
l:=delete(d,l);
if member(d,ineq_) then <<
write"It shows that this factor is in the inequality list"$
terpri()$
write"of non-zero expressions."$
terpri()
>>
>>;
if not member(d,ineq_) then <<
n:=n+1$
level_:=cons(n,level_)$
q:=mkeq(d,get(p,'fcts),get(p,'vars),allflags_,nil,
get(p,'orderings),nil,pdes)$
if print_ then <<
print_level(t)$
terpri()$
write "CRACK is now called with the new equation ",q," : "$
deprint(list d)>>$
% further necessary step to call crackmain():
recycle_fcts:=nil$ % such that functions generated in the sub-call
% will not clash with existing functions
newpdes:=eqinsert(q,drop_pde(p,pdes,nil))$
if freeof(newpdes,q) then <<
write "It turns out that the next factor is a consequence ",
"of another equation."$ terpri()$
write "Therefore the investigation of any factors after ",
"this one is droped."$ terpri()$
l:=nil
>> else
to_do_list:=cons(list('subst_level_35,%newpdes,forg,vl_,list q),
list q,newpdes),
to_do_list)$
l1:=if pvm_try() and (null collect_sol)
then remote_crackmain(newpdes,forg) % i.e. l1:=nil
else crackmain(newpdes,forg)$
% newfdep:=nil$
% for each sol in l1 do
% if sol then <<
% for each f in caddr sol do
% if h:=assoc(f,depl!*) then newfdep:=cons(h,newfdep);
% >>;
% % newfdep are additional dependencies of the new functions in l1
% pdes:=car restore_pdes(bak)$ % to restore all global variables and pdes
% depl!*:=append(depl!*,newfdep);
if l then << % there are further factors=0 to be investigated
h:=restore_and_merge(l1,pdes,forg)$
pdes:= car h;
forg:=cadr h; % was not assigned above as it has not changed probably
newineq:=union(list d,newineq); % new for %1
for each h in reverse newineq do << % new for %1
if contradictioncheck(h,pdes) then l:=nil; % new for %1
% --> drops factors h in all pdes without asking!!
% if contradictioncheck then h can not be non-zero
% but that would be so for all remaining cases --> stop
if not member(h,ineq_) then addineq(pdes,h) % new for %1
>> % new for %1
>>;
if not contradiction_ then contrad:=nil$
if l1 and not contradiction_ then result:=union(l1,result);
contradiction_:=nil$ % <--- neu
>>
>>$
delete_backup()$
contradiction_:=contrad$
if contradiction_ then result:=nil$
if print_ then <<
terpri()$
write"This completes the investigation of all cases of a factorization."$
terpri()$
>>$
return list result
% by returning `list result' and not just `result', what is returned
% is a list with only a single element. This is indicating that the
% content of what is returned from this procedure is a list of
% crackmain returns and not (pdes,forg) which is returned from
% other modules and which is a list of more than one element.
end$
symbolic procedure split_into_cases(arglist)$
% programmed or interactive introduction of two cases whether a
% given expression is zero or not
begin scalar h,hh,s,pdes,forg,contrad,n,q,l1,
result,ps,intact$%,newfdep,bak,sol,f,depl
pdes:=car arglist$
forg:=cadr arglist$
if cdddr arglist then h:=cadddr arglist$
if h=pdes then << % interactive call
intact:=t$
terpri()$
write "Type in the expression for which its vanishing and"$
terpri()$
write "non-vanishing should be considered."$
terpri()$
% write "Terminate with $ or ; : "$
write "You can use names of pds, e.g.: "$terpri()$
write "coeffn(e_12,df(f,x,2),1); or df(e_12,df(f,x,2));"$
terpri()$
ps:=promptstring!*$
promptstring!*:=""$
h:=termxread()$
>>$
for each hh in pdes do h:=subst(get(hh,'val),hh,h)$
h:=reval h;
if not may_vanish(h) then return <<
write"According to the known inequalities, ",
"this expression can not vanish!"$
terpri()$
write" --> Back to main menu."$terpri()$
promptstring!*:=ps$
nil
>>$
if intact then <<
write"If you first want to consider this expression to vanish and"$ terpri()$
write"afterwards it to be non-zero then input t"$ terpri()$
write" otherwise input nil : "$
s:=termread()$
promptstring!*:=ps$
>> else s:=t$
contrad:=t$
n:=0$
%-------------------
backup_to_file(pdes,forg,nil)$ % moved before again:, should be ok
again:
% bak:=backup_pdes(pdes,forg)$
n:=add1 n$
level_:=cons(n,level_)$
print_level(t)$
terpri()$
if s then <<
q:=mkeq(h,ftem_,vl_,allflags_,t,list(0),nil,pdes)$
if print_ then <<
write "CRACK is now called with the assumption 0 = ",q," : "$
deprint(list h)$
>>
>> else <<
if print_ then <<
write "CRACK is now called with assuming "$terpri()$
mathprint h$
write" to be nonzero. "$
>>$
addineq(pdes,h)$
>>$
% necessary steps to call crackmain():
recycle_fcts:=nil$ % such that functions generated in the sub-call
% will not clash with existing functions
% This test comes only now as it drops factors s from all pdes
if (s=nil) and contradictioncheck(h,car arglist) then <<
if print_ then <<
write"According to the system of pdes, this expression must be zero!"$
terpri()$
write" --> Back to main menu."$
>>$
contradiction_:=nil$
promptstring!*:=ps$
l1:=nil$
% newfdep:=nil$
>> else <<
l1:=if pvm_try() and (null collect_sol)
then remote_crackmain(if null s then pdes
else eqinsert(q,pdes),forg) % ie. l1:=nil
else crackmain(if null s then pdes else eqinsert(q,pdes),forg)$
% newfdep:=nil$
% for each sol in l1 do
% if sol then <<
% for each f in caddr sol do
% if depl:=assoc(f,depl!*) then newfdep:=cons(depl,newfdep);
% >>;
% % newfdep are additional dependencies of the new functions in l1
>>;
% pdes:=car restore_pdes(bak)$ % to restore all global variables and pdes
% depl!*:=append(depl!*,newfdep);
hh:=restore_and_merge(l1,pdes,forg)$
pdes:= car hh;
forg:=cadr hh;
if not contradiction_ then contrad:=nil$
if l1 and not contradiction_ then result:=union(l1,result);
contradiction_:=nil$
if n=1 then <<s:=not s; goto again >>;
delete_backup()$
contradiction_:=contrad$
if contradiction_ then result:=nil$
if print_ then <<
terpri()$
write"This completes the investigation of all cases of a case-distinction."$
terpri()$
>>$
return list result
% by returning `list result' and not just `result', what is returned
% is a list with only a single element. This is indicating that the
% content of what is returned from this procedure is a list of
% crackmain returns and not (pdes,forg) which is returned from
% other modules and which is a list of more than one element.
end$
symbolic procedure stop_batch(arglist)$
begin
if !*batch_mode then <<
write"Drop this point from the proc_list_ with 'o, 'cp or quit with 'q."$
terpri()$
!*batch_mode:=nil$
>>$
batchcount_:=stepcounter_ - 2$
return {car arglist,cadr arglist} % only to have arglist involved
end$
symbolic procedure user_defined(arglist)$
begin
arglist:=nil; % only to use arglist
end$
symbolic procedure sub_problem(arglist)$
begin scalar ps,s,h,fl,newpdes,sol,pdes,bak,newfdep,f,sub_afterwards$
if !*batch_mode then return nil;
terpri()$
ps:=promptstring!*$
promptstring!*:=""$
write"This module so far works only for linear problems."$terpri()$
write"Do you want to continue (Y/N)? "$
repeat s:=termread() until (s='y) or (s='n)$
if s='n then <<
promptstring!*:=ps$
return nil
>>$
terpri()$
% Choice
write"Do you want to specify a set of equation to be solved --> Enter 1"$
terpri()$
write"or a set of functions (and then all equations containing"$
terpri()$
write"only these functions are selected) --> Enter 2: "$
repeat h:=termread() until h=1 or h=2$
if h=1 then << %------ Input of a subset of equations
write"Specify a subset of equations to be solved in the form: "$
listprint(car arglist)$
write";"$ terpri()$
s:=termlistread()$
if s=nil then newpdes:=nil else
if not_included(s,car arglist) then <<
write"Equations ",setdiff(s,car arglist)," are not valid."$
terpri()$
newpdes:=nil
>> else <<
for each h in s do fl:=union(fl,get(h,'fcts));
newpdes:=s
>>
>> else << %------ Input of a subset of functions
write"Specify a subset of functions to be solved in the form: "$
listprint(ftem_)$
write";"$ terpri()$
s:=termlistread()$
if s=nil then newpdes:=nil else
if not_included(s,ftem_) then <<
write"Fnctions ",setdiff(s,ftem_)," are not valid."$
terpri()$
newpdes:=nil
>> else <<
fl:=s;
% Determining a subset of equations containing only these functions
for each s in car arglist do
if null setdiff(get(s,'fcts),fl) then newpdes:=cons(s,newpdes)$
if null newpdes then <<
write"There is no subset of equations containing only these functions."$
terpri()
>>
>>
>>;
if null newpdes then return nil;
write "Do you want an automatic substitution "$terpri()$
write "of computed functions afterwards (Y/N)? "$
repeat s:=termread() until (s='y) or (s='n)$
if s='y then sub_afterwards:=t
else sub_afterwards:=nil;
promptstring!*:=ps$
write"CRACK is now called with the following subset of equations"$
terpri()$
write newpdes$ terpri()$
bak:=backup_pdes(car arglist,cadr arglist)$
sol:=crackmain(newpdes,fl)$
% One could add an dropredund call here
newfdep:=nil$
for each s in sol do
if s then <<
for each f in caddr s do
if h:=assoc(f,depl!*) then newfdep:=cons(h,newfdep);
>>;
% newfdep are additional dependencies of the new functions in l1
pdes:=car restore_pdes(bak)$ % to restore all global variables and pdes
depl!*:=append(depl!*,newfdep);
ftem_:=union(ftem_,caddar sol)$
% Test for contradiction or more than one solution
% to be investigated further
for each s in caar sol do
pdes:=eqinsert(mkeq(s,ftem_,vl_,allflags_,t,list(0),nil),
pdes)$
for each s in cadar sol do
if pairp s and (car s='EQUAL) then <<
h:=mkeq({'DIFFERENCE,caddr s,cadr s},ftem_,vl_,allflags_,t,list(0),nil,pdes);
pdes:=eqinsert(h,pdes)$
if sub_afterwards then
to_do_list:=cons(list('subst_level_35,%pdes,cadr arglist,caddr arglist,
list h),
to_do_list)
>>$
ftem_:=union(ftem_,caddar sol)$
return {pdes,cadr arglist}
end$
endmodule$
end$