%********************************************************************** module crackstar$ %********************************************************************** % Main program % Authors: Andreas Brand 1995-97, % Thomas Wolf since 1996 symbolic operator crackshell$ symbolic procedure crackshell$ begin scalar s,ps; terpri()$ if null old_history then << ps:=promptstring!*$ promptstring!*:= redfront_color ""$ 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}; promptstring!*:=ps >>$ !*batch_mode:=nil; return algebraic(crack({},{},{},{})); end$ put('crack,'psopfn,'sq!*crack)$ symbolic procedure sq!*crack(inp)$ % For non-linear problems it is useful to have flin_ assigned % before calling crack. begin scalar el,il,fl,vl,l,l1,l2,a,b,n,m,k,p,pdes$ if l:=check_globals() then << write"The global variable ",l," has an incorrect value, please check!"$ rederr " " >>$ if print_ and logoprint_ then <>$ if not !*batch_mode and null old_history then << if not print_ then <>$ write"Enter `h' for help."$ terpri()$ >>$ %rulelist_:=if pairp userrules_ then %<--- delete? ############# % 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 contradiction_:=nil$ 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$ largest_fully_shortened:=nil$ % size_watch assigned below n:=time()$ m:=gctime()$ el:=aeval car inp$ il:=aeval cadr inp$ fl:=reval caddr inp$ vl:=reval cadddr inp$ el:=if pairp el and (car el='LIST) then for each p in cdr el collect if pairp p and car p='!*SQ then cadr p else simp!* p else if pairp p and car p='!*SQ then list cadr el else list simp!* p$ % el is now a list of standard quotients fl:=if pairp fl and (car fl='LIST) then cdr fl else list fl$ vl:=if pairp vl and (car vl='LIST) then cdr vl else list vl$ il:=if pairp il and (car il='LIST) then cdr il else list il$ vl_:=union(argset fl,vl)$ vl:=nil; % orderings_:=make_orderings(fl, vl_)$ % Orderings support! if vl_ then fl:=fctsort fl$ if null flin_ then ftem_:=fl else << % Sort ftem_ functions such that in each group of functions with the same % number of variables, flin_ functions come first. ftem_:=nil; while fl do << m:=fctlength car fl$ l:=nil; while fl and (m=fctlength car fl) do << if freeof(flin_,car fl) then l:=cons(car fl,l) else ftem_:=cons(car fl,ftem_); fl:=cdr fl >>; ftem_:=append(l,ftem_) >>$ ftem_:=reversip ftem_$ % Now sort flin_ flin_:=sort_according_to(flin_, ftem_); >>$ % Start of the FORM computer algebra system for large computations if form_comp and form_pipe then system "./form_start < formin > formout &"$ % We put all denominators into ineq_ ineq_:=nil; ineq_or:=nil; el:=for each p in el collect << if not freeoflist(denr p,ftem_) then addSQineq(nil,(denr p . 1),t)$ (numr p ./ 1) >>$ for each p in il do if pairp p and (car p = 'LIST) then << p:=cdr p; % p is now a lisp list of expressions of which at least one must not vanish l:=if null p then 1 else nil; while p do % car p = {'!*sq, .., t} if sqzerop car p then p:=cdr p else if freeoflist(car p,ftem_) then <> else <>; % {} because each element of ineq_or (i.e. l) is a list of factors if l = 1 then % the or-inequality is already fulfilled else if null l then contradiction_:=t % all expressions are zero else if cdr l then ineq_or:=cons(l,ineq_or) else addSQineq(nil,caar l,t) >> else addSQineq(nil,if pairp p and (car p='!*SQ) then cadr p else simp p,t); simpSQineq_or_adhoc(nil)$ % the initial simplification of ineq_or % nil because no pdes (yet) assigned il:=nil$ 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:=mkeqSQlist(el,nil,nil,ftem_,vl_, allflags_,t,%orderings_prop_list_all(), list(0),nil)$ if contradiction_ then return {'LIST}$ if equations_file="" then << l:=pdes; while l and get(car l,'linear_) do l:=cdr l; if l then lin_problem:=nil else lin_problem:=t; if lin_problem and null flin_ then flin_:=ftem_; >>$ % Is the system algebraic and polynomial? l:=pdes$ alg_poly:=t$ while l and alg_poly do << if get(car l,'nonrational) then alg_poly:=nil else << el:=get(car l,'derivs); while el and (length(caar el)=1) do el:=cdr el; if el then alg_poly:=nil >>$ l:=cdr l; >>$ el:=nil$ % to free memory if size_watch then size_hist:=list(cons('CP,for each l in proc_list_ collect get(l,'no)))$ % size_hist:=nil$ % size_hist:=if size_watch then {cons(0,get_statistic(pdes,ftem_))} % else nil$ name_session()$ % the computation: l:=crackmain(pdes,ftem_)$ if pairp l and (fixp car l) then l:=nil$ % i.e. if collect_sol=nil then either l=nil or l=(# of solutions) % if l=list(nil) then l:=nil$ % l:=union(l,nil)$ if !*time or time_ then <>$ % dropping redundant functions/constants now done at end of crackmain l:=cons('LIST, for each a in l collect % i.e. for each solution a <>)))}>>)$ if null collect_sol then add_to_sol_list()$ % statements to free space and to make later crack-calls more natural nequ_:=1$ recycle_eqns:=nil . nil$ recycle_fcts:=nil$ recycle_ids:=nil$ old_history:=nil$ % close the equation input file if eqn_input='done then eqn_input:=nil else if eqn_input then <>; recover_reduce_flags()$ % giving the REDUCE flags their backup value % Stop of the FORM computer algebra system which was % started at the start of this procedure. Either send: % skip; % .end % or delete the file `formin' . if form_comp and form_pipe then << >>; if print_ and logoprint_ then << terpri()$ write "This is the end of the CRACK run"$ terpri()$ write "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~", "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"$ terpri()$ >>$ return l %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 % > not to be called from algebraic mode % > it returns % - nil if no solution exists or no solution was collected, % - {nil} if successful but no solutions are collected (collect_sol=nil), % - {sol1,sol2,...} list of solutions % each solution has the form % if not collect_sol then list(1) else % 1 = # of solutions % list list(for each a in pdes collect get(a,'sqval), % forg, % setdiff(ftem_,forg), % append(ineq_, % if null ineq_or then nil % else for each a in ineq_or % collect cons('LIST,a))) % The reason for this format is such that the result can be passed on as the % result of crack() to algebraic mode. The left hand side of equations % {'EQUAL,..,..} in forg is converted to {!*sq,..,t} automatically when % the result is passed on to algebraic mode. % > 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_, ineq_or, vl_, flin_ are essential (but hidden) % input parameters (as well as the properties of the pdes and forg) % and all the global variables *_* assigned in sq!*crack % > crackmain() sets the global variable contradiction_. begin scalar result,l,carpl,unsolvable, % dec_hist_list_copy, s,h,pl,ps,batch_one_step,expert_mode_copy,fnc_to_adjust, fnc_adjusted,loopcount,level_length,newli,processes, full_proc_list_length,si_hi,plcnt,no_of_children$ no_of_children:=0; level_length:=length level_; full_proc_list_length:=length full_proc_list_$ choose_70_65_8_47_origterms:=nil$ %# if level_ then %# history_:=cons(bldmsg("%w%w","*** Start of level ",level_string(nil)), %# cons('cm,history_)); %# size_hist:=cons({'A,reverse level_},size_hist); if tr_main and print_ then <>$ % depl_copy_:=depl!*$ % dec_hist_list_copy:=dec_hist_list$ fnc_to_adjust:=adjust_fnc; if contradiction_ then rederr"** CONTRADICTION_ AT START OF CRACKMAIN()! **"$ contradiction_:=nil$ f_update(pdes,forg)$ % global list of free functions again: repeat << stop_:=nil$ err_catch_readin("_stop_",'symbolic)$ % moved here from below if to_do_list then batchcount_:=add1 batchcount_$ % moved here from below f_update(pdes,forg)$ % ############# should only be done if necessary, expensive? vl_:=var_list(pdes,forg,vl_)$ if time_limit then << l:=time(); if (time_limit=2) and % i.e. terminate with error (limit_time>$ if !*batch_mode or to_do_list or batch_one_step or (( batchcount_>=stepcounter_ ) and ((time_limit=nil) or (limit_time>=l)) ) then % automatic part: ----------------------- <>$ 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$ plcnt:=1; while plcnt<=length(proc_list_) do << carpl:=nth(proc_list_,plcnt)$ if print_ and print_more then if pairp(l:=get(carpl,'description)) then << for each a in l do if a then write a$ write " : " >> else write "trying ",carpl," : "$ l:=apply(carpl,list list(pdes,forg,vl_,pdes))$ % ###### vl_ for historical reasons, % to be cleaned up some time if size_watch and (contradiction_ or (l and (length l > 1))) then size_hist:=cons(cons(get(carpl,'no),si_hi),size_hist); if (fixp size_watch) and ((stepcounter_-size_watch*(stepcounter_/size_watch))=0) then cut_size_hist(); if null choose_70_65_8_47_origterms and size_hist then << s:=size_hist; while s and not fixp caar s do s:=cdr s; choose_70_65_8_47_origterms:=if s then caddr cdddar s else 1000 >>$ 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 <>$ % no case-splitting plcnt:=100000 >> else if contradiction_ then plcnt:=100000 else % not yet used but a possible extension (unless the task in to_do_list is % unsuccessful and then an endless loop could occur): %% the case that no computation was performed %% but to_do_list was assigned: %if to_do_list then << % plcnt:=1$ % if print_ and print_more then % <> %>> else << plcnt:=add1 plcnt$ if print_ and print_more then <>$ if (plcnt>length(proc_list_)) and (null eqn_to_be_gen) then unsolvable:=t >> >>; expert_mode:=expert_mode_copy$ % err_catch_readin("_stop_",'symbolic)$ moved up % if to_do_list then batchcount_:=add1 batchcount_ moved up >> else % interactive part: ----------------------- <>$ rds nil$wrs nil$ ps:=promptstring!*$ promptstring!*:= redfront_color "next: "$ if print_ or null old_history then 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() else if (s='hl) and memq('unix,lispsystem!*) then print_hl() else if s='he then print_he() % 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 <>$ print_:=ps >> else if s='pi then print_ineq((ineq_ . ineq_or)) else if s='f then <> else if s='v then <> else if s='s then << print_level(1)$ 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!*:= redfront_color ""$ 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 if not freeof(l,s) then l:=subst({'!*sq,get(s,'sqval),t},s,l)$ for each s in forg do if (pairp s) and (car s='EQUAL) then l:=subst({'!*sq,caddr s,t},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!*:= redfront_color ""$ 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 <> else if s='pd then plot_dependencies(pdes) else if s='ps then plot_statistics(size_hist) else if s='lc then list_cases(size_hist) else if s='ws then write_stat_in_file() else if s='sn then <> 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!*:=redfront_color "number of steps: "$ s:=termread()$ promptstring!*:=redfront_color "next: "$ if fixp(s) then batchcount_:=sub1 stepcounter_+s else <> >> 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 <>$ repeat_mode:=termread()$ % if print_ or null old_history then 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 si_hi:=get_statistic(pdes,append(forg,setdiff(ftem_,forg)))$ stepcounter_:=add1 stepcounter_$ clean_prop_list(pdes)$ if print_ then <>$ repeat << if to_do_list then loopcount:=sub1 loopcount$ l:=if to_do_list then 'to_do else nth(full_proc_list_,s); l:=apply(l,list list(pdes,forg,vl_,pdes))$ if size_watch and (l or contradiction_) then size_hist:=cons(cons(s,si_hi),size_hist); if (fixp size_watch) and (loopcount neq 0) and ((loopcount-size_watch*(loopcount/size_watch))=0) then cut_size_hist(); if null choose_70_65_8_47_origterms and size_hist then << ps:=size_hist; while ps and not fixp caar ps do ps:=cdr ps; choose_70_65_8_47_origterms:=if ps then caddr cdddar ps else 1000 >>$ 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 <>$ % no case-splitting if print_ then terpri()$ err_catch_readin("_stop_",'symbolic)$ if to_do_list and numberp repeat_mode then repeat_mode:=add1 repeat_mode; 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 si_hi:=get_statistic(pdes,append(forg,setdiff(ftem_,forg)))$ stepcounter_:=add1 stepcounter_$ clean_prop_list(pdes)$ if print_ then <>$ >> >> else if (not contradiction_) and (loopcount=0) and (print_ or null old_history) then <> >> until (not repeat_mode) or result or (not l) or contradiction_ or (time_limit and <>); >>; 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; level_length:=1 + length level_; % not to delete backup files at end if null auto_para_mode then % assumed not to be started from PVM batchcount_:=sub1 stepcounter_ >> else if s='an then pdes:=flin_non_triv_cond pdes else if s='rs then pdes:=comp_resultant(pdes) else if (s='x) or (s=int2id 4) % i.e. if interactive session is submitted % as a job and no more interactive input, ie s=ctrl d then !*batch_mode:=t else if s='q then << if eqn_to_be_gen and eqn_input and (eqn_input neq 'done) then << close eqn_input; eqn_input:='done >>$ stop_:=t >> % to change flags & parameters ----------------------- else if s='pl then << promptstring!*:=redfront_color "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";"$terpri()$ promptstring!*:=redfront_color "New variable ordering : "$ newli := termlistread()$ if newli then << if not_included(vl_,newli) then << write"Not all variables appear in the new list."$ terpri() >> else if not_included(newli,vl_) then << write"The new list has extra ariables."$ terpri() >> else << 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";"$terpri()$ if null vl_ then << write "If you want to sort functions according to frequency, rare"$ terpri()$ write "functions first, then type: sort_by_frequency;"$terpri()$ write "If you want to sort functions randomly, flin_ first and"$ terpri()$ write "non-vanishing last, then type: sort_randomly;"$terpri()$ write "else type the new list."$terpri() >>$ promptstring!*:=redfront_color "New function ordering : "$ newli := termlistread()$ if null vl_ and newli and (car newli='sort_by_frequency) then << how_often(pdes); newli:=ftem_sorted_by_index() >> else if null vl_ and newli and (car newli='sort_randomly) then << s:=ftem_; backup_:=nil; h:=length ftem_; while h>1 do << l:=nth(s,1+random h)$ backup_:=cons((h . l),backup_); s:=delete(l,s); h:=h - 1 >>$ backup_:=cons((1 . car s),backup_); newli:=ftem_sorted_by_index() >> else if newli and (not_included(ftem_,newli) or not_included(newli,ftem_) ) then newli:=nil; if newli 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!*:=redfront_color "Equation name : "$ s:=termread()$ if s and idp s then eqname_:=s else <> >> else if s='nf then << promptstring!*:=redfront_color "Function name : "$ s:=termread()$ if s and idp s then fname_:=s else <> >> else if s='ni then << promptstring!*:=redfront_color "Identity name : "$ s:=termread()$ if s and idp s then idname_:=s else <> >> else if s='na then <> else if s='as then << promptstring!*:=redfront_color "The variable name to be assigned: "$ s:=termread()$ write "What is the value to be assigned to that variable?"$terpri()$ promptstring!*:=redfront_color "Please terminate this input with ';' : "$ l:=termxread()$ if s='collect_sol and l=nil and collect_sol then save_sol_list()$ set(s,reval l)$ >> else if s='ke 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!*:=redfront_color "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 <>$ write algebraic(l-60*s)," minutes. "$ >> >> else write"There is no time-limit set currently."$ terpri()$ % ps:=promptstring!*$ promptstring!*:=redfront_color ""$ if yesp "Do you want to impose a CPU time-limit? " then << repeat << write"After time has expired,"$terpri()$ write" shall CRACK go into interactive mode (1)"$terpri()$ write" or shall CRACK terminate with error (2) ? "$terpri()$ time_limit:=termread() >> until (time_limit=1) or (time_limit=2)$ % 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:=reval 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!*:=redfront_color ""$ write"Please type your comment in "" "" for the history_ list: "$ terpri()$ l:=termread()$ terpri()$ >> else if s='lr then << % ps:=promptstring!*$ promptstring!*:=redfront_color ""$ write"You can either"$ terpri()$ write"- give the name (terminated by ;) of a rule list to be "$terpri()$ write" activated that has been defined before the call of CRACK, or"$ terpri()$ write"- give the name (terminated by ;) of an equation which "$terpri()$ write" is to be converted to a LET rule, or"$terpri()$ write"- 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()$ if atom l then if member(l,pdes) then rule_from_pde(l) else algebraic(let lisp l) else << 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!*:=redfront_color ""$ write"These are all the user defined rules: "$ terpri()$ algebraic (write lisp userrules_); write"You can either"$ terpri()$ write"- give the number of a rule above to be dropped, or "$ terpri()$ write"- give the name of a rule list activated before "$ terpri()$ write" the call of CRACK which should be disabled: "$ l:=termread()$ if not fixp l then << algebraic(clearrules lisp l)$ write"Rule list ",l," has been disabled."$terpri() >> else 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()$ >> >> else if s='ap then if alg_poly then << promptstring!*:=redfront_color ""$ % set_bndstk_size 50000$ % off allfac$ % lisp (simplimit!* := 5000); write"Is the system homogeneous? (y/n) "$ l:=termread()$ if l='y then << homogen_:=t; for each s in pdes do put(s,'hom_deg,find_hom_deg_SF(numr get(s,'sqval))) >> else homogen_:=nil$ write"Should solutions be stored as files? (y/n) "$ l:=termread()$ if l='y then << if collect_sol then save_sol_list()$ collect_sol:=nil >> else collect_sol:=t$ write"Should FORM be used for long computations? (y/n) "$ l:=termread()$ if l='y then form_comp:=t else form_comp:=nil$ groeb_solve:=<< write"Should Singular be used for computing Groebner bases? (y/n) "$ l:=termread()$ if l='y then << write"Use reverse total degree ordering? (y/n) "$ l:=termread()$ if l='y then 'SL_REVGRAD else << write"Pure lexicographical ordering is used."$terpri()$ 'SL_LEX >> >> else << write"Should the GB package of J.C.Faugere be used? (y/n) "$ l:=termread()$ if l='y then << write"Use reverse total degree ordering? (y/n) "$ l:=termread()$ if l='y then 'GB_REVGRAD else << write"Pure lexicographical ordering is used."$terpri()$ 'GB_LEX >> >> else << write"The REDUCE Groebner package is used."$terpri()$ 'REDUCE >> >> >>$ if null size_watch then << write"Will the computation involve 1000's of steps, so that the recording"$ terpri()$ write" of the history of the computation should be limited (y/n)? "$ l:=termread()$ if l='n then size_watch:=t else << repeat << write"About how many last steps shall statistical data be stored? (at least 50) "$ size_watch:=termread()$ >> until fixp size_watch >> >>$ print_more:=nil; record_hist:=nil; % =t for integrating syzygies, would give too long % expressions in prefix form --> too slow subst_1:=11; target_limit_1:=400; subst_3:=11; target_limit_3:=400; %max_gc_short:=25; % 5 % 25; max_gc_elimin:=5$ max_gc_red_len:=1; % 4 if null size_watch then size_hist:=list(cons('CP,for each l in proc_list_ collect get(l,'no)))$ cost_limit5:=200; max_gc_fac:=4; choose_6_20_max_ftem:=25; choose_6_20_max_terms:=5000; choose_27_8_16_max:=15; choose_30_47_21_max:=10; % max_eqn_to_conti:=1; % used in stop_batch() to stop only if more % % than max_eqn_to_conti equations are unsolved proc_list_:='(to_do separation subst_level_0 alg_length_reduction choose_6_20 subst_level_45 choose_27_8_16 diff_length_reduction factorize_to_substitute subst_level_3 choose_30_47_21 decoupling factorize_any subst_level_4 % alg_solve_single stop_batch )$ write"proc_list_ has been changed, see p1."$terpri()$ % promptstring!*:=redfront_color ps >> else % to change data of equations ----------------------- else if s='r then <> else if s='rd then <> else if s='n then newinequ(pdes) else if s='de then pdes:=deletepde(pdes) else if s='di then pdes:=delete_ineq(pdes) else if s='c then change_pde_flag(pdes) else if s='pt then <> >> else if s='se then pdes:=sort_eq_by_length pdes % 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='is 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 <> 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 <> else if s='tg then <> else if s='ti then <> else if s='td then <> else if s='tl then <> else if s='ts then <> else if s='to then <> else if s='tr then << algebraic (load debug)$ % ps:=promptstring!*$ promptstring!*:=redfront_color ""$ write"Please type the name of the procedure to trace: "$ l:=termread()$ terpri()$ evtr list l >> else if s='ut then << % ps:=promptstring!*$ promptstring!*:=redfront_color ""$ 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()$ break() % standardlisp() >> else if s='pc then << % ps:=promptstring!*$ promptstring!*:=redfront_color "The function name: "$ s:=termread(); promptstring!*:=redfront_color "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 << promptstring!*:=redfront_color ""$ write"Please give the name of the file to be read in"$terpri()$ write"double quotes (no ;) : "$ l:=termread()$ terpri()$ in l >> else if s='cu then InternTest(pdes,forg) else if s='qt then << promptstring!*:=redfront_color ""$ terpri()$ write "Please type in a list of procedure names, like: gcdf, .., reval;"$ terpri()$ write "which should be profiled: "$ terpri()$ l:=termlistread()$ % for each h in l do apply('qualtime,h) %write"h=",h$ %qualtime bldmsg("%w",h) >> else if s='pq then print!-qualtime() else if s='so then << promptstring!*:=redfront_color ""$ write"Please give the name of the switch to be switched ON: "$ l:=termread()$ terpri()$ s:=eval intern compress append(explode '!*,explode l); if null s then << switch_list:=cons({level_,l,s},switch_list); on1 l >> >> else if s='sf then << promptstring!*:=redfront_color ""$ write"Please give the name of the switch to be switched OFF: "$ l:=termread()$ terpri()$ s:=eval intern compress append(explode '!*,explode l); if s then << switch_list:=cons({level_,l,s},switch_list); off1 l >> >> else if (s='xp) or (s='sp) or (s='jp) or (s='pp) then if ini_check_of_parallel_crack() then << % Open new duplicate process no_of_children:=add1 no_of_children; level_:=cons(bldmsg("c%d",no_of_children),level_)$ l:=!*iconic; !*iconic:=nil$ % --> a window opens if s='xp then << write"Duplicating process under new xterm."$terpri()$ add_session(pdes,forg,1) >> else if s='sp then << write"Duplicating process under new screen."$terpri()$ add_session(pdes,forg,2) >> else if s='jp then << write"Duplicating process as batch job."$terpri()$ add_session(pdes,forg,3) >> else if pvm_active() then << write"Duplicating process under PVM."$terpri()$ processes:=add_process(processes,pdes,forg)$ >>$ !*iconic:=l$ level_:=cdr level_ >> else else if (s='wp) or (s='yp) or (s='zp) or (s='vp) then if collect_sol then << write"### Currently is collect_sol=t. Therefore parallel case"$terpri()$ write"### solving is not enabled because solutions would not"$terpri()$ write"### be collected. You could set collect_sol to nil using"$terpri()$ write"### 'as collect_sol nil;' command."$terpri()$ >> else if ini_check_of_parallel_crack() then << proczaehler(process_counter,'init)$ % initialize the counter of processes to zero setq(l,bldmsg("%w%w",session_,"sol_list")); if not filep l then save_sol_list()$ % Enable parallel treatment of cases if s='wp then << auto_para_mode:=1; write"From now on parallel case solving with extra xterm's."$ terpri()$ promptstring!*:=redfront_color ""$ write"Shall xterms start as icons (Y/N) ? "$ repeat s:=termread() until (s='y) or (s='n)$ if s='y then !*iconic:=t else !*iconic:=nil; >> else if s='yp then << auto_para_mode:=2; write"From now on parallel case solving with extra screens."$ terpri() >> else if s='zp then << auto_para_mode:=3; write"From now on parallel case solving by submitting jobs."$ terpri() >> else <> else write"PVM is not active on this computer." >> >> else else if s='np then << write"The counter of additional parallel REDUCE processes which is stored"$ terpri()$ write"in the file ",process_counter," is set to zero."$ terpri()$ system bldmsg("touch %w",process_counter)$ % creating file if necessary proczaehler(process_counter,'init)$ % setting counter to zero >> else if s='mp then << promptstring!*:=redfront_color ""$ write"The new maximal number of parallel processes (currently ",max_proc_no,"): "$ max_proc_no:=termread() >> else if s='tp then << promptstring!*:=redfront_color "The directory name for storing case files: "$ para_case_dir:=termread() >> else if s='dp then <> % Disable parallel treatment of cases %else if (s='kp) and pvm_active() then processes:=drop_process(processes) % Kill a parallel PVM process else if s='fo then << form_comp:=t$ promptstring!*:=redfront_color ""$ write"Do you want to interface with FORM through pipes (Y/N)? "$ repeat s:=termread() until (s='y) or (s='n)$ if s='y then form_pipe:=t else form_pipe:=nil$ write"Shall the temporary FORM directory be """,form_tmp_dir,""" (Y/N)? "$ repeat s:=termread() until (s='y) or (s='n)$ if s='n then << write"Please input the directory for temporary FORM computations in ""..."" : "$ form_tmp_dir:=termread(); write"The temporary FORM directory is now ",form_tmp_dir$ >>; write"What is the maximal number of terms of an equations"$terpri()$ write"computed by FORM that shall be read into REDUCE?"$terpri()$ write"(Its current value is ",form_max_read,".) : "$ form_max_read:=termread(); >> else if s='ff then form_comp:=nil else if s='gs then groeb_solve:=<< promptstring!*:=redfront_color ""$ write"Use reverse total degree ordering? (y/n) "$ l:=termread()$ if l='y then 'SL_REVGRAD else << write"Pure lexicographical ordering is used."$terpri()$ 'SL_LEX >> >> else if s='gg then << promptstring!*:=redfront_color ""$ write"Use reverse total degree ordering? (y/n) "$ l:=termread()$ if l='y then 'GB_REVGRAD else << write"Pure lexicographical ordering is used."$terpri()$ 'GB_LEX >> >> else if s='gr then groeb_solve:='REDUCE % otherwise ------------------------------------- else <>$ promptstring!*:=redfront_color 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 <> 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 and not eqn_to_be_gen and ((equations_file="") or (eqn_input='done)))$ % This should not be needed anymore as ineq_ gets constantly updated: % ineq_:=drop_triv_ineq(ineq_); if not (contradiction_ or result) then << if (print_ or null collect_sol) and not stop_ then <>>>>>>>> Solution"$ if level_ then write" of level ",level_string(nil)$ write" : "$ >>$ f_update(pdes,forg)$ forg:=forg_int(forg,ftem_)$ if null collect_sol then <>$ print_pde_forg_ineq(pdes,(ineq_ . ineq_or), 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. l:=if null sol_list then 1 else add1 length sol_list; if not null(getd 'crack_out) and call_crack_out then algebraic (s:=crack_out( lisp cons('LIST,for each a in pdes collect {'!*SQ,get(a,'sqval),t}), lisp cons('LIST,for each a in setdiff(forg,ftem_) collect {'EQUAL,cadr a,{'!*SQ,caddr a,t}}), lisp cons('LIST,ftem_), lisp cons('LIST,append(for each a in ineq_ collect {'!*SQ,a,t}, if null ineq_or then nil else cons('LIST,for each a in ineq_or collect % each a is a single or-inequality cons('LIST,for each b in a collect % each b is a single expression % in an or-inequality cons('LIST,for each c in b collect {'!*SQ,c,t}))))), lisp l)) else s:=nil; % 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 << % the original PDEs under the current case conditions for each l in pdes do << h:=simplifypdeSQ(get(l,'sqval),ftem_,t,l,t)$ put(l,'sqval,car h)$ put(l,'fac,cdr h) >>$ % the conditions returned from crack_out() pl:=pdes; for each l in cdr s do pdes:=eqinsert(mkeqSQ(< 1) then << if level_ then s:=append(reverse cdr reverse explode session_, cdr explode level_string(nil)) else s:=explode session_; s:=compress cons(car s,cons('u,cons('s,cdddr s))); backup_to_file(pdes,forg,s) >> >>$ result:=if not collect_sol then list(1) else % 1 = # of solutions list list(for each a in pdes collect get(a,'sqval), forg, setdiff(ftem_,forg), ineq_, ineq_or) % append(ineq_, % if null ineq_or then nil % else for each a in ineq_or % collect cons('LIST,a))) >>$ % dec_hist_list:=dec_hist_list_copy$ if tr_main and print_ then <>$ l:=(length level_)+1-level_length; for s:=1:l do if level_ then finish_level(% the # of solutions if null result then 0 else if collect_sol or (not pairp result) or (not fixp car result) then length result else car result )$ %# 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$ % of crackmain %algebraic procedure crack_out(eqns,assigns,freef,ineq,solno)$ % eqns .. list of remaining unsolved equations % assigns .. list of computed assignments of the form `function = expression' % freef .. list of list of functions either free or in eqns % ineq .. list of inequalities % solno .. number of the solution % % If anything other than nil is returned then this 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. %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 <>$ 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 <>$ if cfpl then <1) then write ","$ if j>21 then <>$ 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!*:=redfront_color "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 <> else << p:=union(list nth(full_proc_list_,car l),p); l:=cdr l >> >>; >>; if not err then <>$ if size_watch then size_hist:=cons(cons('CP,for each l in proc_list_ collect get(l,'no)), size_hist); %terpri()$write"The new order of procedures:"$ priproli(proc_list_) >> else <> 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()$ <>$ symbolic procedure print_hd()$ <>$ symbolic procedure print_hp()$ <>$ symbolic procedure print_hf()$ < 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" write "ke : ",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()$ write "ap : Adapting the setting to the system to be solved"$ terpri()$ >>$ symbolic procedure print_hc()$ <>$ symbolic procedure print_hi()$ if getd 'show_id then <>$ symbolic procedure print_hb()$ <>$ symbolic procedure print_hl()$ <>$ symbolic procedure print_he()$ <>$ 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 <> else write "trying ",car 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,found_sub$ pdes:=car arglist$ forg:=cadr arglist$ l:=check_subst_df(pdes,forg)$ for each d in l do if not in_cycle({9,stepcounter_,d}) then << found_sub:=t$ f:=newfct(fname_,fctargs cadr d,nfct_)$ nfct_:=add1 nfct_$ ftem_:=fctinsert(f,delete(cadr d,ftem_))$ if flin_ and not freeof(flin_,cadr d) then flin_:=sort_according_to(f . flin_, ftem_); if print_ then <>$ 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:=simp 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:=addsq(simp gensym(),mksq(list('INT,prepsq g,car h),1)); 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 subsq(s,{(cadr d . {'!*sq,g,t})}); % reval subst(g,cadr d,s); if member(cadr d,forg) then << ftem_:=fctinsert(cadr d,ftem_)$ % puting cadr d back into ftem_ q:=mkeqSQ(subtrsq(simp d,simp f),nil,nil, %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 found_sub 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 <>$ return if success then arglist else nil end$ % Substitutions with: % no_cases : subst_level_0 3 (less_vars,subst_0,target_limit_0) % subst_level_03 4 (no_df) % subst_level_04 45 (no_df,subst_1,target_limit_1) % subst_level_05 5 (no_df,subst_4,target_limit_0) % subst_level_2 18 (less_vars,subst_2,target_limit_0) % subst_level_3 16 (subst_3,target_limit_3) % subst_level_33 19 (lin_subst,subst_4,target_limit_4) % subst_level_35 20 (subst_4,target_limit_4) % subst_level_45 6 (min_growth) % min_growth: subst_level_45 6 (no_cases) % less_vars: subst_level_0 3 (no_cases,subst_0,target_limit_0) % subst_level_1 15 (cases,subst_1,target_limit_1) % subst_level_2 18 (no_cases,subst_2,target_limit_0) symbolic procedure subst_level_0(arglist)$ % module 3 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_0, % length_limit for pde to use target_limit_0, % pdelimit for pdes to be changed t, % less_vars nil, % no_df t, % no_cases nil, % lin_subst nil, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_03(arglist)$ % module 4 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_0, % length_limit for pde to use target_limit_0, % pdelimit for pdes to be changed nil, % less_vars t, % no_df t, % no_cases nil, % lin_subst nil, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_04(arglist)$ % module 45 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_1, % length_limit for pde to use target_limit_1, % pdelimit for pdes to be changed nil, % less_vars t, % no_df t, % no_cases nil, % lin_subst nil, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_05(arglist)$ % module 5 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_4, % length_limit for pde to use target_limit_0, % pdelimit for pdes to be changed nil, % less_vars t, % no_df t, % no_cases nil, % lin_subst nil, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_1(arglist)$ % module 15 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_1, % length_limit for pde to use target_limit_1, % pdelimit for pdes to be changed t, % less_vars nil, % no_df nil, % no_cases nil, % lin_subst nil, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_2(arglist)$ % module 18 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_2, % length_limit for pde to use target_limit_0, % pdelimit for pdes to be changed t, % less_vars nil, % no_df t, % no_cases nil, % lin_subst nil, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_3(arglist)$ % module 16 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_3, % length_limit for pde to use target_limit_3, % pdelimit for pdes to be changed nil, % less_vars nil, % no_df nil, % no_cases nil, % lin_subst nil, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_33(arglist)$ % module 19 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_4, % length_limit for pde to use target_limit_4, % pdelimit for pdes to be changed nil, % less_vars nil, % no_df t, % no_cases t, % lin_subst nil, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_35(arglist)$ % module 20 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_4, % length_limit for pde to use target_limit_4, % pdelimit for pdes to be changed nil, % less_vars nil, % no_df t, % no_cases nil, % lin_subst nil, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_4(arglist)$ % module 21 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_4, % length_limit for pde to use target_limit_4, % pdelimit for pdes to be changed nil, % less_vars nil, % no_df nil, % no_cases nil, % lin_subst nil, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_45(arglist)$ % module 6 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from nil, % length_limit for pde to use nil, % pdelimit for pdes to be changed nil, % less_vars nil, % no_df t, % no_cases nil, % lin_subst t, % min_growth cost_limit5, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ symbolic procedure subst_level_5(arglist)$ % module 17 make_subst(if length arglist > 4 then nth(arglist,5) else car arglist, % all pdes cadr arglist,caddr arglist, % forg,vl cadddr arglist, % pdes to choose from subst_4, % length_limit for pde to use target_limit_4, % pdelimit for pdes to be changed nil, % less_vars nil, % no_df nil, % no_cases nil, % lin_subst t, % min_growth nil, % cost_limit nil, % keep_eqn if length arglist > 5 then nth(arglist,6) else nil % sub_fc )$ 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$ l:=get_fact_pde(l,nil)$ return if l then split_into_cases {car arglist, cadr arglist, caddr arglist, car get(l,'fac)} else nil 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$ l:=get_fact_pde(l,t)$ return if l then split_into_cases {car arglist, cadr arglist, caddr arglist, car get(l,'fac)} else nil 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 <1) or ((length l = 1) and (car l neq p))) then <>$ l:=list(pdes,forg) >> >>$ return l$ end$ symbolic procedure case_separation(arglist)$ % does a separation of expressions where the unknowns may occur % as exponents, may generate case distinctions, % in order not to run in cirles some substitution needs a higher priority if null lin_problem then begin scalar force_sep_bak,h$ force_sep_bak:=force_sep$ force_sep:=t$ h:=separation(arglist)$ force_sep:=force_sep_bak$ return h 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,'sqval)$ 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)); % solveeval liefert eg: (list (list (equal x -3) (equal y -3))) if null l3 then << write"There is no solution."$ terpri() >> else if length l3 > 1 then << %######### 1 solution - a restriction for now 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),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 << % should be quaranteed from above l4:=car l3; % the solution pdes2:=pdes; for each l5 in l4 do << l5:=if zd then mkeqSQ(nil,cons(simp l5,zd),nil, fl,vl,allflags_,nil,list(0),nil,pdes) else mkeqSQ(nil,nil,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. % Because standard quotient operations, like multsq do not % simplify i^2 --> -1, also not simp or reval this leads to % problems when ineq_ expressions are not properly simplified % which then may be zero leading to zero denominators. % Therefore it is advisable to give this module only a % very low priority, just before 38. 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,pdes)) then <>$ 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); % NEW 19.5.07: only 2 different functions/derivatives: % if null dl or (length get(p,'allvarfcts) > 2) then return nil$ % VARIED 28.11.07: in order not to get non-rational expressions if null dl or (homogen_ and (length get(p,'allvarfcts) > 2)) then return nil$ % VARIED 11.4.08: in an application more general solutions were needed % and because complex numbers can appear only at the end anyway and at the end % it does not matter if non-rational solutions are generated % if null dl then return nil$ % dropped again as it gave far too complicated solutions which could not % be used for anything. % NEW 19.5.07: only quadratic homogeneous equations if computation is % supposed to be exact: % if get(p,'hom_deg) neq {0,2} then return nil$ % VARIED 28.11.07: if flin_ and not freeoflist(get(p,'allvarfcts),flin_) then return nil$ % because an flin_ function could not occur non-linearly % and a non-flin_ function could not be solved for in terms of % an flin_ function 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 <> 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,pdes)$ begin scalar d,p,abs_was_not_active,fctrl$ 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({'!*SQ,get(car l,'sqval),t}, 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 and (car d='LIST) and (length d = p+1) then << p:=simp 1; for each el in cdr d do if car el='EQUAL then << fctrl:=cons(subtrsq(simp cadr el, simp caddr el),fctrl); p:=multsq(car fctrl,p) >> else d:=nil >> else d:=nil; if d then << % d:=cons('TIMES,p); d:=p; p:=car l; d:=mkeqSQ(d,fctrl,nil,get(p,'fcts),get(p,'vars),allflags_, nil,get(p,'orderings),nil,pdes)$ % last argument is nil as no new inequalities are to be expected. % but that has been changed as one never knows and it does not do % harm, can only be beneficial 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 <> else l1:=cadddr arglist$ if (l:=quick_integrate_one_pde(l1)) then <>$ if null l and to_do_list then << % case invest. issued in odeconvert l:=arglist$ flag(l1,'to_int); flag(l1,'to_fullint) >>$ 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 <> else l1:=cadddr arglist$ if (l:=integrate_one_pde(l1,genint_,t)) then <>$ if null l and to_do_list then << % case invest. issued in odeconvert l:=arglist$ flag(l1,'to_int); flag(l1,'to_fullint) >>$ 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 <> else l1:=cadddr arglist$ if (l:=integrate_one_pde(l1,genint_,nil)) then <>$ if null l and to_do_list then << % case invest. issued in odeconvert l:=arglist$ flag(l1,'to_int); flag(l1,'to_fullint) >>$ 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 <>$ vl1:=vl$ fnew_:=nil$ while vl1 do if (l:=findintfac(stem,ftem,vl,car vl1,nil,nil,nil,nil)) then <> 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 <>$ % 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 cut_size_hist$ if fixp size_watch then begin scalar n,sh,l; n:=0; sh:=size_hist; while (n>$ if sh then << rplacd(sh,nil); rplaca(sh,cons('CP,for each l in proc_list_ collect get(l,'no))) >> 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 <1) then <>$ for each v in fctargs f do << q:=mkeqSQ(diffsq(get(p,'sqval),v),nil,nil,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 <>$ for each v in vli do <>$ 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)$ if car arglist and (length car arglist > 1) and not in_cycle({59,stepcounter_,groeb_solve,length car arglist,length cadr arglist, for each h in car arglist sum get(h,'terms), for each h in car arglist sum get(h,'length)}) then begin scalar pdes,forg,sol,n,result,l1$ pdes:=car arglist$ sol:= if groeb_solve = 'SL_LEX then algebraic {call_singular(lisp(cons('LIST,ftem_)), lisp(cons('LIST,for each p in pdes collect(reval {'!*sq,get(p,'sqval),t}))), lisp 'lex)} else if groeb_solve = 'SL_GRAD then algebraic {call_singular(lisp(cons('LIST,ftem_)), lisp(cons('LIST,for each p in pdes collect(reval {'!*sq,get(p,'sqval),t}))), lisp 'gradlex)} else if groeb_solve = 'SL_REVGRAD then algebraic {call_singular(lisp(cons('LIST,ftem_)), lisp(cons('LIST,for each p in pdes collect(reval {'!*sq,get(p,'sqval),t}))), lisp 'revgradlex)} else if groeb_solve = 'GB_LEX then algebraic {call_gb(lisp(cons('LIST,ftem_)), lisp(cons('LIST,for each p in pdes collect(reval {'!*sq,get(p,'sqval),t}))), lisp 'lex)} else if groeb_solve = 'GB_REVGRAD then algebraic {call_gb(lisp(cons('LIST,ftem_)), lisp(cons('LIST,for each p in pdes collect(reval {'!*sq,get(p,'sqval),t}))), lisp 'revgradlex)} else << write"Situation before call of Groebner:"$terpri()$ print_statistic(pdes,append(cadr arglist,setdiff(ftem_,cadr arglist)))$ err_catch_gb(pdes)$ % groeb_solve='REDUCE >>$ if print_ then << terpri()$ write"An algebraic Groebner basis computation yields "$ >>$ return if null sol then nil else 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:=mkeqSQlist(nil,nil,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$ start_level(n,for each l1 in cdar sol collect {'EQUAL,0,reval l1})$ % "A case of a Groebner computation" %# 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:=mkeqSQlist(nil,nil,cdar sol,ftem_,vl_,allflags_,t, %orderings_prop_list_all() list(0),nil)$ sol:=cdr sol; l1:=crackmain_if_possible_remote(pdes,forg)$ if l1 and not contradiction_ then result:=merge_crack_returns(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_into_cases(arglist)$ % programmed or interactive introduction of two cases whether a % given expression is zero or not. If called automatically then % this expression is cadddr arglist. It must be in sq-form. if not contradiction_ then % that should always be the case begin scalar h,hh,s,pdes,forg,contrad,n,pf,q,sqf,l1,l2,result,ps,intact, print_bak,enlarged_depl!* $ %,contra_bak,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 "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!*:=redfront_color ""$ h:=simp termxread()$ % for each hh in pdes do h:=subst(get(hh,'val),hh,h)$ for each hh in pdes do h:=subsq(h,{(hh . {'!*sq,get(hh,'sqval),t})})$ % bracket from below under the (checked) assumption that h can involve % equation names only if h is specified interactively. >>$ % Preliminary contradiction tests %% 20.11.2006: One should have only simplifypde() OR may_vanish() %% because both factorize % if not may_vanish(h) then return << print_bak:=print_$ print_:=nil$ % not to print the finding of a contradiction % h:=simplifypde(h,smemberl(ftem_,h),t,nil)$ % (h,ftem,tofactor,eqn_name)$ hh:=simplifySQ(h,smemberl(ftem_,h),t,nil,nil)$ % (p,ftem,fctr,en,sep)$ if hh={(1 . 1)} then contradiction_:=t$ print_:=print_bak$ if contradiction_ then return << contradiction_:=nil$ % already assigned here as it may % again be set by addineq below if intact then << write"According to the known inequalities, ", "this expression can not vanish!"$ terpri()$ write" --> Back to main menu."$terpri()$ promptstring!*:=ps$ nil >> else << for each l2 in hh do if l2 neq (1 . 1) then addSQineq(pdes,l2,nil)$ addSQineq(pdes,h,nil)$ % no simplification as simplification % obviously simplifies to (1 . 1) whereas % it was obviously not known that h neq 0 {pdes,forg} >> >>$ 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:=nil$ % s=nil is the default case, ie. h<>0 first then h=0 contrad:=t$ n:=0$ %------------------- backup_to_file(pdes,forg,nil)$ % It is necessary to collect the new dependencies from the first run % to know them after the 2nd run. This would be accomplished by moving % the backup_to_file() command directly after `again:'. Here we do it % cheaper by storing it in enlarged_depl!* . sqf:=car hh; for each q in cdr hh do sqf:=multsq(q,sqf)$ pf:=prepsq sqf$ q:=nil$ % should not be necessary again: n:=add1 n$ if s then << %====== the case that the expression h vanishes start_level(n,list {'EQUAL,0,pf})$ if print_ then terpri()$ q:=mkeqSQ(sqf,hh,pf,ftem_,vl_,allflags_,t,list(0),nil,pdes)$ if print_ then if contradiction_ then << write "The case"$ deprint(list pf)$ write "contradicts inequalities and is not further investigated."$ >> else << write "CRACK is now called with the assumption 0 = ",q," : "$ deprint(list pf)$ >> >> else << %====== the case that h does not vanish identically start_level(n,list {'INEQ,0,pf})$ if print_ then << terpri()$ write "CRACK is now called with assuming "$terpri()$ mathprint pf$ write" to be nonzero. "$ >>$ for each l2 in hh do addSQineq(pdes,l2,nil)$ if contradiction_ and print_ then write"According to the system of equations, this expression must be zero!"$ >>$ % necessary steps to call crackmain(): if contradiction_ then << % skip this case if print_ then << terpri()$ if n=1 then write" --> Next case." else write" --> Case splitting completed."$ >>$ contradiction_:=nil$ l1:=nil$ finish_level(0) >> else << recycle_fcts:=nil$ % such that functions generated in the sub-call % will not clash with existing functions l1:=crackmain_if_possible_remote(if null s then pdes else eqinsert(q,pdes),forg) >>; forg:=restore_and_merge(l1,pdes,forg)$ % also necessary if l1=nil pdes:= car forg; forg:=cadr forg; if not contradiction_ then contrad:=nil$ if l1 and not contradiction_ then result:=merge_crack_returns(l1,result); contradiction_:=nil$ if n=1 then << enlarged_depl!*:=depl!*$ s:=not s; goto again >> else depl!*:=union(depl!*,enlarged_depl!*)$ delete_backup()$ contradiction_:=contrad$ % =t only if all cases give contradiction 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 scalar s; if !*batch_mode then << write"Drop this point from the proc_list_ with 'o, 'cp or quit with 'q."$ terpri()$ !*batch_mode:=nil$ >>$ s:=length car arglist; if (max_eqn_to_conti=0) or (car arglist and (length car arglist>max_eqn_to_conti)) then return << % The above test has been included, so that having stop_batch as % last module in the proc_list_ one can have it stop only if at % least 2 equations are unsolved by setting globally max_eqn_to_conti:=1 terpri()$ write"The program changes now into interactive mode because there "$terpri()$ if s=1 then write"is 1 equation" else write"are ",s," equations"$ write" left to be solved which could not be solved"$terpri()$ write"with the steps preceeding this step 38. If you want to finish the"$terpri()$ write"computation in cases that not more than n equations are unsolved"$terpri()$ write"then do 'as max_eqn_to_conti n;' where n is an integer."$terpri()$ batchcount_:=stepcounter_ - 2$ arglist >> end$ symbolic procedure user_defined(arglist)$ begin arglist:=nil; % only to use arglist end$ symbolic procedure back_up(arglist)$ backup_to_file(car arglist,cadr arglist,nil)$ 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!*:=redfront_color ""$ if null lin_problem then << 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 equations 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()$ h:=setdiff(s,car arglist); if s=nil then newpdes:=nil else if h then << write"Equations ",h," 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()$ h:=setdiff(s,ftem_); if s=nil then newpdes:=nil else if h then << write"Functions ",h," 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)$ collect_sol:=t$ % is backed up sol:=crackmain(newpdes,fl)$ % Returned inequalities are currently not taken care of! % One could add an dropredund call here newfdep:=nil$ for each s in sol do if pairp 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(mkeqSQ(s,nil,nil,ftem_,vl_,allflags_,t,list(0),nil,pdes), pdes)$ for each s in cadar sol do if pairp s and (car s='EQUAL) then << h:=mkeqSQ(subtrsq(caddr s,simp cadr s),nil,nil, 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$ symbolic procedure first_int_for_ode(arglist)$ begin arglist:=cdr arglist$ % only to avoid warning if print_ then << write"Unfortunately this module is not completely implemented yet."$ terpri() >>$ return nil end$ endmodule$ end$