Artifact 7ad94e0f0568614e4a439d9d01bdd5ab473d80164142b29740e9fba1e701ba99:
- Executable file
r38/packages/crack/crmain.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 83363) [annotate] [blame] [check-ins using] [more...]
%********************************************************************** 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$