1%******************************************************************** 2module utilities$ 3 4%%%%%%%%%%%%%%%%%%%%%%%%% 5% properties of pde's % 6%%%%%%%%%%%%%%%%%%%%%%%%% 7 8%****************************************************************************** 9% Routines for finding leading derivatives and others * 10% Author: Andreas Brand 1990 1994 * 11% Thomas Wolf since 1994 * 12%****************************************************************************** 13 14% BSDlicense: ***************************************************************** 15% * 16% Redistribution and use in source and binary forms, with or without * 17% modification, are permitted provided that the following conditions are met: * 18% * 19% * Redistributions of source code must retain the relevant copyright * 20% notice, this list of conditions and the following disclaimer. * 21% * Redistributions in binary form must reproduce the above copyright * 22% notice, this list of conditions and the following disclaimer in the * 23% documentation and/or other materials provided with the distribution. * 24% * 25% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" * 26% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * 27% IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * 28% ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR CONTRIBUTORS BE * 29% LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * 30% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * 31% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * 32% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN * 33% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) * 34% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE * 35% POSSIBILITY OF SUCH DAMAGE. * 36%****************************************************************************** 37 38symbolic procedure drop_dec_with(de1,de2,rl)$ 39% drop de1 from the 'dec_with or 'dec_with_rl list of de2 40% currently for all orderings 41begin scalar a,b,c$ 42 a:=if rl then get(de2,'dec_with_rl) 43 else get(de2,'dec_with)$ 44 for each b in a do << % for each ordering b 45 b:=delete(de1,b); 46 if length b>1 then c:=cons(b,c); 47 >>; 48 if rl then put(de2,'dec_with_rl,c) 49 else put(de2,'dec_with ,c) 50end$ 51 52symbolic procedure add_dec_with(ordering,de1,de2,rl)$ 53% add (ordering de1) to 'dec_with or 'dec_with_rl of de2 54begin scalar a,b$ 55 a:=if rl then get(de2,'dec_with_rl) 56 else get(de2,'dec_with)$ 57 b:=assoc(ordering,a)$ 58 a:=delete(b,a)$ 59 if b then b:=cons(ordering,cons(de1,cdr b)) 60 else b:=list(ordering,de1)$ 61 if rl then put(de2,'dec_with_rl,cons(b,a)) 62 else put(de2,'dec_with ,cons(b,a))$ 63end$ 64 65symbolic procedure add_both_dec_with(ordering,de1,de2,rl)$ 66% add (ordering de1) to 'dec_with or 'dec_with_rl of de2 and 67% add (ordering de2) to 'dec_with or 'dec_with_rl of de1 68begin 69 add_dec_with(ordering,de1,de2,rl)$ 70 add_dec_with(ordering,de2,de1,rl)$ 71end$ 72 73symbolic procedure drop_rl_with(de1,de2)$ 74% drop de1 from the 'rl_with list of de2 75put(de2,'rl_with,delete(de1,get(de2,'rl_with)))$ 76 77symbolic procedure add_rl_with(de1,de2)$ 78% add de1 to 'rl_with of de2 and vice versa 79<<put(de2,'rl_with,cons(de1,get(de2,'rl_with)))$ 80 put(de1,'rl_with,cons(de2,get(de1,'rl_with)))>>$ 81 82symbolic procedure prevent_simp(v,de1,de2)$ 83% it is df(de1,v) = de2 84% add dec_with such that de2 85% will not be simplified to 0=0 86begin scalar a,b$ 87 % a:=get(de1,'fcts)$ 88 a:=list(0); % all orderings for which de1 is used (-->ord) 89 for each b in a do if member(v,fctargs(b)) then 90 <<add_dec_with(b,de2,de1,nil);add_dec_with(b,de2,de1,t)>>; 91 % a:=get(de2,'fcts)$ 92 a:=list(0); % all orderings for which de2 is used (-->ord) 93 for each b in a do if member(v,fctargs(b)) then 94 <<add_dec_with(b,de1,de2,nil);add_dec_with(b,de1,de2,t)>>; 95end$ 96 97symbolic procedure termread$ 98begin scalar val,!*echo; % Don't re-echo tty input 99again: 100 if not null old_history then << 101 val:=car old_history$ 102 if val='ig then << % ignore 'ig and following comment 103 old_history:=cddr old_history; 104 goto again 105 >>; 106 if print_ then <<write"old input: ",val$terpri()>>$ 107 if old_history then old_history:=cdr old_history 108 >> else << 109%write"ipl!* 1 = ",ipl!*$terpri()$ 110%write"ifl!* 1 = ",ifl!*$terpri()$ 111 rds nil; wrs nil$ % Switch I/O to terminal 112 val := read()$ 113%write"ipl!* 2 = ",ipl!*$terpri()$ 114%write"ifl!* 2 = ",ifl!*$terpri()$ 115 if ifl!* then rds cadr ifl!*$ % Resets I/O streams 116%write"ipl!* 3 = ",ipl!*$terpri()$ 117%write"ifl!* 3 = ",ifl!*$terpri()$ 118%system"sleep 10"$ 119 if ofl!* then wrs cdr ofl!*$ 120 >>$ 121 history_:=cons(val,history_)$ 122 return val 123end$ 124 125symbolic procedure termxread$ 126begin scalar val, !*echo; % Don't re-echo tty input 127again: 128 if not null old_history then << 129 val:=car old_history$ 130 if val='ig then << % ignore 'ig and following comment 131 old_history:=cddr old_history; 132 goto again 133 >>; 134 if print_ then <<write"old input: ",val$terpri()>>$ 135 old_history:=cdr old_history 136 >> else << 137 rds nil; wrs nil$ % Switch I/O to terminal 138 val := xread(nil)$ 139 if ifl!* then rds cadr ifl!*$ % Resets I/O streams 140 if ofl!* then wrs cdr ofl!*$ 141 >>$ 142% history_:=cons(compress(append(explode val,list('$))),history_)$ 143 history_:=cons(val,history_)$ 144 return val 145end$ 146 147symbolic procedure termlistread()$ 148begin scalar l; 149 l:=termxread()$ 150 if (not null l) and 151 ((atom l) or 152 (pairp l and (car l neq '!*comma!*))) 153 then l:=list('!*comma!*,l); 154 if l and ((not pairp l) or (car l neq '!*comma!*)) then 155 <<terpri()$write"Error: not a legal list of elements.";terpri()$ 156 l:=nil>> 157 else if pairp l then l:=cdr l; % dropping '!*comma!* 158 return l 159end$ 160 161symbolic procedure change_prompt$ 162begin scalar !*usermode$ 163 if null promptstring!* then promptstring!* := ""; 164 setpchar promptstring!*; 165 promptexp!* := promptstring!* 166end$ 167 168symbolic procedure change_prompt_to u$ 169 begin scalar oldprompt,!*redefmsg,!*usermode$ 170 oldprompt := promptstring!*; 171 promptstring!* := u; 172 copyd('restore_update_prompt,'update_prompt); 173 copyd('update_prompt,'change_prompt); 174 update_prompt(); 175 restore_interactive_prompt()$ 176 return oldprompt 177 end$ 178 179symbolic procedure restore_interactive_prompt$ 180 begin scalar !*redefmsg,!*usermode$ 181 copyd('update_prompt,'restore_update_prompt) 182 end$ 183 184symbolic procedure restore_input_file$ 185% it assumes equations_file to be closed whether eqn_input=nil or not 186if (equations_file="") or (eqn_input='done) or 187 (null eqn_input and zerop eqn_no) then nil else 188begin scalar h,oldinpu,intbak$ 189 intbak:=!*int$ !*int:=nil$ 190 eqn_input := open (equations_file,'input); 191 oldinpu := rds eqn_input; % backup of old input source 192 for h:=1:eqn_no do xread(t)$ 193 rds oldinpu; 194 !*int:=intbak 195end$ 196 197%% currently not used and possibly even not complete: 198%symbolic procedure read_ineq(arglist,ineq_file)$ 199%% in contrast to read_equation() in this procedure the file 200%begin scalar pdes,forg,oldinpu,l,ine_input,ok,ex,subli,intbak$ 201% pdes:=car arglist$ 202% forg:=cadr arglist$ 203% 204% for each h in forg do 205% if pairp h and (car h='equal) then subli:=cons(h,subli); 206% subli:=cons('list,subli)$ 207% 208% intbak:=!*int$ !*int:=nil$ 209% ine_input := open (ineq_file,'input); 210% oldinpu := rds ine_input; % backup of old input source 211%doitagain: 212% ex := xread(t)$ 213% if null ex then 214% return << 215% ex:=xread(t); % strangely needed when somewhere else out(),shut() 216% close ine_input; ine_input:='done; rds oldinpu; !*int:=intbak; 217% list(pdes,forg) 218% >>$ 219% !*uncached:=t; 220% algebraic(ex:=num sub(subli,ex))$ 221% if pairp ex and (car ex = 'list) then << 222% ex:=cdr ex; 223% l:=nil; 224% ok:=nil; 225% while ex do 226% if zerop car ex then ex:=cdr ex else 227% if freeoflist(car ex,ftem_) then <<ex:=nil; l:=nil; ok:=t>> else 228% <<l:=cons(car ex,l); ex:=cdr ex>>; 229% if l then if cdr l then ineq_or:=cons(simp l,ineq_or) 230% else addineq(pdes,car l) 231% else if null ok then contradiction_:=t 232% >> else addineq(pdes,ex); 233% 234% if contradiction_ then 235% return <<close ine_input; ine_input:='done; rds oldinpu; !*int:=intbak; nil>>$ 236% 237% goto doitagain$ 238% 239%end$ 240 241symbolic procedure read_equation(arglist)$ 242% This should come with a higher priority than any module which 243% generates case distinctions because when continuing reading 244% from the file in a subcase, one can not ga back to the old 245% position in the file when completing the subcase. 246begin scalar h,oldinpu,ex,pdes,forg,subli,start_no,intbak; 247 if ( eqn_input='done ) or 248 ((eqn_input=nil) and 249 ((equations_file="") or null equations_file)) then return nil$ 250 251 if null eqn_input then % necessarily equations_file neq "" 252 eqn_input := open (equations_file,'input); 253 254 pdes:=car arglist$ 255 forg:=cadr arglist$ 256 oldinpu := rds eqn_input; % backup of old input source 257 258 for each h in forg do 259% if pairp h and (car h='equal) then subli:=cons(h,subli); 260% subli:=cons('list,subli)$ 261 if pairp h and (car h='equal) then subli:=cons((cadr h . {'!*sq,caddr h,t}),subli); 262 263 start_no:=eqn_no$ 264 intbak:=!*int$ !*int:=nil$ 265oncemore: 266 ex := xread(t)$ 267 if null ex then 268 return << 269 ex:=xread(t); % strangely needed when somewhere else out(),shut() 270 close eqn_input; eqn_input:='done; rds oldinpu; !*int:=intbak; 271 nil 272 >>$ 273 eqn_no:=add1 eqn_no$ 274 !*uncached:=t; 275 276 ex:=(numr subsq(simp ex,subli) . 1)$ 277% algebraic(ex:=num sub(subli,ex))$ 278 if contradiction_ then 279 return <<close eqn_input; eqn_input:='done; rds oldinpu; !*int:=intbak; nil>>$ 280 if sqzerop ex then << 281 if print_ then write eqn_no," "$ 282 goto oncemore 283 >> else << 284 ex:=mkeqSQ(ex,nil,nil,ftem_,vl_,allflags_,t,list(0),nil,pdes)$ 285 h:=eqinsert2(ex,pdes); 286 if null h then << 287 if null car recycle_eqns then 288 recycle_eqns:=(list cadr recycle_eqns) . (cddr recycle_eqns)$ 289 if print_ then write " (",eqn_no,")"$ 290 goto oncemore 291 >> else << 292 pdes:=h$ 293 if print_ then <<terpri()$write"Reading ",eqn_no,".equation. ">> 294 >> 295 >>$ 296 rds oldinpu; 297 !*int:=intbak; 298 return list(pdes,forg) 299end$ 300 301symbolic procedure mkeqSQlist(sqvallist,faclist,pvallist,ftem,vl,flaglist, 302 simp_flag,orderl,pdes)$ 303% makes a list of equations, currently uses either sqvallist or pvallist 304% sqvallist: list of expressions in sq-form (no prefix sq) or nil 305% faclist: list of expressions each as list of factors each in sq-form 306% pvallist: list of expressions in prefix form or nil 307% ftem: list of functions 308% vl: list of variables 309% flaglist: list of flags 310% orderl: list of orderings where the equations are valid 311% pdes: list of all equations by name to update inequalities 312% within updateSQ() 313begin scalar l0,l1$ 314 while (sqvallist or faclist or pvallist) and null contradiction_ do << 315 l0:=mkeqSQ(if sqvallist then car sqvallist else nil, 316 if faclist then car faclist else nil, 317 if pvallist then car pvallist else nil, 318 ftem,vl,flaglist,simp_flag,orderl,nil,append(l1,pdes)); 319 if l0 then l1:=eqinsert(l0,l1); 320 if sqvallist then sqvallist:=cdr sqvallist$ 321 if faclist then faclist:=cdr faclist$ 322 if pvallist then pvallist:=cdr pvallist 323 >>$ 324 325 return l1 326end$ 327 328symbolic procedure mkeqSQ(sqval,fac,pval,ftem,vl,flaglist,simp_flag, 329 orderl,hist,pdes)$ 330% makes a single new equation 331% sqval: expression in sq-form (see header of updateSQ() ) 332% fac: list of factors in sq-form 333% pval: expression in prefix-form 334% ftem: list of functions 335% vl: list of variables 336% flaglist: list of flags 337% orderl: list of orderings where the equation is valid 338% hist: the history of sqval 339% pdes: list of all equations by name to update inequalities 340% within updateSQ() 341% If the new equation to be made is only to exist temporarily then 342% call mkeqSQ with pdes=nil to avoid lasting effects of the temporary pde. 343% 344if (sqval and not sqzerop sqval) or fac or not zerop pval then 345begin scalar s$ 346 s:=new_pde()$ 347 if record_hist and hist then put(s,'histry_,reval hist)$ 348 for each a in flaglist do flag1(s,a)$ 349 if not updateSQ(s,sqval,fac,pval,ftem,vl,simp_flag,orderl,pdes) then 350 <<drop_pde(s,nil,nil)$ 351 s:=nil>>$ 352 if record_hist and null hist and s then put(s,'histry_,s)$ 353 return s 354end$ 355 356symbolic procedure no_of_derivs(equ)$ 357if alg_poly then 0 else 358begin scalar h,dl; 359 h:=0; 360 dl:=get(equ,'derivs); 361 while dl do << 362 if (pairp caar dl) and (cdaar dl) then h:=add1 h; 363 dl:=cdr dl 364 >>; 365 return h 366end$ 367 368symbolic procedure updateSQ(equ,sqval,fac,pval,ftem,vl,simp_flag,orderl,pdes)$ 369% determine the properties of a pde 370% equ: pde name 371% sqval: expression in SQ form (preferred) or nil 372% fac: list of factors in SQ form (2nd best) or nil 373% pval: expression in prefix form or nil 374% At leastone of the 3 must be neq nil. What are definitely 375% stored are 'sqval and 'fac. 'pval only if input pval is neq nil 376% and if simp_flag=nil . 377% ftem: list of functions 378% vl: list of variables 379% orderl: list of orderings where the equation is valid 380% pdes: needed in call of addineq at end, has global effects 381% 382% *** important ***: 383% If this is now a new equation one may have to call before: 384% for each h1 in allflags_ do flag1(p,h1)$ 385% and definitely have to call afterwards: 386% drop_pde_from_idties(p,pdes,if record_hist then new_history_in_prefix_form 387% else nil) and 388% drop_pde_from_properties() 389% ### or should this be included into updateSQ()? YES 390% 391% This procedure can produce contradiction_:=t 392% --> value of contradiction_ is to be tested afterwards. 393% 394% If the value is zero then nil is returned and then the equations 395% should be dropped from pdes (the list of equations). 396% 397% This procedure can effect the whole system through changing ineq_ or ineq_or. 398% For a definition of properties see crinit.red . 399% 400% If sqval=nil and null cdr fac (fac has only one factor) then it is assumed 401% that it is known for sure that the elements of fs do not factorize, 402% as tested with err_catch_fac2(). 403% 404begin scalar l,h,h2,h3,h4,nvars,rational,nonrational,allvarfcts, 405 droped_factors,carl,rati$ 406 407 % safety precaution: 408 if pairp sqval and car sqval = '!*sq then 409 if caddr sqval = t then sqval:=cadr sqval 410 else sqval:=simp!* sqval 411 else if sqval then sqval:=subs2 sqval; 412 413 % For now we will always generate the SQ form and try to get away with 414 % not generating the prefix form if it does not already exist. Maybe we 415 % will have to generate the prefix form always, hopefully not. 416 417 % Should a check for simplification rules be done here ### 418 % because it is currently not done in simplifySQ() ? 419 % Or, should it be done in simplifySQ()? 420 % ruli:=start_let_rules()$ 421 % g:=reval g$ % if reval aeval is needed then inform A. Hearn 422 % % g:=doedel3 g$ 423 % stop_let_rules(ruli)$ 424 put(equ,'terms,nil)$ 425 put(equ,'sqval,nil)$ % maybe not necessary, but safe 426 put(equ,'fac ,nil)$ % maybe not necessary, but safe 427 put(equ,'pval ,nil)$ % necessary as this is sometimes not nil 428 if null sqval then 429 if null fac then <<sqval:=simp!* pval; put(equ,'fac,nil)>> 430 else << 431 if null cdr fac then << % known to have only one factor 432 put(equ,'fac,2); 433 sqval:=subs2 car fac 434 >> else << % more factors 435 % put(equ,'fac,fac); 436 % We throw away the knowledge of factors only because currently we have no 437 % way to remember that these factors are themselves not fully factorized 438 %put(equ,'fac,nil); 439 440 % Now we use the full information and completely factor each factor: 441 l:=nil; 442 for each v in fac do << 443 h:=cdr err_catch_fac2 {'!*sq,(numr v . 1),t}; 444 while h do << 445 if null domainp numr simp cadar h then << 446 if caddar h > 1 then droped_factors:=t$ 447 % 3 Feb 2016: New: 448 h2:=simplifySQ(cadr cadar h,ftem,nil,nil,t)$ % cadr instead of simp as cadar h is no number 449 for each h3 in h2 do 450 if member(h3,l) then droped_factors:=t 451 else l:=cons(numr h3,l)$ 452 % 3 Feb 2016: Old: 453 % l:=cons(numr cadr cadar h,l) % cadr instead of simp as cadar h is no number 454 >>$ 455 h:=cdr h 456 >> 457 % if l and null cdr l then a number factor has been dropped 458 % and one might want to change sqval but if simp_flag=nil then 459 % it is assumed that sqval shall not be changed (e.g. to admit some 460 % special solution of integrating procedure 461 >>; 462 463 if null l then <<sqval:=nil; put(equ,'fac,nil)$ fac:=nil>> else 464 if null cdr l then <<sqval:=(car l . 1); put(equ,'fac,2)$ fac:=2>> 465 else << 466 put(equ,'fac,for each h in l collect (h . 1))$ 467 sqval:=(car l . 1)$ l:=cdr l$ 468 while l do <<sqval:=multsq(sqval,(car l . 1)); l:=cdr l>>$ 469 sqval:=subs2 sqval$ 470 fac:=get(equ,'fac) 471 >> 472 >> 473 >>$ % of null sqval and not null fac, now sqval and fac are both assigned 474 if sqval and not sqzerop sqval then << 475 if null simp_flag and (null fac or null cdr fac) then << 476 477 % If there are factors then they have to be simplified to be 478 % be identified and dropped later, in case this factor (in 479 % simplified form) should appear later to be non-zero. 480 481 if member(sqval,ineq_) then raise_contradiction({'!*sq,sqval,t},nil)$ 482 if null fac then << 483 put(equ,'terms,no_of_tm_sf numr sqval)$ 484 if (null !*complex and (get(equ,'terms) > max_term_to_fac_real )) or 485 ( !*complex and (get(equ,'terms) > max_term_to_fac_complex)) 486 then l:=sffac numr sqval 487 else << 488 h:=cdr err_catch_fac2 {'!*sq,(numr sqval . 1),t}; 489 l:=nil; 490 if cdr h or (caddar h>1) then 491 while h do << 492 if null domainp numr simp cadar h then << 493 if caddar h > 1 then droped_factors:=t$ 494 % 3 Feb 2016: New: 495 h2:=simplifySQ(cadr cadar h,ftem,nil,nil,t)$ % cadr instead of simp as cadar h is no number 496 for each h3 in h2 do 497 if member(h3,l) then droped_factors:=t 498 else l:=cons(numr h3,l)$ 499 % 3 Feb 2016: Old: 500 % l:=cons(numr cadr cadar h,l) % cadr instead of simp as it is no number 501 >>$ 502 h:=cdr h 503 >> 504 % if l and null cdr l then a number factor has been dropped 505 % and one might want to change sqval but if simp_flag=nil then 506 % it is assumed that sqval shall not be changed (e.g. to admit some 507 % special solution of integrating procedure 508 >>; 509 if l and cdr l 510 then put(equ,'fac,for each h in l collect (h . 1)) 511 else put(equ,'fac, 512 if (null !*complex and (get(equ,'terms) > max_term_to_fac_real )) or 513 ( !*complex and (get(equ,'terms) > max_term_to_fac_complex)) 514 then 1 515 else 2) 516 >>$ 517 if pval and null droped_factors then put(equ,'pval,pval) 518 >> else << 519 if null ftem then ftem:=ftem_; % for safety, just in case 520 if null fac then l:=simplifySQ(sqval,ftem,t,equ,t) 521 else <<l:=nil$ 522 for each f in fac do << 523 h:=simplifySQ(f,ftem,t,equ,nil)$ 524 if h = {(1 . 1)} then addSQineq(pdes,f,t) 525 else l:=union(h,l) 526% if h neq {(1 . 1)} then l:=union(h,l) 527 >>; 528 if null l then l:={(1 . 1)} 529 >>$ 530 if l={(1 . 1)} then raise_contradiction({'!*sq,sqval,t},nil)$ 531 sqval:=car l; 532 if null cdr l then put(equ,'fac,1) 533 else <<put(equ,'fac,l); 534 % Maybe one could save the effort of having to compute the product? ### 535 % A possibility would be to store only 'sqval as list of factors 536 % and not have 'fac. 537 l:=cdr l; 538 while l do <<sqval:=multsq(sqval,car l);l:=cdr l>> 539 >>$ 540 put(equ,'terms,no_of_tm_sf numr sqval)$ 541 >> 542 >>$ 543 depl!*:=delete(assoc(reval equ,depl!*),depl!*)$ 544 if null contradiction_ then 545 if null sqval or sqzerop sqval then return nil 546 else << 547 put(equ,'sqval,sqval); 548 put(equ,'kern,union(kernels denr sqval, 549 kernels numr sqval )); 550 l:=nil; 551 for each v in get(equ,'kern) do 552 if pairp v 553 and ((car v neq 'df) or ((car v = 'df) and pairp cadr v)) 554 and member(car v,reducefunctions_) then l:=cons(v,l); 555 put(equ,'non_rat_kern,l); 556 put(equ,'fct_kern_lin,nil); % determined in add_fct_kern() crshort.red if 557 put(equ,'fct_kern_nli,nil); % needed, see def. of prop_list in crinit.red 558 ftem:=sort_according_to(smemberl(ftem,get(equ,'kern)),ftem_)$ 559 put(equ,'fcts,ftem)$ 560 put(equ,'fct_hom,smemberl(ftem,fhom_)); 561 l:=nil; 562 for each v in vl do 563 if not my_freeof(get(equ,'kern),v) then l:=cons(v,l)$ 564 vl:=sort_according_to(l,vl_); 565 put(equ,'vars,vl)$ 566 if null vl then remflag1(equ,'to_diff)$ 567 if vl then 568 depl!*:=cons(cons(equ,vl),depl!*)$ % needed in expressions in idnties_ 569 put(equ,'nvars,length vl)$ 570 put(equ,'level,level_)$ 571 put(equ,'derivs,sort_derivs(if pairp denr sqval then 572 union(all_deriv_search_SF(denr sqval,ftem), 573 all_deriv_search_SF(numr sqval,ftem) ) 574 else 575 all_deriv_search_SF(numr sqval,ftem),ftem,vl))$ 576 if struc_eqn then put(equ,'no_derivs,no_of_derivs(equ)); 577 put(equ,'fcteval_lin,nil)$ 578 put(equ,'fcteval_nca,nil)$ 579 put(equ,'fcteval_nli,nil)$ 580 put(equ,'fcteval_n2l,nil)$ 581 put(equ,'fct_nli_lin,nil)$ 582 put(equ,'fct_nli_nca,nil)$ 583 put(equ,'fct_nli_nli,nil)$ 584 put(equ,'fct_nli_nus,nil)$ 585 if null get(equ,'terms) then put(equ,'terms,no_of_tm_sf numr sqval 586 % + no_of_tm_sf denr sqval 587 )$ 588 %put(equ,'length,pdeweightSF(numr sqval,ftem)+pdeweightSF(denr sqval,ftem))$ 589 put(equ,'length,get(equ,'terms))$ 590 put(equ,'printlength,delengthSQ sqval)$ 591 put(equ,'orderings,orderl)$ % Orderings ! 592 593 % rationality test: 594 nvars:=get(equ,'nvars)$ 595 596 if alg_poly then << 597 rational:=ftem$ 598 nonrational:=nil$ 599 allvarfcts:=ftem 600 >> else << 601 % make a new copy of ftem 602 for each f in reverse ftem do rational:=cons(f,rational)$ 603 rati:=cons(1,rational)$ 604 nonrational:=nil$ 605 allvarfcts:=nil$ 606 l:=get(equ,'kern)$ 607 while l do << 608 carl:=car l$ l:=cdr l$ 609 if atom carl or 610 ((pairp carl ) and 611 (car carl = 'df) and 612 (atom cadr carl) ) then t else << 613 % Move all functions from rational to non-rational which occur in carl. 614 h:=rati; 615 while cdr h do 616 if not freeof(carl,cadr h) then << 617 % Move cadr h from rational to nonrational: 618 nonrational:=cons(cadr h,nonrational); 619 h:=rplacd(h,cddr h) 620 >> else h:=cdr h 621 >> 622 >>$ 623 nonrational:=reverse nonrational$ 624 if nvars=0 then allvarfcts:=rational else 625 for each f in reverse rational do 626 if fctlength f=nvars then allvarfcts :=cons(f,allvarfcts)$ 627 628 % The following test for non-polynomiality is not adequate. 629 % For example, {'expt,'x,4} would be recognized as polynomial 630 % but the kernel would not be an atom or the derivative of an 631 % atom that could be decoupled in crdec.red . 632 %if l then << 633 % if cdr l then l:=cons('plus,l) 634 % else l:=car l; 635 % for each f in reverse ftem do 636 % if polynop(l,f) then << 637 % rational:=cons(f,rational)$ 638 % if fctlength f=nvars then allvarfcts :=cons(f,allvarfcts) 639 % >> else nonrational:=cons(f,nonrational) 640 %>>$ 641 642 >>$ 643 644 for each l in nonrational do rational:=delete(l,rational); 645 646 put(equ,'rational,rational)$ 647 put(equ,'nonrational,nonrational)$ 648 put(equ,'allvarfcts,allvarfcts)$ 649 650% put(equ,'degrees, % too expensive 651% if linear_pr then cons(1,for each l in get(equ,'rational) 652% collect (l . 1)) 653% else fct_degrees(pval,get(equ,'rational)) )$ 654 put(equ,'partitioned,nil)$ 655 put(equ,'case2sep,nil)$ 656 l:=stardep3(get(equ,'vars),get(equ,'kern),get(equ,'derivs))$ 657 if l then << 658 h:=cdr l; 659 l:=simp car l$ 660 if member(l,ineq_) and 661 member(diffsq(l,h),ineq_) then put(equ,'starde,{(0 . prepsq l)}) 662 else <<put(equ,'case2sep,diffsq(l,h))$ 663 put(equ,'starde,sep_var(ftem,vl))>> 664 >> else put(equ,'starde,sep_var(ftem,vl))$ 665 flag1(equ,'to_eval)$ 666 if (l:=get(equ,'starde)) then << 667 %remflag1(equ,'to_eval)$ 668 remflag1(equ,'to_int)$ 669 remflag1(equ,'to_fullint)$ 670 if simp_flag and 671 (zerop caar l) then <<flag1(equ,'to_sep)$ flag1(equ,'to_casesep)>>$ 672 % remflag1(equ,'to_diff) 673 >> else << 674 remflag1(equ,'to_gensep)$ 675 remflag1(equ,'to_casegensep) 676 >>$ 677 if (l:=get(equ,'starde)) and zerop caar l then remflag1(equ,'to_eval) else 678 <<remflag1(equ,'to_sep)$ remflag1(equ,'to_casesep)>>$ 679 if get(equ,'nonrational) then <<%remflag1(equ,'to_decoup)$ 680 if null setdiff(get(equ,'allvarfcts),get(equ,'nonrational)) then 681 remflag1(equ,'to_eval) 682 >>$ 683 if not get(equ,'rational) then remflag1(equ,'to_eval)$ 684 if fhom_ then << 685 l:=find_hom_deg_SF numr sqval$ 686 put(equ,'hom_deg,l)$ 687% if car l=1 then << % i.e. linear in flin_ 688% l:=get(equ,'derivs); 689% while l and (null linf or (length linf < 3)) do << 690% if not freeoflist(car l,flin_) then << 691% linf:=cons(car l,linf); 692% if member(car l,ineq_) then fd1:=car l 693% >>; 694% l:=cdr l 695% >>; 696% if linf and (length linf = 2) and fd1 then << 697% if NON-ZERO(coeffn(get(equ,'pval),fd1,1)) then << 698% fd2:=car delete(fd1,linf); 699% braucht pdes, was nicht vorhanden ist 700% addineq(pdes,fd2); 701% addineq(pdes,coeffn(get(equ,'pval),fd2,1)) 702% >> 703% >> 704% >> 705 >>$ 706 put(equ,'split_test,nil)$ 707 put(equ,'linear_, 708 if nonrational then nil else 709 if lin_problem then t else 710 % if the above line is active (not commented out) then after 711 % a linear problem the next problem is automatically taken to 712 % be linear too, if it is active allows to declare large 713 % systems as linear avoiding costly checking 714 if not freeof(denr sqval,ftem) then nil else 715 if lin_check_SQ(((first_term_SF numr sqval) . 1),ftem) then 716 if lin_check_SQ(sqval,ftem) then t else nil else nil)$ 717 put(equ,'not_to_eval,nil)$ 718 719 % The following aims at global lasting effects, so it shall not be 720 % run if equation equ is not necessary 721 if pdes then << 722 723 new_ineq_from_equ_SQ(equ,pdes); 724 if null cdr pdes then % When the first and so far only equation 725 % was established (created by updatesq) 726 % then pdes was nil before, so it was not 727 % checked before and should be checked now. 728 new_ineq_from_equ_SQ(car pdes,pdes)$ 729 if null contradiction_ then simp_all_ineq_with_equ_SQ(equ,pdes)$ 730 731 % Does the new equation imply a vanishing derivative which is known 732 % not to vanish? 733 h:=get(equ,'allvarfcts)$ 734 if h and null cdr h and get(equ,'vars) and cdr get(equ,'fcts) then << 735 736 % There should be only one type of derivative of car h 737 h4:=nil$ h3:=t$ 738 l:=get(equ,'derivs); 739 while h3 and l do << 740 if caaar l = car h then 741 if null h4 then h4:=caar l 742 else if h4 neq caar l then h3:=nil; 743 l:=cdr l 744 >>$ 745 746 if h3 then << 747 748 % There should be only one derivative of car h in equ. 749 h4:=if cdr h4 then cons('df,h4) % h4 is the only occuring 750 else car h4$ % derivative of car h 751 752 % Stop if car h does occur non-rationally 753 l:=if freeof(get(equ,'nonrational),car h) then get(equ,'vars) 754 else nil$ 755 756 if l then << 757 % Continue only with variables which do not come up explicitly 758 h2:=nil$ 759 for each h3 in l do % for each potential separation variable h3 do 760% if freeof(get(equ,'kern),h3) then h2:=cons(h3,h2); 761 if not member(h3,get(equ,'kern)) then h2:=cons(h3,h2); 762 l:=h2; 763 >>$ 764 765 if l then << 766 % Continue only with those variables which are not variables 767 % of other functions 768 h2:=setdiff(get(equ,'fcts),h); 769 for each h3 in h2 do l:=setdiff(l,fctargs h3); 770 >>$ 771 772 if l then << % else there is no variable of which car h should be independent 773 while l and null member(simp {'df,h4,car l},ineq_) do l:=cdr l; 774 if l then << 775 if print_ then <<write"Next comes a separation of equation ",equ, 776 " wrt. ",h4$terpri()>>$ 777 h:=cdr algebraic(coeff(lisp {'!*sq,get(equ,'sqval),t},lisp h4)); 778 to_do_list:= 779 cons(list('add_eqns, 780 for each g in h collect if pairp g and 781 car g = '!*sq then cadr g 782 else simp g),to_do_list) 783 >> else 784 to_do_list:=cons(list('add_differentiated_pdes,list equ), 785 to_do_list) 786 >> 787 >> 788 >>$ 789 790 % Must all terms be zero? 791 if real_valued and non_negative numr sqval 792 and non_negative denr sqval then << 793 if print_ then << 794 write"Because of real_valued=t all variables, unknowns and parameters"$terpri()$ 795 write"are supposed to be real and therefore each term of equation ",equ$terpri()$ 796 write"must vanish on its own."$terpri()$ 797 eqprint list('equal,equ,{'!*sq,sqval,t}) 798 >>$ 799 h:=numr sqval$ 800 while h do << 801 l:=first_term_SF(h)$ h:=subtrf(h,l)$ 802 to_do_list:=cons(list('replace_equation,{nil,nil,(l . 1),nil}),to_do_list)$ 803 >> 804 >>$ 805 806 >>$ 807 808 return equ 809 >>$ 810end$ 811 812symbolic procedure add_eqns(arglist)$ 813% The 4th element of arglist is a lisp list of standard 814% quotient expressions that are to be added as equations. 815% This procedure is typically called from to_do when other steps 816% found expressions which necessarily vanish but these procedures 817% were not able to generate new equations because they did not have 818% the pdes variable or could not return it. 819% This procedure is similar to the procedure replace_equation() 820% which in addition allows to specify new functions and their 821% independent variables. 822begin scalar pdes,eqns,q$ 823 pdes:=car arglist$ 824 eqns:=cadddr arglist$ 825 while eqns and null contradiction_ do << 826 if zerop car eqns then q:=nil else 827 q:=mkeqSQ(car eqns,nil,nil,ftem_,vl_,allflags_,t,list(0),nil,nil)$%pdes)$ 828 if q then pdes:=eqinsert(q,pdes)$ 829 eqns:=cdr eqns 830 >>$ 831 return {pdes,cadr arglist} 832end$ 833 834%symbolic procedure new_ineq_from_pde(equ,pdes)$ 835%% currently only effective for equations with 2 terms 836%% If one term of the equation is non-zero then the sum of the 837%% remaining terms has to be non-zero too 838%if pdes and null lin_problem and (get(equ,'terms)=2) % >1) 839%then begin scalar valu; 840% valu:=numr get(equ,'sqval); 841%% if pairp valu and car valu='quotient then valu:=cadr valu; 842% if not (pairp valu and (car valu='plus)) then valu:=reval valu; 843% if pairp valu and car valu='quotient then valu:=cadr valu; 844% if not (pairp valu and (car valu='plus)) then << 845% write"err in update:"$terpri()$ 846% write"equ=",equ$terpri()$ 847% write"val =",get(equ,'val)$terpri()$ 848% write"reval val=",valu$terpri() 849% >> else 850%% for each l in cdr valu do 851%% if null may_vanish l then addineq(pdes,reval{'DIFFERENCE,valu,l}) 852% if null may_vanish cadr valu then addineq(pdes,caddr valu) else 853% if null may_vanish caddr valu then addineq(pdes,cadr valu) 854%end$ 855 856%symbolic procedure fct_degrees(pv,ftem)$ % if ever needed then write an 857%% ftem are to be the rational functions % SQ version like lin_check_SQ 858%begin % or do a search through the SQ tree 859% scalar f,l,ll,h,degs$ 860% if den pv then pv:=num pv$ 861% for each f in ftem do << 862% l:=gensym()$ 863% ll:=cons((f . l),ll)$ 864% pv:=subst({'times,l,f},f,pv)$ 865% >>$ 866% pv:=reval pv$ 867% for each l in ll do << 868% degs:=cons((car l . deg(pv,cdr l)),degs)$ 869% >>; 870% h:=cdar ll$ 871% for each l in cdr ll do pv:=subst(h,cdr l,pv)$ 872% pv:=reval pv$ 873% return cons(deg(pv,h),degs) 874%end$ 875 876%symbolic procedure pde_degree(pv,ftem)$ 877%% ftem are to be the rational functions 878%begin 879% scalar f,h$ 880% if den pv neq 1 then pv:=num pv$ 881% h:=gensym()$ 882% for each f in ftem do pv:=subst({'times,h,f},f,pv)$ 883% pv:=reval pv$ 884% return deg(pv,h) 885%end$ 886 887symbolic procedure pde_degree_SQ(pv,fl)$ 888% fl must be rational functions 889begin 890 scalar f,sb,k$ 891 k:=setkorder list lin_test_const$ 892 sb:=for each f in fl collect (f . {'!*sq,simp {'times,lin_test_const,f},t})$ 893 pv:=subf(numr pv,sb); 894 setkorder k$ 895 return ldeg numr pv 896end$ 897 898symbolic procedure dfsubst_update(f,der,equ)$ 899% miniml update of some properties of a pde 900% equ: pde 901% der: derivative 902% f: new function 903begin scalar l,h$ 904 for each d in get(equ,'derivs) do 905 if not member(cadr der,car d) then l:=cons(d,l) 906 else << 907 l:=cons(cons(cons(f,df_int(cdar d,cddr der)),cdr d),l)$ 908 put(equ,'kern, 909 subst(reval cons('df,caar l),reval cons('df,car d), 910 get(equ,'kern)))$ 911 h:=get(equ,'pval)$ 912 if h then put(equ,'pval,subst(reval cons('df,caar l),cons('df,car d),h)); 913 h:=get(equ,'fac)$ 914 if pairp h then put(equ,'fac, 915 for each f in h collect subsq(f,{((mvar car mksq(cons('df,car d),1)) . 916 (reval cons('df,caar l)))})); 917 put(equ,'partitioned,nil); 918 put(equ,'sqval, 919 subsq(get(equ,'sqval),{((mvar car mksq(cons('df,car d),1)) . (reval cons('df,caar l)))}) 920 )$ 921 >>$ 922 put(equ,'fcts,sort_according_to(subst(f,cadr der,get(equ,'fcts)),ftem_))$ 923 put(equ,'allvarfcts,sort_according_to(subst(f,cadr der,get(equ,'allvarfcts)),ftem_))$ 924 if get(equ,'allvarfcts) then flag(list equ,'to_eval)$ 925% This would reactivate equations which resulted due to 926% substitution of derivative by a function. 927% 8.March 98: change again: the line 3 lines above has been reactivated 928 put(equ,'rational,subst(f,cadr der,get(equ,'rational)))$ 929 put(equ,'nonrational,subst(f,cadr der,get(equ,'nonrational)))$ 930 put(equ,'derivs,sort_derivs(l,get(equ,'fcts),get(equ,'vars)))$ 931 return equ 932end$ 933 934symbolic procedure insert_in_eqlist(s,l)$ 935% 26.8.2009: The sorting criterium was 'length but 0=a and 0=a*b 936% have both length 1 and 0=a*b may come first although having a 937% higher 'printlength and thus 0=a will not be found by module 3 938% to be usable for a simplifying substitution. Thus the sorting 939% criteria is changed to 'printlength. 940if null l then list s else 941begin scalar l1,m,n,found1,found2$ 942 n:=get(s,'printlength)$ 943 return 944 if n<=get(car l,'printlength) then << 945 largest_fully_shortened:=nil; 946 currently_to_be_substituted_in:=car l$ 947 cons(s,l) 948 >> else << 949 l1:=l; 950 while cdr l and (null(m:=get(cadr l,'printlength)) or (n>m)) do << 951 if null m then write"### The equation ",cadr l," has no length! ###"$ 952 if car l=largest_fully_shortened then found1:=t; 953 if car l=currently_to_be_substituted_in then found2:=t; 954 l:=cdr l 955 >>$ 956 if largest_fully_shortened and null found1 then 957 largest_fully_shortened:=car l; 958 if currently_to_be_substituted_in and null found2 then 959 currently_to_be_substituted_in:=car l; 960 961 rplacd(l,cons(s,cdr l))$ 962 l1 963 >> 964end$ 965 966symbolic procedure eqinsert(s,l)$ 967% l is a sorted list 968if not (s or get(s,'sqval)) or zerop get(s,'length) or member(s,l) then l 969else if not l then list s 970else begin scalar l1$ %,n,m$ 971 l1:=proddel_SQ(s,l)$ 972 if car l1 then << 973% n:=get(s,'length)$ 974% l:=cadr l1$ 975% l1:=nil$ 976% while l and (null(m:=get(car l,'length)) or (n>m)) do 977% <<if m then l1:=cons(car l,l1) 978% else write"### The equation ",car l," has no length! ###"$ 979% l:=cdr l>>$ 980% l1:=append(reverse l1,cons(s,l))$ 981 l1:=insert_in_eqlist(s,cadr l1) 982 >> else if l1 then l1:=cadr l1 % or reverse of it 983 else l1:=l$ 984 return l1$ 985end$ 986 987symbolic procedure eqinsert2(s,l)$ 988% like eqinsert, but if s is a consequence of l and l is not changed 989% (because, for example, some equations of l are simplified because of 990% new inequalities coming through s (e.g. if s has only 2 terms and one 991% is made from only non-zero factors) and then factors are dropped and 992% then some equations of l become obsolete) then nil is returned 993if not (s or get(s,'sqval)) or zerop get(s,'length) or member(s,l) 994then nil 995else if not l then list s 996 else begin scalar l1,n,found1,found2$ 997 l1:=proddel_SQ(s,l)$ 998 if car l1 then << 999 n:=get(s,'length)$ 1000 l:=cadr l1$ 1001 l1:=nil$ 1002 while l and (n>get(car l,'length)) do 1003 <<l1:=cons(car l,l1)$ 1004 if car l=largest_fully_shortened then found1:=t; 1005 if car l=currently_to_be_substituted_in then found2:=t; 1006 l:=cdr l>>$ 1007 1008 if largest_fully_shortened and null found1 then 1009 largest_fully_shortened:=if null l1 then nil 1010 else car l1; 1011 if currently_to_be_substituted_in and null found2 then 1012 largest_fully_shortened:=s$ 1013 1014 l1:=append(reverse l1,cons(s,l))$ 1015 >> else if not_included(l,cadr l1) then l1:=cadr l1 1016 else l1:=nil$ 1017 return l1$ 1018end$ 1019 1020symbolic procedure not_included(a,b)$ 1021% meaning: not_all_a_in_b = setdiff(a,b) 1022% Are all elements of a also in b? If yes then return nil else t 1023% This could be done with setdiff(a,b), only setdiff 1024% copies expressions and needs extra memory whereas here we only 1025% want to know one bit (included or not) 1026begin scalar c$ 1027 c:=t; 1028 while a and c do << 1029 c:=b; 1030 while c and ((car a) neq (car c)) do c:=cdr c; 1031 % if c=nil then car a is not in b 1032 a:=cdr a; 1033 >>; 1034 return if c then nil 1035 else t 1036end$ 1037 1038%symbolic procedure follows_from(p,pdes)$ 1039%% determines whether the equation p=0 follows straight forwardly from 1040%% the list of equation names pdes 1041%begin scalar p1,follows$ 1042% if pairp p and (car p='times) then p:= cdr p 1043% else p:=list p$ 1044% while pdes do << 1045% if pairp(p1:=get(car pdes,'val)) and (car p1='times) then p1:=cdr p1 1046% else p1:=list p1$ 1047% if null not_included(p1,p) % p is a consequence of car pdes 1048% then <<follows:=t; pdes:=nil>> 1049% else pdes:=cdr pdes 1050% >>$ 1051% return follows 1052%end$ 1053 1054symbolic procedure follows_fromSQ(pfac,pdes)$ 1055% determines whether the equation p=0 where p is a product of all elements 1056% of pfac follows straight forwardly from the list of equation names pdes 1057begin scalar p1,follows$ 1058 while pdes do << 1059 if not pairp(p1:=get(car pdes,'fac)) then p1:=list get(car pdes,'sqval)$ 1060 if null not_included(p1,pfac) % pfac is a consequence of car pdes 1061 then <<follows:=t; pdes:=nil>> 1062 else pdes:=cdr pdes 1063 >>$ 1064 return follows 1065end$ 1066 1067%symbolic procedure proddel(s,l)$ 1068%% delete all pdes from l with s as factor 1069%% delete s if it is a consequence of any known pde from l 1070%begin scalar l1,l2,l3,n,lnew,pdes,s_hist$ 1071% if pairp(lnew:=get(s,'val)) and (car lnew='times) then lnew:=cdr lnew 1072% else lnew:=list lnew$ 1073% n:=length lnew$ 1074% pdes:=l$ 1075% while l do << 1076% if pairp(l1:=get(car l,'val)) and (car l1='times) then l1:=cdr l1 1077% else l1:=list l1$ 1078% if n<length l1 then % s has less factors than car l 1079% if not_included(lnew,l1) then 1080% l2:=cons(car l,l2) % car l is not a consequ. of s 1081% else 1082% <<l3:=cons(car l,l3); % car l is a consequ. of s 1083% drop_pde(car l,nil,{'quotient,{'times,s,get(car l,'val)},get(s,'val)}) 1084% >> 1085% else << 1086% if null not_included(l1,lnew) then % s is a consequence of car l 1087% <<if print_ then <<terpri()$write s," is a consequence of ",car l,".">>$ 1088% % one could stop here but continuation can still be useful 1089% if null s_hist then s_hist:={'quotient, 1090% {'times,car l,get(s,'val)}, 1091% get(car l,'val) }$ 1092% >>$ 1093% % else 1094% if null l3 or (car l3 neq car l) then l2:=cons(car l,l2)$ 1095% >>; 1096% l:=cdr l 1097% >>$ 1098% if print_ and l3 then << 1099% listprint l3$ 1100% if cdr l3 then write " are consequences of ",s 1101% else write " is a consequence of ",s; 1102% terpri()$ 1103% >>$ 1104% if s_hist then <<drop_pde(s,nil,s_hist);s:=nil>>$ 1105% return list(s,reverse l2)$ 1106%end$ 1107 1108 1109symbolic procedure proddel_SQ(s,l)$ 1110% delete all pdes from l with s as factor 1111% delete s if it is a consequence of any known pde from l 1112begin scalar l1,l2,l3,n,lnew,pdes,s_hist$ 1113 if not pairp(lnew:=get(s,'fac)) then lnew:=list get(s,'sqval); 1114 n:=length lnew$ 1115 pdes:=l$ 1116 while l do << 1117 if not pairp(l1:=get(car l,'fac)) then l1:=list get(car l,'sqval); 1118 if n<length l1 then % s has less factors than car l 1119 if not_included(lnew,l1) then 1120 l2:=cons(car l,l2) % car l is not a consequ. of s 1121 else 1122 <<l3:=cons(car l,l3); % car l is a consequ. of s 1123 drop_pde(car l,nil, 1124 reval {'!*sq,quotsq(multsq(simp s,get(car l,'sqval)), 1125 get(s,'sqval)),t}) 1126 >> 1127 else << 1128 if null not_included(l1,lnew) then % s is a consequence of car l 1129 <<if print_ then <<terpri()$write s," is a consequence of ",car l,".">>$ 1130 % one could stop here but continuation can still be useful 1131 if null s_hist then 1132 s_hist:=quotsq(multsq(simp car l,get(s,'sqval)),get(car l,'sqval))$ 1133 >>$ 1134 % else 1135 if null l3 or (car l3 neq car l) then l2:=cons(car l,l2)$ 1136 >>; 1137 l:=cdr l 1138 >>$ 1139 if print_ and l3 then << 1140 listprint l3$ 1141 if cdr l3 then write " are consequences of ",s 1142 else write " is a consequence of ",s; 1143 terpri()$ 1144 >>$ 1145 if s_hist then << 1146 drop_pde(s,nil,reval {'!*sq,s_hist,t});s:=nil>>$ 1147 return list(s,reverse l2)$ 1148end$ 1149 1150symbolic procedure clean_hist$ 1151begin scalar h,newh; 1152 h:=reverse history_; 1153 while h do 1154 if car h='s or car h='ph or car h='po then h:=cdr h else 1155 if car h='t and cdr h and cadr h='t then h:=cddr h else 1156 if car h='t and cdr h and cadr h='e and cddr h and caddr h='t then h:=cdddr h else 1157 % To drop the following unsuccessfull command it depends on whether expert 1158 % mode (t) is on or off, i.e. how many list elements can be dropped, i.e. 1159 % one would need to keep track of how often t was issued. 1160 %if (cdr h) and (cadr h = 'ig) and (cddr h) and 1161 % ((caddr h = "*** Invalid input.") or 1162 % ((fixp car h) and 1163 % (caddr h=bldmsg("*** %w un-succ.", 1164 % nth(full_proc_list_,car h))))) then h:=cdddr h else 1165 << 1166 newh:=cons(car h,newh); 1167 h:=cdr h 1168 >>; 1169 return newh 1170end$ 1171 1172symbolic procedure unsucc(s)$ 1173<<s:=reverse explode s; 1174 if car s = '!" and 1175 cadr s = '!. and 1176 cddr s and 1177 caddr s = 'c and 1178 cdddr s and 1179 cadddr s = 'c then t 1180 else nil 1181>>$ 1182 1183symbolic procedure pri_hist(l)$ 1184begin scalar w,j$ 1185 l:=reverse l$ 1186 while l do << 1187 w:=nil$ 1188 if j then j:=not j else 1189 if (car l = 'cm) or (car l = 'gs) or 1190 (car l = 'r ) or (car l = '44) or 1191 ((car l = 'ig) and null (cdr l and unsucc cadr l)) or << 1192 if null cdr l then nil else 1193 if null cddr l then nil else 1194 unsucc caddr l 1195 >> then <<j:=t;terpri()>> else j:=nil;$ 1196 prin1 car l$ 1197 if unsucc car l then <<j:=t;terpri()>> 1198 else <<j:=nil;prin2 " ">>$ 1199 l:=cdr l 1200 >> 1201end$ 1202 1203symbolic procedure myprin2l(l,trenn)$ 1204% myprin2l(l," ") = prin2l(l) , CSL does not have prin2l. 1205if l then 1206 <<if pairp l then 1207 while l do 1208 <<write car l$ 1209 l:=cdr l$ 1210 if l then write trenn>> 1211 else write l>>$ 1212 1213symbolic procedure print_stars(s)$ 1214begin scalar b,star,pv,cs$ 1215 pv:=pairp get(s,'fac)$ 1216 cs:=get(s,'case2sep)$ 1217 star:=get(s,'starde)$ 1218 if star or pv or cs then << 1219 write "("$ 1220 if pv then write"#"$ 1221 if cs then write"!"$ 1222 if star then for b:=1:(1+caar star) do write"*"$ 1223 write")"$ 1224 >>$ 1225end$ 1226 1227symbolic procedure typeeq(s)$ 1228% print equation 1229if (null print_) or (get(s,'printlength)>print_) then begin scalar a,b$ 1230 print_stars(s); 1231 write " ",(a:=get(s,'terms))," terms,"$ 1232 if a neq (b:=get(s,'length)) then write" ",b," factors,"$ 1233 write" with "$ 1234 if get(s,'vars) then write"derivatives" else write"powers: "$ 1235 if get(s,'starde) then << 1236 write": "$ terpri()$ 1237 print_derivs(s,nil)$ 1238 >> else << 1239 if (a:=get(s,'vars)) then <<write" of functions of all ",length a, 1240 " variables: "$ 1241 listprint get(s,'vars) 1242 >>$ 1243 terpri()$ 1244 print_derivs(s,t)$ 1245 >> 1246end else 1247mathprint list('equal,0,{'!*sq,get(s,'sqval),t})$ 1248 1249symbolic procedure print_derivs(p,allvarf)$ 1250begin scalar a,d,dl,avf; 1251 dl:=get(p,'derivs)$ 1252 if allvarf then << 1253 avf:=get(p,'allvarfcts); 1254 for each d in dl do 1255 if not freeoflist(d,avf) then a:=cons(d,a); 1256 dl:=reverse a 1257 >>$ 1258 dl:=for each d in dl collect << 1259 a:=if null cdar d then caar d 1260 else cons('df,car d); 1261 if cdr d=1 then a else {'expt,a,cdr d} 1262 >>$ 1263 mathprint cons('! ,dl); 1264 dl:=get(p,'non_rat_kern)$ 1265 if dl then mathprint cons('list,dl)$ 1266 1267% write dl % hard to read 1268end$ 1269 1270symbolic procedure type_pre_ex(p)$ 1271% p is an expression in prefix form 1272if print_ then mathprint 1273if pairp p and 1274 (((car p = 'PLUS ) and ( length p > print_ )) or 1275 ((car p = 'QUOTIENT) and ((length cadr p > print_) or 1276 (length caddr p > print_) )) ) 1277then bldmsg("%w%d%w"," ",no_of_tm_sf numr p," terms ") 1278else p$ 1279 1280symbolic procedure type_sq_ex(p)$ 1281% p is an expression in SQ form 1282if print_ then mathprint 1283if (delengthSQ p > print_) 1284then bldmsg("%w%d%w"," ",no_of_tm_sf numr p," terms ") 1285else {'!*sq,p,t}$ 1286 1287symbolic procedure typeeqlist(l)$ 1288% print equations and their property lists 1289<<terpri()$ 1290for each s in l do 1291 <<terpri()$ 1292 write s," : "$ 1293 if not print_all then typeeq(s) 1294 else 1295 if (null print_) or (get(s,'printlength)>print_) then 1296 <<write get(s,'terms)," terms"$terpri()>> else 1297 mathprint list('equal,0,{'!*sq,get(s,'sqval),t})$ 1298 if print_all then << 1299 write " derivs : "$ 1300 terpri()$print_derivs(s,nil)$ 1301 terpri()$write " derivs(raw) : ",get(s,'derivs)$ 1302 terpri()$write " fac : "$ 1303 if pairp get(s,'fac) then << 1304 terpri()$ 1305 mathprint cons('list,for each f in get(s,'fac) collect 1306 if (null print_) or 1307 (delengthSQ f > print_) then 1308 bldmsg("%w%d%w"," ",no_of_tm_sf numr f," terms ") 1309% {'list,no_of_tm_sf numr f," terms"} 1310 else {'!*sq,f,t}); 1311% for each f in get(s,'fac) do 1312% if (null print_) or (delengthSQ f > print_) then 1313% <<write no_of_tm_sf numr f," terms"$terpri()>> else 1314% mathprint list('equal,0,{'!*sq,f,t})$ 1315 >> else write get(s,'fac)$ 1316 terpri()$write " pval : ",get(s,'pval)$ 1317% if get(s,'pval) then "assigned" 1318% else "not assigned"$ 1319% terpri()$write " sqval : ",get(s,'sqval)$ 1320% terpri()$write " fac : ",get(s,'fac)$ 1321% terpri()$write " pval : ",get(s,'pval)$ 1322 terpri()$write " partitioned : ",if get(s,'partitioned) then 1323 "not nil" else 1324 "nil"$ 1325 terpri()$write " kern : ",get(s,'kern)$ 1326 terpri()$write " non_rat_kern : ",get(s,'non_rat_kern)$ 1327 terpri()$write " fct_kern_lin : ",get(s,'fct_kern_lin)$ 1328 terpri()$write " fct_kern_nli : ",get(s,'fct_kern_nli)$ 1329 terpri()$write " fcts : ",get(s,'fcts)$ 1330 terpri()$write " fct_hom : ",get(s,'fct_hom)$ 1331 terpri()$write " vars : ",get(s,'vars)$ 1332 terpri()$write " nvars : ",get(s,'nvars)$ 1333 terpri()$write " level : ",get(s,'level)$ 1334 terpri()$write " terms : ",get(s,'terms)$ 1335 terpri()$write " length : ",get(s,'length)$ 1336 terpri()$write " printlength : ",get(s,'printlength)$ 1337 terpri()$write " rational : ",get(s,'rational)$ 1338 terpri()$write " nonrational : ",get(s,'nonrational)$ 1339 terpri()$write " allvarfcts : ",get(s,'allvarfcts)$ 1340% terpri()$write " degrees : ",get(s,'degrees)$ 1341 terpri()$write " starde : ",get(s,'starde)$ 1342 terpri()$write " fcteval_lin : ",get(s,'fcteval_lin)$ 1343 terpri()$write " fcteval_nca : ",get(s,'fcteval_nca)$ 1344 terpri()$write " fcteval_nli : ",get(s,'fcteval_nli)$ 1345 terpri()$write " fcteval_n2l : ",get(s,'fcteval_n2l)$ 1346 terpri()$write " fct_nli_lin : ",get(s,'fct_nli_lin)$ 1347 terpri()$write " fct_nli_nca : ",get(s,'fct_nli_nca)$ 1348 terpri()$write " fct_nli_nli : ",get(s,'fct_nli_nli)$ 1349 terpri()$write " fct_nli_nus : ",get(s,'fct_nli_nus)$ 1350 terpri()$write " rl_with : ",get(s,'rl_with)$ 1351 terpri()$write " dec_with : ",get(s,'dec_with)$ 1352 terpri()$write " dec_with_rl : ",get(s,'dec_with_rl)$ 1353 terpri()$write " res_with : ",get(s,'res_with)$ 1354 terpri()$write " to_int : ",flagp(s,'to_int)$ 1355 terpri()$write " to_fullint : ",flagp(s,'to_fullint)$ 1356 terpri()$write " to_sep : ",flagp(s,'to_sep)$ 1357 terpri()$write " to_casesep : ",flagp(s,'to_casesep)$ 1358 terpri()$write " to_gensep : ",flagp(s,'to_gensep)$ 1359 terpri()$write " to_casegensep : ",flagp(s,'to_casegensep)$ 1360 terpri()$write " to_decoup : ",flagp(s,'to_decoup)$ 1361 terpri()$write " to_drop : ",flagp(s,'to_drop)$ 1362 terpri()$write " to_eval : ",flagp(s,'to_eval)$ 1363 terpri()$write " to_diff : ",flagp(s,'to_diff)$ 1364 terpri()$write " to_under : ",flagp(s,'to_under)$ 1365 terpri()$write " to_separant : ",flagp(s,'to_separant)$ 1366 terpri()$write " not_to_eval : ",get(s,'not_to_eval)$ 1367 terpri()$write " used_ : ",flagp(s,'used_)$ 1368 terpri()$write " orderings : ",get(s,'orderings)$ 1369 terpri()$write " split_test : ",get(s,'split_test)$ 1370 terpri()$write " linear_ : ",get(s,'linear_)$ 1371 terpri()$write " histry_ : ",get(s,'histry_)$ 1372 terpri()$write " hom_deg : ",get(s,'hom_deg)$ 1373 terpri()$write " case2sep : ",get(s,'case2sep)$ 1374% if fhom_ then << 1375% terpri()$write " hom_deg : ",get(s,'hom_deg) 1376% >>$ 1377 terpri()>> 1378 >> >>$ 1379 1380 1381symbolic procedure rationalp(p,f)$ 1382% tests if p (in prfix form) is rational in f and its derivatives 1383% currently (June 2007) only called from crint.red --> prefix input 1384not pairp p 1385or 1386((car p='quotient) and 1387 polynop(cadr p,f) and polynop(caddr p,f)) 1388or 1389((car p='equal) and 1390 rationalp(cadr p,f) and rationalp(caddr p,f)) 1391or 1392polynop(p,f)$ 1393 1394 1395symbolic procedure ratexp(p,ftem)$ 1396% tests if p (in prfix form) is rational in f of ftem and their derivatives 1397% currently (June 2007) only called from crint.red --> prefix input 1398if null ftem then t 1399 else if rationalp(p,car ftem) then ratexp(p,cdr ftem) 1400 else nil$ 1401 1402 1403symbolic procedure polynop(p,f)$ 1404% tests if p (in prefix form) is a polynomial in f and its derivatives 1405% p: expression 1406% f: function 1407if atom p then t else 1408if (pairp p) and (car p = 'df) and (atom cadr p) then t else 1409if my_freeof(p,f) then t else 1410begin scalar a$ 1411 if member(car p,list('expt,'plus,'minus,'times,'quotient,'df)) then 1412 % erlaubte Funktionen 1413 <<if (car p='plus) or (car p='times) then 1414 <<p:=cdr p$ 1415 while p do 1416 if a:=polynop(car p,f) then p:=cdr p 1417 else p:=nil>> 1418 else if (car p='minus) then 1419 a:=polynop(cadr p,f) 1420 else if (car p='quotient) then 1421 <<if freeof(caddr p,f) then a:=polynop(cadr p,f)>> 1422 else if car p='expt then % Exponent 1423 <<if (fixp caddr p) then 1424 if caddr p>0 then a:=polynop(cadr p,f)>> 1425 else if car p='df then % Ableitung 1426 if (cadr p=f) or freeof(cadr p,f) then a:=t>> 1427 else a:=(p=f)$ 1428 return a 1429end$ 1430 1431symbolic procedure stardep3(vl,ker,drv)$ 1432% If there is a variable v which does not occur explicitly and only one 1433% function with only one derivative df occurs then (df . v) is returned else nil 1434begin scalar v,dfc, % the function or derivative (without df) 1435 dfcp, % the exponent 1436 drvcp, % a copy of drv 1437 caa$ 1438 while vl and null dfc do << 1439 v:=car vl; vl:=cdr vl; 1440 if freeof(ker,v) then << 1441 drvcp:=drv; 1442 while drvcp do << 1443 caa:=caar drvcp; % e.g. caa = (h x) 1444 if caa=dfc then if cdar drvcp>dfcp then dfcp:=cdar drvcp else 1445 else % car drv is a different power of dfc 1446 if member(v,fctargs car caa) then % car caar depends on v 1447 if null dfc then <<dfc:=caa;dfcp:=cdar drvcp>> else <<drvcp:={1}; dfc:=nil>>; 1448 drvcp:=cdr drvcp; 1449 >> 1450 >> 1451 >>$ 1452 return if (null dfc) or (dfcp=1) then nil else 1453 if null cdr dfc then cons(car dfc,v) else cons(mvar car mksq(cons('df,dfc),1),v) 1454end$ 1455 1456 1457symbolic procedure starp(ft,n)$ 1458% yields t if 1459% - one function is known to depend on one variable 1460% - and this variable does only come up in this function, 1461% not explicitly nor in any other function, or 1462% if all functions from ft have less than n arguments 1463begin scalar b$ 1464 while not b and ft do % searching a fct of all vars 1465 if fctlength car ft=n then b:=t 1466 else ft:=cdr ft$ 1467 return not b 1468end$ 1469 1470 1471% replaced by sep_var below giving more information 1472%symbolic procedure stardep(ftem,vl)$ 1473%% yields: nil, if a function (from ftem) in p depends 1474%% on all variables (from vl) 1475%% cons(v,n) otherwise, with v being the list of variables 1476%% which occur in a minimal number of n functions 1477%if vl then 1478%begin scalar b,v,n$ 1479% if starp(ftem,length vl) then 1480% <<n:=sub1 length ftem$ 1481% while vl do % searching var.s on which depend 1482% % a minimal number of functions 1483% <<if n> (b:=for each h in ftem sum 1484% if member(car vl,fctargs h) then 1 else 0) 1485% then <<n:=b$v:=list car vl>> % a new minimum 1486% else if b=n then v:=cons(car vl,v)$ 1487% vl:=cdr vl>> >>$ 1488% return if v then cons(v,n) % on each varible from v depend n 1489% % functions 1490% else nil 1491%end$ 1492 1493 1494symbolic procedure sep_var(ftem,vl)$ 1495% input: ftem are all the functions occuring in an equation 1496% and vl are all the variables occuring in that equation 1497% yields: nil if one function depends on all variables else 1498% a list ((n1 . v1) (n2 . v2) (n3 . v3)...) 1499% where vi are variables which do not occur in all 1500% functions ftem and ni is the number of functions of vi 1501% entries are sorted for increasing ni 1502if vl then 1503begin scalar n,f,fv,v,s$ 1504 if null starp(ftem,length vl) then return nil; 1505 fv:=for each f in ftem collect fctargs f$ 1506 for each v in vl do << 1507 n:=for each f in fv sum if member(v,f) then 1 else 0; 1508 s:=cons((n . v),s) 1509 >>$ 1510 return idx_sort(s) 1511end$ 1512 1513 1514%symbolic procedure no_of_sep_var(ftem)$ 1515%% assuming ftem are all functions from an ise 1516%% How many are there indirectly separable variables? 1517%% If just two then the new indirect separation is possible 1518%begin scalar v,vs$ 1519% vl:=argset(ftem); 1520% for each f in ftem do 1521% vs:=union(setdiff(vl,fctargs f),vs)$ 1522% return vs 1523%end$ 1524 1525put('parti_fn,'psopfn,'parti_fncts)$ 1526 1527symbolic procedure parti_fncts(inp)$ 1528% inp= (fl,el) 1529% fl ... alg. list of functions, el ... alg. list of equations 1530% partitions fl such that all functions that are somehow dependent on 1531% each other through equations in el are grouped in lists, 1532% returns alg. list of these lists 1533 1534if length inp neq 2 then << 1535 terpri()$ 1536 write"PARTI_FNCTS DOES NOT HAVE 2 ARGUMENTS."$ 1537>> else 1538begin 1539 scalar fl,f1,f2,f3,f4,f5,el,e1,e2; 1540 1541 fl := cdr reval car inp$ 1542 el := cdr aeval cadr inp$ 1543 1544 while fl do << 1545 f1:=nil; % f1 is the sublist of functions depending on each other 1546 f2:=list car fl; % f2 ... func.s to be added to f1, not yet checked 1547 fl:=cdr fl; 1548 while f2 and fl do << 1549 f3:=car f2; f2:=cdr f2; 1550 f1:=cons(f3,f1); 1551 for each f4 in 1552 % smemberl will be all functions not registered yet that occur in 1553 % an equation in which the function f3 occurs 1554 smemberl(fl, % fl ... the remaining functions not known yet to depend 1555 <<e1:=nil; % equations in which f3 occurs 1556 for each e2 in el do 1557 if smember(f3,e2) then e1:=cons(e2,e1); 1558 e1 1559 >> 1560 ) do << 1561 f2:=cons(f4,f2); 1562 fl:=delete(f4,fl) 1563 >> 1564 >>; 1565 if f2 then f1:=append(f1,f2); 1566 f5:=cons(cons('list,f1),f5) 1567 >>; 1568 return cons('list,f5) 1569end$ 1570 1571 1572symbolic procedure plot_dependencies(pdes)$ 1573begin scalar fl$ 1574 change_prompt_to ""$ 1575 fl:=ftem_; 1576 if flin_ and yesp 1577 "Shall only functions from the linear list flin_ be considered? " 1578 then fl:=setdiff(fl,setdiff(fl,flin_))$ 1579 restore_interactive_prompt()$ 1580 plot_dep_matrix(pdes,fl) 1581end$ 1582 1583fluid '(!*gc)$ 1584 1585symbolic procedure plot_dep_matrix(pdes,allf)$ 1586begin scalar f,ml,lf,fl,h,lh,lco,n,m,ll,gcbak; 1587 1588 gcbak:=!*gc$ 1589 if gcbak then algebraic(off gc)$ 1590 1591 ml:=0; % the maximal length of all variable names 1592 lf:=length allf$ 1593 for each f in reverse allf do << 1594 h:=explode f; 1595 lh:=length h; 1596 if lh>ml then ml:=lh; 1597 lco:=cons(h,lco); 1598 >>$ 1599 1600 ll:=linelength (lf+6); 1601 terpri()$ 1602 write "Horizontally: function names (each vertical), ", 1603 "Vertically: equation indices"$ 1604 terpri()$ 1605 1606 % print the variable names 1607 for n:=1:ml do << 1608 terpri()$ write" "$ 1609 for m:=1:lf do write << 1610 h:=nth(lco,m); 1611 if n>length h then " " 1612 else nth(nth(lco,m),n) 1613 >> 1614 >>$ 1615 1616 m:=add1 add1 ml; 1617 terpri()$terpri()$ 1618 for each p in pdes do 1619 if m>=0 then << 1620 h:=explode p; 1621 for n:=3:length h do write nth(h,n); 1622 for n:=(sub1 length(h)):5 do write" "$ 1623 fl:=get(p,'fcts); 1624 if (not get(p,'fcteval_lin)) and 1625 (not get(p,'fcteval_nca)) and 1626 (not get(p,'fcteval_nli)) then fcteval(p)$ % for writing "s" 1627 for each f in allf do 1628 if freeof(fl,f) then write" " else 1629 if solvable_case(p,f,'fcteval_lin) or 1630 solvable_case(p,f,'fcteval_nca) then write"s" 1631 else write"+"$ 1632 terpri()$ 1633 m:=add1 m$ 1634% if m=23 then if not yesp "Continue ?" then m:=-1 1635% else m:=0 1636 >>$ 1637 if gcbak then algebraic(on gc)$ 1638 linelength ll 1639end$ 1640 1641symbolic procedure plot_statistics(size_history)$ 1642begin scalar s,h,k,n,pl,sf,tl,proli,plcp,newplcp, 1643 time_offset,next_time,old_time,mint,maxt,quick, 1644 maxmeth,maxfl,maxpdes,maxterms,maxfactperterm,maxcells, 1645 a,save,ofl!*bak; 1646 change_prompt_to ""$ 1647 1648 h:=size_history; 1649 while h do << 1650 k:=car h; h:=cdr h; 1651 if car k = 'CP then 1652 if null plcp then plcp:=cdr k 1653 else << % merge plcp and cdr k 1654 newplcp:=nil; 1655 k:=cdr k; 1656 while k or plcp do << 1657 if k and not freeof(newplcp,car k) then k:=cdr k else 1658 if plcp and not freeof(newplcp,car plcp) then plcp:=cdr plcp else 1659 if null k then << 1660 newplcp:=cons(car plcp,newplcp); 1661 plcp:=cdr plcp 1662 >> else 1663 if null plcp then << 1664 newplcp:=cons(car k,newplcp); 1665 k:=cdr k 1666 >> else 1667 if car k = car plcp then << 1668 newplcp:=cons(car k,newplcp); 1669 k:=cdr k;plcp:=cdr plcp 1670 >> else 1671 if freeof(k,car plcp) then << 1672 newplcp:=cons(car plcp,newplcp); 1673 plcp:=cdr plcp 1674 >> else 1675 if freeof(plcp,car k) then << 1676 newplcp:=cons(car k,newplcp); 1677 k:=cdr k 1678 >> else << 1679 newplcp:=cons(car k,cons(car plcp,newplcp)); 1680 k:=cdr k;plcp:=cdr plcp 1681 >> 1682 >>; 1683 plcp:=reverse newplcp 1684 >> 1685 >>$ 1686 1687 s:=0; 1688 while plcp do << 1689 s:=add1 s; 1690 proli:=cons(cons(car plcp,s),proli)$ 1691 plcp:=cdr plcp 1692 >>$ 1693 1694 maxmeth:=0; 1695 maxfl:=0$ 1696 maxpdes:=0; 1697 maxterms:=0; 1698 maxfactperterm:=0; 1699 maxcells:=0; 1700 proli:=reverse proli$ 1701 time_offset:=0$ 1702 old_time:=-1$ 1703 s:="schrott.tmp"$ 1704 %out s; 1705 a:=open(s, 'output); 1706 ofl!*bak:=ofl!*$ 1707 ofl!*:=s$ % any value neq nil, to avoid problem with redfront 1708 save:=wrs a; 1709 1710 for each h in reverse size_history do 1711 if (fixp car h) and (cdddr cdddr h) % nothing is missing 1712 then << 1713 if old_time=-1 then old_time:=caddr h$ 1714 next_time:=time_offset+caddr h$ 1715 if next_time<old_time then << 1716 time_offset:=time_offset+(old_time-next_time); 1717 next_time:=old_time 1718 >>$ 1719 write next_time," ", % time 1720 if (n:=assoc(car h,proli)) then cdr n 1721 else 0," ", % method 1722 cadddr h," ", % # of remaining unknowns 1723 cadddr cdr h," ", % # of pdes 1724 cadddr cddr h," ", % # of terms 1725 cadddr cdddr h," ",% total length of pdes 1726 cadddr cddddr h$ % last_free_cells 1727 % cadr h," ", % stepcounter_ 1728 old_time:=next_time$ 1729 if n and cdr n>maxmeth then maxmeth:=cdr n; 1730 if cadddr h>maxfl then maxfl:=cadddr h; 1731 if cadddr cdr h>maxpdes then maxpdes:=cadddr cdr h; 1732 if cadddr cddr h>maxterms then maxterms:=cadddr cddr h; 1733 if (100*(cadddr cdddr h)) > maxfactperterm*(cadddr cddr h) then 1734 maxfactperterm:=(100*(cadddr cdddr h))/(cadddr cddr h); 1735 if (fixp cadddr cddddr h) and 1736 (cadddr cddddr h>maxcells) then maxcells:=cadddr cddddr h; 1737 terpri()$ 1738 >>$ 1739 %shut s; 1740 wrs save$ 1741 ofl!*:=ofl!*bak$ 1742 close a; 1743 1744 pl:=nil$ 1745 if yesp "Do you want a quick overview on the screen? " then quick:=t$ 1746 if quick then << 1747 terpri()$ 1748 write"Here are the maximal values scaled to 1 in the diagram:"$terpri()$ 1749 % write"max method index: ",maxmeth$terpri()$ 1750 write"max # of unknows: ",maxfl$terpri()$ 1751 write"max # of equations: ",maxpdes$terpri()$ 1752 write"max # of terms: ",maxterms$terpri()$ 1753 write"max # of factors/term: ",maxfactperterm,"/100"$terpri()$ 1754 write"max # of free cells: ",maxcells$terpri()$ 1755 1756 % If the method shall be plotted then these 4 lines: 1757 %pl:=bldmsg("%w%w%w%d%w", 1758 % "plot '",s,"' using ($1/60000):($2/",maxmeth ,") title ""method :"" with lines"); 1759 %pl:=bldmsg("%w%w%w%w%d%w",pl, 1760 % ", '",s,"' using ($1/60000):($3/",maxfl ,") title ""unknowns :"" with lines"); 1761 % else the following 4 lines: 1762 pl:=bldmsg("%w", 1763 "plot '")$ 1764 pl:=bldmsg("%w%w%w%d%w",pl, 1765 s,"' using ($1/60000):($3/",maxfl ,") title ""unknowns :"" with lines"); 1766 1767 pl:=bldmsg("%w%w%w%w%d%w",pl, 1768 ", '",s,"' using ($1/60000):($4/",maxpdes ,") title ""equations :"" with lines"); 1769 pl:=bldmsg("%w%w%w%w%d%w",pl, 1770 ", '",s,"' using ($1/60000):($5/",maxterms,") title ""all terms :"" with lines"); 1771 pl:=bldmsg("%w%w%w%w%d%w",pl, 1772 ", '",s,"' using ($1/60000):(100*$6/$5/",maxfactperterm ,") title ""factors/term:"" with lines"); 1773 pl:=bldmsg("%w%w%w%w%d%w",pl, 1774 ", '",s,"' using ($1/60000):($7/",maxcells,") title ""free cells :"" with lines"); 1775 pl:=bldmsg("%w%w%w%w",pl, 1776 ", '",s,"' using ($1/60000):(0) title ""step :"""); 1777 >> else 1778 repeat << 1779 write"Do you want to add to the plot a graph for the "$terpri()$ 1780 write" - method used at each step: 1"$terpri()$ 1781 write" - number of unknowns: 2"$terpri()$ 1782 write" - number of pdes: 3"$terpri()$ 1783 write" - number of terms: 4"$terpri()$ 1784 write" - number of factors/term: 5"$terpri()$ 1785 write" - number of last free cells: 6"$terpri()$ 1786 write"or add no further graphs: n "$ 1787 h:=termread()$ 1788 if (h=1) or (h=2) or (h=3) or (h=4) or (h=5) or (h=6) then << 1789 write"What is the scaling factor for this graph? "$ 1790 repeat sf:=termread() until fixp sf$ 1791 if null pl then pl:="plot " 1792 else pl:=bldmsg("%w%w",pl,",")$ 1793 if h=1 then pl:=bldmsg("%w%w%w%w%d%w",pl,"'",s,"' using ($1/60000):(", 1794 sf,"*$2) title ""method :""") else 1795 if h=2 then pl:=bldmsg("%w%w%w%w%d%w",pl,"'",s,"' using ($1/60000):(", 1796 sf,"*$3) title ""unknowns :""") else 1797 if h=3 then pl:=bldmsg("%w%w%w%w%d%w",pl,"'",s,"' using ($1/60000):(", 1798 sf,"*$4) title ""equations :""") else 1799 if h=4 then pl:=bldmsg("%w%w%w%w%d%w",pl,"'",s,"' using ($1/60000):(", 1800 sf,"*$5) title ""all terms :""") else 1801 if h=5 then pl:=bldmsg("%w%w%w%w%d%w",pl,"'",s,"' using ($1/60000):(", 1802 sf,"*$6/$5) title ""factors/term:""") else 1803 if h=6 then pl:=bldmsg("%w%w%w%w%d%w",pl,"'",s,"' using ($1/60000):(", 1804 sf,"*$7) title ""free cells :""")$ 1805 >>$ 1806 >> until h='N$ 1807 1808 % Generating the headline 1809 tl:="set title ""Modules in order of their priority: "$ 1810 for each h in proli do tl:=bldmsg("%w%d%w",tl,car h," "); 1811 tl:=bldmsg("%w%w",tl,""" ")$ 1812 algebraic(gnuplot(lisp tl)); 1813 1814 if quick or 1815 yesp "Do you want the x-range to be determined automatically? " then << 1816 algebraic(gnuplot("set autoscale x")); 1817 algebraic(gnuplot("set autoscale y")); 1818 >> else << 1819 write "What is the minimal value of x (time in minutes) ? "$ 1820 mint:=termread()$ %mint:=mint*60000$ 1821 write "What is the maximal value of x (time in minutes) ? "$ 1822 maxt:=termread()$ %maxt:=maxt*60000$ 1823 tl:=bldmsg("%w%d%w%d%w","set xrange [",mint,":",maxt,"]")$ 1824 1825 algebraic(gnuplot("set noautoscale")); 1826 algebraic(gnuplot("set autoscale y")); 1827 % algebraic(gnuplot("set autoscale xmin")); 1828 % algebraic(gnuplot("set xrange [mint:maxt]")); 1829 algebraic(gnuplot(lisp tl)); 1830 >>$ 1831 1832 algebraic(gnuplot("set key Left")); 1833 1834 if quick or 1835 yesp "Do you want to display the plot on the screen? " then << 1836 >> else 1837 if yesp "Do you want to print the plot? " then << 1838 lisp setq(plotheader!*,""); 1839 algebraic(gnuplot("set output '|lpr -Pmath4'")); 1840 algebraic(gnuplot("set terminal postscript eps 22")); 1841 >> else << 1842 write"Give the file name in which to save the plot in "" "": "$ 1843 tl:=termread()$ 1844 tl:=bldmsg("%w%w%w","set output '",tl,"'")$ 1845 lisp setq(plotheader!*,""); 1846 algebraic(gnuplot(lisp tl)); 1847 algebraic(gnuplot("set terminal postscript eps 22")); 1848 >>$ 1849 algebraic(gnuplot(lisp pl))$ 1850 algebraic lisp null eval '(plotshow)$ 1851 1852 % doing: out s; shut s; gives an error with gnuplot 1853 restore_interactive_prompt() 1854end$ 1855 1856 1857symbolic operator plot_stat$ 1858symbolic procedure plot_stat$ 1859begin scalar s,ask$ 1860 change_prompt_to ""$ 1861 if null session_ then ask:=t else << 1862 write "Do you want to plot statistics of this session,"$ 1863 terpri()$ 1864 if not yesp "i.e. since loading CRACK the last time? " then ask:=t$ 1865 % terpri() 1866 >>$ 1867 if ask then << 1868 ask_for_session()$ 1869 setq(s,bldmsg("%w.%w",session_,"size_hist")); 1870 in s 1871 >>$ 1872 plot_statistics(size_hist); 1873 restore_interactive_prompt() 1874end$ 1875 1876 1877symbolic procedure list_cases(size_history)$ 1878begin scalar s,m,n,p,h,cntr,laststep,lastp,ll,sh$ 1879 ll:=linelength(250)$ 1880 change_prompt_to ""$ 1881 algebraic(off nat)$ 1882 1883 if size_watch neq t then << 1884 write"Warning: Because the parameter size_watch was set to ",size_watch$ 1885 terpri()$ 1886 write"(to save memory in long computations) only the last ",size_watch," steps"$ 1887 terpri()$ 1888 write"are recorded, i.e. early cases may be missing in this listing."$ 1889 terpri()$terpri()$ 1890 >>$ 1891 1892 write"Start"$ cntr:=0$laststep:=0$lastp:=nil$ 1893 n:=0; 1894 sh:=reverse size_history$ 1895 while sh do << 1896 p:=caar sh$ 1897 if p='A then << 1898 h:=laststep - cntr$ 1899 write" : ",h,if h=1 then " step" else " steps"$ 1900 terpri()$ 1901 cntr:=laststep$ 1902 n:=add1 n; 1903 h:=cadddr car sh$ 1904 s:=""$ 1905 for each m in caddr car sh do setq(s,bldmsg("%w%d",s,m)); 1906 write s$ 1907 if h then 1908 if atom h then write h 1909 else 1910 repeat << 1911 if caar h = 'equal then <<write" 0=" $maprin caddr car h>> else 1912 if caar h = 'ineq then <<write" 0<>"$maprin caddr car h>>; 1913 h:=cdr h; 1914 if h then << 1915 s:=""$ 1916 for each m in caddr car sh do setq(s,bldmsg("%w%w",s," ")); 1917 write s 1918 >> 1919 >> until null h 1920 >> else 1921 if p='Z then << 1922 n:=sub1 n; 1923 if lastp neq 'z then write", ",cadddr car sh," soln" 1924 >> else 1925 if numberp caar sh then laststep:=cadar sh$ 1926 1927 if (size_watch=t) and 1928 ((p='A) or (p='Z)) and 1929 (n neq length caddar sh) then 1930 <<write"Somthing is wrong with level counting in size_hist"$terpri()$ 1931 write"n=",n," level:",caddar sh$terpri()$ 1932 >>$ 1933 lastp:=p; 1934 sh:=cdr sh 1935 >>$ 1936 terpri()$ 1937 algebraic(on nat)$ 1938 restore_interactive_prompt()$ 1939 linelength(ll) 1940end$ 1941 1942symbolic procedure list_global_crack_variables$ 1943for each h in global_var do << 1944 terpri()$ 1945 write "variable: ",h$ terpri()$ 1946 write "value: "$ 1947 if h='backup_ or h='size_hist and eval h then write" as this value might be 1948 large, please print it in a separate command: pv ",h 1949 else write eval h$terpri()$ 1950 write"description: ",get(h,'description)$terpri()$ 1951 if freeof(not_passed_back,h) and 1952 freeof(passed_back,h) then <<write"not in not_passed_back, passed_back">>$ 1953 terpri() 1954>>$ 1955 1956symbolic procedure describe_id$ 1957begin scalar h,hh$ 1958 change_prompt_to ""$ 1959 write"Please enter the interactive command or "$terpri()$ 1960 write" the number of a module or "$terpri()$ 1961 write" the global variable: "$terpri()$ 1962 h:=termread()$ 1963 if fixp h then 1964 if (h<=0) or (h>length full_proc_list_) then << 1965 write"The number must be in 1 .. ",length full_proc_list_," ."$terpri() 1966 >> else << 1967 hh:=nth(full_proc_list_,h); 1968 if h<10 then write" "$ 1969 write h," : procedure: ",hh$terpri()$ write" description: "$ 1970 hh:=get(hh,'description)$ 1971 for each h in hh do write h 1972 >> else 1973 if member(h,global_var) then write h," (global variable): ",car get(h,'description) else << 1974 hh:=mkid('i_,h); 1975 if member(hh,global_var) then write h," (interactive command): ",car get(hh,'description) else << 1976 write h," is not a global variable and not a command."$ terpri()>> 1977 >> 1978end$ 1979 1980symbolic operator print_tree$ 1981symbolic procedure print_tree$ 1982% (a "Start of " (1 1 1 1 1 1 1 1 1 2 2) assumption) 1983% (z "Back to " (1 1 1 1 1 1 1 1 1 2) 1) 1984begin scalar s,ask$ 1985 change_prompt_to ""$ 1986 if null session_ then ask:=t else << 1987 write "Do you want to print the tree of cases of this session,"$ 1988 terpri()$ 1989 if not yesp "i.e. since loading CRACK the last time? " then ask:=t$ 1990 terpri() 1991 >>$ 1992 if ask then << 1993 ask_for_session()$ 1994 setq(s,bldmsg("%w.%w",session_,"size_hist")); 1995 in s 1996 >>$ 1997 list_cases(size_hist)$ 1998 restore_interactive_prompt() 1999end$ 2000 2001 2002symbolic procedure modify_proc_list(method,revsl)$ 2003% e.g.: method='choose_30_47_72 and revsl is the list of module 2004% names for 30,47,72 but in reverse order of order to be called 2005begin scalar plbak,plcop,ok$ 2006 2007 %******* Start of modification of proc_list_ ******* 2008 plbak:=proc_list_; 2009 2010 %*** copy everything before 'method' 2011 ok:=t$ 2012 while ok and proc_list_ and (car proc_list_ neq method) do 2013 if not freeof(revsl,car proc_list_) then << 2014 write"*** Mis-use of ",method$terpri()$ 2015 write"*** ",car proc_list_," came before ",method," in proc_list_ !"$ 2016 terpri()$ 2017 proc_list_:=plbak$ 2018 ok:=nil 2019 >> else << 2020 plcop:=cons(car proc_list_,plcop); 2021 proc_list_:=cdr proc_list_ 2022 >>; 2023 2024 if ok then << 2025 plcop:=cons(method,plcop); 2026 2027 % delete method from proc_list_ 2028 if proc_list_ then proc_list_:=cdr proc_list_; 2029 2030 % the crucial part: adding re-ordered procedures 2031 plcop:=append(revsl,plcop)$ 2032 2033 % jump the steps we re-order in the remainder of proc_list_ 2034 while proc_list_ and member(car proc_list_,revsl) do proc_list_:=cdr proc_list_; 2035 2036 % add the remainder 2037 while proc_list_ do << 2038 % if freeof(plcop,car proc_list_) then 2039 plcop:=cons(car proc_list_,plcop); 2040 proc_list_:=cdr proc_list_ 2041 >>; 2042 2043 proc_list_:=reverse plcop$ 2044 if print_more then << 2045 write"New proc_list_ based on ",method$terpri() 2046 >> 2047 >> 2048end$ % of modify_proc_list 2049 2050symbolic procedure choose_6_20(arglist)$ 2051comment 2052 This procedure is for automatic runs, not interactive use. 2053 It assumes that in proc_list_ the entry 'choose_6_20 is 2054 followed by either 'subst_level_45 (6) or 'subst_level_35 (20). 2055 If it is 6 and proc_list_ includes no 20 and if the problem is 2056 by now small enough then it is changed to 20 which is more 2057 aggressive and for large systems potentially explosive. The 2058 procedure uses the last entry of size_hist which is taken to 2059 be a list of elements 2060 {method 2061 stepcounter_, 2062 time(), 2063 number of remaining unknowns, 2064 number of pdes, 2065 number of terms, 2066 total length of pdes 2067 } 2068 If size_hist does not exist then data are actively gathered. 2069 2070 Parameters: 2071 Currently there are only: 2072 choose_6_20_max_ftem=20, choose_6_20_max_terms=4000 2073 2074 Improvements: 2075 One could make it dependent not only on #(ftem_) but #(ftem\flin_),... 2076 2077$ 2078if freeof(proc_list_,'subst_level_35) then begin 2079 scalar allterms,unkn,plbak,plcop,p,ok,shcop$ 2080 2081 % parameters: 2082 % choose_6_20_max_ftem:=20$ choose_6_20_max_terms:=4000$ 2083 % initialized in crinit.red 2084 2085 % obtaining values 2086 if size_watch then << 2087 shcop:=size_hist; 2088 while shcop and not fixp caar shcop do shcop:=cdr shcop 2089 >>$ 2090 if null shcop then << 2091 unkn:=length ftem_$ 2092 allterms:=for each p in car arglist sum get(p,'terms) 2093 >> else << 2094 unkn:=cadddr car shcop$ 2095 allterms:=cadddr cddar shcop 2096 >>$ 2097 2098 % changing proc_list_ 2099 if (unkn<=choose_6_20_max_ftem) and (allterms<=choose_6_20_max_terms) then << 2100 2101 % Start of modification of proc_list_ 2102 plbak:=proc_list_; 2103 2104 % copy everything before 'choose_6_20' 2105 ok:=t$ 2106 while ok and proc_list_ and (car proc_list_ neq 'choose_6_20) do 2107 if car proc_list_='subst_level_45 then << 2108 write"*** Mis-use of choose_6_20"$terpri()$ 2109 write"*** subst_level_45 came before choose_6_20 in proc_list_ !"$ 2110 terpri()$ 2111 proc_list_:=plbak$ 2112 ok:=nil 2113 >> else << 2114 plcop:=cons(car proc_list_,plcop); 2115 proc_list_:=cdr proc_list_ 2116 >>; 2117 if ok then << 2118 2119 % do not copy choose_6_20 and not subst_level_45 2120 if proc_list_ then proc_list_:=cddr proc_list_$ 2121 2122 % but include now subst_level_35 (20) 2123 plcop:=cons('subst_level_35,plcop)$ 2124 2125 % add the remainder 2126 while proc_list_ do << 2127 if freeof(plcop,car proc_list_) then plcop:=cons(car proc_list_,plcop); 2128 proc_list_:=cdr proc_list_ 2129 >>; 2130 2131 proc_list_:=reverse plcop$ 2132 if print_more then << 2133 write"proc_list_ has been automatically changed."$terpri()$ 2134 write"6 is changed to 20."$terpri() 2135 >> 2136 >> 2137 >> 2138 2139 % returns always nil 2140end$ 2141 2142 2143symbolic procedure choose_27_8_16(arglist)$ 2144comment 2145 This procedure is for automatic runs, not interactive use. 2146 It assumes that in proc_list_ the entry 'choose_27_8_16 2147 is followed by 'diff_length_reduction,'factorize_to_substitute,'subst_level_3 2148 in any order. The order of these 3 entries is freshly 2149 determined in this procedure on the basis of recent 2150 entries in size_hist which is taken to be a list of elements 2151 {method 2152 stepcounter_, 2153 time(), 2154 number of remaining unknowns, 2155 number of pdes, 2156 number of terms, 2157 total length of pdes 2158 } 2159 If anything goes wrong or anything unexpected happens then 2160 the order becomes 27,8,16. 2161 2162 Parameters: 2163 Currently there is only one parameter: choose_27_8_16_max 2164 2165 Improvements: 2166 One may want to have some rules what has a higher priority: 8 or 16. 2167 2168$ 2169begin 2170 scalar too_much_27,shcp,sh1,sh2,n,h,plbak,plcop,ok$ 2171 2172 if null size_watch then << 2173 write"*** choose_27_8_16 needs size_watch=t !"$terpri() 2174 >> else << 2175 shcp:=size_hist; 2176 while shcp and (not fixp caar shcp) do shcp:=cdr shcp; 2177 if shcp and (caar shcp=27) then << 2178 sh1:=car shcp; shcp:=cdr shcp; 2179 2180 while shcp and (not fixp caar shcp) do shcp:=cdr shcp; 2181 if shcp and (caar shcp=27) then << 2182 sh2:=car shcp; shcp:=cdr shcp; 2183 2184 % main parameter 2185 % choose_27_8_16_max:=15$ % initialized in crinit.red 2186 2187 % should a case-generating step 8 or 16 be done before 27? 2188 % typical order: 1 3 11 6 27 8 20 30 47 21 38 2189 n:=0; 2190 2191 while sh2 and (car sh2 = 27) do << 2192 % compared to choose_30_47_16 we do not check whether the 2193 % number of terms increases as it decreases 2194 2195 % if the last diff_length_reduction step took very long, e.g. because 2196 % of a long generated equation or stopped elimin calls then 2197 % inc n by the minutes 2198 h:= caddr sh1 - caddr sh2$ 2199 n:=n+(h/60000); 2200 2201 % Are there enough reasons to do a factorization or case generating 2202 % substitution now? 2203 if n>=choose_27_8_16_max then too_much_27:=t; 2204 sh1:=sh2; 2205 while shcp and (not fixp caar shcp) do shcp:=cdr shcp; 2206 if null shcp then sh2:=nil 2207 else <<sh2:=car shcp; shcp:=cdr shcp>> 2208 >> 2209 >> 2210 >>; 2211 >>; 2212 2213 %******* Start of modification of proc_list_ ******* 2214 plbak:=proc_list_; 2215 2216 % copy everything before 'choose_27_8_16' 2217 ok:=t$ 2218 while ok and proc_list_ and (car proc_list_ neq 'choose_27_8_16) do 2219 if not freeof({'diff_length_reduction,'subst_level_3,'factorize_to_substitute},car proc_list_) 2220 then << 2221 write"*** Mis-use of choose_27_8_16"$terpri()$ 2222 write"*** ",car proc_list_," came before choose_27_8_16 in proc_list_ !"$ 2223 terpri()$ 2224 proc_list_:=plbak$ 2225 ok:=nil 2226 >> else << 2227 plcop:=cons(car proc_list_,plcop); 2228 proc_list_:=cdr proc_list_ 2229 >>; 2230 2231 if ok then << 2232 2233 % copy 'choose_27_8_16' 2234 plcop:=cons('choose_27_8_16,plcop); 2235 if proc_list_ then proc_list_:=cdr proc_list_; 2236 2237 % the crucial part of the procedure: reordering proc_list_ 2238 if too_much_27 then % add 8,16,27 2239 plcop:=append({'diff_length_reduction,'subst_level_3,'factorize_to_substitute}, 2240 plcop) else % add 27,8,16 2241 plcop:=append({'subst_level_3,'factorize_to_substitute,'diff_length_reduction}, 2242 plcop)$ 2243 2244 % add the remainder 2245 while proc_list_ do << 2246 if freeof(plcop,car proc_list_) then plcop:=cons(car proc_list_,plcop); 2247 proc_list_:=cdr proc_list_ 2248 >>; 2249 2250 proc_list_:=reverse plcop$ 2251 if print_more then << 2252 write"proc_list_ has been automatically changed."$terpri()$ 2253 if too_much_27 then write"The order is 8,16,27." 2254 else write"The order is 27,8,16."$ 2255 terpri() 2256 >> 2257 >>; 2258 arglist:=nil % to avoid compiler warnings 2259 % nil is always returned 2260end$ 2261 2262 2263symbolic procedure choose_30_47_21(arglist)$ 2264comment 2265 This procedure is for automatic runs, not interactive use. 2266 It assumes that in proc_list_ the entry 'choose_30_47_21 2267 is followed by 'decoupling,'factorize_any,'subst_level_4 2268 in any order. The order of these 3 entries is freshly 2269 determined in this procedure on the basis of recent 2270 entries in size_hist which is taken to be a list of elements 2271 {method 2272 stepcounter_, 2273 time(), 2274 number of remaining unknowns, 2275 number of pdes, 2276 number of terms, 2277 total length of pdes 2278 } 2279 If anything goes wrong or anything unexpected happens then 2280 the order becomes 30,47,21. 2281 2282 Parameters: 2283 Currently there is only one parameter: choose_30_47_21_max 2284 2285 Improvements: 2286 One may want to have some rules what has a higher priority: 47 or 21. 2287 2288$ 2289begin 2290 scalar too_much_30,shcp,sh1,sh2,n,h,plbak,plcop,ok,shcop,unkn,allterms,p$ 2291 2292 if null size_watch then << 2293 write"*** choose_30_47_21 needs size_watch=t !"$terpri() 2294 >> else << 2295 shcp:=size_hist; 2296 while shcp and (not fixp caar shcp) do shcp:=cdr shcp; 2297 if shcp and (caar shcp=30) then << 2298 sh1:=car shcp; shcp:=cdr shcp; 2299 2300 while shcp and (not fixp caar shcp) do shcp:=cdr shcp; 2301 if shcp and (caar shcp=30) then << 2302 sh2:=car shcp; shcp:=cdr shcp; 2303 2304 % main parameter 2305 % choose_30_47_21_max:=10$ % initialized in crinit.red 2306 2307 % should a case-generating step 47 or 21 be done before 30? 2308 % typical order: 1 3 11 6 27 8 20 30 47 21 38 2309 n:=0; 2310 2311 while sh2 and (car sh2 = 30) do << 2312 % if the number of equations did not shrink then increase n by 1 2313 % if the number of equations did increase then increase n by 2 2314 if cadddr cdr sh1 >= cadddr cdr sh2 then << 2315 n:=add1 n; 2316 if cadddr cdr sh1 > cadddr cdr sh2 then n:=add1 n; 2317 % if the last decoupling step took very long, e.g. because 2318 % of a long generated equation or stopped elimin calls then 2319 % inc n by the minutes 2320 h:= caddr sh1 - caddr sh2$ 2321 n:=n+(h/60000); 2322 2323 % Are there enough reasons to do a factorization or case generating 2324 % substitution now? 2325 if n>=choose_30_47_21_max then too_much_30:=t 2326 >>; 2327 sh1:=sh2; 2328 while shcp and (not fixp caar shcp) do shcp:=cdr shcp; 2329 if null shcp then sh2:=nil 2330 else <<sh2:=car shcp; shcp:=cdr shcp>> 2331 >> 2332 >> 2333 >>; 2334 >>; 2335 2336 %******* Start of modification of proc_list_ ******* 2337 plbak:=proc_list_; 2338 2339 % copy everything before 'choose_30_47_21' 2340 ok:=t$ 2341 while ok and proc_list_ and (car proc_list_ neq 'choose_30_47_21) do 2342 if not freeof({'decoupling,'subst_level_4,'factorize_any},car proc_list_) 2343 then << 2344 write"*** Mis-use of choose_30_47_21"$terpri()$ 2345 write"*** ",car proc_list_," came before choose_30_47_21 in proc_list_ !"$ 2346 terpri()$ 2347 proc_list_:=plbak$ 2348 ok:=nil 2349 >> else << 2350 plcop:=cons(car proc_list_,plcop); 2351 proc_list_:=cdr proc_list_ 2352 >>; 2353 2354 if ok then << 2355 2356 plcop:=cons('choose_30_47_21,plcop); 2357 2358 if member('external_groebner,proc_list_) then << 2359 proc_list_:=delete('external_groebner,proc_list_)$ 2360 h:=length ftem_; 2361 if h <= groeb_diff_max then plcop:=cons('external_groebner,plcop) 2362 >>$ 2363 2364 % delete 'choose_30_47_21' from proc_list_ 2365 if proc_list_ then proc_list_:=cdr proc_list_; 2366 2367 % the crucial part of the procedure: reordering proc_list_ 2368 if too_much_30 then << 2369 2370 % obtaining values 2371 if size_watch then << 2372 shcop:=size_hist; 2373 while shcop and not fixp caar shcop do shcop:=cdr shcop 2374 >>$ 2375 if null shcop then << 2376 unkn:=length ftem_$ 2377 allterms:=for each p in car arglist sum get(p,'terms) 2378 >> else << 2379 unkn:=cadddr car shcop$ 2380 allterms:=cadddr cddar shcop 2381 >>$ 2382 2383 if (unkn<=choose_6_20_max_ftem) and 2384 (allterms<=choose_6_20_max_terms) then % add 47,21,30 2385 plcop:=append({'decoupling,'subst_level_4,'factorize_any},plcop) 2386 else % add 47,30,21 2387 plcop:=append({'subst_level_4,'decoupling,'factorize_any},plcop) 2388 >> else % add 30,47,21 2389 plcop:=append({'subst_level_4,'factorize_any,'decoupling},plcop)$ 2390 2391 % add the remainder 2392 while proc_list_ do << 2393 if freeof(plcop,car proc_list_) then plcop:=cons(car proc_list_,plcop); 2394 proc_list_:=cdr proc_list_ 2395 >>; 2396 2397 proc_list_:=reverse plcop$ 2398 if print_more then << 2399 write"proc_list_ has been automatically changed."$terpri()$ 2400 if too_much_30 then write"The order is 47,21,30." 2401 else write"The order is 30,47,21."$ 2402 terpri() 2403 >> 2404 >>; 2405 arglist:=nil % to avoid compiler warnings 2406 % nil is always returned 2407end$ 2408 2409symbolic procedure choose_70_65_8_47(arglist)$ 2410comment 2411 This procedure is for automatic runs, not interactive use. 2412 The idea is to simplify the system through a case splitting if 2413 it gets too difficult. The decision is based on the last 2414 entry in the list size_hist which is taken to be a list of elements 2415 {method, 2416 stepcounter_, 2417 time(), 2418 number of remaining unknowns, 2419 number of pdes, 2420 number of terms, 2421 total length of pdes, 2422 number of remaining free cells 2423 } 2424 This module should be placed before unconditional substitution (20). 2425 2426 Parameters: 2427 Currently the used parameters are: 2428 choose_70_65_8_47_origterms .. the original number of terms 2429 choose_70_65_8_47_origmem .. the original free cells 2430 choose_70_65_8_47_ratioterms .. percentage of increase of terms 2431 choose_70_65_8_47_ratiomem .. percentage of left free mem 2432 2433 Improvements: 2434 One could consider simplifying the system if computing times between 2435 individual steps grew too large or substituted equations become too large. 2436$ 2437begin scalar csh,plbak,ok,plcop,do_split,sl,shcp$ 2438 shcp:=size_hist; 2439 while shcp and (not fixp caar shcp) do shcp:=cdr shcp; 2440 if shcp then << 2441 sl:={'pre_determined_case_splits,'case_on_most_frequ_fnc, 2442 'factorize_to_substitute,'factorize_any}; 2443 2444 csh:=car size_hist$ 2445 if ((100*cadr cddddr csh) > 2446 (choose_70_65_8_47_ratioterms*choose_70_65_8_47_origterms) ) or 2447 ((100*cadddr cddddr csh) < 2448 (choose_70_65_8_47_ratiomem *choose_70_65_8_47_origmem) ) then do_split:=t$ 2449 2450 %******* Start of modification of proc_list_ ******* 2451 plbak:=proc_list_; 2452 2453 % copy everything before 'choose_70_65_8_47' 2454 ok:=t$ 2455 while ok and proc_list_ and (car proc_list_ neq 'choose_70_65_8_47) do 2456 if not freeof(sl,car proc_list_) then << 2457 write"*** Mis-use of choose_70_65_8_47"$terpri()$ 2458 write"*** ",car proc_list_," came before choose_70_65_8_47 in proc_list_ !"$ 2459 terpri()$ 2460 proc_list_:=plbak$ 2461 ok:=nil 2462 >> else << 2463 plcop:=cons(car proc_list_,plcop); 2464 proc_list_:=cdr proc_list_ 2465 >>; 2466 2467 if ok then << 2468 2469 plcop:=cons('choose_70_65_8_47,plcop); 2470 2471 % delete 'choose_70_65_8_47' from proc_list_ 2472 if proc_list_ then proc_list_:=cdr proc_list_; 2473 2474 % the crucial part of the procedure: reordering proc_list_ 2475 if do_split then 2476 plcop:=append(sl,plcop)$ 2477 2478 % jump case-splitting steps in proc_list_ 2479 while proc_list_ and member(car proc_list_,sl) do proc_list_:=cdr proc_list_; 2480 2481 % add the remainder 2482 while proc_list_ do << 2483 % if freeof(plcop,car proc_list_) then 2484 plcop:=cons(car proc_list_,plcop); 2485 proc_list_:=cdr proc_list_ 2486 >>; 2487 2488 proc_list_:=reverse plcop$ 2489 if print_more and do_split then << 2490 write"proc_list_ has been automatically changed."$terpri()$ 2491 write"70,8,47 has been inserted."$terpri() 2492 >> 2493 >> 2494 >>; 2495 arglist:=nil % to avoid compiler warnings 2496 % nil is always returned 2497end$ 2498 2499symbolic procedure choose_30_47_72(arglist)$ 2500comment 2501 This procedure is for automatic runs, not interactive use. 2502 The idea is for huge and highly overdetermined systems to balance 2503 reading in of equations, to do substitutions, decoupling and 2504 different kinds of factorizations (8,47). The decision is partially 2505 based on the last entry in the list size_hist which is taken to be 2506 a list of elements 2507 {method, 2508 stepcounter_, 2509 time(), 2510 number of remaining unknowns, 2511 number of pdes, 2512 number of terms, 2513 total length of pdes, 2514 number of remaining free cells 2515 } 2516 The following procedures should have a higher priority 2517 than this procedure: 2518 subst_level_0 (3) 2519 alg_length_reduction (11) (to be tried out, not for very many eqns.) 2520 factorize_to_substitute (8) 2521 subst_level_35 (20) (for very overdetermined systems) 2522 2523 Parameters: 2524 Currently the used parameters are: 2525 choose_30_47_72_origterms .. the original number of terms 2526 2527 Improvements: 2528 2529$ 2530begin scalar shcp,csh,revsl$ 2531 shcp:=size_hist; 2532 while shcp and (not fixp caar shcp) do shcp:=cdr shcp; 2533 if shcp then << 2534 2535 %******* Decide on the ordering by preparing the reverse list revsl of procedures 2536 csh:=car size_hist$ 2537 2538 %******* If no equations then read in an equation 2539 if car cddddr csh = 0 then revsl:={'read_equation} else 2540 %******* If only few equations and last was not 2541 if car cddddr csh < choose_30_47_72_eqn then 2542 revsl:={'decoupling,'factorize_any,'read_equation} else 2543 %******* If many equations then 2544 % if last two were no decouplings, then decoupling first, 2545 % else factorization first 2546 if car csh neq 30 and pairp cdr shcp and caadr shcp neq 30 then 2547 revsl:={'read_equation,'factorize_any,'decoupling} else 2548 revsl:={'read_equation,'decoupling,'factorize_any}$ 2549 2550 %******* Do the change 2551 modify_proc_list('choose_30_47_72,revsl)$ 2552 >>; 2553 arglist:=nil % to avoid compiler warnings 2554 % nil is always returned 2555end$ 2556 2557 2558symbolic procedure choose_11_30(arglist)$ 2559comment 2560 This procedure is for automatic runs, not interactive use. 2561 It assumes that in proc_list_ the entry 'choose_11_30 is 2562 followed by either 'alg_length_reduction (11) or 'decoupling (30). 2563 The procedure uses the last entries of size_hist which is taken to 2564 be a list of elements 2565 {method 2566 stepcounter_, 2567 time(), 2568 number of remaining unknowns, 2569 number of pdes, 2570 number of terms, 2571 total length of pdes 2572 } 2573 If size_hist does not exist then data are actively gathered. 2574 2575 Parameters: 2576 Currently there are only: 2577 choose_11_30_max_11=10, choose_11_30_max_30=3 2578$ 2579if size_watch then begin 2580 scalar shcop,n11,n30,ok,plbak,plcop,last_11_time,last_30_time,last_size,steps_ago$ 2581 2582 % obtaining values 2583 shcop:=size_hist; 2584 n11:=0; n30:=0; steps_ago:=0; 2585 2586 last_size:=get_statistic(car arglist,append(cadr arglist,setdiff(ftem_,cadr arglist)))$ 2587 % last_size has same format as car shcop apart from the first element (method) 2588 2589 % When searching backwards one should not consider irrelevant other subcases 2590 while shcop and 2591 ((caar shcop neq 72) or (null last_11_time) or (null last_30_time)) and 2592 (not fixp caar shcop or 2593 (n11 < choose_11_30_max_11) or 2594 (n30 <= choose_11_30_max_30) ) do << 2595 if fixp caar shcop then << 2596 steps_ago:=add1 steps_ago; 2597 if caar shcop = 11 then << 2598 n11:=add1 n11; 2599 if null last_11_time then 2600 last_11_time:=((cadr last_size) - (caddar shcop))*50/(50+steps_ago)$ 2601 % i.e. after 50 steps the time is halved to give it a new chance 2602 >> else 2603 if caar shcop = 30 then << 2604 n30:=add1 30; 2605 if null last_30_time then 2606 last_30_time:=((cadr last_size) - (caddar shcop))*50/(50+steps_ago)$ 2607 >>$ 2608 last_size:=cdar shcop 2609 >>$ 2610 shcop:=cdr shcop 2611 >>$ 2612 if null last_11_time then last_11_time:=0$ 2613 if null last_30_time then last_30_time:=0$ 2614 2615 % Start of modification of proc_list_ 2616 plbak:=proc_list_; 2617 2618 % copy everything before 'choose_11_30' 2619 ok:=t$ 2620 while ok and proc_list_ and (car proc_list_ neq 'choose_11_30) do 2621 if (car proc_list_='alg_length_reduction) or 2622 (car proc_list_='decoupling) then << 2623 write"*** Mis-use of choose_11_30"$terpri()$ 2624 write"*** alg_length_reduction (11) or decoupling (30)"$terpri()$ 2625 write"*** came before choose_11_30 in proc_list_ !"$terpri()$ 2626 terpri()$ 2627 proc_list_:=plbak$ 2628 ok:=nil 2629 >> else << 2630 plcop:=cons(car proc_list_,plcop); 2631 proc_list_:=cdr proc_list_ 2632 >>; 2633 if ok then << 2634 2635 while proc_list_ and 2636 ((car proc_list_ = 'choose_11_30) or 2637 (car proc_list_ = 'alg_length_reduction) or 2638 (car proc_list_ = 'decoupling) ) do 2639 proc_list_:=cdr proc_list_$ 2640 2641 plcop:=cons('choose_11_30,plcop); 2642 % These 2 lines can use a bit more sophistication 2643 if (last_11_time<4000) and % 4 seconds time limit 2644 (n11<choose_11_30_max_11) then plcop:=cons('alg_length_reduction,plcop); 2645 if (last_30_time<2000) and % 2 seconds time limit 2646 (n30<choose_11_30_max_30) then plcop:=cons('decoupling,plcop); 2647 2648 % add the remainder 2649 while proc_list_ do << 2650 if freeof(plcop,car proc_list_) then plcop:=cons(car proc_list_,plcop); 2651 proc_list_:=cdr proc_list_ 2652 >>; 2653 2654 proc_list_:=reverse plcop$ 2655 if print_more then << 2656 write"proc_list_ has been automatically updated."$terpri()$ 2657 >> 2658 >>$ 2659 2660 arglist:=nil % to avoid compiler warnings 2661 % returns always nil 2662end$ 2663 2664symbolic procedure try_other_ordering(arglist)$ 2665comment 2666 This procedure is for automatic runs, not interactive use. 2667 It assumes that in proc_list_ there is 'decoupling (30) 2668 and that this procedure comes definitely after 30 and pretty 2669 much at the end of proc_list_.$ 2670begin scalar plcop,pdes,s$ 2671 pdes:=car arglist; 2672 2673 % no action if only one equation left 2674 if null pdes or null cdr pdes then return nil; 2675 2676 % copy everything before 'try_other_ordering' 2677 while proc_list_ and (car proc_list_ neq 'try_other_ordering) do << 2678 plcop:=cons(car proc_list_,plcop); 2679 proc_list_:=cdr proc_list_ 2680 >>; 2681 2682 % modification of the ordering or of proc_list_ 2683 if proc_list_ then << % This is the case if the procedure was called automatically 2684 if not lex_df then << 2685 lex_df:=t; 2686 if print_ then <<terpri()$write"From now on lexicographic ordering of derivatives.">>$ 2687 plcop:=cons(car proc_list_,plcop); % i.e. adding 'try_other_ordering 2688 >> else << 2689 if print_ then <<terpri()$write"The current variable ordering is going to be reversed.">>$ 2690 vl_ := reverse vl_$ 2691 for each s in pdes do put(s,'vars,sort_according_to(get(s,'vars),vl_)); 2692 % 'try_other_ordering is not added again to proc_list_ to terminate afterall 2693 >>; 2694 pdes := change_derivs_ordering(pdes,ftem_,vl_); 2695 proc_list_:=cdr proc_list_$ % dropping 'try_other_ordering 2696 >>$ 2697 2698 % copying of the rest of proc_list_ 2699 while proc_list_ do << 2700 plcop:=cons(car proc_list_,plcop); 2701 proc_list_:=cdr proc_list_ 2702 >>; 2703 proc_list_:=reverse plcop$ 2704 return cons(pdes,cdr arglist) 2705end$ 2706 2707symbolic procedure solvable_case(p,f,case)$ 2708begin scalar fe; 2709 fe:=get(p,case); 2710 while fe and (cdar fe neq f) do fe:=cdr fe$ 2711 return fe 2712end$ 2713 2714%symbolic procedure lin_check(pde,fl)$ 2715%begin scalar subpde, 2716% while fl and << 2717% subpde:=subst({'times,lin_test_const,car fl},car fl,pde); 2718% freeof(reval {'quotient,subpde,lin_test_const},lin_test_const) 2719% >> do fl:=cdr fl; 2720% return if fl then nil 2721% else t 2722%end$ 2723 2724symbolic procedure add2flin(pdes,f)$ 2725% returns t if the function/constant f appears linearly in all pdes 2726% in addition to the flin_ functions/constants 2727% and in that case inserts f into flin_. 2728 2729begin scalar pcp,nonli,h,p,fl,f0$ 2730 2731 % at first check that f comes only with 1st degree 2732 while pdes do << % continue until a non-linearity is found 2733 p:=car pdes; 2734 if freeof(get(p,'fcts),f) then pdes:=cdr pdes 2735 else << 2736 pcp:=cons(p,pcp)$ 2737 h:=get(p,'derivs); 2738 while h and 2739 ((cdar h = 1) or (caaar h neq f)) do h:=cdr h; 2740 if h then <<nonli:=t;pdes:=nil>> 2741 else pdes:=cdr pdes 2742 >> 2743 >>$ 2744 2745 % then check that it does not appear as factor to flin_'s 2746 if null nonli and flin_ then << 2747 f0:=for each fl in flin_ collect (fl . 0)$ 2748 while pcp do 2749 if not freeof(denr get(car pcp,'sqval),f) then 2750 <<nonli:=t;pcp:=nil>> else << 2751 h:=subtrsq( get(car pcp,'sqval) , 2752 subsq(get(car pcp,'sqval),f0) ); 2753 if not freeof(h,f) then <<nonli:=t;pcp:=nil>> 2754 else pcp:=cdr pcp 2755 >> 2756 >>$ 2757 if null nonli then 2758 flin_:=sort_according_to(f . flin_, ftem_); 2759 2760 return null nonli 2761end$ 2762 2763symbolic procedure lin_check_SQ(sqval,fl)$ 2764% returns t iff standard quotient sqval is homogeneously or 2765% inhomogeneously linear in the elements of fl 2766if denr sqval neq 1 and not freeoflist(sqval,fl) then nil else 2767begin scalar k,f,nu,sb$ 2768 k:=setkorder list lin_test_const$ 2769 sb:=for each f in fl collect (f . {'times,lin_test_const,f})$ 2770 nu:=numr subf(numr sqval,sb); 2771 setkorder k$ 2772 return if domainp nu or 2773 (lin_test_const neq mvar nu) or 2774 (2>ldeg nu) then t 2775 else nil 2776end$ 2777 2778symbolic procedure lin_check(pde,fl)$ 2779% This needs pde to have prefix form. It tests not only whether each 2780% single function occurs linearly but also whether in products of them 2781begin scalar inhom,f; 2782 inhom:=pde; 2783 for each f in fl do inhom:=err_catch_sub(f,0,inhom); 2784 return << 2785 for each f in fl do pde:=subst({'times,lin_test_const,f},f,pde); 2786 freeof(reval {'quotient,{'DIFFERENCE,pde,inhom},lin_test_const},lin_test_const) 2787 >> 2788end$ 2789 2790symbolic procedure symbol_explanation$ << 2791 write"+------------------------------------------------------------------------------+"$terpri()$ 2792 write"|CHARACTERIZING FUNCTIONS: |"$terpri()$ 2793 write"|flin_: The function occurs linear and is element of the global list flin_. |"$terpri()$ 2794 write"|fhom_: The function is one of a set of homogeneously occuring functions fhom_.|"$terpri()$ 2795 write"| <>0 : The function is known to be non-zero, i.e. it is an element of ineq_. |"$terpri()$ 2796 write"| n2l : The function is not linearly occuring but the equation involves |"$terpri()$ 2797 write"| linearly occuring functions. |"$terpri()$ 2798 write"|CHARACTERIZING SUBSTITUTIONS: |"$terpri()$ 2799 write"| (+) : a favourable substitution |"$terpri()$ 2800 write"| (-) : an unfavourable substitution |"$terpri()$ 2801 write"| const coeff : substitution generates no cases |"$terpri()$ 2802 write"| no cases : no cases but coefficient involves unknowns |"$terpri()$ 2803 write"| case generating : substitution generates cases |"$terpri()$ 2804 write"+------------------------------------------------------------------------------+"$terpri()$ 2805>>$ 2806 2807symbolic procedure list_all_subs(txt,sl,s)$ 2808if sl then 2809begin scalar h; 2810 write txt,": "$ terpri()$ 2811 while sl do << 2812 write cdar sl," :"$ 2813 if member(cdar sl,flin_) then write" flin_(+)" else 2814 if not freeoflist(flin_,get(s,'fcts)) then write" n2l(-)"$ 2815 if member(cdar sl,fhom_) then write" fhom_(+)"$ 2816 if member(simp cdar sl,ineq_) then write" <>0(-)"$ 2817 if (h:=( delengthSF numr caar sl 2818 + delengthSF denr caar sl))>print_ then 2819 write" coeff: (print length = ",h,")" else 2820 write" coeff: ",prepsq caar sl$terpri()$ 2821 % mathprint caar sl$ 2822 sl:=cdr sl 2823 >> 2824end$ 2825 2826symbolic procedure list_possible_subs(s)$ 2827% list all substitutions with all their advantages and disadvantages 2828begin 2829 fcteval(s)$terpri()$ 2830 list_all_subs("const coeff substitutions", get(s,'fcteval_lin),s)$ 2831 list_all_subs("no cases substitutions", get(s,'fcteval_nca),s)$ 2832 list_all_subs("case generating substitutions",get(s,'fcteval_nli),s)$ 2833end$ 2834 2835symbolic procedure plot_non0_separants(s)$ 2836% One could think of storing all leading derivatives for which 2837% the symbol is non-zero. 2838begin scalar dv,dl,dlc,dr,fdl,avf,ur; 2839 if (userrules_ neq {'list}) and 2840 (zerop reval {'DIFFERENCE, 2841 car cdadr userrules_, 2842 cadr cdadr userrules_}) 2843 then <<ur:=t; algebraic (clearrules lisp userrules_) >>$ 2844 2845 dv:=get(s,'derivs); 2846 avf:=get(s,'allvarfcts); 2847 while dv do << 2848 dr:=caar dv; % the derivative without 'df (and no power) 2849 dv:=cdr dv; 2850 if member(car dr,avf) then << 2851 dlc:=dl; % dl will be the derivative list 2852 while dlc and ((caar dlc neq car dr) or 2853 which_deriv(car dlc,dr) ) do dlc:=cdr dlc; 2854 if null dlc then dl:=cons(dr,dl); 2855 % which_deriv(a,b) takes two lists of derivatives and returns how 2856 % often you need to diff. a in order to get at least the 2857 % derivatives in b. e.g. which_deriv((x 2 y), (x y 2)) returns y 2858 >> 2859 >>; 2860 for each dr in dl do << 2861 dr:=if null cdr dr then car dr 2862 else cons('df,dr); 2863 dr:=mvar car mksq(dr,1); 2864 if get(s,'linear_) or 2865 can_not_become_zeroSQ(diffsq(get(s,'sqval),dr),get(s,'fcts)) 2866 then fdl:=cons(dr,fdl) 2867 >>; 2868 terpri()$ 2869 if fdl then << 2870 write "Leading derivatives with non-zero separant: "$ 2871 % terpri()$ mathprint cons('! ,fdl)$ 2872 write cdr reval cons('list,fdl)$ 2873 >> else 2874 write "No leading derivative with non-zero separant. "$ 2875 if ur then algebraic(let lisp userrules_) 2876end$ 2877 2878 2879symbolic procedure rule_from_pde(s)$ 2880% s is the name of a PDE that is to be converted to a rule 2881begin scalar dv,dl,dlc,dr,fdl,avf,l; 2882 dv:=get(s,'derivs); 2883 avf:=get(s,'allvarfcts); 2884 while dv do << 2885 dr:=caar dv; 2886 if member(car dr,avf) then << 2887 dlc:=dl; 2888 while dlc and ((caaar dlc neq car dr) or 2889 which_deriv(caar dlc,dr) ) do dlc:=cdr dlc; 2890 if null dlc then dl:=cons(car dv,dl); 2891 % which_deriv(a,b) takes two lists of derivatives and returns how 2892 % often you need to diff. a in order to get at least the 2893 % derivatives in b. e.g. which_deriv((x 2 y), (x y 2)) returns y 2894 >>$ 2895 dv:=cdr dv 2896 >>; 2897 for each dv in dl do << 2898 dr:=if null cdar dv then caar dv 2899 else cons('df,car dv); 2900 dr:=mvar car mksq(dr,1); 2901 if get(s,'linear_) or 2902 can_not_become_zeroSQ(<<l:=coeffn(mk!*sq get(s,'sqval),dr,cdr dv); 2903 if pairp l then cadr l 2904 else simp l>>, 2905 get(s,'fcts)) then 2906 if cdr dv=1 then fdl:=cons(dr,fdl) 2907 else fdl:=cons({'expt,dr,cdr dv},fdl) 2908 >>; 2909 if null fdl then << 2910 write"No leading derivative has a non-zero coefficient."$ terpri() 2911 >> else 2912 if cdr fdl then << 2913 write"Which term shall be substituted by the rule?"$ terpri()$ 2914 mathprint cons('! ,fdl)$ 2915 write"Input its number + Enter: "$ 2916 l:=termread()$ 2917 if not fixp l then << 2918 fdl:=nil; 2919 write"Input is not a number!"$terpri() 2920 >> else 2921 if l > length fdl then << 2922 fdl:=nil; 2923 write"This number is too big."$terpri() 2924 >> else fdl:={nth(fdl,l)} 2925 >>$ 2926 if fdl then << 2927 l:=get(s,'sqval); 2928 if pairp car fdl and (caar fdl = 'expt) then dv:=coeffn({'!*sq,l,t},cadar fdl,caddar fdl) 2929 else dv:=coeffn({'!*sq,l,t}, car fdl,1); 2930 dv:=if pairp dv then cadr dv 2931 else simp dv; 2932 userrules_:=cons('list, 2933 cons({'REPLACEBY,car fdl, 2934 {'!*sq,quotsq(subtrsq(multsq(simp car fdl,dv),l),dv),t}}, 2935 cdr userrules_))$ 2936 algebraic (write "The new list of user defined rules: ", 2937 lisp userrules_)$ 2938 terpri() 2939 >> 2940end$ 2941 2942%symbolic procedure addup(ex)$ 2943%if pairp ex then <<addup(car ex);addup(cdr ex)>> else 2944%if ex and not numberp ex then begin scalar h; 2945% h:=backup_; 2946% while h and cdar h neq ex do h:=cdr h; 2947% if h then rplaca(h,(add1 caar h . cdar h)) 2948%end$ 2949 2950symbolic procedure how_often(pdes)$ 2951% returns an assoc list of the number of terms in the numerators 2952% of all equations in which each function turns up 2953begin scalar f,n,equn; 2954 backup_:=nil; 2955% for each f in ftem_ do 2956% %if not member(f,ineq_) then 2957% backup_:=cons((0 . f),backup_); 2958% if null backup_ then return nil; 2959% for each p in pdes do addup(get(p,'val)); 2960 for each f in ftem_ do << 2961 n:=0; 2962 for each p in pdes do 2963 n:=n + get(p,'terms) - no_of_tm_sf numr subf(numr get(p,'sqval),{(f . 0)})$ 2964 backup_:=cons((n . f),backup_); 2965 >>$ 2966 2967 backup_:=rev_idx_sort backup_; 2968 for each f in ftem_ do << 2969 n:=0; 2970 for each p in pdes do if member(f,get(p,'fcts)) then n:=add1 n; 2971 equn:=cons((n . f),equn); 2972 >>$ 2973 equn:=rev_idx_sort(equn); 2974 if print_ then << 2975 write"Total number of occurences of all unknowns in all equations:"$terpri()$ 2976 prettyprint backup_; 2977 write"Total number of equations in which unknowns occur:"$terpri()$ 2978 prettyprint equn; 2979 >>$ 2980 return backup_ 2981end$ 2982 2983symbolic procedure case_on_most_frequ_fnc(arglist)$ 2984begin scalar h; 2985 h:=how_often(car arglist)$ 2986 while h and member(simp cdar h,ineq_) and not zerop(caar h) do h:=cdr h; 2987 return 2988 if h and not zerop(caar h) then split_into_cases({car arglist,cadr arglist, 2989 caddr arglist,cdar h}) 2990 else nil 2991end$ 2992 2993symbolic procedure pre_determined_case_splits(arglist)$ 2994begin scalar h,carh; 2995 h:=cdr case_list$ 2996 while h do << 2997 carh:=simp car h; 2998 if freeoflist(carh,ftem_) or member(carh,ineq_) then <<carh:=nil;h:=cdr h>> 2999 else h:=nil; 3000 case_list:=cons('list,cddr case_list) 3001 >>$ 3002 return 3003 if carh then split_into_cases({car arglist,cadr arglist,caddr arglist,carh}) 3004 else nil 3005end$ 3006 3007symbolic procedure ftem_sorted_by_index; 3008begin scalar h,h1,h2,h3,h4,h5$ 3009 % ftem_ functions are sorted by the following criteria: 3010 % 1. possibly zero flin_ 3011 % 2. non-zero flin_ 3012 % 3. possibly zero non-flin_ 3013 % 4. non-zero non-flin_ 3014 % Each of these groups is sorted by decreasing frequency. 3015 3016 if flin_ then 3017 while backup_ do << 3018 if member(cdar backup_,flin_) then h1:=cons(car backup_,h1) 3019 else h2:=cons(car backup_,h2); 3020 backup_:=cdr backup_ 3021 >> else 3022 while backup_ do <<h1:=cons(car backup_,h1);backup_:=cdr backup_>>$ 3023 3024 for each h3 in ineq_ do if atom h3 and member(h3,ftem_) then 3025 if member(h3,flin_) then << 3026 h:=h1; 3027 while h and cdar h neq h3 do h:=cdr h; 3028 if h then <<h1:=delete(car h,h1);h4:=cons(car h,h4)>> 3029 >> else << 3030 h:=h2; 3031 while h and cdar h neq h3 do h:=cdr h; 3032 if h then <<h2:=delete(car h,h2);h5:=cons(car h,h5)>> 3033 >>; 3034 h3:=append(append(h1,idx_sort h4), 3035 append(h2,idx_sort h5) ); 3036 return for each h in h3 collect cdr h 3037end$ 3038 3039%%%%%%%%%%%%%%%%%%%%%%%%% 3040% leading derivatives % 3041%%%%%%%%%%%%%%%%%%%%%%%%% 3042 3043symbolic procedure maxmum(a,b)$ 3044if a>b then a else b$ 3045 3046symbolic procedure degree_SF(sf,f)$ 3047% returns the highest exponent of f in the standard form sf 3048% (((mvar . ldeg) . lc) . red) 3049if null pairp sf then 0 else 3050if f = mvar sf then ldeg sf 3051 else maxmum(degree_SF(lc sf,f), 3052 degree_SF(red sf,f) )$ 3053 3054symbolic procedure listrel(a,b,l)$ 3055% a>=b w.r.t list l; e.g. l='(a b c) -> a>=a, b>=c 3056member(b,member(a,l))$ 3057 3058symbolic procedure abs_dfrel(p,q,vl)$ 3059% returns t if derivative of p is lower than derivative of q 3060% 0 " equal " 3061% nil " higher " 3062% p,q : derivatives or functions from ftem like ((f x 2 y z 3) . 2) 3063% ftem : list of fcts 3064% vl : list of vars 3065begin scalar a$ 3066return 3067if lex_df then dfrel2(p,q,vl) else 3068if zerop (a:=absodeg(cdar p)-absodeg(cdar q)) then dfrel2(p,q,vl) 3069else a<0$ 3070end$ 3071 3072symbolic procedure mult_derivs(a,b)$ 3073% multiplies deriv. of a and b 3074% a,b list of derivs of the form ((fct var1 n1 ...).pow) 3075begin scalar l$ 3076 return 3077 if not b then a 3078 else if not a then b 3079 else 3080 << 3081 for each s in a do 3082 for each r in b do 3083 if car s=car r then l:=union(list cons(car r,plus(cdr r,cdr s)),l) 3084 else l:=union(list(r,s),l)$ 3085 l>>$ 3086end$ 3087 3088 3089%symbolic procedure all_deriv_search_SF(p,ftem)$ 3090% Is simpler but also slower than version below. 3091%% (((mvar . ldeg) . lc) . red) 3092%if pairp p and pairp car p and not domainp p % pairp caar p 3093%then begin scalar a,b$ 3094% a:=mvar p; 3095%%write"a=",a$terpri()$ 3096%%write"red p=",red p$terpri()$ 3097%%write"lc p=",lc p$terpri()$ 3098% b:=union(all_deriv_search_SF(red p,ftem), 3099% all_deriv_search_SF(lc p,ftem) )$ 3100% return 3101% if atom a and member(a,ftem) then cons(({a} . ldeg p),b) else 3102% if pairp a and car a = 'df and 3103% member(cadr a,ftem) then cons((cdr a . ldeg p),b) 3104% else b 3105%end$ 3106 3107 3108symbolic procedure all_power_search_SF(p)$ 3109if pairp p and pairp car p and not domainp p % pairp caar p 3110then begin scalar a,b,lcp$ 3111 a:=mvar p; 3112 lcp:=all_power_search_SF lc p; 3113 b:=if atom a then ({a} . ldeg p) else 3114 if pairp a and car a = 'df then (cdr a . ldeg p); 3115 while pairp red p and 3116 pairp car red p and 3117 not domainp red p do 3118 if a eq mvar red p then <<if b then lcp:=cons((car b . ldeg red p),lcp); 3119 lcp:=union(all_power_search_SF lc red p,lcp); p:=red p >> 3120 else <<lcp:=union(all_power_search_SF red p,lcp); p:={nil . nil}>>$ 3121 return if b then cons(b,lcp) 3122 else lcp 3123end$ 3124 3125symbolic procedure all_deriv_search_SF(p,ftem)$ 3126begin scalar h,ad$ 3127 for each h in all_power_search_SF p do 3128 if member(caar h,ftem) then ad:=cons(h,ad); 3129 return ad 3130end$ 3131 3132symbolic procedure all_deriv_search(p,ftem)$ % currently (July 2007) only used in crident.red 3133% yields all derivatives occuring polynomially in a pde p 3134begin scalar a$ 3135 if not pairp p then <<if member(p,ftem) then a:=list cons(list p,1)>> 3136 else <<if member(car p,'(plus quotient equal)) then 3137 for each q in cdr p do 3138 a:=union(all_deriv_search(q,ftem),a) 3139 else if car p='minus then a:=all_deriv_search(cadr p,ftem) 3140 else if car p='times then 3141 for each q in cdr p do 3142 a:=mult_derivs(all_deriv_search(q,ftem),a) 3143 else if (car p='expt) and numberp caddr p then 3144 for each b in all_deriv_search(cadr p,ftem) do 3145 <<if numberp cdr b then 3146 a:=cons(cons(car b,times(caddr p,cdr b)),a)>> 3147 else if (car p='df) and member(cadr p,ftem) then a:=list cons(cdr p,1) 3148 >>$ 3149 return a 3150end$ 3151 3152symbolic procedure abs_ld_deriv(p)$ 3153if get(p,'derivs) then reval cons('df,caar get(p,'derivs))$ 3154 3155symbolic procedure abs_ld_deriv_pow(p)$ 3156if get(p,'derivs) then cdar get(p,'derivs) 3157 else 0$ 3158 3159symbolic procedure which_first(a,b,l)$ 3160if null l then nil else 3161if a = car l then a else 3162if b = car l then b else which_first(a,b,cdr l)$ 3163 3164 3165symbolic procedure total_less_dfrel(a,b,ftem,vl)$ 3166% = 0 if a=b, =t if a<b, = nil if a>b 3167begin scalar fa,ad,al,bl$ 3168 fa:=caar a$ 3169 return 3170 if a=b then 0 else 3171 if lex_fc then % lex. order. of functions has highest priority 3172 if fa=caar b then 3173 if (ad:=abs_dfrel(a,b,vl))=0 then % power counts 3174 if cdr a < cdr b then t 3175 else nil 3176 else 3177 if ad then t 3178 else nil 3179 else 3180 if fa=which_first(fa,caar b,ftem) then nil 3181 else t 3182 else % order. of deriv. has higher priority than fcts. 3183 % number of variables of functions has still higher priority 3184 if (al:=fctlength fa) > (bl:=fctlength caar b) then nil 3185 else 3186 if bl>al then t 3187 else 3188 if (ad:=abs_dfrel(a,b,vl))=0 then 3189 if fa=caar b then 3190 if cdr a < cdr b then t 3191 else nil 3192 else 3193 if fa=which_first(fa,caar b,ftem) then nil 3194 else t 3195 else 3196 if ad then t 3197 else nil 3198end$ 3199 3200symbolic procedure sort_derivs(l,ftem,vl)$ 3201% yields a sorted list of all derivatives in l using quicksort 3202begin scalar l1,l2,a$ 3203 return 3204 if null l then nil 3205 else << 3206 a:=car l$ 3207 l:=cdr l$ 3208 while l do << 3209 if a neq car l then 3210 if total_less_dfrel(a,car l,ftem,vl) then l1:=cons(car l,l1) 3211 else l2:=cons(car l,l2)$ 3212 l:=cdr l 3213 >>$ 3214 append(sort_derivs(l1,ftem,vl),cons(a,sort_derivs(l2,ftem,vl)))>> 3215end$ 3216 3217symbolic procedure dfmax(p,q,vl)$ 3218% yields the higher derivative 3219% vl list of variables e.g. p=((x 2 y 3 z).2), q=((x y 4 z).1) 3220% df(f,x,2,y,3,z)^2, df(f,x,y,4,z) 3221if dfrel(p,q,vl) then q 3222 else p$ 3223 3224symbolic procedure dfrel(p,q,vl)$ 3225% the relation "p is lower than q" 3226% vl list of vars e.g. p=((x 2 y 3 z).2), q=((x y 4 z).1) 3227if lex_df then dfrel1(p,q,vl) 3228 else begin scalar a$ 3229 return 3230 if zerop(a:=absodeg(car p)-absodeg(car q)) then dfrel1(p,q,vl) 3231 else if a<0 then t 3232 else nil 3233end$ 3234 3235symbolic procedure diffrelp(p,q,v)$ 3236% gives t when p "<" q 3237% nil when p ">" q 3238% 0 when p = q 3239% p, q Paare (liste.power), v Liste der Variablen 3240% liste Liste aus Var. und Ordn. der Ableit. in Diff.ausdr., 3241% power Potenz des Differentialausdrucks 3242if cdr p='infinity then nil else 3243if cdr q='infinity then t else dfrel(p,q,v)$ 3244% 8.6.2006: changed from dfrel1 to dfrel as diffrelp() must use same 3245% ordering of derivatives as lderiv() for intpde_() to work properly. 3246% dfrel1 uses only lex-ordering whereas dfrel also totdeg-ordering. 3247 3248symbolic procedure dfrel1(p,q,v)$ 3249% p,q like ((f x 2 y z 3) . 2) 3250if null v then 3251 if cdr p='infinity then nil else % #+# 3252 if cdr q='infinity then t else % #+# 3253 if cdr p>cdr q then nil else % same derivatives, 3254 if cdr p<cdr q then t else 0 % considering powers 3255 % for termorderings of non-linear problems the last 2 lines 3256 % have to be extended 3257else begin 3258 scalar a,b$ 3259 a:=dfdeg(car p, car v)$ 3260 b:=dfdeg(car q, car v)$ 3261 return if a<b then t 3262 else if b<a then nil 3263 else dfrel1(p,q,cdr v) % same derivative w.r.t car v 3264end$ 3265 3266symbolic procedure dfrel2(p,q,v)$ 3267% p,q like ((f x 2 y z 3) . 2) 3268if null v then 0 3269else begin 3270 scalar a,b$ 3271 a:=dfdeg(car p, car v)$ 3272 b:=dfdeg(car q,car v)$ 3273 return if a<b then t 3274 else if b<a then nil 3275 else dfrel2(p,q,cdr v) % same derivative w.r.t car v 3276end$ 3277 3278symbolic procedure absodeg(p)$ 3279if not pairp p then 0 3280else eval cons('plus,for each v in p collect if fixp(v) then sub1(v) 3281 else 1)$ 3282 3283symbolic procedure maxderivs(numberlist,deriv,varlist)$ 3284if null numberlist then 3285 for each v in varlist collect dfdeg(deriv,v) 3286else begin scalar l$ 3287 for each v in varlist do 3288 <<l:=cons(max(car numberlist,dfdeg(deriv,v)),l)$ 3289 numberlist:=cdr numberlist>>$ 3290 return reverse l 3291end$ 3292 3293symbolic procedure dfdeg(p,v)$ 3294% yields order of deriv. wrt. v$ 3295% e.g p='(x 2 y z 3), v='x --> 2 3296if null(p:=member(v,p)) then 0 3297else if null(cdr p) or not fixp(cadr p) 3298 then 1 % v without order 3299 else cadr p$ % v with order 3300 3301symbolic procedure lower_deg(p,v)$ 3302% reduces the order of the derivative p wrt. v by one 3303% e.g p='(x 2 y z 3), v='z --> p='(x 2 y z 2) 3304% e.g p='(x 2 y z 3), v='y --> p='(x 2 z 3) 3305% returns nil if no v-derivative 3306begin scalar newp$ 3307 while p and (car p neq v) do <<newp:=cons(car p,newp);p:=cdr p>>$ 3308 if p then 3309 if null(cdr p) or not fixp(cadr p) then p:=cdr p 3310 else << 3311 newp:=cons(sub1 cadr p,cons(car p,newp)); 3312 p:=cddr p 3313 >> else newp:=nil; 3314 while p do <<newp:=cons(car p,newp);p:=cdr p>>$ 3315 return reverse newp 3316end$ 3317 3318symbolic procedure df_int(d1,d2)$ 3319begin scalar n,l$ 3320return 3321 if d1 then 3322 if d2 then 3323 <<n:=dfdeg(d1,car d1)-dfdeg(d2,car d1)$ 3324 l:=df_int(if cdr d1 and numberp cadr d1 then cddr d1 3325 else cdr d1 ,d2)$ 3326 if n<=0 then l 3327 else if n=1 then cons(car d1,l) 3328 else cons(car d1,cons(n,l)) 3329 >> 3330 else d1$ 3331end$ 3332 3333symbolic procedure alg_linear_fct(p,f)$ 3334begin scalar l$ 3335 l:=ld_deriv(p,f)$ 3336 return l and ((car l=f) and (cdr l=1)) 3337end$ 3338 3339% not used anymore: 3340% 3341%symbolic procedure dec_ld_deriv(p,f,vl)$ 3342%% gets leading derivative of f in p wrt. vars order vl 3343%% result: derivative , e.g. '(x 2 y 3 z) 3344%begin scalar l,d,ld$ 3345% l:=get(p,'derivs)$ 3346% vl:=intersection(vl,get(p,'vars))$ 3347% while caaar l neq f do l:=cdr l$ 3348% ld:=car l$l:=cdr l$ 3349% % --> if lex_df then dfrel1() else 3350% d:=absodeg(cdar ld)$ 3351% while l and (caaar l=f) and (d=absodeg cdaar l) do 3352% <<if dfrel1(ld,car l,vl) then ld:=car l$ 3353% l:=cdr l>>$ 3354% return cdar ld$ 3355%end$ 3356 3357symbolic procedure ld_deriv(p,f)$ 3358% gets leading derivative of f in p 3359% result: derivative + power , e.g. '((DF f x 2 y 3 z) . 3) 3360begin scalar l$ 3361 return 3362 if l:=get(p,'derivs) then << 3363 while l and (caaar l neq f) do l:=cdr l$ 3364 if l then cons(reval cons('df,caar l),cdar l) 3365 >> else cons(nil,0) 3366end$ 3367 3368symbolic procedure ldiffp(p,f)$ 3369% liefert Liste der Variablen + Ordnungen mit Potenz 3370% p Ausdruck in LISP - Notation, f Funktion 3371ld_deriv_search(p,f,fctargs f)$ 3372 3373symbolic procedure ld_deriv_search(p,f,vl)$ 3374% gets leading derivative of function f in expr. p w.r.t 3375% list of variables vl 3376begin scalar a$ 3377if p=f then a:=cons(nil,1) 3378else 3379<<a:=cons(nil,0)$ 3380if pairp p then 3381 if member(car p,'(plus times quotient equal)) then 3382 <<p:=cdr p$ 3383 while p do 3384 <<a:=dfmax(ld_deriv_search(car p,f,vl),a,vl)$ 3385 %if cdr a='infinity then p:=nil 3386 % else 3387 p:=cdr p 3388 >> 3389 >> 3390 else if car p='minus then a:=ld_deriv_search(cadr p,f,vl) 3391 else if car p='expt then 3392 <<a:=ld_deriv_search(cadr p,f,vl)$ 3393 if numberp cdr a then 3394 if numberp caddr p 3395 then a:=cons(car a,times(caddr p,cdr a)) 3396 else if not zerop cdr a 3397 then a:=cons(nil,'infinity) 3398 else if not my_freeof(caddr p,f) 3399 then a:=cons(nil,'infinity) 3400 >> 3401 else if car p='df then 3402 if cadr p=f then a:=cons(cddr p,1) 3403 else if my_freeof(cadr p,f) 3404 then a:=cons(nil,0) % a constant 3405 else a:=cons(nil,'infinity) 3406 else if my_freeof(p,f) then a:=cons(nil,0) 3407 else if member(car p,ONE_ARGUMENT_FUNCTIONS_) then 3408 a:=cons(car ld_deriv_search(cadr p,f,vl),'infinity) 3409 else a:=cons(nil,'infinity) 3410>>$ 3411return a 3412end$ 3413 3414symbolic procedure lderiv(p,f,vl)$ 3415% fuehrende Ableitung in LISP-Notation mit Potenz (als dotted pair) 3416begin scalar l$ 3417l:=ld_deriv_search(p,f,vl)$ 3418return cons(if car l then cons('df,cons(f,car l)) 3419 else if zerop cdr l then nil 3420 else f 3421 ,cdr l) 3422end$ 3423 3424symbolic procedure splitinhom(q,ftem,vl)$ 3425% Splitting the equation q into the homogeneous and inhom. part 3426% returns dotted pair qhom . qinhom 3427begin scalar qhom,qinhom,denm; 3428 vl:=varslist(q,ftem,vl)$ 3429 if pairp q and (car q = 'quotient) then 3430 if starp(smemberl(ftem,caddr q),length vl) then 3431 <<denm:=caddr q; q:=cadr q>> else return (q . 0) 3432 else denm:=1; 3433 3434 if pairp q and (car q = 'plus) then q:=cdr q 3435 else q:=list q; 3436 while q do << 3437 if starp(smemberl(ftem,car q),length vl) then qinhom:=cons(car q,qinhom) 3438 else qhom :=cons(car q,qhom); 3439 q:=cdr q 3440 >>; 3441 if null qinhom then qinhom:=0 3442 else 3443 if length qinhom > 1 then qinhom:=cons('plus,qinhom) 3444 else qinhom:=car qinhom; 3445 if null qhom then qhom:=0 3446 else 3447 if length qhom > 1 then qhom:=cons('plus,qhom) 3448 else qhom:=car qhom; 3449 if denm neq 1 then <<qhom :=list('quotient, qhom,denm); 3450 qinhom:=list('quotient,qinhom,denm)>>; 3451 return qhom . qinhom 3452end$ 3453 3454symbolic procedure search_den(l)$ 3455% get all denominators and arguments of LOG,... anywhere in a list l 3456begin scalar l1$ 3457if pairp l then 3458 if car l='quotient then 3459 l1:=union(cddr l,union(search_den(cadr l),search_den(caddr l))) 3460 else if member(car l,'(log ln logb log10)) then 3461 if pairp cadr l and (caadr l='quotient) then 3462 l1:=union(list cadadr l,search_den(cadr l)) 3463 else l1:=union(cdr l,search_den(cadr l)) 3464 else l1:=union(search_den(car l),search_den(cdr l))$ 3465 return l1$ 3466end$ 3467 3468symbolic procedure zero_den(l,ftem)$ 3469% l is in prefix form, each element of the returned list cases is in SQ-form 3470begin scalar cases,carl$ 3471 l:=search_den(l)$ 3472 while l do << 3473 carl:=simp car l; 3474 if null can_not_become_zeroSQ(carl,ftem) 3475% if not freeofzero(car l,ftem,vl,ftem) 3476 then cases:=cons(carl,cases); 3477 l:=cdr l 3478 >>$ 3479 return cases 3480end$ 3481 3482symbolic procedure forg_int(forg,fges)$ 3483for each ex in forg collect 3484 if pairp ex and pairp cadr ex then forg_int_f(ex,smemberl(fges,ex)) 3485 else ex$ 3486 3487symbolic procedure forg_int_f(ex,fges)$ 3488% try to integrate expr. ex of the form df(f,...)=p . 3489begin scalar p,h,f$ 3490 p:={'!*sq,caddr ex,t}$ 3491 f:=cadadr ex$ 3492 if pairp p and (car p='plus) 3493 then p:=reval cons('plus,cons(list('minus,cadr ex),cdr p)) 3494 else p:=reval list('DIFFERENCE,p,cadr ex)$ 3495 p:=integratepde(p,cons(f,fges),nil,nil,nil)$ 3496 if p and (car p) and not cdr p then 3497 <<h:=car lderiv(car p,f,fctargs f)$ 3498 p:=reval list('plus,car p,h)$ 3499 for each ff in fnew_ do 3500 if not member(ff,ftem_) then ftem_:=fctinsert(ff,ftem_)$ 3501 ex:=list('equal,h,p)>>$ 3502 return ex 3503end$ 3504 3505%symbolic operator total_alg_mode_deriv$ 3506%symbolic procedure total_alg_mode_deriv(f,x)$ 3507%begin scalar tdf$ %,u,uli,v,vli$ 3508% tdf:={'df,f,x}$ 3509%% explicit program for chain rule of differentiation which is not used 3510%% as currently f=f(u), u=u(x) gives df(f**2,x)=2*f*df(f,x) 3511%% 3512%% for each u in depl!* do 3513%% if not freeof(cdr u,x) then uli:=cons(car u,uli)$ 3514%% for each u in uli do << 3515%% vli:=nil$ 3516%% for each v in depl!* do 3517%% if not freeof(cdr v,u) then vli:=cons(car v,vli)$ 3518%% algebraic ( tdf:=tdf+df(f,v)*df(v,u)*df(u,x) )$ 3519%% >>$ 3520% return reval tdf 3521%end$ 3522 3523put('total_alg_mode_deriv,'psopfn,'tot_alg_deri)$ 3524symbolic procedure tot_alg_deri(inp)$ 3525begin scalar s$ 3526 return 3527 {'!*sq,diffsq(<<s:=aeval car inp$ 3528 if pairp s and (car s='!*sq) then cadr s 3529 else simp s>>,reval cadr inp),t} 3530end$ 3531 3532symbolic procedure no_of_v(v,l)$ 3533% v is a variable name, l a list of derivatives like (x 2 y z 3) 3534% it returns the order of v-derivatives 3535<<while l and car l neq v do l:=cdr l; 3536 if null l then 0 else 3537 if null cdr l or not fixp cadr l or (cadr l = 1) then 1 else 3538 cadr l 3539>>$ 3540 3541symbolic procedure multiple_diffsq(p,h)$ 3542% multiple differentiation of p in sq-form eg. wrt h=(x 2 y) 3543begin scalar v,m,n$ 3544 while h do << 3545 v:=car h$ h:=cdr h$ 3546 v:=mvar car mksq(v,1)$ 3547 if null h then n:=1 else 3548 if fixp car h then <<n:=car h; h:=cdr h>> else n:=1$ 3549 for m:=1:n do p:=diffsq(p,v) 3550 >>$ 3551 return p 3552end$ 3553 3554symbolic procedure cp_sq2p_val(p)$ 3555if null get(p,'pval) then put(p,'pval,prepsq get(p,'sqval))$ 3556 3557%symbolic procedure cp_p2sq_val(p)$ 3558% % if ever needed then it should also assign 'fac 3559%put(p,'sqval,simp get(p,'pval))$ 3560 3561symbolic procedure sqzerop(p)$ 3562% p is recognized as zero if p=0 or (nil . 1) or (0 . 1) or {!*sq,(nil . 1),t} 3563% and NOT if p=nil (because atom nil = t and zerop nil = nil). 3564if atom p then zerop p else 3565if car p neq '!*sq then null numr p or 3566 zerop numr p 3567 else null numr cadr p or 3568 (domainp caadr p and not atom caadr p and 3569 apply1(get(car caadr p,'zerop),caadr p))$ 3570 3571%symbolic procedure sqzerop(p)$ 3572%% p is recognized as zero if p=0 or (nil . 1) or (0 . 1) or {!*sq,(nil . 1),t} 3573%% and NOT if p=nil (because atom nil = t and zerop nil = nil. 3574%if atom p then zerop p else 3575%if car p neq '!*sq then null numr p or 3576% zerop numr p 3577% else null numr cadr p or 3578% (dmode!* and domainp caadr p and 3579% apply(get(dmode!*,'zerop),list caadr p))$ 3580 3581%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 3582% general purpose procedures % 3583%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 3584 3585symbolic procedure memberl(a,b)$ 3586% member for a list 3587if a and b then 3588if member(car a,b) then cons(car a,memberl(cdr a,b)) 3589 else memberl(cdr a,b)$ 3590 3591symbolic procedure smemberl(fl,ex)$ 3592% smember for a list 3593if fl and ex then 3594if smember(car fl,ex) then cons(car fl,smemberl(cdr fl,ex)) 3595 else smemberl(cdr fl,ex)$ 3596 3597symbolic operator my_freeof$ 3598symbolic procedure my_freeof(u,v)$ 3599not(smember(v,u)) and freeofdepl(depl!*,u,v)$ 3600 3601lisp flag('(my_freeof),'BOOLEAN)$ 3602 3603symbolic procedure freeoflist(l,m)$ 3604% liefert t, falls kein Element aus m in l auftritt 3605if null m then t 3606else if freeof(l,car m) then freeoflist(l,cdr m) 3607 else nil$ 3608 3609symbolic procedure freeofdepl(de,u,v)$ 3610if null de then t 3611else if smember(v,cdar de) and smember(caar de,u) then nil 3612else freeofdepl(cdr de,u,v)$ 3613 3614symbolic procedure fctins(f,flen,ftem)$ 3615if null ftem then list f else 3616if fctlength car ftem < flen then cons(f,ftem) 3617else cons(car ftem,fctinsert(f,cdr ftem))$ 3618 3619symbolic procedure fctinsert(f,ftem)$ 3620% isert a function f in the function list ftem 3621if freeof(ftem,f) then fctins(f,fctlength f,ftem) 3622 else ftem$ 3623 3624symbolic procedure newfct(id,l,nfct)$ 3625begin scalar f$ 3626 % Only in the top level function names may be recycled otherwise 3627 % name clashes occur when passing back solutions with new functions 3628 % of integration but old used names 3629 if (null level_) and (id=fname_) and recycle_fcts then << 3630 f:=car recycle_fcts$ 3631 recycle_fcts:=cdr recycle_fcts 3632 >> else 3633 f:=mkid(id,nfct)$ 3634 depl!*:=delete(assoc(f,depl!*),depl!*)$ 3635 %put(f,'simpfn,'simpiden)$ 3636 %if pairp l then f:=cons(f,l)$ 3637 if pairp l then depl!*:=cons(cons(f,l),depl!*)$ 3638 if print_ then 3639 <<terpri()$ 3640 if pairp l then 3641 <<write "new function: "$ 3642 fctprint list f>> 3643 else 3644 write "new constant: ",f>>$ 3645 return f$ 3646end$ 3647 3648symbolic procedure drop_fct(f)$ 3649% check before that f is not one of the forg functions! 3650% check dropping f also from ftem_ 3651if null collect_sol then % This test is necessary as dependencies 3652 % are not recorded in collected solutions. 3653<<if do_recycle_fnc then recycle_fcts:=f . recycle_fcts$ 3654 depl!*:=delete(assoc(reval f,depl!*),depl!*) 3655>>$ 3656 3657symbolic procedure varslist(p,ftem,vl)$ 3658begin scalar l$ 3659ftem:=argset smemberl(ftem,p)$ 3660for each v in vl do 3661 if not my_freeof(p,v) or member(v,ftem) then l:=cons(v,l)$ 3662return reverse l$ 3663end$ 3664 3665symbolic procedure var_list(pdes,forg,vl)$ 3666begin scalar l,l1$ 3667for each p in pdes do l:=union(get(p,'vars),l)$ 3668for each v in vl do 3669 if member(v,l) or not my_freeof(forg,v) then l1:=cons(v,l1)$ 3670return reverse l1$ 3671end$ 3672 3673symbolic procedure f_update(pdes,forg)$ 3674begin scalar fdrop,p,f$ 3675 fdrop:=ftem_; 3676 for each p in pdes do fdrop:=setdiff_according_to(fdrop,get(p,'fcts),ftem_)$ 3677 for each f in ftem_ do if not freeof(forg,f) then fdrop:=delete(f,fdrop)$ 3678 if fsub_ then 3679 for each f in ftem_ do if not freeof(fsub_,f) then fdrop:=delete(f,fdrop)$ 3680 %% The following test is dropped because there could be functions to be 3681 %% computed which do not turn up in any equation. 3682 % for each f in forg do 3683 % if not pairp f and not member(f,ftem_) then 3684 % <<p:=0$ write"***** ERROR: forg not in ftem_ !!!"$1/p>>$ 3685 for each f in fdrop do drop_fct(f)$ 3686 flin_:=setdiff_according_to(flin_,fdrop,ftem_); 3687 ftem_:=setdiff_according_to(ftem_,fdrop,ftem_) 3688end$ 3689 3690symbolic operator fargs$ 3691symbolic procedure fargs f$ 3692cons('list,fctargs if pairp f and car f='!*sq then reval f else f)$ 3693 3694symbolic procedure fctargs f$ 3695% arguments of a function 3696if (f:=assoc(f,depl!*)) then cdr f$ 3697 3698symbolic procedure fctlength f$ 3699% number of arguments 3700length fctargs f$ 3701 3702symbolic procedure fctsort(l)$ 3703% list sorting 3704begin scalar l1,l2,l3,m,n$ 3705return 3706if null l then nil 3707else 3708<<n:=fctlength car l$ 3709 l2:=list car l$ 3710 l:=cdr l$ 3711 while l do 3712 <<m:=fctlength car l$ 3713 if m<n then l1:=cons(car l,l1) 3714 else if m>n then l3:=cons(car l,l3) 3715 else l2:=cons(car l,l2)$ 3716 l:=cdr l>>$ 3717 append(fctsort reversip l3,append(reversip l2,fctsort reversip l1))>> 3718end$ 3719 3720symbolic operator chkflist$ 3721symbolic procedure chkflist(flist,sb)$ 3722begin scalar f,h$ 3723 for each f in cdr flist do 3724 if (h:=memberl(cdr sb,fctargs f)) then << 3725 write "##### The function ",f," that is to be computed depends on ",h, 3726 " which is a left hand side of the input system or a ", 3727 "derivative of a left hand side of the input system"$ 3728 >> 3729end$ 3730 3731symbolic procedure listprint(l)$ 3732% print elements of a lisp list 3733if pairp l then << 3734 prin1 car l$ 3735 for each v in cdr l do <<prin2 ","$prin1 v>> 3736>>$ 3737 3738symbolic procedure fctprint1(f)$ 3739% print a function 3740begin scalar vl; 3741if f then 3742 if pairp f then << 3743 write car f$ 3744 if pairp cdr f then << 3745 for each a in vl_ do 3746 if not freeof(cdr f,a) then vl:=cons(a,vl); 3747 write "("$ 3748% listprint cdr f$ 3749 listprint append(setdiff(cdr f,vl),reverse vl)$ 3750 write ")">> 3751 >> 3752 else write f$ 3753end$ 3754 3755symbolic procedure fctprint(fl)$ 3756% printing the functions of the lisp list fl of elements: 3757% - {equal,f,...} where the rhs is in prefix or {'!*sq,..,t} form or 3758% - f or 3759% - {f,x,y,z} 3760begin scalar l,f,a,n,nn$ 3761 n:=0$ 3762 while fl do << 3763 f:=car fl$ 3764 fl:=cdr fl$ 3765 if pairp f then 3766 if car f='equal then << 3767 n:=if (pairp caddr f) and 3768 (car caddr f='!*sq) then no_of_tm_sq cadr caddr f 3769 else no_of_terms caddr f$ 3770 if (null print_) or (n>print_) then << 3771 terpri()$write cadr f,"= expr. with ",n," terms"$ 3772 if (l:=get(cadr f,'fcts)) then <<write " in "$myprin2l(l,", ")>>$ 3773 terpri() 3774 >> 3775 else mathprint f$ % not too long 3776 n:=0 3777 >> else << % pairp but not {'equal,...} 3778 if n = 4 then <<terpri()$n:=0>>$ % i.e. 4 in a row 3779 fctprint1 f$ 3780 if fl then write ", "$ 3781 n:=add1 n 3782 >> 3783 else << % not pairp 3784 nn:=reval {'plus,4,length explode f, 3785 for each a in fctargs f sum add1 length explode a}; 3786 if nn+n > 79 then <<terpri()$n:=0>>$ 3787 l:=assoc(f,depl!*)$ 3788 fctprint1 if l then l 3789 else f$ 3790 if fl then write ", "$ 3791 n:=nn+n 3792 >> 3793 >>$ 3794end$ 3795 3796symbolic procedure fctprint_SQ(fl)$ 3797% printing the functions of the lisp list fl of elements: 3798% - {equal,f,...} where the rhs is in SQ form or 3799% - f or 3800% - {f,x,y,z} 3801begin scalar l,f,a,n,nn$ 3802 n:=0$ 3803 while fl do << 3804 f:=car fl$ 3805 fl:=cdr fl$ 3806 if pairp f then 3807 if car f='equal then << 3808 n:=no_of_tm_sq caddr f; 3809 if (null print_) or (n>print_) then << 3810 terpri()$write cadr f,"= expr. with ",n," terms"$ 3811 if (l:=get(cadr f,'fcts)) then <<write " in "$myprin2l(l,", ")>>$ 3812 terpri() 3813 >> else % not too long 3814 mathprint {'equal, cadr f, 3815 if null numr caddr f then 0 3816 else{'!*sq,caddr f,t}}$ 3817 n:=0 3818 >> else << % pairp but not {'equal,...} 3819 if n = 4 then <<terpri()$n:=0>>$ % i.e. 4 in a row 3820 fctprint1 f$ 3821 if fl then write ", "$ 3822 n:=add1 n 3823 >> 3824 else << % not pairp 3825 nn:=reval {'plus,4,length explode f, 3826 for each a in fctargs f sum add1 length explode a}; 3827 if nn+n > 79 then <<terpri()$n:=0>>$ 3828 l:=assoc(f,depl!*)$ 3829 fctprint1 if l then l 3830 else f$ 3831 if fl then write ", "$ 3832 n:=nn+n 3833 >> 3834 >>$ 3835end$ 3836 3837symbolic operator fdep$ 3838symbolic procedure fdep(fl)$ 3839% fl is an algebraic list of function names. fdep prints their dependencies 3840begin scalar l,f$ 3841 terpri()$ 3842 fl:=cdr reval fl$ 3843 while fl do << 3844 f:=car fl; fl:=cdr fl; 3845 l:=assoc(f,depl!*)$ 3846 write f$ 3847 if l and cdr l then <<write"="$fctprint1 if l then l else f>>$ 3848 if fl then write ", " 3849 >>$ 3850 terpri() 3851end$ 3852 3853symbolic procedure deprint(l)$ 3854% Ausdrucken der Gl. aus der Liste l 3855if l and print_ then for each x in l do eqprint list('equal,0,x)$ 3856 3857symbolic procedure eqprint(e)$ 3858% Ausdrucken der Gl. e 3859% e must be in prefix form or {'!*sq, .. ,t} form 3860if print_ then 3861begin scalar n$ 3862 n:=if not pairp e then 1 else 3863 if (car e = '!*sq) then delengthSQ cadr e else 3864 if (car e = 'equal) then if not pairp caddr e then 1 else 3865 if (caaddr e = '!*sq) then delengthSQ cadr caddr e 3866 else delength caddr e 3867 else delength e$ 3868 if n>print_ then 3869 <<write %"expr. with ", 3870 n," factors in ", 3871 if not pairp e then 1 else 3872 if (car e = '!*sq) then no_of_tm_sq cadr e else 3873 if (car e = 'equal) then if not pairp caddr e then 1 else 3874 if (caaddr e = '!*sq) then no_of_tm_sq cadr caddr e 3875 else no_of_terms caddr e 3876 else no_of_terms e, 3877 " terms"$ 3878 terpri() 3879 >> else 3880 if sqzerop e then mathprint 0 else 3881 if pairp e and 3882 car e='equal and 3883 sqzerop caddr e then mathprint {'equal,cadr e,0} 3884 else mathprint e$ 3885end$ 3886 3887symbolic procedure print_level(mode)$ 3888if print_ and level_ then << 3889 terpri()$ 3890 if mode=2 then write "New level : " else 3891 if mode=1 then write "Current level : " else 3892 write "Back to level : "$ 3893 for each m in reverse level_ do write m,"."$ 3894 terpri() 3895>>$ 3896 3897symbolic procedure start_level(n,new_assumption)$ 3898<<level_:=cons(n,level_)$ 3899 CaseTree(if null new_assumption then {nil} % simply nil would mean 3900 % that a case is finished 3901 else new_assumption)$ 3902 print_level(2)$ 3903 if size_watch and not fixp size_watch then % otherwise avoid growth 3904 history_:=cons(bldmsg("%w%w","Start of level ",level_string(nil)), 3905 cons('ig,history_)); 3906 if size_watch then size_hist:=cons({'A,"Start of ",reverse level_, 3907 new_assumption},size_hist); 3908>>$ 3909 3910symbolic procedure finish_level(no_of_sol)$ 3911begin scalar s$ 3912 delete_backup()$ 3913 CaseTree(no_of_sol)$ 3914 if size_watch and not fixp size_watch then <<% otherwise avoid growth 3915 s:=level_string(nil); 3916 s:=bldmsg("End of level %w, %d solution(s)",s,no_of_sol); 3917 history_:=cons(s,cons('ig,history_)) 3918 >>$ 3919 level_:=cdr level_$ 3920 print_level(0)$ 3921 if size_watch then 3922 size_hist:=cons({'Z,"Back to ",reverse level_,no_of_sol},size_hist); 3923 % change switches back 3924 s:=switch_list$ 3925 while s do << 3926 if length car s > length level_ then << % switch back 3927 if caddar s then on1 cadar s 3928 else off1 cadar s; 3929 s:=cdr s; 3930 switch_list:=cdr switch_list 3931 >> else s:=nil 3932 >> 3933end$ 3934 3935symbolic procedure print_statistic(pdes,fcts)$ 3936if print_ then begin 3937 integer j,k,le,r,s$ 3938 scalar n,m,p,el,fl,vl,pl,st,pdecp$ 3939 pdecp:=pdes$ 3940 3941 %--- printing the stats of equations: 3942 if pdes then << 3943 if equations_file neq "" then << 3944 terpri()$write"equations read from disk : ",eqn_no$ 3945 st:=" "$ 3946 >> else 3947 if null lin_problem then st:=" " 3948 else st:=""$ 3949 terpri()$write "number of equations ",st,": ",length pdes$ 3950 if null lin_problem then << 3951 j:=0; 3952 for each p in pdes do 3953 if get(p,'linear_) then j:=add1 j$ 3954 terpri()$write "number of lin. equations : ",j$ 3955 >>$ 3956 terpri()$write "total no of terms ",st,": ", 3957 j:=for each p in pdes sum get(p,'terms)$ 3958 k:=for each p in pdes sum get(p,'length)$ 3959 if k neq j then <<terpri()$ 3960 write "total no of factors ",st,": ",k>>$ 3961 while pdes do << 3962 j:=0; 3963 el:=nil; 3964 for each p in pdes do << 3965 vl:=get(p,'vars); 3966 if vl then le:=length vl 3967 else le:=0; 3968 if ((j=0) and null vl) or 3969 (j=le) then el:=cons(p,el) 3970 else if j<le then << 3971 j:=le; 3972 el:=list(p) 3973 >> 3974 >>; 3975 pdes:=setdiff(pdes,el); 3976 if el then << 3977 n:=length el$ 3978 terpri()$write n," equation"$ 3979 if n>1 then write"s"$write" in ",j," variable"$ 3980 if j neq 1 then write"s"$ 3981 write": "$ 3982 3983 if struc_eqn then el:=sort_deriv_pdes(el)$ 3984 repeat << 3985 if struc_eqn then << 3986 pl:=first el; el:=cdr el; 3987 terpri()$ 3988 write length cdr pl," equations with ",car pl," derivative", 3989 if car pl = 1 then ":" else "s:"$ 3990 pl:=cdr pl 3991 >> else <<pl:=el;el:=nil>>; 3992% terpri()$ 3993 k:=29; 3994 while pl do << 3995 if (k geq 70) then <<k:=0;terpri();write" ">>$ 3996 k:=k+4+length explode car pl + length explode get(car pl,'terms)$ 3997 write car pl,"(",get(car pl,'terms)$ 3998 if (s:=get(car pl,'starde)) then << 3999 for r:=1:(1+caar s) do write"*"$ 4000 k:=k+1+caar s; 4001 >>$ 4002 if pairp get(car pl,'fac) then write"#"$ 4003 if get(car pl,'case2sep) then write"!"$ 4004 if flin_ and get(car pl,'allvarfcts) and 4005 freeoflist(get(car pl,'allvarfcts),flin_) then write"a"$ 4006 if null lin_problem and get(car pl,'linear_) then write"l"$ 4007 write")"$ 4008 pl:=cdr pl$ 4009 if pl then write","$ 4010 >>; 4011 4012 >> until null el; 4013 4014 >>$ 4015 j:=add1 j; 4016 >> 4017 >> 4018 else <<terpri()$write "no equations">>$ 4019 4020 %--- printing the stats of functions: 4021 for each f in fcts do if not pairp f then fl:=cons(f,fl)$ 4022 for each f in fsub_ do fl:=delete(car f,fl); 4023 4024 if fl then << 4025 fl:=fctsort fl$ 4026 m:=fctlength car fl$ 4027 while m>=0 do << 4028 n:=0$ 4029 el:=nil; 4030 while fl and (fctlength car fl=m) do << 4031 n:=add1 n$ 4032 el:=cons(car fl,el)$ 4033 fl:=cdr fl 4034 >>$ 4035 if n>0 then 4036 if m>0 then << 4037 terpri()$ 4038 write n," function"$ 4039 if n>1 then write"s"$ 4040 write" with ",m," argument",if m>1 then "s : " 4041 else " : " 4042 >> else << 4043 terpri()$ 4044 write n," constant"$ 4045 if n>1 then write"s"$ 4046 write" : " 4047 >>$ 4048 k:=5; 4049 el:=sort_according_to(el,ftem_)$ 4050 while el do << 4051 if k=8 then <<k:=0;terpri();write" ">> 4052 else k:=add1 k$ 4053 write car el$ 4054 n:=0; 4055 for each p in pdecp do if member(car el,get(p,'fcts)) then n:=add1 n; 4056 write"(",n,")"$ 4057 el:=cdr el$ 4058 if el then write","$ 4059 >>$ 4060 m:=if fl then fctlength car fl 4061 else -1 4062 >> 4063 >> else <<terpri()$write "no functions or constants">>$ 4064 terpri()$ 4065end$ 4066 4067symbolic procedure get_statistic(pdes,fcts)$ 4068 % returns: {stepcounter_, 4069 % time(), 4070 % number of remaining unknowns, 4071 % number of pdes, 4072 % number of terms, 4073 % total length of pdes, 4074 % last_free_cells 4075 % % {{no of eq, no of var in eq}, ...} 4076 % % {{no of fc, no of var in fc}, ...} 4077 % } 4078if contradiction_ then "contradiction" else 4079begin 4080 integer j,le$ 4081 scalar n,p,el,fl,vl,li,stats$ 4082 4083 stats:={last_free_cells, 4084 for each p in pdes sum get(p,'length), 4085 for each p in pdes sum get(p,'terms), 4086 length pdes, 4087 length ftem_, 4088 time(), 4089 stepcounter_}$ 4090 4091 if null vl_ then return reverse stats$ 4092 4093 %--- the statistics of equations: 4094 while pdes do << 4095 % j is number of variables and el the list of equations 4096 j:=0; 4097 el:=nil; 4098 for each p in pdes do << 4099 vl:=get(p,'vars); 4100 if vl then le:=length vl 4101 else le:=0; 4102 if ((j=0) and null vl) or 4103 (j=le) then el:=cons(p,el) 4104 else if j<le then << 4105 j:=le; 4106 el:=list(p) 4107 >> 4108 >>; 4109 pdes:=setdiff(pdes,el); 4110 li:=cons({length el,j},li) 4111 % length el equations in j variables 4112 >>; 4113 stats:=cons(li,stats)$ 4114 li:=nil; 4115 4116 %--- the statistics of functions: 4117 for each f in fcts do if not pairp f then fl:=cons(f,fl)$ 4118 if fl then << 4119 fl:=fctsort reverse fl$ 4120 j:=fctlength car fl$ 4121 while j>=0 do << 4122 n:=0$ 4123 while fl and (fctlength car fl=j) do <<n:=add1 n$ fl:=cdr fl>>$ 4124 li:=cons({n,j},li)$ 4125 % n functions of j variables 4126 j:=if fl then fctlength car fl 4127 else -1 4128 >> 4129 >>$ 4130 stats:=cons(li,stats)$ 4131 4132 return reverse stats 4133end$ 4134 4135symbolic procedure sort_deriv_pdes(pdes)$ 4136begin scalar max_no_deri,cp,pl,res$ 4137 max_no_deri:=0; 4138 cp:=pdes; 4139 while cp do << 4140 if get(car cp,'no_derivs)>max_no_deri then 4141 max_no_deri:=get(car cp,'no_derivs); 4142 cp:=cdr cp 4143 >>; 4144 repeat << 4145 pl:=nil; 4146 cp:=pdes; 4147 while cp do << 4148 if get(car cp,'no_derivs)=max_no_deri then pl:=cons(car cp,pl); 4149 cp:=cdr cp 4150 >>$ 4151 if pl then res:=cons(cons(max_no_deri,reverse pl),res)$ 4152 pdes:=setdiff(pdes,pl); 4153 max_no_deri:=if zerop max_no_deri then nil 4154 else sub1(max_no_deri); 4155 >> until (null max_no_deri) or (null pdes); 4156 return res 4157end$ 4158 4159symbolic procedure print_pdes(pdes)$ 4160% print all pdes up to some size 4161begin scalar pl,n,pdecp$ 4162 terpri()$ 4163 if pdes then << 4164 if (null !*batch_mode) and 4165 (batchcount_<stepcounter_) and 4166 (cdr pdes) then << % if more than one pde 4167 n:=1000000000; 4168 if nil then 4169 repeat << 4170 write"What is the maximal number of terms of equations to be shown? "$ 4171 change_prompt_to ""$ 4172 terpri()$n:=termread()$ 4173 restore_interactive_prompt() 4174 >> until fixp n$ 4175 for each pl in pdes do 4176 if get(pl,'terms)<=n then pdecp:=cons(pl,pdecp); 4177 pdecp:=reverse pdecp; 4178 >> else pdecp:=pdes$ 4179 4180 write "equations : "$ 4181 if struc_eqn then << 4182 pl:=sort_deriv_pdes(pdecp)$ 4183 while pl do << 4184 terpri()$ 4185 write length cdar pl," equations with ",caar pl," derivatives:"$ 4186 typeeqlist(cdar pl)$ 4187 pl:=cdr pl 4188 >> 4189 >> else typeeqlist(pdecp) 4190 >> else <<write "no equations"$ terpri()>>$ 4191end$ 4192 4193symbolic procedure print_ineq(ineqs)$ 4194% print all ineqs where ineqs=(ineq_ . ineq_or) 4195begin scalar a,b,c,d,h$ 4196 terpri()$ 4197 if car ineqs then << 4198 terpri()$write "Non-vanishing expressions: "$ 4199 for each a in car ineqs do 4200 if no_number_atom_SQ a then c:=cons(mvar numr a,c) 4201 else b:=cons({'!*sq,a,t},b); 4202 listprint c;terpri()$ 4203 for each a in b do eqprint a 4204 >>$ 4205 if cdr ineqs then << 4206 terpri()$write "Lists with at least one non-vanishing sub-list "$ 4207 terpri()$write "(ie. a sub-list of which no element vanishes.): "$terpri()$ 4208 for each a in cdr ineqs do << 4209 write"{"$ % a is an or-inequality 4210 for each h in a do << % h is a potentially non-vanishing expression, i.e. list of factors 4211 write"{"$ 4212 4213 c:=nil; b:=nil; 4214 for each d in h do % b,c will be lists of factors of h 4215 if no_number_atom_SQ d then c:=cons(mvar numr d,c) 4216 else b:=cons({'!*sq,d,t},b); 4217 listprint c; 4218 4219 if not null b then << 4220 if c then <<write","$terpri()>>$ 4221 for each d in b do eqprint d 4222 >>$ 4223 write"}"$%terpri()$ 4224 >>$ % of for each h 4225 write"}"$terpri()$ 4226 >> % of for each a 4227 >> % of cdr ineqs 4228end$ 4229 4230symbolic procedure print_fcts(pdes,fcts)$ 4231% print all fcts that are not evaluated as something and prints vars 4232begin scalar dflist,dfs,f,p,cp,h,hh,showcoef$ 4233 4234 for each h in fcts do if not pairp h then hh:=cons(h,hh); 4235 change_prompt_to ""$ 4236 4237 fcts:=select_from_list(hh,nil)$ 4238 pdes:=select_from_list(pdes,nil)$ 4239 4240 write"Do you want to see the coefficients of all derivatives in all equations"$ 4241 terpri()$ 4242 write"in factorized form which may take relatively much time? y/n"$ 4243 terpri()$ 4244 repeat 4245 h:=termread() 4246 until (h='y) or (h='n); 4247 if h='n then showcoef:=nil else showcoef:=t; 4248 4249 restore_interactive_prompt()$ 4250 4251 while fcts do 4252 if pairp car fcts then fcts:=cdr fcts 4253 else << 4254 f:=car fcts; fcts:=cdr fcts; 4255 dflist:=nil; 4256 for each p in pdes do if not freeof(get(p,'fcts),f) then << 4257 dfs:=get(p,'derivs); 4258 while dfs do << 4259 if caaar dfs=f then << 4260 cp:=dflist; 4261 while cp and (caar cp neq caar dfs) do cp:=cdr cp; 4262 if cdaar dfs then h:=cons('df,caar dfs) 4263 else h:=caaar dfs; 4264 if showcoef then 4265 if null cp then dflist:=cons({caar dfs, 4266 {'list,p, 4267 err_catch_fac coeffn({'!*sq,get(p,'sqval),t},h,1)}},dflist) 4268 else rplaca(cp,cons(caar cp, 4269 cons({'list,p, 4270 err_catch_fac coeffn({'!*sq,get(p,'sqval),t},h,1)}, 4271 cdar cp))) 4272 else 4273 if null cp then dflist:=cons({caar dfs,p},dflist) 4274 else rplaca(cp,cons(caar cp,cons(p,cdar cp))) 4275 >>; 4276 dfs:=cdr dfs 4277 >>; 4278 >>; 4279 while dflist do << 4280 dfs:=car dflist;dflist:=cdr dflist; 4281 if cdar dfs then h:=cons('df,car dfs) 4282 else h:=caar dfs; 4283 if showcoef then algebraic <<write h,": ",lisp cons('list,cdr dfs)>> 4284 else <<write h,": "$ print cdr dfs$ terpri()>> 4285 >>; 4286 >>; 4287end$ 4288 4289symbolic procedure print_forg(fcts,vl)$ 4290% print all fcts and vars 4291<<if fsub_ then << 4292 terpri()$write "Eliminations not yet used for substitutions : "$terpri()$ 4293 for each p in fsub_ do algebraic(write lisp car p, " = ",lisp reval cdr p) 4294 >>$ 4295 if fcts then << 4296 terpri()$write "Functions : "$ 4297 fctprint_SQ(fcts)$ terpri()$ 4298 write "with ", 4299 for each p in fcts sum 4300 if pairp p and (car p = 'equal) then no_of_tm_sq caddr p 4301 else 1 ," terms"$ 4302 terpri()$ 4303 >>$ 4304 if vl then <<terpri()$write "Variables : "$ fctprint(vl)>>$ 4305>>$ 4306 4307symbolic procedure print_pde_forg_ineq(pdes,ineqs,fcts,vl)$ 4308% print all pdes, ineqs and fcts which if {equal,f,x} have x in SQ-form (forg) 4309if print_ then begin$ 4310 print_pdes(pdes)$ 4311 print_ineq(ineqs)$ 4312 print_forg(fcts,vl)$ 4313 print_statistic(pdes,fcts) 4314end$ 4315 4316symbolic procedure no_of_terms(d)$ 4317if not pairp d then if (null d) or (zerop d) then 0 4318 else 1 else 4319if car d='plus then length d - 1 else 4320if car d='equal then no_of_terms(cadr d) + 4321 no_of_terms(caddr d) else 4322if (car d='minus) or (car d='quotient) then 4323 no_of_terms(cadr d) else 4324if car d='expt then 4325if (not fixp caddr d) or (caddr d < 2) then 1 else 4326% number of terms of (a1+a2+..+an)**r = n+r-1 over r 4327begin scalar h,m,q$ 4328 m:=no_of_terms(cadr d)-1; 4329 h:=1; 4330 for q:=1:caddr d do h:=h*(m+q)/q; 4331 return h 4332end else 4333if car d='times then begin scalar h,r; 4334 h:=1; 4335 for each r in cdr d do h:=h*no_of_terms(r); 4336 return h 4337end else 1$ 4338 4339symbolic procedure no_of_tm_sf s$ 4340% input is a standard form s 4341% counts no of terms 4342if null s then 0 else 4343if (not pairp s) or (not pairp car s) then 1 % an integer number 4344 else 4345no_of_tm_sf(cdar s)+no_of_tm_sf(cdr s)$ 4346 4347symbolic procedure no_of_tm_sf_limited(s,x)$ 4348% input is a standard form s 4349% counts no of terms up to x 4350if null s then 0 else 4351if (not pairp s) or (not pairp car s) then 1 % an integer number 4352 else 4353begin scalar r; 4354 r:=no_of_tm_sf_limited(cdar s,x)$ 4355 return 4356 if r>x then r 4357 else r+no_of_tm_sf_limited(cdr s,x) 4358end$ 4359 4360symbolic procedure more_than_x_terms(s,x)$ 4361% input is a standard form s 4362% it checks whether s includes more than x terms 4363% counts no of terms until it reaches x 4364begin scalar y$ 4365 return 4366 if null s then nil else 4367 if (not pairp s) or (not pairp car s) then % 1 term 4368 if x=0 then t else nil 4369 else << 4370 y:=no_of_tm_sf_limited(cdar s,x); 4371 if y<=x then y:=y+no_of_tm_sf_limited(cdr s,x)$ 4372 y>x 4373 >> 4374end$ 4375 4376% not used so far: 4377%symbolic procedure no_of_fac_sf s$ 4378%% input is a standard form s 4379%% counts no of factors, powers count as one 4380%if null s then 0 else 4381%if s eq 1 then 0 else 4382%if not pairp s then 1 % an integer number 4383% else 1+no_of_fac_sf(cdar s)+ 4384%if cdr s eq 1 then 1 4385% else no_of_fac_sf(cdr s)$ 4386 4387symbolic procedure no_of_tm_sq s$ 4388% input is a standard quotient form s 4389% counts no of terms 4390no_of_tm_sf numr s + if denr s = 1 then 0 4391 else no_of_tm_sf denr s$ 4392 4393symbolic procedure no_number_atom_SF(sf)$ 4394if pairp sf and 4395 null red sf and 4396 lc sf = 1 and 4397 ldeg sf = 1 and 4398 null pairp mvar sf then t 4399 else nil$ 4400 4401symbolic procedure no_number_atom_SQ(sq)$ 4402no_number_atom_SF numr sq$ 4403 4404symbolic procedure one_termpSF(sf)$ 4405% returns nil if sf has more than one term 4406if domainp sf then t else 4407if red sf then nil else one_termpSF lc sf$ 4408 4409symbolic procedure first_term_SF(sf)$ 4410% returns first term of standard form sf in standard form 4411% (((mvar . ldeg) . lc) . red) or 4412% (( lpow . lc) . red) 4413if domainp sf then sf else 4414{(lpow sf . first_term_SF lc sf)}$ 4415 4416symbolic procedure num_term_SF(sf)$ 4417% returns purely numerical term of standard form sf if there is one 4418% (((mvar . ldeg) . lc) . red) or 4419% (( lpow . lc) . red) 4420if sf then if domainp sf then sf 4421 else num_term_SF red sf$ 4422 4423symbolic procedure lmon_SF(sf)$ 4424% returns the leading monomial of standard form sf in standard form 4425% (((mvar . ldeg) . lc) . red) or 4426% (( lpow . lc) . red) 4427if domainp sf then 1 else 4428{(lpow sf . lmon_SF lc sf)}$ 4429 4430symbolic procedure nco_SQ(h)$ 4431% returns the numerical coefficient of the leading term 4432% of the standard quotient h 4433begin scalar d$ 4434 % h:=cadr aeval h$ 4435 d:=cdr h$ 4436 h:=car h$ 4437 while pairp h and not domainp car h do h:=lc h; 4438 if pairp h then h:={'quotient,cadr h,cddr h}; 4439 if d neq 1 then h:={'quotient,h,d}; 4440 return h 4441end$ 4442 4443put('numcoeff,'psopfn,'numco)$ % currently (11.6.08) used in sstools 4444symbolic procedure numco(h)$ 4445% returns the numerical of the first term of the expression h 4446begin 4447 h:=car cadr aeval car h; 4448 while pairp h and not domainp car h do h:=lc h; 4449 if pairp h then h:={'quotient,cadr h,cddr h}; 4450 return h 4451end$ 4452 4453symbolic procedure non_negative(exf)$ 4454% gives t iff the standard form exf is a positive sum of squares 4455null exf or 4456(domainp exf and plusp exf) or 4457(null domainp exf and 4458 (fixp ldeg exf and evenp ldeg exf ) and 4459 ((domainp lc exf and plusp lc exf) or 4460 (null domainp lc exf and non_negative lc exf)) and 4461 non_negative red exf)$ 4462 4463%-------- 4464 4465symbolic procedure mymemq (u , v, v1)$ 4466% EQ version of Member 4467% hard truncating the list in front of the item found 4468if not pairp v then nil 4469 else if eq( u ,car v) then << if v1 then rplacd(v1,nil) ; v>> 4470 else mymemq(u ,cdr v, v)$ 4471 4472%>>>>>>>>>> The normal REDUCE algebraic mode function cons 4473% converts standard quotient lists into prefix form which to 4474% convert back into standard quotient form would take very very long 4475% for large expressions. The new function sqcons returns 4476% a list of standard quotient expressions. 4477 4478symbolic procedure sq!*cons(x)$ 4479<< 'list . cons (aeval car x, cdr aeval cadr x)>>$ 4480put('sqcons,'psopfn,'sq!*cons)$ 4481 4482%-------- 4483symbolic procedure sq!*length(x)$ 4484((length aeval car x) - 1)$ 4485put('sqlength,'psopfn,'sq!*length)$ 4486 4487%-------- 4488symbolic procedure sq!*rest(x)$ 4489<< 'list . cddr aeval car x>>$ 4490put('sqrest,'psopfn,'sq!*rest)$ 4491 4492%-------- 4493symbolic procedure sq!*first(x)$ 4494cadr aeval car x$ 4495put('sqfirst,'psopfn,'sq!*first)$ 4496 4497%-------- 4498symbolic procedure sq!*second(x)$ 4499caddr aeval car x$ 4500put('sqsecond,'psopfn,'sq!*second)$ 4501 4502%-------- 4503symbolic procedure sq!*third(x)$ 4504cadddr aeval car x$ 4505put('sqthird,'psopfn,'sq!*third)$ 4506 4507%-------- 4508symbolic procedure sq!*part(x)$ 4509% This procedure is only equivalent to part(a,b) if the first 4510% argument to sqpart is an algebraic list and it the second 4511% argument is not 0. 4512begin scalar c1,c2$ 4513 c1:=aeval car x$ 4514 c2:=aeval cadr x$ 4515 return 4516 if (c2=0) and not pairp c1 then -1 4517 else nth(c1,add1 c2)$ 4518end$ 4519put('sqpart,'psopfn,'sq!*part)$ 4520 4521%-------- 4522symbolic procedure sq!*reverse(x)$ 4523<< 'list . reverse cdr aeval car x>>$ 4524put('sqreverse,'psopfn,'sq!*reverse)$ 4525 4526%-------- 4527symbolic procedure sq!*append(x)$ 4528<< 'list . append(cdr aeval car x,cdr aeval cadr x)>>$ 4529put('sqappend,'psopfn,'sq!*append)$ 4530 4531%-------- 4532 4533symbolic procedure delengthSF(d)$ 4534% counting all factors, even numbers in the standard form d 4535if (not pairp d) or (not pairp car d) or (not pairp caar d) 4536then if domainp d then 0 4537 else 1 4538else ldeg d + delengthSF(lc d) + delengthSF(red d)$ 4539 4540symbolic procedure delengthSQ(d)$ 4541% counting all factors, even numbers in the standard quotient form 4542(if numr d = 1 then 0 else delengthSF numr d) + 4543(if denr d = 1 then 0 else delengthSF denr d) $ 4544 4545symbolic procedure delength(d)$ 4546% Laenge eines Polynoms in prefix Form 4547if not pairp d then 4548 if d then 1 4549 else 0 4550else 4551if (car d='plus) or (car d='times) or (car d='quotient) 4552 or (car d='minus) or (car d='equal) 4553 then for each a in cdr d sum delength(a) 4554else 1$ 4555 4556symbolic procedure pdeweightSF(d,ftem)$ 4557% determines the total number of factors of elements of ftem 4558% in the standard form d which has structure: (((mvar . ldeg) . lc) . red) 4559% This version does not count ftem in exponents 4560 4561if null d or d=1 or d=0 then 0 else 4562if (not pairp d) or (not pairp car d) or (not pairp caar d) then 1 else 4563if freeoflist(mvar d,ftem) then 4564 pdeweightSF(lc d,ftem) + pdeweightSF(red d,ftem) 4565 else 4566ldeg d + pdeweightSF(lc d,ftem) + pdeweightSF(red d,ftem)$ 4567% assuming that ldeg d is an integer 4568 4569symbolic procedure pdeweight(d,ftem)$ 4570% Laenge eines Polynoms in LISP - Notation 4571if not smemberl(ftem,d) then 0 4572else if not pairp d then 1 4573else if (car d='plus) or (car d='times) or (car d='equal) 4574 or (car d='quotient) then 4575 for each a in cdr d sum pdeweight(a,ftem) 4576else if (car d='expt) then 4577 if numberp caddr d then 4578 caddr d*pdeweight(cadr d,ftem) 4579 else 4580 pdeweight(caddr d,ftem)+pdeweight(cadr d,ftem) 4581else if (car d='minus) then pdeweight(cadr d,ftem) 4582else 1$ 4583 4584symbolic procedure desort(l)$ 4585% sort expressions in prefix form hat are the elements of the list l by size 4586% currently called only once in liepde.red 4587for each a in idx_sort for each b in l collect cons(delength b,b) 4588collect cdr a$ 4589 4590symbolic procedure idx_sort(l)$ 4591% All elements of l have a numerical first element and are sorted 4592% by quicksort according to that number, lowest first 4593if null l then nil else 4594begin scalar l1,l2,l3,m,n$ 4595 return 4596 <<n:=caar l$ 4597 l2:=list car l$ 4598 l:=cdr l$ 4599 while l do 4600 <<m:=caar l$ 4601 if m<n then l1:=cons(car l,l1) 4602 else if m>n then l3:=cons(car l,l3) 4603 else l2:=cons(car l,l2)$ 4604 l:=cdr l>>$ 4605 append(idx_sort(l1),append(l2,idx_sort(l3))) 4606 >> 4607end$ 4608 4609symbolic procedure rev_idx_sort(l)$ 4610% All elements of l have a numerical first element and are sorted 4611% by quicksort according to that number, highest first 4612if null l then nil else 4613begin scalar l1,l2,l3,m,n$ 4614 return 4615 <<n:=caar l$ 4616 l2:=list car l$ 4617 l:=cdr l$ 4618 while l do 4619 <<m:=caar l$ 4620 if m>n then l1:=cons(car l,l1) 4621 else if m<n then l3:=cons(car l,l3) 4622 else l2:=cons(car l,l2)$ 4623 l:=cdr l>>$ 4624 append(rev_idx_sort(l1),append(l2,rev_idx_sort(l3))) 4625 >> 4626end$ 4627 4628symbolic procedure rat_idx_sort(l)$ 4629% All elements of l have a rational number first element 4630% and are sorted by quicksort according to that number 4631% The rational number has to be reval-ed ! 4632begin scalar l1,l2,l3,m,n$ 4633return 4634if null l then nil 4635else 4636<<n:=caar l$ 4637 l2:=list car l$ 4638 l:=cdr l$ 4639 while l do 4640 <<m:=caar l$ 4641 if rational_less(m,n) then l1:=cons(car l,l1) 4642 else if rational_less(n,m) then l3:=cons(car l,l3) 4643 else l2:=cons(car l,l2)$ 4644 l:=cdr l>>$ 4645 append(rat_idx_sort(l1),append(l2,rat_idx_sort(l3)))>> 4646end$ 4647 4648symbolic procedure sort_eq_by_length(pdes)$ 4649<<largest_fully_shortened:=nil; 4650 currently_to_be_substituted_in:=nil; 4651 for each p in 4652 idx_sort(for each p in pdes collect (get(p,'terms) . p) ) 4653 collect cdr p>>$ 4654 4655symbolic procedure update_eq_sort_by_length(pdes)$ 4656% update the list pdes to have a monotonic increase of 4657% the number of terms 4658if null pdes or null cdr pdes then pdes else 4659begin scalar p,q,carpt,cadrpt,cadrp$ 4660 p:=pdes; 4661 carpt:=get(car p,'terms); 4662 while cdr p do << 4663 cadrpt:=get(cadr p,'terms); 4664 if carpt<=cadrpt then <<carpt:=cadrpt; p:=cdr p>> 4665 else << 4666 % take out cadr p 4667 cadrp:=cadr p; 4668 rplacd(p,cddr p)$ 4669 if cadrpt<=get(car pdes,'terms) then pdes:=cons(cadrp,pdes) 4670 else << 4671 q:=pdes; 4672 while cdr q and (cadrpt>get(cadr q,'terms)) do q:=cdr q; 4673 % insert cadrp 4674 rplacd(q,cons(cadrp,cdr q))$ 4675 >> 4676 >> 4677 >>$ 4678 return pdes 4679end$ 4680 4681symbolic procedure kernel_sort(l)$ 4682% All elements of l are kernels to be sorted by quicksort 4683if null l then nil else 4684if null cdr l then l else 4685begin scalar n,l1,l2$ 4686 return 4687 <<n:=car l$ 4688 l2:=list n$ 4689 l:=cdr l$ 4690 while l do << 4691 if ordp(car l,n) then l1:=cons(car l,l1) 4692 else l2:=cons(car l,l2); 4693 l:=cdr l 4694 >>$ 4695 %append(kernel_sort(l1),kernel_sort(l2)) 4696 nconc(kernel_sort(l1),kernel_sort(l2)) % should work as l1,l2 are defined locally 4697 >> 4698end$ 4699 4700symbolic procedure argset(ftem)$ 4701% List of arguments of all functions in ftem 4702if ftem then union(reverse fctargs car ftem,argset(cdr ftem)) 4703 else nil$ 4704 4705symbolic procedure no_fnc_of_v$ 4706begin scalar vl,v,nofu,f,nv$ 4707 % How many functions do depend on each variable? 4708 vl:=argset(ftem_)$ 4709 for each v in vl do << 4710 nofu:=0; % the number of functions v occurs in 4711 for each f in ftem_ do 4712 if not freeof(fctargs f,v) then nofu:=add1 nofu$ 4713 nv:=cons((v . nofu),nv)$ 4714 >>$ 4715 return nv 4716end$ 4717 4718procedure push_vars(liste)$ 4719for each x in liste collect 4720if not boundp x then x else eval x$ % valuecell x$ 4721 4722symbolic procedure backup_pdes(pdes,forg)$ 4723% returns a list with all data that are passed on to a separate 4724% computation and which are not received back, therefore this 4725% backup is made. 4726begin scalar allfl$ 4727 return 4728 list(push_vars not_passed_back, 4729 for each p in pdes collect 4730 list(p, 4731 for each q in prop_list collect cons(q,get(p,q)), 4732 <<allfl:=nil; 4733 for each q in allflags_ do 4734 if flagp(p,q) then allfl:=cons(q,allfl); 4735 allfl>>), 4736 for each f in forg collect 4737 if pairp f then cons(f,get(cadr f,'fcts)) 4738 else cons(f,get( f,'fcts)), 4739 for each id in idnties_ collect 4740 list(id,get(id,'val),flagp(id,'to_int),flagp(id,'to_subst)) 4741 ) 4742end$ 4743 4744%symbolic procedure backup_pdes(pdes,forg)$ 4745%% make a backup of all pdes 4746%begin scalar cop$ 4747% cop:=list(nequ_, 4748% for each p in pdes collect 4749% list(p, 4750% for each q in prop_list collect cons(q,get(p,q)), 4751% for each q in allflags_ collect if flagp(p,q) then q), 4752% for each f in forg collect 4753% if pairp f then cons(cadr f,get(cadr f,'fcts)) 4754% else cons(f,get(f,'fcts)), 4755% ftem_, 4756% ineq_, 4757% recycle_ens, 4758% recycle_fcts)$ 4759% return cop 4760%end$ 4761 4762symbolic procedure pop_vars(liste,altewerte)$ 4763foreach x in liste do <<set (x,car altewerte); 4764 altewerte := cdr altewerte>>$ 4765 4766symbolic procedure restore_pdes(bak)$ 4767% restore all data: not_passed_back, pdes, forg from bak 4768% returns {pdes,forg} 4769begin scalar pdes,forg,!*complex_bak,modular_comp_bak$ 4770 4771 %------ Conflict of interests: 4772 % 1. We want to restore the backup version, including the switches. 4773 % 2. If solutions of the just completed subcase should be carried 4774 % over and merged with the other solutions and if the just completed 4775 % solutions involve :mod: numbers and :gi: numbers and solutions of 4776 % other subcases do not then one might want to pass back on complex and 4777 % on modular. If one wants that then one needs !*complex_bak and 4778 % modular_comp_bak below. 4779 4780 % backup 2 switch settings, please read below at %----- 4781 !*complex_bak:=!*complex$ 4782 modular_comp_bak:=modular_comp; 4783 4784 % recover values of global variables 4785 pop_vars(not_passed_back,car bak)$ 4786 4787 % Alert 4788 if !*complex_bak and null !*complex then << 4789 write"### WARNING: You were currently in a session with ON COMPLEX and"$ terpri()$ 4790 write" now loaded a backed up session with OFF COMPLEX. If you want"$ terpri()$ 4791 write" to do anything with the data/solutions just computed under"$ terpri()$ 4792 write" ON COMPLEX in the loaded session with OFF COMPLEX then better"$terpri()$ 4793 write" switch ON COMPLEX now."$ terpri() 4794 >>$ 4795 if modular_comp_bak and null modular_comp then << 4796 write"### WARNING: You were currently in a session which did computations"$ terpri()$ 4797 write" with ON MODULAR and now loaded a backed up session with OFF MODULAR."$terpri()$ 4798 write" If you want to do anything with the data/solutions just computed"$ terpri()$ 4799 write" under ON MODULAR in the loaded session with calculations done under"$ terpri()$ 4800 write" OFF MODULAR then better do the interactive crack command MO now."$ terpri() 4801 >>$ 4802 4803 % For some switches it is not enough to set the !*.. value. 4804 if !*complex then on complex 4805 else off complex; 4806 if modular_comp then setmod modular_comp; % = the prime number modulo which 4807 % computations are to be done 4808 % Even if modular_comp is not null, this does not mean on modular as 4809 % modular is only switched on for the computational steps, as, for example, 4810 % loop variables should not be :mod: variables. 4811 4812 if !*complex_bak and null !*complex then << 4813 !*complex:=t$ 4814 algebraic(on complex)$ % changed from OFF to ON on 14 June 4815 >>$ 4816 if modular_comp_bak and null modular_comp then << 4817 setmod modular_comp % the prime number modulo which computation are to be done 4818 >>$ 4819 4820 % recover the pdes 4821 for each c in cadr bak do << 4822 pdes:=cons(car c,pdes)$ 4823 for each s in cadr c do put(car c,car s,cdr s)$ 4824 for each s in caddr c do flag1(car c,s) 4825 >>$ 4826 4827 % recover the properties of forg 4828 for each c in caddr bak do << 4829 forg:=cons(car c,forg)$ 4830 if pairp car c then put(cadar c,'fcts,cdr c) 4831 >>$ 4832 4833 % recover the properties of idnties_ 4834 if cdddr bak then 4835 for each c in cadddr bak do << 4836 put(car c,'val,cadr c); 4837 if caddr c then flag1(car c,'to_int) 4838 else if flagp(car c,'to_int) then remflag(car c,'to_int); 4839 if caddr c then flag1(car c,'to_subst) 4840 else if flagp(car c,'to_subst) then remflag(car c,'to_subst); 4841 >>$ 4842 4843 UniquifyAll(pdes,forg)$ 4844 4845 return {reverse pdes,reverse forg}$ 4846end$ 4847 4848symbolic procedure deletepde(pdes)$ 4849begin scalar s,l$ 4850 change_prompt_to ""$ 4851 terpri()$ 4852 write "Equations to be deleted: "$ 4853 l:=select_from_list(pdes,nil)$ 4854 restore_interactive_prompt()$ 4855 for each s in l do 4856 if member(s,pdes) then pdes:=drop_pde(s,pdes,nil)$ 4857 f_update(pdes,nil)$ 4858 return pdes 4859end$ 4860 4861symbolic procedure new_pde()$ 4862begin scalar s$ 4863 4864 if null car recycle_eqns and cdr recycle_eqns then 4865 clean_prop_list(cdr recycle_eqns)$ 4866 4867 if null car recycle_eqns then << 4868 s:=mkid(eqname_,nequ_)$ 4869 nequ_:=add1 nequ_$ 4870 >> else << 4871 s:=caar recycle_eqns$ 4872 recycle_eqns:=(cdar recycle_eqns) . (cdr recycle_eqns) 4873 >>$ 4874 setprop(s,nil)$ 4875 return s 4876end$ 4877 4878symbolic procedure drop_pde_from_properties(p,pdes)$ 4879begin 4880 put(p,'dec_with,nil); 4881 put(p,'dec_with_rl,nil); 4882 put(p,'rl_with,nil); 4883 for each q in pdes do if q neq p then << 4884 drop_dec_with(p,q,t)$ 4885 drop_dec_with(p,q,nil)$ 4886 drop_rl_with(p,q) 4887 >> 4888end$ 4889 4890symbolic procedure drop_pde_from_idties(p,pdes,phist)$ 4891% to be used whenever the equation p is dropped or changed and 4892% afterwards newly characterized in update, 4893% phist is the new value of p in terms of other equations, 4894% if this is unknown then phist=nil, 4895% to be done before setprop(p,nil) 4896begin scalar q,newidval,idnt$ 4897 for each q in pdes do if q neq p then 4898 if not freeof(get(q,'histry_),p) then 4899 put(q,'histry_, if null phist then q 4900 else subst(phist,p,get(q,'histry_)))$ 4901 4902 if record_hist and (getd 'show_id) then << 4903 4904 % update of all identities involving p 4905 idnt:=idnties_$ 4906 while idnt do << 4907 if not freeof(get(car idnt,'val),p) then 4908 if null phist then drop_idty(car idnt) 4909 else << 4910 % Once pdes_ is available as global variable then simplify 'val 4911 % before put() 4912 newidval:=reval subst(phist,p,get(car idnt,'val))$ 4913 if trivial_idty(pdes,newidval) then drop_idty(car idnt) 4914 else << 4915 put(car idnt,'val,newidval); 4916 flag1(car idnt,'to_subst)$ 4917 flag1(car idnt,'to_int) 4918 >> 4919 >>; 4920 idnt:=cdr idnt 4921 >>; 4922 4923 % adding a new identity based on phist and the 'histry_ entry of p 4924 if phist and not zerop phist and (p neq get(p,'histry_)) then << 4925 idnt:=reval {'plus,get(p,'histry_),{'minus,phist}}$ 4926 if pairp idnt and car idnt='quotient then idnt:=cadr idnt; 4927 if not zerop idnt then 4928 new_idty(idnt,pdes,if pdes then t else nil) 4929 >> 4930 >> 4931end$ 4932 4933symbolic procedure drop_pde(p,pdes,phist)$ 4934% phist is the value of p in terms of other equations, 4935% (this is needed for substitution of p in identities) 4936% if phist=nil then unknown 4937% pdes should be a list of all currently used pde-names 4938if p then begin scalar l; 4939 if do_recycle_eqn and freeof(car recycle_eqns,p) then 4940 recycle_eqns:=(car recycle_eqns) . union({p},cdr recycle_eqns)$ 4941 depl!*:=delete(assoc(reval p,depl!*),depl!*)$ 4942 drop_pde_from_idties(p,pdes,phist)$ 4943 setprop(p,nil)$ 4944 if (p=largest_fully_shortened) or 4945 (p=currently_to_be_substituted_in) then 4946 if (null pdes) or (p=car pdes) then << 4947 if p=largest_fully_shortened then 4948 largest_fully_shortened:=nil; 4949 if p=currently_to_be_substituted_in then 4950 currently_to_be_substituted_in:=nil 4951 >> else << 4952 l:=pdes; 4953 while cdr l and (p neq cadr l) do l:=cdr l; 4954 if p=largest_fully_shortened then largest_fully_shortened:=car l; 4955 if p=currently_to_be_substituted_in then 4956 currently_to_be_substituted_in:=if cdr l and cddr l then caddr l 4957 else car l 4958 >>$ 4959 return delete(p,pdes) 4960end$ 4961 4962symbolic procedure drop_all_pdes(pdes)$ 4963begin scalar p; 4964 if do_recycle_eqn then 4965 recycle_eqns:=union(pdes,car recycle_eqns) . 4966 setdiff(cdr recycle_eqns,pdes); 4967 for each p in pdes do << 4968 depl!*:=delete(assoc(reval p,depl!*),depl!*)$ 4969 setprop(p,nil) 4970 >>; 4971 % dropping all identities 4972 while idnties_ do drop_idty(car idnties_) 4973end$ 4974 4975symbolic procedure change_pde_flag(pdes)$ 4976begin scalar p,ty,h$ 4977 terpri()$ write"At first we need the list of equations for which "$ 4978 terpri()$ write"you want to change properties."$ 4979 pdes:=select_from_list(pdes,nil)$ 4980 terpri()$ 4981 write"Type in one of the following flags that is to be flipped "$ 4982 terpri()$ 4983 write"(e.g. to_int <ENTER>): "$ 4984 terpri()$terpri()$ 4985 write allflags_; 4986 terpri()$terpri()$ 4987 write"or type in one of the following properties that is to be changed"$ 4988 terpri()$ 4989 write"(e.g. vars <ENTER>): "$ 4990 terpri()$terpri()$ 4991 write prop_list; 4992 terpri()$terpri()$ 4993 change_prompt_to ""$ 4994 ty:=termread()$ 4995 if member(ty,allflags_) then << 4996 terpri()$ write"Shall the flag be set (Y) "$ 4997 terpri()$ write"or be removed ? (N) "$ 4998 h:=termread()$ 4999 for each p in pdes do if h='y then flag1(p,ty) 5000 else remflag1(p,ty) 5001 >> else 5002 if member(ty,prop_list) then << 5003 terpri()$ write"Shall the property list for all selected equations be set to nil (Y/N) "$ 5004 h:=termread()$ 5005 if h='y then for each p in pdes do put(p,ty,nil) 5006 else for each p in pdes do << 5007 terpri()$ 5008 write"current value for ",p,": ",get(p,ty)$ 5009 terpri()$ 5010 write"new value (e.g. '(x y z); ENTER): "$ 5011 terpri()$ 5012 h:=termread()$ 5013 put(p,ty,h)$ 5014 write"The new value of ",ty,": ",get(p,ty) 5015 >>; 5016 if ty='rl_with then largest_fully_shortened:=nil 5017 >> else write"Input not recognized."$ 5018 terpri()$ 5019 restore_interactive_prompt() 5020end$ 5021 5022symbolic procedure restore_backup_from_file(pdes,forg,nme)$ 5023% This procedure restores the not_passed_back AND the passed_back variables 5024% from the old session as stored in the backup file. So one should use 5025% this procedure if nothing should be passed back from the current 5026% computation, i.e. when the new computation is just a side computation 5027% which, for example, does not pass back solutions with newly generated 5028% functions. If on the other hand newly generated functions,... should 5029% be passed back then the procedure restore_and_merge() should be 5030% called which passes back, i.e. keeps, the passed_back variable values. 5031% returns {pdes,forg} 5032begin scalar s,p,echo_bak,semic_bak,flist,n,h,fi,oldsession,old_sol_li$ 5033 if nme=t then << 5034 change_prompt_to ""$ 5035 terpri()$ 5036 write"Please give the name of the file in double quotes"$terpri()$ 5037 write"without `;' : "$ 5038 s:=termread()$ 5039 restore_input_file()$ % in case 5040 p:=explode s; 5041 if member('!*,p) or member('!?,p) then << 5042 p := pipe!-open(bldmsg("ls %w",s), 'input); 5043 fi:=""$ 5044 repeat << 5045 h:=channelreadchar(p); 5046 if h = 10 then <<flist:=cons(fi,flist);fi:="">> else 5047 if h neq 4 then fi:=bldmsg("%w%w",fi,int2id h) 5048 >> until h=4; 5049 if fi neq "" then flist:=cons(fi,flist); % should not occur 5050 close p; 5051 if flist then << 5052 n:=0$ 5053 p:=flist$ 5054 while p do << 5055 n:=add1 n$ 5056 write n,": ",car p$terpri()$ 5057 p:=cdr p 5058 >>$ 5059 terpri()$ 5060 write"Indicate the file you want to load by"$terpri()$ 5061 write"entering the corresponding number: "$ 5062 p:=termread()$ 5063 while (not numberp p) or (p<0) or (p>length flist) do << 5064 write"This is not a number >0 and <=",length flist,"! Try again: "$ 5065 p:=termread() 5066 >>$ 5067 s:=nth(flist,p) 5068 >> 5069 >>; 5070 restore_interactive_prompt() 5071 >> else 5072 if nme then s:=nme 5073 else s:=level_string(session_)$ 5074 %-- infile s$ 5075 if null sol_list % and (stepcounter_=0) 5076 then << 5077 old_sol_li:=bldmsg("%w%w",session_,"sol_list")$ 5078 if filep old_sol_li then oldsession:=session_ 5079 >>$ 5080 % to delete the current bu*-sol_list file which has been created 5081 % when the current session was started 5082 5083 echo_bak:=!*echo; semic_bak:=semic!*; 5084 semic!*:='!$; in s$ 5085 !*echo:=echo_bak; semic!*:=semic_bak$ 5086 %-- cleaning up: 5087 for each p in pdes do setprop(p,nil)$ 5088 for each p in forg do if pairp p then put(cadr p,'fcts,nil)$ 5089 %-- assigning the new values: 5090 pop_vars(passed_back,car backup_)$ %1 5091 uniquifykord kord!*$ 5092 uniquifydepl depl!*$ 5093 uniquifyasymplis asymplis!*$ 5094 if eqn_input and (eqn_input neq 'done) then close eqn_input; 5095 s:=restore_pdes(cdr backup_)$ %1 5096 backup_:=nil; 5097 % orderings_:=car orderings_; 5098 if oldsession and (oldsession neq session_) then 5099 system bldmsg("rm %w",old_sol_li)$ 5100 5101 return s 5102end$ 5103 5104symbolic procedure level_string(s)$ 5105begin scalar m; 5106 for each m in reverse level_ do 5107 setq(s,if s then if fixp m then if m<10 then bldmsg("%w%d",s,m) 5108 else bldmsg("%w.%d.",s,m) 5109 else bldmsg("%w%w.",s,m) 5110 else if fixp m then if m<10 then bldmsg("%d",m) 5111 else bldmsg(".%d.",m) 5112 else bldmsg("%w.",m)); 5113 return s 5114end$ 5115 5116symbolic procedure backup_to_file(pdes,forg,nme)$ 5117% saves all data to a file which might have changed since the 5118% initialization of global variables when loading CRACK 5119% This includes data which are passed back in a serial 5120% computation (passed_back) and those not (not_passed_back) 5121begin scalar s,a,save,ofl!*bak,!*natbat$ %,levelcp$ 5122 if nme=t then << 5123 change_prompt_to ""$ 5124 terpri()$ 5125 write"Please give the name of the file in double quotes"$terpri()$ 5126 write"without `;' : "$ 5127 s:=termread()$ 5128 restore_interactive_prompt() 5129 >> else 5130 if nme then s:=nme 5131 else s:=level_string(session_)$ 5132 a := open(s, 'output); 5133 ofl!*bak:=ofl!*$ 5134 ofl!*:=s$ % any value neq nil, to avoid problem with redfront 5135 save:=wrs a; 5136 % The above 2 lines instead of `out s;' allow to return 5137 % below after `close a;' (instead of `shut a;') to write 5138 % again automatically to the same file as before 5139 !*natbat:=!*nat$ 5140 off nat$ 5141 % orderings_:=list orderings_; 5142 write"off echo$"$ 5143 write "backup_:='"$terpri()$ 5144 print cons(push_vars passed_back,backup_pdes(pdes,forg))$ %1 5145 write"$"$terpri()$ 5146 write "end$"$terpri()$ 5147 wrs save$ 5148 ofl!*:=ofl!*bak$ 5149 close a; 5150 if !*nat neq !*natbat then on nat 5151end$ 5152 5153symbolic procedure delete_backup$ 5154begin scalar s$ 5155 % at first delete the bu.. file 5156 s:=level_string(session_); 5157 delete!-file!-exact s; 5158 5159 % then the cd..* files 5160 s:=explode s$ 5161 s:=reverse cons(car s,cons('*,cdr reverse s)); 5162 s:=cons(car s,cons('c,cons('d,cdddr s)))$ 5163 delete!-file!-match compress s; 5164 5165 % then the ie..* files 5166 s:=cons(car s,cons('i,cons('e,cdddr s)))$ 5167 delete!-file!-match compress s; 5168end$ 5169 5170symbolic procedure merge_crack_returns(r1,r2)$ 5171if (null collect_sol) and 5172 ((null r1) or (fixp car r1)) and 5173 ((null r2) or (fixp car r2)) then 5174if null r1 then r2 else 5175if null r2 then r1 else list((car r1) + (car r2)) 5176 else union(r1,r2)$ 5177 5178symbolic procedure restore_and_merge(soln,pdes,forg)$ 5179% pdes, forg are cleaned up 5180% one could just use restore_pdes without assigning bak 5181% but then it would not be stored in a file, such that 5182% rb can reload the file 5183% returns {pdes,forg} 5184begin scalar bak,newfdep,sol,f,h$ 5185 5186 % store ongoing global values in bak 5187 newfdep:=nil$ 5188 for each sol in soln do 5189 if pairp sol then << 5190 for each f in caddr sol do 5191 if h:=assoc(f,depl!*) then newfdep:=union({h},newfdep); 5192 >>; 5193 bak:={push_vars passed_back,newfdep}; % to be used 2 lines below 5194 h:=restore_backup_from_file(pdes,forg,nil)$ 5195 5196 % actually merging of depl!* with newfdep need only be done if non-parallel 5197 pop_vars(passed_back,car bak)$ 5198 5199 % actually merging of depl!* with newfdep need only be done if collect_sol=t 5200 depl!*:=union(cadr bak,depl!*); 5201 5202 return h 5203end$ 5204 5205symbolic operator write_stat_in_file$ 5206symbolic procedure write_stat_in_file$ 5207if null size_watch then << 5208 write"No statistical history is recorded."$terpri()$ 5209 write"To record one enter: as {size_watch,t};"$terpri()$ 5210>> else 5211begin scalar s,a,save,ofl!*bak$ 5212 change_prompt_to ""$ 5213 setq(s,bldmsg("%w.%w",session_,"size_hist")); 5214 %out s; 5215 a:=open(s, 'output); 5216 ofl!*bak:=ofl!*$ 5217 ofl!*:=s$ % any value neq nil, to avoid problem with redfront 5218 save:=wrs a; 5219 write"size_hist:='"$ 5220 prettyprint size_hist$ 5221 write"$end$"$terpri()$ 5222 %shut s; 5223 wrs save$ 5224 ofl!*:=ofl!*bak$ 5225 close a; 5226 restore_interactive_prompt() 5227end$ 5228 5229symbolic procedure write_in_file(pdes,forg)$ 5230begin scalar p,pl,s,h,wn,vl,v,ll,a,save,ofl!*bak,!*natbak$ 5231 ll:=linelength 79$ 5232 change_prompt_to ""$ 5233 terpri()$ 5234 write "Enter a list of equations, like e2,e5,e35; from: "$terpri()$ 5235 listprint(pdes)$ 5236 terpri()$write "To write all equations just enter ; "$terpri()$ 5237 repeat << 5238 s:=termlistread()$ 5239 h:=s; 5240 if s=nil then pl:=pdes else << 5241 pl:=nil;h:=nil$ 5242 if (null s) or pairp s then << 5243 for each p in s do 5244 if member(p,pdes) then pl:=cons(p,pl); 5245 h:=setdiff(pl,pdes); 5246 >> else h:=s; 5247 >>; 5248 if h then <<write "These are no equations: ",h," Try again."$terpri()>>$ 5249 >> until null h$ 5250 write"Shall the name of the equation be written? (y/n) "$ 5251 repeat s:=termread() 5252 until (s='y) or (s='Y) or (s='n) or (s='N)$ 5253 if (s='y) or (s='Y) then wn:=t$ 5254 write"Please give the name of the file in double quotes"$terpri()$ 5255 write"without `;' : "$ 5256 s:=termread()$ 5257 %out s; 5258 a:=open(s, 'output); 5259 ofl!*bak:=ofl!*$ 5260 ofl!*:=s$ % any value neq nil, to avoid problem with redfront 5261 save:=wrs a; 5262 !*natbak:=!*nat$ 5263 off nat$ 5264 5265 write"% Modify the following load command by adding the"$terpri()$ 5266 write"% directory name in which crack is stored, for example:"$terpri()$ 5267 write"% load ""~/crack/crack""$"$terpri()$ 5268 write"load crack$"$terpri()$ 5269 write"lisp(nfct_:=",nfct_,")$"$terpri()$ 5270 if wn then write"lisp(nequ_:=",nequ_,")$"$terpri()$ 5271 write"off batch_mode$"$terpri()$ 5272 for each p in pl do <<h:=get(p,'vars);if h then vl:=union(h,vl)>>$ 5273 write"list_of_variables:="$ 5274 algebraic write lisp cons('list,vl)$ 5275 5276 write"list_of_functions:="$ 5277 algebraic write lisp cons('list,ftem_)$ 5278 5279 if flin_ then << 5280 write"% linearly occuring functions:"$terpri()$ 5281 write"lisp(flin_:='("$terpri()$ 5282 for each h in flin_ do <<write h$terpri()>>$ 5283 write"))$"$terpri() 5284 >>$ 5285 5286 if fhom_ then << 5287 write"% homogeneous functions:"$terpri()$ 5288 write"lisp(fhom_:='("$terpri()$ 5289 for each h in fhom_ do <<write h$terpri()>>$ 5290 write"))$"$terpri() 5291 >>$ 5292 5293 for each h in ftem_ do 5294 if assoc(h,depl!*) then << 5295% p:=pl; 5296% while p and freeof(get(car p,'sqval),h) do p:=cdr p; 5297% if p then << 5298 % The above 3 lines make only sense if get(p,'fcts) is not accurate 5299 write "depend ",h$ 5300 for each v in cdr assoc(h,depl!*) do <<write ","$print v>>$ 5301 write "$"$terpri()$ 5302% >> 5303 >>$ 5304 if wn then << 5305 for each h in pl do algebraic (write h,":=",lisp {'!*sq,get(h,'sqval),t})$ 5306 write"list_of_equations:="$ 5307 algebraic write lisp cons('list,pl) 5308 >> else << 5309 write"list_of_equations:="$ 5310 algebraic write lisp cons('list, 5311 for each h in pl collect {'!*sq,get(h,'sqval),t})$ 5312 >>$ 5313 5314 write"list_of_inequalities:="$ 5315 algebraic write lisp( 5316 cons('list,append(for each p in ineq_ collect {'!*sq,p,t}, 5317 if null ineq_or then nil else 5318 for each h in ineq_or collect 5319 cons('list,for each p in h collect 5320 {'!*sq,if null cdr p then car p else 5321 <<v:=car p; p:=cdr p; 5322 while p do<<v:=multsq(v,car p); 5323 p:= cdr p>>; 5324 v>> 5325 ,t})) 5326 ) )$ 5327 5328 terpri()$ write"solution_:=crack(list_of_equations,"$ 5329 terpri()$ write" list_of_inequalities,"$ 5330 terpri()$ write" list_of_functions,"$ 5331 terpri()$ write" list_of_variables)$"$ 5332 terpri()$ 5333 5334 for each h in forg do << 5335 if pairp h and (car h = 'equal) then << 5336 terpri()$ 5337 algebraic 5338 write lisp(cadr h)," := sub(second first solution_,", 5339 lisp({'!*sq,caddr h,t}),")" 5340 >> 5341 >>$ 5342 terpri()$ 5343 write"end$"$terpri()$terpri()$ 5344 write"These data were produced with the following input:"$terpri()$terpri()$ 5345 write"lisp( old_history := "$terpri()$ 5346 write"'",reverse history_,")$"$terpri()$ 5347 %shut s; 5348 wrs save$ 5349 ofl!*:=ofl!*bak$ 5350 close a; 5351 if !*nat neq !*natbak then on nat$ 5352 restore_interactive_prompt()$ 5353 linelength ll 5354end$ 5355 5356symbolic procedure give_low_priority(pdes,f)$ 5357% It assumes that 5358% - f is in prefix form (f is just an atom), 5359% - f is element of ftem_, 5360% - flin_ functions come first in each group of functions with 5361% the same number of independent variables. 5362% If f is element of flin_ then f is put at the end of the flin_ 5363% functions with equally many variables but before the first functions 5364% that occur in ineq_ in order to change ftem_ as little as possible 5365% not to invalidate previous decoupling. 5366 5367begin scalar ftemcp,ano,h,s,fli$ 5368 ftemcp:=ftem_$ 5369 while ftemcp and (car ftemcp neq f) do << 5370 h:=cons(car ftemcp,h)$ 5371 ftemcp:=cdr ftemcp 5372 >>$ 5373 % Is there an element of the remaining ftemcp with the same no of 5374 % variables and that is not in ineq_ ? 5375 5376 if ftemcp then << 5377 ftemcp:=cdr ftemcp; 5378 ano:=fctlength f$ 5379 if member(f,flin_) then fli:=t$ 5380 while ftemcp do 5381 if (ano > (fctlength car ftemcp)) or 5382 (fli and (not member(car ftemcp,flin_))) then ftemcp:=nil else << 5383 h:=cons(car ftemcp,h)$ 5384 ftemcp:=cdr ftemcp$ 5385 if not member(simp car h,ineq_) then << 5386 while ftemcp and 5387 (ano = (fctlength car ftemcp)) and 5388 (not member(simp car ftemcp,ineq_)) and 5389 ((not fli) or member(car ftemcp,flin_)) do << 5390 h:=cons(car ftemcp,h)$ 5391 ftemcp:=cdr ftemcp 5392 >>$ 5393 5394 if print_ or tr_orderings then << 5395 write"The lexicographical ordering of unknowns is changed"$ 5396 terpri()$ 5397 write"because ",f," has to be non-zero, giving ",f," a low priority."$ 5398 terpri()$ 5399 write "Old ordering: "$ 5400 s:=ftem_; 5401 while s do <<write car s$ s:=cdr s$ if s then write",">>$ 5402 terpri()$ 5403 write "New ordering: "$ 5404 s:=append(reverse h,cons(f,ftemcp)); 5405 while s do <<write car s$ s:=cdr s$ if s then write",">>$ 5406 terpri()$ 5407 5408 >>$ 5409 change_fcts_ordering(append(reverse h,cons(f,ftemcp)),pdes,vl_)$ 5410 ftemcp:=nil 5411 >> % of not member(simp car h,ineq_) 5412 >> % of ano > (fctlength car ftemcp) 5413 >> % of ftemcp 5414end$ 5415 5416 5417% symbolic procedure drop_factor(h,pro)$ 5418% % This procedure drops a factor h or its negative from an expression pro 5419% begin scalar hs,newpro,mi; 5420% hs:=signchange(h); 5421% if pairp pro and (car pro='minus) then <<pro:=cadr pro; mi:=t>>; 5422% if pro = h then newpro:= 1 else 5423% if pro = hs then newpro:=-1 else 5424% if pairp pro and (car pro = 'times) then 5425% if member(h ,pro) then newpro:=reval delete(h ,pro) else 5426% if member(hs,pro) then newpro:=reval list('minus,delete(hs,pro)); 5427% if mi and newpro then newpro:=reval list('minus,newpro) 5428% return newpro 5429% end$ 5430 5431 5432symbolic procedure updateSQfcteval(pdes,newineq)$ 5433% newineq is a new (scalar) inequality in SQ form 5434begin scalar p,pv,ps,hist,h1,mod_switched$ 5435 for each p in pdes do 5436 if null contradiction_ then 5437 if newineq=get(p,'sqval) then raise_contradiction({'!*sq,newineq,t},nil) 5438 else << 5439 pv:=get(p,'fac)$ 5440 if pairp pv and member(newineq,pv) then << 5441 if record_hist then hist:=reval {'quotient,get(p,'histry_),reval {'!*sq,newineq,nil}}$ 5442 5443 for each h1 in allflags_ do flag1(p,h1)$ % <-- to be added because this was 5444 % in contradictioncheck() which is now fully covered by this procedure 5445 if modular_comp and null !*modular then <<on modular$ mod_switched:=t>>$ 5446 h1:=quotsq(get(p,'sqval),newineq)$ 5447 if mod_switched then off modular$ 5448 updateSQ(p,h1,nil,nil,get(p,'fcts), 5449 get(p,'vars),t,list(0),pdes)$ 5450 % pdes:=insert_in_eqlist(p,delete(p,pdes))$ %<=<=<=<= 5451 drop_pde_from_idties(p,pdes,hist)$ 5452 drop_pde_from_properties(p,pdes) 5453 >> else << 5454 % h1 will be the list of functions of p occuring in the inequality. 5455 % If anyone of them occurs in a coefficient of a case-generating 5456 % substitution then new determination of all possible substitutions using p. 5457 5458 ps:=get(p,'fcteval_nli)$ 5459 if ps and (h1:=smemberl(get(p,'fcts),newineq)) then << 5460 5461 while ps and freeoflist(caar ps,h1) do ps:=cdr ps; 5462 5463 % The following is the old code based on prefix form. It has been 5464 % commented out for simplicity for now. It would need a factorization of 5465 % the coefficients to test whether newineq is contained as a factor. 5466 5467 %while ps and 5468 % <<h1:=caar ps; 5469 % h2:=signchange(h1); 5470 % (not ((newineq=h1 ) or 5471 % (pairp h1 and 5472 % (car h1 = 'times) and 5473 % member(newineq,h1) ) )) and 5474 % (not ((newineq=h2 ) or 5475 % (pairp h2 and 5476 % (car h2 = 'times) and 5477 % member(newineq,h2) ) )) 5478 % >> do ps:=cdr ps; 5479 5480 if ps then << % simple but more expensive fix: 5481 flag1(p,'to_eval)$ 5482 put(p,'fcteval_lin,nil)$ 5483 put(p,'fcteval_nca,nil)$ 5484 put(p,'fcteval_nli,nil)$ 5485 put(p,'fcteval_n2l,nil)$ 5486 put(p,'fct_nli_lin,nil)$ 5487 put(p,'fct_nli_nca,nil)$ 5488 put(p,'fct_nli_nli,nil)$ 5489 put(p,'fct_nli_nus,nil)$ 5490 >> 5491 >> 5492 >> 5493 >>; 5494 %return pdes %<=<=<=<= 5495end$ 5496 5497symbolic procedure addfunction(ft)$ 5498begin scalar f,ff,l,ok$ 5499 change_prompt_to ""$ 5500 ff:=mkid(fname_,nfct_)$ 5501 repeat << 5502 ok:=t; 5503 terpri()$ 5504 write "What is the name of the new function?"$ 5505 terpri()$ 5506 write "If the name is ",fname_,"+digits then use ",ff,". Terminate with <ENTER>: "$ 5507 f:=termread()$ 5508 if f=ff then nfct_:=add1 nfct_ 5509 else if member(f,ft) then << 5510 terpri()$ 5511 write"Choose another name. ",f," is already in use."$ 5512 ok:=nil 5513 >>$ 5514 >> until ok; 5515 depl!*:=delete(assoc(f,depl!*),depl!*)$ 5516 terpri()$ 5517 write "Give a list of variables ",f," depends on, for example x,y,z; "$ 5518 terpri()$ 5519 write "For constant ",f," input a `;' "$ 5520 l:=termxread()$ 5521 if (pairp l) and (car l='!*comma!*) then l:=cdr l; 5522 if pairp l then depl!*:=cons(cons(f,l),depl!*) else 5523 if l then depl!*:=cons(list(f,l),depl!*)$ 5524 ft:=fctinsert(f,ft)$ 5525 ftem_:=fctinsert(f,ftem_)$ 5526 restore_interactive_prompt()$ 5527 return (ft . f) 5528end$ 5529 5530symbolic procedure reducepde(pdes,ftem,vl)$ 5531begin scalar p,q,ex$ 5532 change_prompt_to ""$ 5533 terpri()$ 5534 write "Which equation is to be simplified? "$ 5535 p:=termread()$ 5536 if not member(p,pdes) then write"This is not the name of an equation!" 5537 else << 5538 ex:=get(p,'sqval)$ 5539 pdes:=drop_pde(p,pdes,nil)$ 5540 q:=mkeqSQ(ex,nil,nil,ftem,vl,allflags_,t,list(0),nil,pdes)$ 5541 terpri()$write q," replaces ",p$ 5542 pdes:=eqinsert(q,pdes)$ 5543 if member(q,pdes) then <<terpri()$write q," : "$ typeeq(q)$ plot_non0_separants(q)>> 5544 >>$ 5545 restore_interactive_prompt()$ 5546 return list(pdes,ftem) 5547end$ 5548 5549 5550symbolic procedure replace_equation(arglist)$ 5551% This procedure is called from to_do and is performed in batch_mode. 5552% It follows instructions as given in the 4th argument of arglist 5553% which has the structure: {s,nfl,exsq,hist} where 5554% s is the name of an equation to be deleted, none if s=nil, 5555% nfl is the list of new functions with their arguments like ((f1 x y z) (f2 y)) 5556% exsq is the value of a new equation in sq form 5557% hist is the history value of exsq or nil if not known 5558% 5559begin scalar pdes,forg,s,nfl,q$ 5560 pdes:=car arglist$ 5561 forg:=cadr arglist$ 5562 % the 3rd argument of arglist is vl_ which is a global variable 5563 5564 % deleting old equation 5565 s:=car cadddr arglist$ 5566 if s then pdes:=drop_pde(s,pdes,nil)$ 5567 5568 % adding new functions 5569 nfl:=cadr cadddr arglist$ 5570 for each f in nfl do << % i.e. for each new function 5571 if cdr f then depl!*:=cons(f,depl!*)$ 5572 ftem_:=fctinsert(car f,ftem_)$ 5573 >>$ 5574 5575 % add equation 5576 q:=mkeqSQ(caddr cadddr arglist,nil,nil,ftem_,vl_,allflags_,t,list(0), 5577 cadddr cadddr arglist,pdes)$ 5578 pdes:=eqinsert(q,pdes)$ 5579 5580 % output comments 5581 terpri()$ 5582 if freeof(pdes,q) then 5583 if s then write "Equation ",s," is deleted." 5584 else write "A new equation turned out to be a consequence of known ones." 5585 else 5586 if s then write "Equation ",q," replaces ",s,"." 5587 else write "Equation ",q," is added."$ 5588 5589 return list(pdes,forg) 5590end$ 5591 5592 5593symbolic procedure replacepde(pdes,ftem,vl)$ 5594begin scalar p,q,ex,h,newft,again$ 5595 change_prompt_to ""$ 5596 repeat << 5597 terpri()$ 5598 write "Is there a"$ 5599 if again then write" further"$ 5600 write" new function in the changed/new PDE that"$ 5601 terpri()$ 5602 write "is to be calculated (y/n)? "$ 5603 p:=termread()$ 5604 if (p='y) or (p='Y) then << 5605 h:=addfunction(ftem)$ 5606 ftem:=car h$ 5607 if cdr h then newft:=cons(cdr h,newft) 5608 >>; 5609 again:=t 5610 >> until (p='n) or (p='N)$ 5611 terpri()$ 5612 write "If you want to replace a pde then type its name, e.g. e_23 <ENTER>."$ 5613 terpri()$ 5614 write "If you want to add a pde then type `new_pde' <ENTER>. "$ 5615 p:=termread()$ 5616 if (p='NEW_PDE) or member(p,pdes) then 5617 <<terpri()$write "Input of a value for "$ 5618 if p='new_pde then write "the new pde." 5619 else write p,"."$ 5620 terpri()$ 5621 write "You can use names of other pds, e.g. 3*e_12 - df(e_13,x); "$ 5622 terpri()$ 5623 write "Terminate the expression with ; or $ : "$ 5624 terpri()$ 5625 ex:=termxread()$ 5626% for each a in pdes do ex:=subst(get(a,'val),a,ex)$ 5627% for each a in pdes do ex:=subsq(ex,{(a . {'!*sq,get(a,'sqval),t})})$ 5628 for each a in pdes do 5629 if not freeof(ex,a) then << 5630 if null get(a,'val) then put(a,'val,prepsq get(a,'sqval)); 5631 ex:=subst(get(a,'val),a,ex)$ 5632 >>$ 5633 ex:=simp ex$ 5634 terpri()$ 5635 write "Do you want the equation to be"$terpri()$ 5636% write "- left completely unchanged"$ 5637% terpri()$ 5638% write " (e.g. to keep the structure of a product to "$ 5639% terpri()$ 5640% write " investigate subcases) (1)"$ 5641% terpri()$ 5642 write "- simplified (e.g. e**log(x) -> x) without"$ 5643 terpri()$ 5644 write " dropping non-zero factors and denominators"$ 5645 terpri()$ 5646 write " (e.g. to introduce integrating factors) (1)"$ 5647 terpri()$ 5648 write "- simplified completely (2) "$ 5649 h:=termread()$ 5650% if h=2 then ex:=reval ex$ 5651% if h<3 then h:=nil 5652% else h:=t$ 5653 if h=1 then h:=nil else h:=t$ 5654 if p neq 'NEW_PDE then 5655 % pdes:=drop_pde(p,pdes,{'quotient,{'times,p,prepsq ex},prepsq get(p,'sqval)})$ 5656 %### 18.6.07 this drop_pde does not make much sense to me 5657 pdes:=drop_pde(p,pdes,nil)$ 5658 if flin_ then % so that these functions are not the only linear ones 5659 % for example, when adding g=newf*h to a homogeneous 5660 % system, g as non-flin_ could not be solved for if 5661 % newf would be in flin_ . 5662 for each q in newft do 5663 if lin_check_SQ(ex,{q}) then flin_:=sort_according_to(cons(q,flin_),ftem_); 5664 q:=mkeqSQ(ex,nil,nil,ftem,vl,allflags_,h,list(0),nil,pdes)$ 5665 % A new equation with a new function appearing linear and only 5666 % algebraically can only have the purpose of a transformation 5667 % in which case the new equation should not be solved for the 5668 % new function as this would just mean dropping the new equation: 5669 if (p='NEW_PDE) and newft then 5670 put(q,'not_to_eval,newft)$ 5671 terpri()$write q$ 5672 if p='NEW_PDE then write " is added" 5673 else write " replaces ",p$ 5674 pdes:=eqinsert(q,pdes)>> 5675 else <<terpri()$ 5676 write "A pde ",p," does not exist! (Back to previous menu)">>$ 5677 restore_interactive_prompt()$ 5678 return list(pdes,ftem) 5679end$ 5680 5681symbolic procedure select_from_list(liste,n)$ 5682begin scalar s$ 5683 change_prompt_to ""$ 5684 terpri()$ 5685 if n then write"Pick ",n," from this list:" 5686 else write"Pick from this list"$ 5687 terpri()$ 5688 listprint(liste)$write";"$terpri()$ 5689 if null n then << 5690 write"a sublist and input it in the same form. Enter ; to choose all."$ 5691 terpri()$ 5692 >>$ 5693 s:=termlistread()$ 5694 if n and n neq length s then << 5695 write "Wrong number picked."$terpri()$ 5696 s:=nil; 5697 >> else 5698 if null s then s:=liste else 5699 if not_included(s,liste) then << 5700 write setdiff(s,liste)," is not allowed."$terpri()$ 5701 s:=nil; 5702 >>; 5703 restore_interactive_prompt()$ 5704 return s 5705end$ 5706 5707symbolic procedure selectpdes(pdes,n)$ 5708% interactive selection of n pdes 5709% n may be an integer or nil. If nil then the 5710% number of pdes is free. 5711if pdes then 5712begin scalar l,s,m$ 5713 change_prompt_to ""$ 5714 terpri()$ 5715 if null n then << 5716 write "How many equations do you want to select? "$terpri()$ 5717 write "(number <ENTER>) : "$terpri()$ 5718 n:=termread()$ 5719 >>$ 5720 write "Please select ",n," equation"$ 5721 if n>1 then write "s"$write " from: "$ 5722 write pdes$ 5723 terpri()$ 5724 m:=0$ 5725 s:=t$ 5726 while (m<n) and s do 5727 <<m:=add1 m$ 5728 if n>1 then write m,". "$ 5729 write "pde: "$ 5730 s:=termread()$ 5731 while not member(s,pdes) do << 5732 if size_watch and not fixp size_watch then % otherwise avoid growth 5733 history_:=cons("*** Invalid input.",cons('ig,history_))$ 5734 write "Error!!! Please select a pde from: "$ 5735 write pdes$ 5736 terpri()$if n>1 then write m,". "$ 5737 write "pde: "$ 5738 s:=termread()>>$ 5739 if s then << 5740 pdes:=delete(s,pdes)$ 5741 l:=cons(s,l) 5742 >> 5743 >>$ 5744 restore_interactive_prompt()$ 5745 return reverse l$ 5746end$ 5747 5748symbolic procedure depnd(y,xlist)$ 5749% xlist is a list of list of new dependencies 5750for each xx in xlist do 5751for each x in xx do depend y,x$ 5752 5753symbolic operator nodependlist$ 5754symbolic procedure nodependlist(fl)$ 5755% deleting all dependencies of the list fl which 5756% can be a lisp list or an algebraic mode list 5757for each f in fl do 5758if f neq 'list then << 5759 f:=reval f; depl!*:=delete(assoc(f,depl!*),depl!*)$ 5760 f:=mkid(f,'_);depl!*:=delete(assoc(f,depl!*),depl!*) 5761>>$ 5762 5763algebraic procedure dependlist(y,xlist)$ 5764% adding the dependence of y on all elements of all algebraic 5765% sublists of the algebraic list xlist 5766for each xx in xlist do 5767for each x in xx do depend y,x$ 5768 5769symbolic procedure err_catch_groeb(arglist)$ 5770% The purpose of this procedure is only to allow manual interrupts 5771% without crashing the whole computation. 5772if cadddr arglist and 5773 (length cadddr arglist > 1) then 5774begin scalar h,ll$ 5775 ll := linelength 10000000; 5776 h:=errorset({'comp_groebner_basis,mkquote arglist},nil,nil) 5777 where !*protfg=t; 5778 linelength ll; 5779 erfg!*:=nil; 5780 return if null h or errorp h then nil 5781 else car h 5782end$ 5783 5784symbolic operator err_catch_readin$ 5785symbolic procedure err_catch_readin(fname,in_mode)$ 5786if null filep fname then nil else 5787begin scalar h,mode_bak,echo_bak,semic_bak$ 5788 mode_bak:=!*mode; % if the file to read starts with 'lisp;' 5789 echo_bak:=!*echo; semic_bak:=semic!*; 5790 semic!*:='!$; 5791 !*mode := if in_mode='algebraic then 'algebraic else 'symbolic; 5792 h:= errorset({'in,mkquote {fname}},nil,nil) 5793 where !*protfg=t; 5794 !*echo:=echo_bak; semic!*:=semic_bak$ 5795 erfg!*:=nil; !*mode:=mode_bak$ 5796 return not errorp h 5797end$ 5798 5799symbolic procedure err_catch_solve(eqs,fl)$ 5800% fl='(list x y z); eqs='(list expr1 expr2 .. ) 5801begin scalar h$ 5802 h:=errorset({'solveeval,mkquote{eqs, fl}},nil,nil) 5803 where !*protfg=t; 5804 erfg!*:=nil; 5805 return if errorp h then nil 5806 else cdar h % cdr for deleting 'list 5807end$ 5808 5809symbolic procedure err_catch_odesolve(eqs,y,x)$ 5810begin scalar h,k,bak,bakup_bak$ 5811 bak:=max_gc_counter; 5812 max_gc_counter:=my_gc_counter+max_gc_ode; 5813 bakup_bak:=backup_;backup_:='max_gc_ode$ 5814 k:=setkorder nil$ 5815 h:=errorset({'odesolve,mkquote reval eqs,mkquote reval y,mkquote reval x},nil,nil) 5816 where !*protfg=t; 5817 erfg!*:=nil; 5818 setkorder k$ 5819 max_gc_counter:=bak; 5820 backup_:=bakup_bak; 5821 return if errorp h then {'list,nil} 5822 else car h 5823end$ 5824 5825symbolic procedure err_catch_minsub(pdes,l1,cost_limit,no_cases)$ 5826begin scalar h,bak,bakup_bak$ 5827 bak:=max_gc_counter; 5828 max_gc_counter:=my_gc_counter+max_gc_minsub; 5829 bakup_bak:=backup_;backup_:='max_gc_minsub$ 5830 h:=errorset({'search_subs,mkquote pdes,mkquote l1, 5831 mkquote cost_limit,mkquote no_cases},nil,nil) 5832 where !*protfg=t; 5833 erfg!*:=nil; 5834 max_gc_counter:=bak; 5835 backup_:=bakup_bak; 5836 return if errorp h then nil 5837 else car h 5838end$ 5839 5840symbolic procedure err_catch_gb(pdes)$ 5841begin scalar h,p,bak,bakup_bak$ 5842 bak:=max_gc_counter; 5843 max_gc_counter:=my_gc_counter+max_gc_gb; 5844 bakup_bak:=backup_;backup_:='max_gc_gb; 5845 h:=errorset( 5846 {'groebnerfeval, 5847 mkquote{cons('list,for each p in pdes collect {'!*sq,get(p,'sqval),t}), 5848 cons('list,ftem_), 5849 cons('list,for each p in ineq_ collect {'!*sq,p,t}) }},nil,nil) 5850 where !*protfg=t; 5851 erfg!*:=nil; 5852 max_gc_counter:=bak; 5853 backup_:=bakup_bak; 5854 return if errorp h then nil 5855 else car h 5856end$ 5857 5858symbolic operator err_catch_sub$ 5859symbolic procedure err_catch_sub(h2,h6,h3)$ 5860% do sub(h2=h6,h3) with error catching 5861% prefix version 5862begin scalar h4,h5; 5863 h4 := list('equal,h2,h6); 5864 h5:=errorset({'subeval,mkquote{reval h4, 5865 reval h3 }},nil,nil) 5866 where !*protfg=t; 5867 erfg!*:=nil; 5868 return if errorp h5 then nil 5869 else car h5 5870end$ 5871 5872 5873put('err_catch_sub_SQ,'psopfn,'ecs_SQ)$ 5874symbolic procedure ecs_SQ(inp)$ 5875% This is a psopfn procedure which does not evaluate the arguments 5876% automatically, this is done at the start of . 5877% The input equations should be in {!*sq,..,t} form (fast) but can be 5878% in prefix form (slow). 5879% inp is a lisp list of 3 expressions h2,h6,h3 for performing sub(h2=h6,h3) 5880% The procedure returns nil or {'!*sq,..,t} 5881% 5882begin scalar h2,h3,h5,h6; 5883 if length inp neq 3 then << 5884 terpri()$ 5885 write"SPLIT_SIMPLIFY DOES NOT HAVE 3 ARGUMENTS."$ 5886 >>$ 5887 h2:= reval car inp$ 5888 h6:= aeval cadr inp$ % including {'!*sq,.. 5889 h3:=cadr aeval caddr inp$ % excluding {'!*sq,.. 5890 h5:=errorset({'subsq,mkquote h3,mkquote {(h2 . h6)}},nil,nil) 5891 where !*protfg=t; 5892 erfg!*:=nil; 5893 return if errorp h5 then nil 5894 else {'!*sq,car h5,t} 5895end$ 5896 5897symbolic operator err_catch_int$ 5898symbolic procedure err_catch_int(h2,h3)$ 5899% do int(h2,h3) with error catching 5900begin scalar h5,bak,bakup_bak; 5901 bak:=max_gc_counter; 5902 max_gc_counter:=my_gc_counter+max_gc_int; 5903 bakup_bak:=backup_;backup_:='max_gc_int; 5904 h5:=errorset({'simpint,mkquote{reval h2, 5905 reval h3 }},nil,nil) 5906 where !*protfg=t; 5907 erfg!*:=nil; 5908 max_gc_counter:=bak; 5909 backup_:=bakup_bak; 5910 return if errorp h5 then nil 5911% else 5912% if not freeof(car h5,'INT) then nil 5913% 5914% It is useful to have this formal integral included because in the 5915% call in intpde_ not all functions are listed in the parameter listing 5916% functions so terms involving these unknown functions would get 5917% integrated this way. Also, if expressions are too large then 5918% errorp h5 is true and then it would not jam the following computation. 5919% 5920 else prepsq car h5 5921end$ 5922 5923symbolic procedure err_catch_reval(h)$ 5924% do reval h with error catching 5925begin scalar h2,bak,bakup_bak; 5926 bak:=max_gc_counter; 5927 max_gc_counter:=my_gc_counter+max_gc_reval; 5928 bakup_bak:=backup_;backup_:='max_gc_reval; 5929 h2:=errorset({'reval,mkquote h},nil,nil) 5930 where !*protfg=t; 5931 erfg!*:=nil; 5932 max_gc_counter:=bak; 5933 backup_:=bakup_bak; 5934 return if errorp h2 then nil 5935 else car h2 5936end$ 5937 5938symbolic procedure check_stop$ 5939if filep "stop_now" then << 5940 !*batch_mode:=nil$ 5941 old_history:=nil$ 5942 batchcount_:=sub1 stepcounter_$ 5943 repeat_mode:=1$ 5944>>$ 5945 5946% The following function should get called at the end of each garbage 5947% collection. 5948 5949symbolic procedure aftergcuserhook1$ 5950begin scalar li$ 5951!#if (memq 'psl lispsystem!*) 5952 last_free_cells:=if boundp 'gcfree!* and gcfree!* then gcfree!* % for 32 bit PSL 5953 else known!-free!-space()$ % for 32 bit PSL and 64 bit PSL 5954!#endif 5955 % for CSL last_free_cells is not updated as heap is extended dynamically 5956 5957 li:={'max_gc_elimin,'max_gc_fac,'max_gc_gb,'max_gc_int,'max_gc_minsub, 5958 'max_gc_ode,'max_gc_red_len,'max_gc_short,'max_gc_reval,'max_gc_ss}$ 5959 my_gc_counter:=add1 my_gc_counter$ 5960 if !*gc and member(backup_,li) then << 5961 write backup_," : ", 5962 if backup_='max_gc_elimin then max_gc_elimin else 5963 if backup_='max_gc_fac then max_gc_fac else 5964 if backup_='max_gc_gb then max_gc_gb else 5965 if backup_='max_gc_int then max_gc_int else 5966 if backup_='max_gc_minsub then max_gc_minsub else 5967 if backup_='max_gc_ode then max_gc_ode else 5968 if backup_='max_gc_red_len then max_gc_red_len else 5969 if backup_='max_gc_short then max_gc_short else 5970 if backup_='max_gc_reval then max_gc_reval else 5971 if backup_='max_gc_ss then max_gc_ss, 5972 " max # of GC's left to do: ",1+max_gc_counter-my_gc_counter$ 5973 terpri() 5974 >>$ 5975 if member(backup_,li) and 5976 ((my_gc_counter > max_gc_counter) or 5977 (last_free_cells<100000)) then << 5978 if print_ % and print_more (User must know that not all is computed.) 5979 then << 5980 write "Stop of ", 5981 if backup_='max_gc_elimin then "an elimination" else 5982 if backup_='max_gc_fac then "a factorization" else 5983 if backup_='max_gc_gb then "a groebner basis computation" else 5984 if backup_='max_gc_int then "an integration" else 5985 if backup_='max_gc_minsub then "a minimal growth substitution" else 5986 if backup_='max_gc_ode then "solving an ODE" else 5987 if backup_='max_gc_red_len then "a length reducing decoupling step" else 5988 if backup_='max_gc_short then "a shortening step" else 5989 if backup_='max_gc_reval then "a simplification" else 5990 if backup_='max_gc_ss then "searching a sub-system" else 5991 "an unknown step", 5992 " due to ", 5993 if last_free_cells<100000 then "less than 100000 free cells." 5994 else "reaching the limit of garbage collections."$ 5995 terpri()$ 5996 >>$ 5997 rederr "Heidadeife " 5998 >> else 5999 if print_ and (last_free_cells<100000) then 6000 write"Memory seems to run out. Less than 100000 free cells!" 6001end$ 6002 6003!#if (memq 'csl lispsystem!*) 6004 6005% For CSL the GC hook has its name saved in !*gc!-hook!*, so I can 6006% just implement a new function that calls what I know is the prior 6007% function and then the new stuff. 6008 6009symbolic procedure csl_aftergcuserhook u$ 6010<< aftergcsystemhook u; % The handler in rlisp/inter.red 6011 if u then aftergcuserhook1() else nil 6012>>$ 6013 6014lisp(!*gc!-hook!* := 'csl_aftergcuserhook)$ 6015 6016!#endif 6017 6018 6019!#if (memq 'psl lispsystem!*) 6020 6021% For PSL the GC hook is specified by its function name. Here I 6022% wish to chain on after an existing one, so I save the old version as 6023% psl_aftergcuserhook and define a new version that calls that followed 6024% by the new behaviour that is expected by crack. 6025% 6026% If neither the old (aftergcuserhook) nor the new (psl_aftergcuserhook) version 6027% are present, define an empty function. 6028 6029if getd 'aftergcuserhook and not getd 'psl_aftergcuserhook then 6030 copyd('psl_aftergcuserhook, 'aftergcuserhook) 6031 else 6032 putd('psl_aftergcuserhook, 'expr, '(lambda nil nil)); 6033 6034 6035symbolic procedure aftergcuserhook; 6036 << psl_aftergcuserhook(); 6037 aftergcuserhook1(); 6038 nil >>; 6039 6040!#endif 6041 6042symbolic operator err_catch_fac$ 6043symbolic procedure err_catch_fac(a)$ 6044% converts input into prfix form through call of symbolic operator 6045% and returns prefix form 6046% prefix form is currently needed at least in the calls from crint.red 6047begin scalar h,bak,kernlist!*bak,kord!*bak,bakup_bak,modular_bak, 6048 no_powers_changed,rational_changed; 6049 bak:=max_gc_counter; 6050 max_gc_counter:=my_gc_counter+max_gc_fac; 6051 kernlist!*bak:=kernlist!*$ 6052 kord!*bak:=kord!*$ 6053 bakup_bak:=backup_;backup_:='max_gc_fac$ 6054 if null !*nopowers then <<algebraic(on nopowers)$ 6055 no_powers_changed:=t>>$ 6056 if null !*rational and not freeof(a,'!:rn!:) 6057 and (null !*complex or not freeof(a,'!:gi!:)) 6058 then <<off msg$ algebraic(on rational)$ on msg$ 6059 rational_changed:=t>>$ 6060 % 8.9.04: This became necessary due to a strange factorizer bug 6061 % ` Non-numerical ... in arithmetic (or so) 6062 % 12.7.08: The same error occurs when on complex and an expression 6063 % contains '!:gi!: and then on rational is done and factorize. 6064 6065 if (modular_comp and not freeof(a,'!:mod!:)) or !*modular then << 6066 modular_bak:=!*modular; 6067 if !*modular then off modular$ 6068 % simp converts prefixed SQ into SQ and resimp gets rid of :mod: 6069 h:=errorset({'reval,list('FACTORIZE,mkquote mk!*sq resimp simp a)},nil,nil) 6070 where !*protfg=t; % reval --> aeval for speedup 6071 if modular_bak then on modular 6072 >> else 6073 h:=errorset({'reval,list('FACTORIZE,mkquote a)},nil,nil) % reval --> aeval for speedup 6074 where !*protfg=t; 6075 if modular_bak then on modular$ 6076 if rational_changed then <<off msg$ algebraic(off rational)$ on msg>>$ 6077 if no_powers_changed then algebraic(off nopowers)$ 6078 kernlist!*:=kernlist!*bak$ 6079 kord!*:=kord!*bak; 6080 erfg!*:=nil; 6081 max_gc_counter:=bak; 6082 backup_:=bakup_bak; 6083 return if errorp h or 6084 (pairp h and pairp car h and 6085 cdar h and null cadar h) % seems a REDUCE bug 6086 then {'list,a} 6087 else car h 6088end$ 6089 6090symbolic procedure err_catch_fac2(a)$ 6091% a is in prefixed SQ-form or prefix form 6092% returns list of factors, i.e. works under off nopowers 6093% The first factor may be numeric, e.g. 1/2. 6094begin scalar h,bak,kernlist!*bak,kord!*bak,bakup_bak, 6095 no_powers_changed,rational_changed,modular_bak; 6096 bak:=max_gc_counter; 6097 max_gc_counter:=my_gc_counter+max_gc_fac; 6098 kernlist!*bak:=kernlist!*$ 6099 kord!*bak:=kord!*$ 6100 bakup_bak:=backup_;backup_:='max_gc_fac$ 6101 if !*nopowers then <<algebraic(off nopowers)$ 6102 no_powers_changed:=t>>$ 6103 if null !*rational and not freeof(a,'!:rn!:) 6104 and (null !*complex or not freeof(a,'!:gi!:)) 6105 then <<off msg$ algebraic(on rational)$ on msg$ 6106 rational_changed:=t>>$ 6107 % 8.9.04: This became necessary due to a strange factorizer bug 6108 % ` Non-numerical ... in arithmetic (or so) 6109 % 12.7.08: The same error occurs when on complex and an expression 6110 % contains '!:gi!: and then on rational is done and factorize. 6111 6112 if (modular_comp and not freeof(a,'!:mod!:)) or !*modular then << 6113 modular_bak:=!*modular; 6114 if !*modular then off modular$ 6115 % simp converts prefixed SQ into SQ and resimp gets rid of :mod: 6116 h:=errorset(list('FACTORIZE,mkquote mk!*sq resimp simp a),nil,nil) 6117 where !*protfg=t; 6118 if modular_bak then on modular 6119 >> else 6120 h:=errorset(list('FACTORIZE,mkquote a),nil,nil) where !*protfg=t; 6121 6122 if rational_changed then <<off msg$ algebraic(off rational)$ on msg>>$ 6123 if no_powers_changed then algebraic(on nopowers)$ 6124 kernlist!*:=kernlist!*bak$ 6125 kord!*:=kord!*bak; 6126 erfg!*:=nil; 6127 max_gc_counter:=bak; 6128 backup_:=bakup_bak; 6129 return if errorp h or 6130 (pairp h and pairp car h and 6131 cdar h and null cadar h) % seems a REDUCE bug 6132 then {'list,{'list,a,1}} 6133 else car h 6134end$ 6135 6136symbolic procedure err_catch_fac3(a)$ 6137% a is in standard form format 6138% returns list of factors in special format 6139% the first factor is numeric 6140% or (1 . nil) if error 6141begin scalar h,bak,kernlist!*bak,kord!*bak,bakup_bak, 6142 no_powers_changed,rational_changed,modular_bak; 6143 bak:=max_gc_counter; 6144 max_gc_counter:=my_gc_counter+max_gc_fac; 6145 kernlist!*bak:=kernlist!*$ 6146 kord!*bak:=kord!*$ 6147 bakup_bak:=backup_;backup_:='max_gc_fac$ 6148 if !*nopowers then <<algebraic(off nopowers)$ 6149 no_powers_changed:=t>>$ 6150 if null !*rational and not freeof(a,'!:rn!:) 6151 and (null !*complex or not freeof(a,'!:gi!:)) 6152 then <<off msg$ algebraic(on rational)$ on msg$ 6153 rational_changed:=t>>$ 6154 % 8.9.04: This became necessary due to a strange factorizer bug 6155 % ` Non-numerical ... in arithmetic (or so) 6156 % 12.7.08: The same error occurs when on complex and an expression 6157 % contains '!:gi!: and then on rational is done and factorize. 6158 6159 if (modular_comp and not freeof(a,'!:mod!:)) or !*modular then << 6160 modular_bak:=!*modular; 6161 if !*modular then off modular$ 6162 % simp converts prefixed SQ into SQ and resimp gets rid of :mod: 6163 h:=errorset(list('fctrf,mkquote numr resimp (a ./ 1)),nil,nil) 6164 where !*protfg=t; 6165 if modular_bak then on modular 6166 >> else 6167 h:=errorset(list('fctrf,mkquote a),nil,nil) where !*protfg=t; 6168 6169 if rational_changed then <<off msg$ algebraic(off rational)$ on msg>>$ 6170 if no_powers_changed then algebraic(on nopowers)$ 6171 kernlist!*:=kernlist!*bak$ 6172 kord!*:=kord!*bak; 6173 erfg!*:=nil; 6174 max_gc_counter:=bak; 6175 backup_:=bakup_bak; 6176 return if errorp h then cons(1,nil) 6177 else car h 6178end$ 6179 6180symbolic procedure err_catch_gcd(a,b)$ 6181% a and b must have form {'!*sq, .. ,t} (or prefix form which is 6182% infinitely slower for large expressions) 6183% returns GCD in {'!*sq,..,t}-form 6184begin scalar h,bak,kernlist!*bak,kord!*bak,bakup_bak; 6185 bak:=max_gc_counter; 6186 max_gc_counter:=my_gc_counter+max_gc_fac; 6187 kernlist!*bak:=kernlist!*$ 6188 kord!*bak:=kord!*$ 6189 bakup_bak:=backup_;backup_:='max_gc_fac$ 6190 h:=errorset({'aeval,list('list,''GCD,mkquote a,mkquote b)},nil,nil) 6191 where !*protfg=t; 6192 kernlist!*:=kernlist!*bak$ 6193 kord!*:=kord!*bak; 6194 erfg!*:=nil; 6195 max_gc_counter:=bak; 6196 backup_:=bakup_bak; 6197 % return if errorp h then 1 % --> previous prefix form 6198 % else car h 6199 return if errorp h then {'!*sq,(1 . 1),t} 6200 else car h 6201end$ 6202 6203symbolic procedure err_catch_preduce(a,b)$ 6204begin scalar h,k$ 6205 k:=setkorder nil$ 6206 h:= errorset({'aeval , mkquote {'preduce,mkquote a,mkquote b}},nil,nil) 6207 where !*protfg=t; 6208 erfg!*:=nil; 6209 setkorder k$ 6210 return if errorp h then nil 6211 else car h 6212end$ 6213 6214 6215symbolic procedure find_factorization(arglist)$ 6216% finding a PDE that is not thoroughly tested for factorization and that factorizes 6217begin scalar l,g,h,k,m,new_sqval,fs,dropped_factors,mb,pdes,pdecp,dropped_eqn$ 6218 pdes:=car arglist; 6219 if expert_mode then l:=selectpdes(pdes,1) 6220 else l:=cadddr arglist$ 6221 % fs is list of factors, i.e. fs neq nil means factorization was successful 6222 while l and null fs 6223 and null contradiction_ 6224 and null dropped_eqn do << % find only one successful factorization 6225 h:=get(car l,'fac); 6226 if null h or (fixp h and (h<2)) then << 6227 h:=cdr err_catch_fac2 {'!*sq,(numr get(car l,'sqval) . 1),t}; 6228 if pairp h and (cdr h or (caddar h>1)) then 6229 while h and null dropped_eqn do << 6230 g:=simp cadar h; 6231 if domainp numr g then h:=cdr h 6232 else << 6233 mb:=can_not_become_zeroSQ(g,ftem_)$ 6234 if (caddar h > 1) or mb then << 6235 dropped_factors:=t$ 6236 if null new_sqval then new_sqval:=get(car l,'sqval); 6237 k:=caddar h; % caddar h is the power of this factor 6238 if not mb then k:=sub1 k; % k is the power of the factor that is dropped 6239 for m:=1:k do new_sqval:=quotsq(new_sqval,g) 6240 >>$ 6241 if mb then h:=cdr h 6242 else << % Check whether the factor is = +/- an equation 6243 g:=numr cadr cadar h; 6244 k:=no_of_tm_sf g; 6245 pdecp:=pdes; 6246 while pdecp and h do 6247 if (get(car pdecp,'terms)=k) and 6248 (car pdecp neq car l) and 6249 ((g=numr get(car pdecp,'sqval)) or 6250 (g=numr negsq get(car pdecp,'sqval)) ) 6251 then <<dropped_eqn:=car pdecp;h:=nil>> 6252 else pdecp:=cdr pdecp; 6253 if h then <<fs:=cons((g . 1),fs);h:=cdr h>> 6254 >> 6255 >> 6256 >>; 6257 6258 if dropped_eqn then << 6259 pdes:=drop_pde(car l,pdes,{'times,dropped_eqn, 6260 {'quotient,prepsq get(car l,'sqval), 6261 prepsq get(dropped_eqn,'sqval)}})$ 6262 drop_pde_from_properties(car l,pdes) 6263 >> else 6264 if null dropped_factors and (null fs or null cdr fs) then << 6265 fs:=nil; 6266 put(car l,'fac,2) 6267 >> else 6268 if null dropped_factors then put(car l,'fac,fs) 6269 else << % factors are dropped -> new equation -> updatesq() 6270 for each f in allflags_ do flag1(car l,f)$ 6271 if record_hist then h:=get(car l,'sqval)$ 6272 updateSQ(car l,new_sqval,fs,nil,get(car l,'fcts),get(car l,'vars),t,list(0),pdes)$ 6273 % The updateSQ-call is correct whether fs holds only one factor or more than one 6274 drop_pde_from_idties(car l,pdes,if record_hist then reval 6275 {'times,get(car l,'hist),{'quotient,prepsq get(car l,'sqval),prepsq h}} 6276 else nil); 6277 drop_pde_from_properties(car l,pdes); 6278 if null contradiction_ then 6279 pdes:=eqinsert(car l,delete(car l,pdes))$ 6280 >> 6281 >>$ 6282 if print_ and ((fs or dropped_eqn) or contradiction_) then << 6283 write"Equation ",car l," factorized."$terpri()$ 6284 if contradiction_ then write"This leads to a contradiction!" else 6285 if dropped_eqn then write"It is a consequence of ",dropped_eqn,"." 6286 >>$ 6287 l:=cdr l 6288 >>; 6289 return 6290 if contradiction_ then nil else 6291 if dropped_eqn or dropped_factors then {pdes,cadr arglist} else 6292 if fs then arglist 6293end$ 6294 6295 6296%symbolic procedure factored_form(a)$ 6297%% a is expected to be in prefix form 6298%begin scalar b; 6299% if (pairp a) and (car a = 'plus) then << 6300% b:=err_catch_fac a$ 6301% if b and (length b > 2) then a:=cons('times,cdr b) 6302% >>; 6303% return a 6304%end$ 6305 6306symbolic procedure leading_factors(u)$ 6307% called from sffac() 6308% u is a standard form 6309% returns a list: first element is what can not be factorized, 6310% i.e. either 1 or a sum followed by monomial factors, 6311% each as a standard form, also numbers, like 7 or (!:rn!: 1 . 12) 6312begin scalar fli,v,w; 6313 while pairp u and 6314 null cdr u and 6315 not domainp car u do << % last test should already be included in 2nd test 6316 fli := cons(numr mksq(mvar u,ldeg u), fli)$ 6317 u := lc u 6318 >>$ 6319 6320 if domainp u then fli:=cons(u,fli) 6321 else << % find the numerical coefficient of the leading term 6322 v:=u$ 6323 while pairp v and not domainp car v do v:=lc v; 6324 6325 if v=1 then fli:=cons(u,fli) 6326 else << 6327 w:=quotsq((u . 1),(v . 1)); 6328 %w:=simpquot {{'!*sq,(u . 1),t},{'!*sq,(v . 1),t}}$ 6329 if denr w = 1 then fli:=cons(numr w,cons(v,fli)) 6330 else fli:=cons(u,fli) 6331 >> 6332 >>$ 6333 return fli 6334end$ 6335 6336symbolic procedure sffac(u)$ 6337% u is a standard form (not standard quotient) 6338% returns nil or fli - a list of standard forms, each being a factor 6339begin scalar u1,u2,u3,fli,v; 6340 6341 % at first splitting u into list of monomial factors and remainder 6342 % remainder coming first 6343 fli:=leading_factors(u)$ 6344 u:=car fli$ 6345 fli:=cdr fli$ 6346 6347 % then computing the GCD of all coefficients of the leading variable 6348 if not domainp u then << % u must be a sum with different powers of mvar u 6349 6350 v:=mvar u; 6351 % u1:=u$ 6352 % while u1 do 6353 % if domainp u1 or (v neq mvar u1) then <<u2:= u1 . u2;u1:= nil>> 6354 % else <<u2:=lc u1 . u2;u1:=red u1>>; 6355 % % u2 is now a list of coefficients of different powers 6356 % % u1:=1$ 6357 % % u1:=gcdlist u2; % gave sometimes error with rational numbers occuring in u2 6358 % % but then gcdf() in fixes.red was fixed and now gcdlist is re-activated 9.12.07 6359 % % u1:=gcdlist_aux u2; % temporarily when gcdlist gave errors 6360 % % 14 March 2012: gcdlist crashed when there were complex numbers ( :gi: ) 6361 % % involved. comfac did not crash, so now compfac is used 6362 6363 % comfac nimmt den gcd aller Koeffizienten der Potenzen der leading Variable 6364 % des Input Polynoms. Der gcd Algorithmus wird allerdings bestimmt durch den 6365 % Domainmode. Also wenn man z.B. 'on complex' gemacht hat, dann wird der gcd 6366 % auch ueber der Domaene des Rings der Gaussian Integer gemacht (was relativ 6367 % teuer ist). gcdlist hingegen ist eine Unterprozedur des 'extended Zassenhaus 6368 % gcd' Algorithmus und funktioniert daher nur ueber dem Ring Integer. 6369 6370 u1 := cdr comfac u; 6371 if (domainp u1) and (u neq 1) then fli:=cons(numr quotsq((u . 1),(u1 . 1)),cons(u1,fli)) 6372 else << 6373 u2:=sffac u1$ 6374 6375 if null u2 then u2:=list u1; 6376 for each u3 in u2 do % if not domainp u3 then 6377 << 6378 v:=quotsq((u . 1),(u3 . 1))$ % it should be denr v = 1 6379 if denr v = 1 then <<fli:=cons(u3,fli)$u:=numr v>> 6380 >>$ 6381 fli:=cons(u,fli) 6382 >> 6383 >>$ 6384 6385 %write"factors:"$ 6386 %for each u in fli do mathprint {'!*sq, (u . 1), t}$ 6387 %write"============================"$ 6388 6389 return fli 6390end$ 6391 6392!#if (memq 'psl lispsystem!*) 6393% PSL does not have a function oblist(), therefore: 6394 6395symbolic lispeval '(putd 'countids 'expr 6396 '(lambda nil (prog (nn) (setq nn 0) 6397 (mapobl (function (lambda (x) (setq nn (plus2 nn 1))))) 6398 (return nn))))$ 6399 6400!#else 6401 6402symbolic procedure countids$ length oblist()$ 6403 6404!#endif 6405 6406symbolic operator low_mem$ 6407% if garbage collection recovers only 500000 cells then backtrace 6408% to be used only on workstations, not PCs i.e. under LINUX, Windows 6409 6410%symbolic procedure newreclaim()$ 6411% <<oldreclaim(); 6412% if (known!-free!-space() < 500000 ) then backtrace() 6413% >>$ 6414 6415symbolic procedure low_mem()$ 6416if not( getd 'oldreclaim) then << 6417 copyd('oldreclaim,'!%reclaim); 6418 copyd('!%reclaim,'newreclaim); 6419>>$ 6420 6421symbolic operator polyansatz$ 6422symbolic procedure polyansatz(ev,iv,fn,degre,homo)$ 6423% - ev, iv are algebraic mode lists 6424% - generates a polynomial in the variables ev of degree degre 6425% with functions with name fn_index of the variables iv 6426% - if homo then a homogeneous polynomial 6427% - generates and returns polynomial in prefix form which could 6428% be speeded up to SQ-form if needed. 6429begin scalar a,fi,el1,el2,f,fl,p,pr; 6430 a:=reval list('expt,cons('plus,if homo then cdr ev 6431 else cons(1,cdr ev)),degre)$ 6432 a:=reverse cdr a$ 6433 fi:=0$ 6434 iv:=cdr iv$ 6435 for each el1 in a collect << 6436 if (not pairp el1) or 6437 (car el1 neq 'times) then el1:=list el1 6438 else el1:=cdr el1; 6439 f:=newfct(fn,iv,fi); 6440 fi:=add1 fi; 6441 fl:=cons(f,fl)$ 6442 pr:=list f$ 6443 for each el2 in el1 do 6444 if not fixp el2 then pr:=cons(el2,pr); 6445 if length pr>1 then pr:=cons('times,pr) 6446 else pr:=car pr; 6447 p:=cons(pr,p) 6448 >>$ 6449 p:=reval cons('plus,p)$ 6450 return list('list,p,cons('list,fl)) 6451end$ 6452 6453symbolic operator polyans$ 6454symbolic procedure polyans(ordr,dgr,x,y,d_y,fn)$ 6455% - generates a polynom 6456% for i:=0:dgr sum fn"i"(x,y,d_y(1),..,d_y(ordr-1))*d_y(ordr)**i 6457% with fn as the function names and d_y as names or derivatives 6458% of y w.r.t. x 6459% - generates and returns polynomial in prefix form which could 6460% be speeded up to SQ-form if needed. 6461% - this is an older function hardly used anymore 6462begin scalar ll,fl,a,i,f$ 6463 i:=sub1 ordr$ 6464 while i>0 do 6465 <<ll:=cons(list(d_y,i),ll)$ 6466 i:=sub1 i>>$ 6467 ll:=cons(y,ll)$ 6468 ll:=reverse cons(x,ll)$ 6469 fl:=nil$ 6470 i:=0$ 6471 while i<=dgr do 6472 <<f:=newfct(fn,ll,i)$ 6473 fl:=(f . fl)$ 6474 a:=list('plus,list('times,f,list('expt,list(d_y,ordr),i)),a)$ 6475 i:=add1 i>>$ 6476 return list('list,reval a,cons('list,fl)) 6477end$ % of polyans 6478 6479symbolic operator sepans$ 6480symbolic procedure sepans(kind,v1,v2,fn)$ 6481% Generates a separation ansatz 6482% v1,v2 = lists of variables, fn = new function name + index added 6483% The first variable of v1 occurs only in one sort of the two sorts of 6484% functions and the remaining variables of v1 in the other sort of 6485% functios. 6486% The variables of v2 occur in all functions. 6487% Returned is a sum of products of each one function of both sorts. 6488% form: fn1(v11;v21,v22,v23,..)*fn2(v12,..,v1n;v21,v22,v23,..)+... 6489% the higher "kind", the more general and difficult the ansatz is 6490% kind = 0 is the full case 6491begin scalar n,vl1,vl2,h1,h2,h3,h4,fl$ 6492 if cdr v1 = nil then <<vl1:=cdr v2$vl2:=cdr v2>> 6493 else <<vl1:=cons(cadr v1,cdr v2)$ 6494 vl2:=append(cddr v1,cdr v2)>>$ 6495 return 6496 if kind = 0 then <<vl1:=append(cdr v1,cdr v2)$ 6497 h1:=newfct(fn,vl1,'_)$ 6498 list('list,h1,list('list,h1))>> 6499 else 6500 if kind = 1 then <<h1:=newfct(fn,vl1,1)$ 6501 list('list,h1,list('list,h1))>> 6502 else 6503 if kind = 2 then <<h1:=newfct(fn,vl2,1)$ 6504 list('list,h1,list('list,h1))>> 6505 else 6506 if kind = 3 then <<h1:=newfct(fn,vl1,1)$ 6507 h2:=newfct(fn,vl2,2)$ 6508 list('list,reval list('plus,h1,h2), 6509 list('list,h1,h2))>> 6510 else 6511 if kind = 4 then <<h1:=newfct(fn,vl1,1)$ 6512 h2:=newfct(fn,vl2,2)$ 6513 list('list,reval list('times,h1,h2), 6514 list('list,h1,h2))>> 6515 else 6516 if kind = 5 then <<h1:=newfct(fn,vl1,1)$ 6517 h2:=newfct(fn,vl2,2)$ 6518 h3:=newfct(fn,vl1,3)$ 6519 list('list,reval list('plus,list('times,h1,h2),h3), 6520 list('list,h1,h2,h3))>> 6521 else 6522 if kind = 6 then <<h1:=newfct(fn,vl1,1)$ 6523 h2:=newfct(fn,vl2,2)$ 6524 h3:=newfct(fn,vl2,3)$ 6525 list('list,reval list('plus,list('times,h1,h2),h3), 6526 list('list,h1,h2,h3))>> 6527 else 6528 if kind = 7 then <<h1:=newfct(fn,vl1,1)$ 6529 h2:=newfct(fn,vl2,2)$ 6530 h3:=newfct(fn,vl1,3)$ 6531 h4:=newfct(fn,vl2,4)$ 6532 list('list,reval list('plus, 6533 list('times,h1,h2),h3,h4), 6534 list('list,h1,h2,h3,h4))>> 6535 else 6536% ansatz of the form FN = FN1(v11,v2) + FN2(v12,v2) + ... + FNi(v1i,v2) 6537 if kind = 8 then <<n:=1$ vl1:=cdr v1$ vl2:=cdr v2$ 6538 fl:=()$ 6539 while vl1 neq () do << 6540 h1:=newfct(fn,cons(car vl1,vl2),n)$ 6541 vl1:=cdr vl1$ 6542 fl:=cons(h1, fl)$ 6543 n:=n+1 6544 >>$ 6545 list('list, cons('plus,fl), cons('list,fl))>> 6546 6547 6548 else 6549 <<h1:=newfct(fn,vl1,1)$ 6550 h2:=newfct(fn,vl2,2)$ 6551 h3:=newfct(fn,vl1,3)$ 6552 h4:=newfct(fn,vl2,4)$ 6553 list('list,reval list('plus,list('times,h1,h2), 6554 list('times,h3,h4)), 6555 list('list,h1,h2,h3,h4))>> 6556end$ % of sepans 6557 6558% 6559% Orderings support! 6560% 6561% change_derivs_ordering(pdes,fl,vl) changes the ordering of the 6562% list of derivatives depending on the current ordering (this 6563% is detected "automatically" by sort_derivs using the lex_df flag to 6564% toggle between total-degree and lexicographic. 6565% 6566symbolic procedure change_derivs_ordering(pdes,fl,vl)$ 6567begin scalar p, dl; 6568 for each p in pdes do << 6569 if tr_orderings then << 6570 terpri()$ 6571 write "Old: ", get(p,'derivs)$ 6572 >>$ 6573 dl := sort_derivs(get(p,'derivs),fl,vl)$ 6574 if tr_orderings then << 6575 terpri()$ 6576 write "New: ", dl$ 6577 >>$ 6578 put(p,'derivs,dl)$ 6579 put(p,'dec_with,nil)$ % only if orderings are not 6580 % investigated in parallel (-->ord) 6581 put(p,'dec_with_rl,nil)$ % only if orderings are not .. 6582 flag1(p,'to_separant)$ % df(p,lead_deriv) has to be updated if needed 6583 >>$ 6584 return pdes 6585end$ 6586 6587symbolic procedure sort_according_to(r,s)$ 6588% All elements in r that are in s are sorted according to their order in s. 6589% This assumes that r is a subset of s. 6590begin scalar ss,h; 6591 for each ss in s do 6592 if member(ss,r) then h:=cons(ss,h); 6593 return reverse h 6594end$ 6595 6596symbolic procedure a_before_b_according_to_c(a,b,s)$ 6597% determines whether a comes before b in the list s 6598% returns nil if a=b or if a and b are not in s 6599if not pairp s then nil else 6600if b=car s then nil else 6601if a=car s then t else a_before_b_according_to_c(a,b,cdr s)$ 6602 6603symbolic procedure change_fcts_ordering(newli,pdes,vl)$ 6604begin scalar s$ 6605 ftem_:=newli$ 6606 flin_:=sort_according_to(flin_,ftem_); 6607 for each s in pdes do << 6608 put(s,'fcts,sort_according_to(get(s,'fcts),ftem_))$ 6609 put(s,'allvarfcts,sort_according_to(get(s,'allvarfcts),ftem_))$ 6610 >>$ 6611 pdes := change_derivs_ordering(pdes,ftem_,vl)$ 6612 if tr_orderings then << 6613 terpri()$ 6614 write "New functions list: ", ftem_$ 6615 >> 6616end$ 6617 6618symbolic procedure search_li(l,care)$ 6619% Find the cadr of all sublists which have 'care' as car (no nesting) 6620if pairp l then 6621if car l = care then {cadr l} 6622 else begin 6623 scalar b,resul; 6624 while pairp l do << 6625 if b:=search_li(car l,care) then resul:=union(b,resul); 6626 l:=cdr l 6627 >>$ 6628 return resul 6629end$ 6630 6631symbolic procedure search_li2(l,care)$ 6632% Find all sublists which have 'care' as car (no nesting) 6633if pairp l then 6634if car l = care then list l 6635 else begin 6636 scalar b,resul; 6637 while pairp l do << 6638 if b:=search_li2(car l,care) then resul:=union(b,resul); 6639 l:=cdr l 6640 >>$ 6641 return resul 6642end$ 6643 6644symbolic operator filter$ 6645% an algebraic mode function to return a list of all occurences of operator care 6646% no reval needed as call of symbolic operator converts to prefix form 6647symbolic procedure filter(l,care)$ 6648cons('list,search_li2(l,care))$ 6649 6650symbolic operator backup_reduce_flags$ 6651symbolic procedure backup_reduce_flags$ 6652% !*nopowers = t to have output of FACTORIZE like in Reduce 3.6 6653% !*allowdfint = t moved here from crintfix, to enable simplification 6654% of derivatives of integrals 6655begin 6656 !*dfprint_bak := cons(!*dfprint,!*dfprint_bak)$ 6657 !*exp_bak := cons(!*exp,!*exp_bak)$ 6658 !*ezgcd_bak := cons(!*ezgcd,!*ezgcd_bak)$ 6659 !*fullroots_bak := cons(!*fullroots,!*fullroots_bak)$ 6660 !*gcd_bak := cons(!*gcd,!*gcd_bak)$ 6661 !*mcd_bak := cons(!*mcd,!*mcd_bak)$ 6662 !*ratarg_bak := cons(!*ratarg,!*ratarg_bak)$ 6663 !*rational_bak := cons(!*rational,!*rational_bak)$ 6664 6665 if null !*dfprint then algebraic(on dfprint)$ 6666 if null !*exp then algebraic(on exp)$ 6667 if null !*ezgcd then algebraic(on ezgcd)$ 6668 if null !*fullroots then algebraic(on fullroots)$ 6669 if !*gcd then algebraic(off gcd)$ 6670 if null !*mcd then algebraic(on mcd)$ 6671 if null !*ratarg then algebraic(on ratarg)$ 6672% if null !*rational then algebraic(on rational)$ 6673 6674 !*nopowers_bak := cons(!*nopowers,!*nopowers_bak)$ 6675 !*allowdfint_bak := cons(!*allowdfint,!*allowdfint_bak)$ 6676 if null !*nopowers then algebraic(on nopowers)$ 6677 if null !*allowdfint then algebraic(on allowdfint)$ 6678 6679end$ 6680 6681symbolic operator recover_reduce_flags$ 6682symbolic procedure recover_reduce_flags$ 6683begin 6684 6685 if !*dfprint neq car !*dfprint_bak then 6686 if !*dfprint then algebraic(off dfprint) else algebraic(on dfprint)$ 6687 !*dfprint_bak:= cdr !*dfprint_bak$ 6688 6689 if !*exp neq car !*exp_bak then 6690 if !*exp then algebraic(off exp) else algebraic(on exp)$ 6691 !*exp_bak:= cdr !*exp_bak$ 6692 6693 if !*ezgcd neq car !*ezgcd_bak then 6694 if !*ezgcd then algebraic(off ezgcd) else algebraic(on ezgcd)$ 6695 !*ezgcd_bak:= cdr !*ezgcd_bak$ 6696 6697 if !*fullroots neq car !*fullroots_bak then 6698 if !*fullroots then algebraic(off fullroots) else algebraic(on fullroots)$ 6699 !*fullroots_bak:= cdr !*fullroots_bak$ 6700 6701 if !*gcd neq car !*gcd_bak then 6702 if !*gcd then algebraic(off gcd) else algebraic(on gcd)$ 6703 !*gcd_bak:= cdr !*gcd_bak$ 6704 6705 if !*mcd neq car !*mcd_bak then 6706 if !*mcd then algebraic(off mcd) else algebraic(on mcd)$ 6707 !*mcd_bak:= cdr !*mcd_bak$ 6708 6709 if !*ratarg neq car !*ratarg_bak then 6710 if !*ratarg then algebraic(off ratarg) else algebraic(on ratarg)$ 6711 !*ratarg_bak:= cdr !*ratarg_bak$ 6712 6713 if !*rational neq car !*rational_bak then 6714 if !*rational then algebraic(off rational) else algebraic(on rational)$ 6715 !*rational_bak:= cdr !*rational_bak$ 6716 6717 if !*nopowers neq car !*nopowers_bak then 6718 if !*nopowers then algebraic(off nopowers) else algebraic(on nopowers)$ 6719 !*nopowers_bak:= cdr !*nopowers_bak$ 6720 if !*allowdfint neq car !*allowdfint_bak then 6721 if !*allowdfint then algebraic(off allowdfint) else algebraic(on allowdfint)$ 6722 !*allowdfint_bak:= cdr !*allowdfint_bak$ 6723end$ 6724 6725algebraic procedure maklist(ex)$ 6726% making a list out of an expression if not already 6727if lisp(atom algebraic ex) then {ex} else 6728if lisp(car algebraic ex neq 'list) then ex:={ex} 6729 else ex$ 6730 6731symbolic procedure add_to_last_steps(h)$ 6732begin scalar n$ 6733 last_steps:=cons(h,last_steps)$ 6734 if fixp size_watch then << 6735 n:=0; 6736 h:=last_steps; 6737 while n<size_watch and cdr h do <<n:=add1 n;h:=cdr h>>; 6738 if cdr h then rplacd(h,nil) 6739 >> 6740 6741end$ 6742 6743symbolic procedure same_steps(a,b)$ 6744if (car a = car b ) and 6745 ((cddr a = cddr b) or % full equality apart from stepcounter_ 6746 ((car a neq 'subst ) and 6747 (car a neq 27 ) and 6748 (car a neq 30 ) and 6749 (car a neq 11 ) and 6750 (car a neq 59 ) and 6751 (car a neq 'sub_sys) )) then t 6752 else nil$ 6753 6754symbolic procedure in_cycle(h)$ 6755% h={'number of module',stepcounter_,'more parameter(s)} 6756begin scalar cpls1,cpls2,n,m,cycle; 6757 cpls1:=last_steps$ 6758 if car h = 11 then << 6759 n:=0; 6760 m:=0; 6761 while cpls1 and (m<20) do << 6762 if same_steps(h,car cpls1) then n:=add1 n; 6763 m:=add1 m; 6764 cpls1:=cdr cpls1 6765 >>; 6766 if (n>1) and (3*n>m) then cycle:=t else cycle:=nil 6767 >> else 6768 if car h='subst then << 6769 n:=0$ 6770 while cpls1 do << 6771 if same_steps(h,car cpls1) then n:=add1 n; 6772 cpls1:=cdr cpls1 6773 >>$ 6774 cycle:= 6775 if n>2 then << % the subst. had been done already >=3 times 6776 write"A partial substitution has been repeated too often."$ terpri()$ 6777 write"It will now be made rigorously."$ terpri()$ 6778 t 6779 >> else nil 6780 % add_to_last_steps(h) is done outside for substitutions as it is not 6781 % clear at this stage whether the substitution will be performed 6782 >> else 6783 if (car h=9) or (car h=80) then << % 9=subst_derivative, 80=subst_power 6784 n:=1$ 6785 while (n=1) and cpls1 do << 6786 if same_steps(h,car cpls1) then n:=add1 n; 6787 cpls1:=cdr cpls1 6788 >>$ 6789 if n>1 then cycle:=t else cycle:=nil 6790 >> else 6791 if (car h=32) then << % add_diff_ise 6792 % There is now easy way of controling cycling if module 32 is allowed. 6793 % E.g. one should allow it if it is a new case but not allow too many 6794 % differentiations of differentiated equations. 6795 % The simplest is to take 32 out of the default loop and perform it 6796 % only interactively. It is very unlikely anyway that 32 helps. 6797 % Here we allow it only 5 times to occur in all of last_steps. 6798 n:=1$ m:=1; 6799 while cpls1 and (n<6) and (m<100) do << 6800 if same_steps(h,car cpls1) then n:=add1 n; 6801 m:=add1 m; 6802 cpls1:=cdr cpls1 6803 >>$ 6804 if n>=6 then cycle:=t else cycle:=nil 6805 >> else 6806 if (car h=59) and cpls1 and same_steps(h,car cpls1) then cycle:=t 6807 else << 6808 n:=1$ 6809 % Exactly the same step taken repeatedly one directly after another is not a 6810 % cycle (unless the last step is a step dealing with the whole problem, like 6811 % module 59 (computing a Groebner Basis). --> Go back as long as the same 6812 % steps were done one after another. 6813 while cpls1 and (car h = caar cpls1) and zerop(cadr h - n - cadar cpls1) do 6814 <<n:=add1 n;cpls1:=cdr cpls1>>$ 6815 while cpls1 and (not same_steps(h,car cpls1)) do 6816 <<n:=add1 n;cpls1:=cdr cpls1>>$ 6817 6818 if null cpls1 or 6819 ((reval {'plus,n,n})>length last_steps) then cycle:=nil 6820 else << 6821 cpls1:=cdr cpls1; 6822 cpls2:=last_steps$ 6823 while (n>0) and same_steps(car cpls2,car cpls1) do 6824 <<cpls1:=cdr cpls1;cpls2:=cdr cpls2;n:=sub1 n>>$ 6825 if (n=0) and print_ then << 6826 write if car h = 'sub_sys then "A step to find overdet. sub-systems (" else 6827 if car h = 9 then "A derivative replacement (" else 6828 if car h = 11 then "An algebraic length reduction (" else 6829 if car h = 27 then "A length reducing simplification (" else 6830 if car h = 59 then "A Groebner Basis computation (" else 6831 "A step (", 6832 car h,") was prevented"$ terpri()$ 6833 write"to avoid a cycle."$ terpri()$ 6834 >>$ 6835 cycle:=if n>0 then nil else t 6836 >>; 6837 if null cycle then add_to_last_steps(h)$ 6838 >>; 6839 return cycle 6840end$ 6841 6842symbolic procedure switchp (x); 6843% When called through: mapobl function switchp 6844% then this procedure lists all switch settings. 6845if idp x then if flagp(x ,' switch) then << 6846 x := intern bldmsg("*%w",x); 6847 if boundp x then print list(x, eval x) 6848>>$ 6849 6850endmodule$ 6851 6852%******************************************************************** 6853module solution_handling$ 6854%******************************************************************** 6855% Routines for storing, retrieving, merging and displaying solutions 6856% Author: Thomas Wolf Dec 2001 6857 6858symbolic procedure save_solution(eqns,assigns,freef,ineq,ineqor,file_name)$ 6859% input lists are in symbolic mode, i.e. without 'list at start 6860% eqns .. list of remaining unsolved equations 6861% assigns .. list of computed assignments of the form `function = expression' 6862% freef .. list of functiones either free or in eqns 6863% ineq .. list of inequalities 6864% ineqor .. list of OR-inequalities 6865begin scalar s,h,p,conti,a,save,ofl!*bak$ 6866 if file_name then s:=file_name 6867 else << 6868 s:=level_string(session_)$ 6869 s:=explode s$ 6870 s:=compress cons(car s,cons('s,cons('o,cdddr s)))$ 6871 >>$ 6872 6873 sol_list:=union(list s,sol_list)$ 6874 6875 %out s; 6876 a:=open(s,'output); 6877 ofl!*bak:=ofl!*$ 6878 ofl!*:=s$ % any value neq nil, to avoid problem with redfront 6879 save:=wrs a; 6880 6881 write"off echo$ "$ 6882 write"backup_:='("$terpri()$ 6883 6884 for each h in freef do 6885 if p:=assoc(h,depl!*) then conti:=cons(p,conti); 6886 6887 % The first sub-list is a list of dependencies, like ((f x y) (g x)) 6888 write"% A list of dependencies, like ((f x y) (g x))"$terpri()$ 6889 print conti$write" "$terpri()$ 6890 6891 % The next sublist is a list of unsolved equations 6892 write"% A list of unsolved equations"$terpri()$ 6893 print eqns$write" "$terpri()$ 6894 6895 % The next sublist is a list of assignments 6896 write"% A list of assignments"$terpri()$ 6897 % For algebraic problems one might want to reduce the rhs 6898 % modulo eqns (see end of merge_two() ). 6899 print assigns$write" "$terpri()$ 6900 6901 % The next sublist is a list of free or unresolved functions 6902 write"% A list of free or unresolved functions"$terpri()$ 6903 print freef$write" "$terpri()$ 6904 6905 % The next sublist is a list of non-vanishing expressions 6906 write"% A list of non-vanishing expressions."$terpri()$ 6907 print ineq$write" "$terpri()$ 6908 6909 % The next sublist is a list of or-lists. Each or-list has 6910 % elements that are factor-lists, such that for each or-list 6911 % at least from one factor-list all elements must be non-zero. 6912 write"% A list of or-lists. Each or-list has elements that "$terpri()$ 6913 write"% are factor-list, such that for each or-list at least"$terpri()$ 6914 write"% from one factor-list all elements must be non-zero. "$terpri()$ 6915 print ineqor$write" "$terpri()$ 6916 6917 terpri()$ 6918 6919 write")$"$ 6920 6921 write "end$"$terpri()$ 6922 %shut s; 6923 wrs save$ 6924 ofl!*:=ofl!*bak$ 6925 close a; 6926 6927 return s 6928end$ 6929 6930symbolic procedure print_indexed_list(li)$ 6931begin scalar a,h$ 6932 terpri()$ 6933 h:=0$ 6934 for each a in li do << 6935 h:=add1 h; 6936 write"[",h,"]";terpri()$ 6937 mathprint a 6938 >> 6939end$ 6940 6941symbolic procedure printDHMStime(a)$ 6942% print how many days, hours, minutes and seconds a is 6943begin scalar b$ 6944 if a>10000 then << 6945 write" = "$ 6946 if a>=86400000 then << 6947 b:=floor(a/86400000); 6948 write b,if b=1 then " day " else " days "; 6949 a:=a-b*86400000 6950 >>; 6951 if a>=3600000 then << 6952 b:=floor(a/3600000); 6953 write b,if b=1 then " hour " else " hours "; 6954 a:=a-b*3600000 6955 >>; 6956 if a>=60000 then << 6957 b:=floor(a/60000); 6958 write b,if b=1 then " minute " else " minutes "; 6959 a:=a-b*60000 6960 >>; 6961 if a>=1000 then << 6962 b:=floor(a/1000); 6963 write b,if b=1 then " seccond " else " seconds "; 6964 a:=a-b*1000 6965 >>; 6966 if a neq 0 then write a," msec " 6967 >> 6968end$ 6969 6970symbolic procedure sub_list(sb,aim,tr_merge)$ 6971% sb is a list of substitutions to be done safely in aim 6972begin scalar a,b$ 6973 while sb and aim do << 6974 % By not computing the numerator we get a sufficient test 6975 % aim:=cons('list,for each a in cdr aim collect 6976 % algebraic(num(lisp(aim)))); 6977 a:=car sb; sb:=cdr sb; 6978 if tr_merge then b:=aim; 6979 aim:=err_catch_sub(cadr a,caddr a,aim); 6980 if tr_merge and null aim then << 6981 write"Sub: ";mathprint a$ 6982 write"in: ";mathprint b$ 6983 write"gives a singular result."$terpri() 6984 >> 6985 >>$ 6986 if null aim then << 6987 write"Substitutions give singularities."$ terpri()$ 6988 % write"Even substitutions in the numerator "$ terpri()$ 6989 % write"are giving singularities like for log(0)."$ terpri()$ 6990 >>$ 6991 return aim 6992end$ 6993 6994% In earlier versions of crack the operation of copying a file was 6995% performed as (system bldmsg("cp w w", n1, n2)) which is concise, 6996% however A.C.Norman believes that the overhead in calling "system" can 6997% be extreme and the issues of Windows vs Unix/Linux/MacOSX 6998% compatibility can be bad, so this might be safer and could even end up 6999% faster. 7000 7001% This returns T on success or NIL on failure... 7002 7003symbolic procedure merge_two(s1,sol1,s2,sol2,absorb)$ 7004% Is sol1 a special case of sol2 ? 7005% If yes, return the new generalized solution sol2 with one less inequality. 7006% If absorb then modify s2 and sol2 if s1 can be absorbed 7007% ineqor lists are currently not considered nor modified if absorb 7008 7009begin scalar eli_2,singular_eli,regular_eli,a,b,cond2,sb,remain_sb, 7010 singular_sb,regular_sb,c2,remain_c2,remain_num_c2,h,hh, 7011 try_to_sub,try_to_sub_cp,num_sb,singular_ex,new_eqn, 7012 singular_ex_cp,ineq2,ine,ineqnew,ineqdrop,tr_merge, 7013 extra_par_in_s1,gauge_of_s2,gauge_of_s2_cp,did_trafo,n, 7014 remain_c2_cp,dropped_assign_in_s2,new_assign_in_s2,ass1, 7015 ass2,sol1_eqn,sol2_eqn,gb$ %num_sb_quo, 7016 7017%tr_merge:=t$ 7018 if tr_merge then << 7019 write"*** sol1 ***: ",s1$ terpri()$ 7020 if cadr sol1 then <<write"Remaining equations:"$deprint(cadr sol1)>>$ 7021 print_indexed_list(caddr sol1)$ 7022 7023 write"*** sol2 ***: ",s2$ terpri()$ 7024 if cadr sol2 then <<write"Remaining equations:"$deprint(cadr sol2)>>$ 7025 print_indexed_list(caddr sol2)$ 7026 write"free param in sol1: ",cadddr sol1$terpri()$ 7027 write"free param in sol2: ",cadddr sol2$terpri()>>$ 7028 7029 % We drop all assignments like a6=a6 from both sets of assignments 7030 ass1:=caddr sol1$ for each a in cadddr sol1 do ass1:=delete({'equal,a,a},ass1); 7031 ass2:=caddr sol2$ for each a in cadddr sol2 do ass2:=delete({'equal,a,a},ass2); 7032 7033 % 1. We check whether all remaining equations of sol2 are 7034 % either fulfilled by assignments of sol1 or if after these 7035 % assignments the remaining equations of sol2 are in the ideal of the 7036 % remaining equations of sol1. In a first implementation we simply 7037 % check whether both remaining systems are the same. 7038 sol1_eqn:=cons('list,cadr sol1)$ % unsolved equations in sol1 7039 sol2_eqn:=cons('list,cadr sol2)$ % unsolved equations in sol2 7040 7041 % 1.1. We do all substitutions of assignments of sol2 in sol2_eqn and 7042 % similar for sol1 as some substitutions may not have been fully 7043 % performed during the computation of the solutions as they were too 7044 % expensive at the time. 7045 % At first for the unsolved equations of sol1: 7046 if cdr sol1_eqn then << 7047 if tr_merge then <<write"Initial preparation of unsolved eqn in sol1"$ 7048 terpri()>>$ 7049 if null (sol1_eqn:=sub_list(ass1,sol1_eqn,tr_merge)) then return nil$ 7050 >>$ 7051 7052 % And now for the unsolved equations of sol2: 7053 if cdr sol2_eqn then << 7054 if tr_merge then <<write"Initial preparation of unsolved eqn in sol2"$ 7055 terpri()>>$ 7056 if null (sol2_eqn:=sub_list(ass2,sol2_eqn,tr_merge)) then return nil$ 7057 >>$ 7058 7059 % 1.2. We do all substitutions of sol1 in sol2_eqn, always 7060 % taking the numerator after each substitution. 7061 if cdr sol2_eqn then << 7062 if tr_merge then <<write"sol1 substitutions in sol2"$ 7063 terpri()>>$ 7064 if null (sol2_eqn:=sub_list(ass1,sol2_eqn,tr_merge)) then return nil$ 7065 >>$ 7066 % If sol1 had no remaining equations then after these substitutions 7067 % there should be no equations from sol2 left. 7068 if null cdr sol1_eqn and cdr sol2_eqn then return nil$ 7069 7070 % If sol1 has remaining equations (i.e. if cdr sol1_eqn <> nil 7071 % then from now onwards, everything has to be satisfied modulo 7072 % this set of equations (called gb below). 7073 7074 % 1.3. If the remaining equations sol2_eqn are not solved then they 7075 % should be in the ideal of sol1_eqn. If not then sol1 can not be 7076 % merged to sol2. 7077 7078 % 1.3.1. Bring sol1_eqn into the form of a Groebner Basis gb 7079 if cdr sol1_eqn then algebraic << 7080 torder(lisp(cons('list,cadddr sol1)),lex); 7081 gb:=groebner sol1_eqn; % maybe covering this in a shell in case it 7082 % takes too long 7083 if tr_merge then write "gb=",gb$ 7084 % 1.3.2. Check whether each equation of sol2_eqn is in the ideal of gb 7085 while (sol2_eqn neq {}) and 7086 (preduce(num first sol2_eqn,gb)=0) do sol2_eqn:=rest sol2_eqn 7087 >>$ 7088 sol2_eqn:=cdr sol2_eqn$ 7089 7090 if tr_merge then 7091 if null sol2_eqn then << 7092 write "The remaining equations of solution sol2 are in the"$ terpri()$ 7093 write "ideal of the remaining equations of solution sol1."$ terpri() 7094 >> else << 7095 write"Equation "$mathprint car sol2_eqn$ 7096 write"of solution sol2 is not in the ideal of"$ terpri()$ 7097 write"the remaining equations of solution sol1."$ terpri()$ 7098 write"--> sol1 is not a special case of sol2."$terpri()$ 7099 >>$ 7100 if sol2_eqn then return nil; 7101 7102 % 2. We list all lhs y_i in assignments y_i=... in sol2 7103 eli_2:=for each a in ass2 collect cadr a; 7104 7105 % writing assignments of solution 2 as expressions to vanish, 7106 % no numerator taken yet 7107 cond2:=for each a in ass2 7108 collect {'plus,cadr a,{'minus,caddr a}}; 7109 7110 % Do all substitutions a=... from sol1 for which there is an 7111 % assignment a=... in sol2 and collect the other substitutions as remain_sb. 7112 % These are straight forward substitutions not to be debated. 7113 cond2:=cons('list,cond2); % because of use of subeval in substitution 7114 sb:=ass1; % all assignments of solution 1 7115 while sb do << 7116 a:=car sb; sb:=cdr sb; 7117 if member(cadr a,eli_2) then << 7118 eli_2:=delete(cadr a,eli_2)$ 7119 cond2:=err_catch_sub(cadr a,caddr a,cond2) 7120 >> else remain_sb:=cons(a,remain_sb) 7121 >>$ 7122 7123 % eli_2 becomes now the list of new sol2 parameters 7124 eli_2:=append(eli_2,cadddr sol2)$ % needed only much further below 7125 7126 % The same again, now taking only numerators and only the remaining 7127 % substitutions are done in the remaining not identically zero 7128 % conditions from sol2. In remain_num_c2 are all those non-vanishing, 7129 % denominator free conditions of sol2 collected which give a 7130 % singularity for the remaining sol1-substitutions. If there is 7131 % anyone of these then stop --> sol1 is not a specialized solution of 7132 % sol2. If after all substitutions one numerator is not zero then 7133 % stop --> sol1 can not be merged to sol2. 7134 7135 remain_c2:=cond2; % remain_c2 to be used later 7136 7137 cond2:=cdr cond2; 7138 c2:=nil$ 7139 h:=0$ 7140 while cond2 and (null c2 or zerop c2) do << 7141 c2:=car cond2; 7142 h:=add1 h; 7143 if tr_merge then <<write"[",h,"]"$terpri()$mathprint c2>>$ 7144 7145 % Is the numerator of c2 fulfilled by assignments of solution 1? 7146 sb:=remain_sb; % all remaining assignments of solution 1 7147 while sb and c2 and not zerop c2 do << 7148 a:=car sb; sb:=cdr sb; 7149 c2:=algebraic(num(lisp(c2))); 7150 if tr_merge then b:=c2; 7151 c2:=err_catch_sub(cadr a,caddr a,c2); 7152 if tr_merge and (b neq c2) then << 7153 write"Sub: ";mathprint a$ 7154 if c2 then <<write"new value="$mathprint c2>> 7155 else <<write"singular result"$terpri()>> 7156 >>$ 7157 if c2 and not zerop c2 and gb then << 7158 c2:=algebraic(preduce(num c2,gb))$ 7159 if tr_merge then << 7160 if zerop c2 then 7161 write"which vanishes modulo the remaining eqn.s of sol1." else 7162 write"which does not vanish modulo the remaining eqn.s of sol1."$ 7163 terpri()$ 7164 >> 7165 >> 7166 >>$ 7167 if null c2 then remain_num_c2:=cons(car cond2,remain_num_c2); 7168 cond2:=cdr cond2 7169 >>$ 7170 7171 if c2 and not zerop c2 then return nil; % sol1 is not special case of sol2 7172 if remain_num_c2 then << % can only occur if there were singular subst. 7173 write"Even substitutions in the numerator is giving "$terpri()$ 7174 write"singularities like log(0)."$ terpri()$ 7175 return nil 7176 >>$ 7177 7178 write"Substitutions in numerators give all zero"$terpri()$ 7179 7180 % Data used below are remain_sb which are the remaining substitutions 7181 % in sol1, remain_c2 which are the remaining conditions in sol2 and 7182 % eli_2 the list of so far not determined functions in sol2. 7183 7184 % We now want to find a different order of substitutions, especially 7185 % substituting for the free parameter functions of sol2 7186 % based on remain_sb to be done in remain_c2. 7187 7188 % At first we sort all sol1 assignments into regular_sb and singular_sb. 7189 % remain_c2 is not changed in this 7190 sb:=remain_sb; % all remaining assignments of solution 1 7191 while sb do << 7192 a:=car sb; sb:=cdr sb; 7193 h:=err_catch_sub(cadr a,caddr a,remain_c2); 7194 if null h then singular_sb:=cons(a,singular_sb) 7195 else regular_sb:=cons(a,regular_sb) 7196 >>$ 7197 if tr_merge then <<terpri()$ 7198 write"regular_sb: "$mathprint cons('list,regular_sb)>>$ 7199 if tr_merge then <<write"singular_sb: "$mathprint cons('list,singular_sb)>>$ 7200 7201 if singular_sb then << 7202 write"Substitutions lead to singularities."$terpri()$ 7203 write"Solution ",s2," has to be transformed."$terpri() 7204 >>$ 7205 7206 % We now make a list of vanishing expressions based on singular_sb 7207 % which when replaced by 0 in remain_c2 give singularities 7208 singular_ex:=for each a in singular_sb 7209 collect reval {'plus,cadr a,{'minus,caddr a}}; 7210 if tr_merge then << 7211 write"The following are expressions which vanish due to sol1 and"$ 7212 terpri()$ 7213 write"which lead to singularities when used for substitutions in sol2"$ 7214 terpri()$ 7215 mathprint cons('list,singular_ex) 7216 >>$ 7217 7218 if tr_merge then << 7219 write"The following are all free parameters in sol2 for which there are"$ 7220 terpri()$ 7221 write"substitutions in sol1"$ terpri()$ 7222 >>$ 7223 singular_eli:=for each a in singular_sb collect cadr a; 7224 regular_eli:=for each a in regular_sb collect cadr a; 7225 if tr_merge then <<terpri()$ 7226 write"singular_eli: "$mathprint cons('list,singular_eli)>>; 7227 if tr_merge then <<write"regular_eli: "$mathprint cons('list,regular_eli)>>; 7228 7229 % Before continuing we want to check whether the supposed to be more special 7230 % solution sol1 has free parameters which are not free parameters in the more 7231 % general solution sol2. That can cause problems, i.e. division through 0 7232 % and non-includedness when in fact sol1 is included in sol2. 7233 7234 extra_par_in_s1:=setdiff(cadddr sol1,cadddr sol2); 7235 if tr_merge then <<write"Param in sol1 and not in sol2: ",extra_par_in_s1; 7236 terpri()>>$ 7237 7238 for each a in extra_par_in_s1 do << 7239 h:=ass2$ 7240 while h and cadar h neq a do h:=cdr h; 7241 if null h then write"ERROR, there must be an assignment of a in sol2!" 7242 else << 7243 if tr_merge then << 7244 write"Assignment in ",s2," of a variable that is a free parameter in ", 7245 s1," :"$ 7246 terpri()$ 7247 mathprint car h$ 7248 >>$ 7249 dropped_assign_in_s2:=cons(car h,dropped_assign_in_s2); 7250 gauge_of_s2:=cons(algebraic(num(lisp({'plus,cadr car h, 7251 {'minus,caddr car h}}))), 7252 gauge_of_s2) 7253 >> 7254 >>$ 7255 7256 gauge_of_s2:=cons('list,gauge_of_s2); 7257 7258 if tr_merge then <<write"gauge_of_s2="$mathprint gauge_of_s2>>$ 7259 7260 % We should not do all regular substitutions in gauge_of_s2 (tried that) 7261 % because some of them may set variables to zero which limits the 7262 % possibilities of doing transformations of remain_c2 7263 7264 % We now search for a substitution based on one of the equations 7265 % gauge_of_s2. The substitution is to be performed on remain_c2. 7266 7267 % One sometimes has to solve for regular_eli as singular_eli 7268 % might appear only non-linearly. 7269 % try_to_sub:=append(regular_eli,singular_eli); 7270 try_to_sub:=append(singular_eli,regular_eli); 7271 7272 % Successful re-parametrizing transformations are not unique. Those 7273 % are given a higher priority who preserve linearity of unknowns 7274 % and parameters. This matters if, for example, symmetries and 7275 % conservation laws are determined and each arbitrary parameter of flin_ 7276 % corresponds to one such conservation law, but only if they remain to 7277 % appear linearly after the re-parametrization. 7278 h:=reverse try_to_sub; 7279 for each a in h do 7280 if (flin_ and (not freeof(flin_,a))) or 7281 (not flin_ and <<cond2:=remain_c2; 7282 while cond2 and lin_check(car cond2,{a}) do cond2:=cdr cond2$ 7283 null cond2 7284 >>) then << 7285 if tr_merge then << 7286 write"Because ",a," is either in flin_ or appears linearly in sol2,"$ 7287 terpri()$ 7288 write"it gets a higher priority."$terpri()$ 7289 >>$ 7290 try_to_sub:=cons(a,delete(a,try_to_sub)) 7291 >>$ 7292 7293 n:=1; 7294 repeat << 7295 did_trafo:=nil; 7296 gauge_of_s2_cp:=cdr gauge_of_s2; 7297 while gauge_of_s2_cp do << 7298 sb:=reval car gauge_of_s2_cp$ 7299 gauge_of_s2_cp:=cdr gauge_of_s2_cp$ 7300 if not zerop sb then << 7301 try_to_sub_cp:=try_to_sub; 7302 if tr_merge then <<write"next relation to be used: 0="$mathprint sb$ 7303 write"try_to_sub=",try_to_sub$terpri()>>$ 7304 h:=err_catch_fac(sb); 7305 if h then << 7306 sb:=nil; 7307 h:=cdr h; 7308 while h do << 7309 if pairp car h then 7310 if not((caar h = 'quotient) and (fixp cadar h) and (fixp caddar h)) then 7311 if caar h='list then 7312 if pairp cadar h then sb:=cons(cadar h,sb) else 7313 else sb:=cons(car h,sb); 7314 h:=cdr h; 7315 >> 7316 >>$ 7317 7318 % From the next condition 0=sb we drop all factors which are 7319 % single variables which set to zero would be a limitation 7320 if tr_merge then <<write"After dropping single variable factors ", 7321 length sb," factor(s) remain"$terpri()>>$ 7322 sb:=reval cons('times,cons(1,sb)); % to re-gain a product from the factors 7323 if tr_merge then <<write"New relation used for substitution: sb="$ 7324 mathprint sb$terpri()>>$ 7325 7326 % If sb contains flin_ unknowns then only those should be solved 7327 % for to have them not to turn up in denominators, so that they 7328 % can be set to zero in crack_out when extracting single first integrals,.. 7329 if flin_ and not freeoflist(sb,flin_) then << 7330 h:=nil; 7331 for each a in try_to_sub_cp do 7332 if not freeof(flin_,a) then h:=cons(a,h); 7333 try_to_sub_cp:=h 7334 >>; 7335 7336 % Now start to find a good transformation 7337 while try_to_sub_cp do << 7338 a:=car try_to_sub_cp; try_to_sub_cp:=cdr try_to_sub_cp; 7339 if tr_merge then <<write"try to sub next: ",a$terpri()>>$ 7340 if not freeof(sb,a) and lin_check(sb,{a}) then << 7341 num_sb:=reval {'DIFFERENCE, sb,{'times,a,coeffn(sb,a,1)}}; 7342 if tr_merge then <<write"num_sb="$mathprint num_sb>>$ 7343% singular_ex_cp:=singular_ex; 7344% while singular_ex_cp do << 7345% if tr_merge then <<write"car singular_ex_cp=",car singular_ex_cp$ 7346% terpri()>>$ 7347 % Check whether any one of the expressions (from denom-free A_1) 7348 % which causes a singular substitution is a factor of the substituted 7349 % expression for a, i.e. a factor of num_sb 7350 7351 % sb=0 is the equation from which to get now a re-parametrization 7352 % It is sb = a*..+num_sb 7353% num_sb_quo:=reval {'quotient,num_sb,car singular_ex_cp}; 7354% if tr_merge then <<write"num_sb_quo="$mathprint num_sb_quo>>$ 7355% % if (not pairp num_sb_quo) or 7356% % (car num_sb_quo neq 'quotient) then << 7357 if t then << 7358 eli_2:=delete(a,eli_2); 7359 % i.e. num_sb is a multiple of one of members of singular_ex, HURRAY! 7360 % Do the substitution in remain_c2 7361 b:=cadr solveeval list(sb,a)$ 7362 h:=err_catch_sub(cadr b,caddr b,remain_c2); 7363 if tr_merge and null h then << 7364 write"Trafo "$mathprint b$write" was singular."$ terpri() 7365 >>$ 7366 if h then << 7367 % Is that test a good success? 7368 % a is an unknown that got assigned in sol1 (because a is 7369 % element of try_to_sub=append(singular_eli,regular_eli) ) 7370 % and was a parameter in sol2. If it is assigned in sol2 as 7371 % well then this is a good sign. If a was in regular_eli 7372 % then the regular substitution of a in remain_c2 is not so 7373 % surprising but rhs of a=.. in regular_sb or singular_sb 7374 % minus the rhs of the re-parametrization assignment a=.. is appended 7375 % to remain_c2 and must be made to zero finally. 7376 % The only improvement would be to try all combinations of all 7377 % possible assignments from all gauge_of_s2 and check for which 7378 % of them all sol1 assignments become regular. If in 7379 % applications it should turn out that some mergings are missed 7380 % then a complete investigation of all possible 7381 % re-parametrizations should be considered. 7382 7383 % next substitution must work because gauge_of_s2 is denom-free 7384 gauge_of_s2:=err_catch_sub(cadr b,caddr b,gauge_of_s2); 7385 gauge_of_s2:=cons('list, for each gauge_of_s2_cp in cdr gauge_of_s2 7386 collect algebraic(num(lisp(gauge_of_s2_cp)))); 7387 gauge_of_s2_cp:=nil$ 7388 new_assign_in_s2:=cons(b,new_assign_in_s2); 7389 did_trafo:=t$ 7390 write"In order to avoid a singularity when doing substitutions"$ 7391 terpri()$ 7392 write"the supposed to be more general solution was transformed using:"$ 7393 terpri()$ 7394 mathprint b$ 7395 if tr_merge then <<write"The new gauge_of_s2: "$ 7396 mathprint gauge_of_s2>>$ 7397 7398 remain_c2:=h; % after the new re-parametrization was done 7399 7400 h:=append(regular_sb,singular_sb); 7401 while h and a neq cadar h do h:=cdr h; 7402 if h then remain_c2:=append(remain_c2,list {'DIFFERENCE,caddar h,caddr b}); 7403 if tr_merge then <<write"remain_c2="$print_indexed_list(cdr remain_c2)>>$ 7404 singular_ex_cp:=nil; 7405 try_to_sub:=delete(a,try_to_sub); 7406 try_to_sub_cp:=nil; 7407 n:=n+1 7408 >> % else singular_ex_cp:=cdr singular_ex_cp 7409 >> % else singular_ex_cp:=cdr singular_ex_cp 7410% >> % while singular_ex_cp 7411 >> % if car try_to_sub_cp passes first test 7412 >>$ % while try_to_sub_cp 7413 >> % if not zerop sb 7414 >>$ % while gauge_of_s2_cp 7415 >> until (did_trafo=nil)$ 7416 7417 if tr_merge then << 7418 write"After completing the trafo the new list of parameters of"$ 7419 terpri()$ 7420 write"sol2 is: ",eli_2$terpri()$ 7421 write"sol1 has free parameters: ",cadddr sol1$terpri() 7422 >>$ 7423 7424 if not_included(cadddr sol1,eli_2) then return << 7425 write"Something seems wrong in merge_sol(): after the transformation of"$ 7426 terpri()$ 7427 write"sol2, all free parameters of sol1 should be free parameters of sol2."$ 7428 terpri(); 7429 nil 7430 >> else << 7431 if tr_merge then << 7432 write"All free parameters of sol1 are free parameters of sol2"$ 7433 terpri() 7434 >> 7435 >>$ 7436 7437 % Now all in remain_c2 has to become zero by using first substitutions 7438 % from regular_sb and substituting parameters from sol2 such that 7439 % the substituted expression has one of the singular_ex as factor. 7440 7441 % We seek global substitutions, i.e. substitutions based on sol1 7442 % which satisfy all sol2 conditions and not for each sol2 condition a 7443 % different set of sol1 based substitutions. Therefore substitutions 7444 % are done in the whole remain_c2. 7445 7446 % try_to_sub are free parameters in sol2 that are contained in 7447 % regular_eli and which are therefore not in singular_eli and not free 7448 % parameters in sol1. They are to be substituted next because sol1 is 7449 % obviously singularity free, so we have to express sol2 in the same 7450 % free parameters, so we have to substitute for the free parameters fo 7451 % sol2 which are not free parameters of sol1. But we must not use the 7452 % same substitutions regular_sb which substitute for them as they lead 7453 % to singular substitutions afterwards. 7454 7455% try_to_sub:=memberl(cadddr sol2,regular_eli); 7456% 7457% write"try_to_sub=",try_to_sub$terpri()$ 7458% 7459% % We now search for a substitution in regular_sb which leads to a 7460% % substitution of a member of try_to_sub, say p, ... 7461% b:=regular_sb; 7462% for each sb in b do << 7463% sb_cp:=algebraic(num(lisp({'plus,cadr sb,{'minus,caddr sb}}))); 7464% try_to_sub_cp:=delete(cadr sb,try_to_sub); % ... but the substitution 7465% % does not originally 7466% % have the form p=... . 7467% while try_to_sub_cp do << 7468% a:=car try_to_sub_cp; try_to_sub_cp:=cdr try_to_sub_cp; 7469% if not freeof(sb_cp,a) and lin_check(sb_cp,{a}) then << 7470% num_sb:={'DIFFERENCE, sb_cp,{'times,a,coeffn(sb_cp,a,1)}}; 7471% 7472% singular_ex_cp:=singular_ex; 7473% while singular_ex_cp do << 7474% % Search for an expression causing a singular substitution 7475% % which is a factor of the substituted expression for a 7476% num_sb_quo:=reval {'quotient,num_sb,car singular_ex_cp}; 7477% if (not pairp num_sb_quo) or 7478% (car num_sb_quo neq 'quotient) then << 7479% % i.e. num_sb is a multiple of one of members of singular_ex, HURRAY! 7480% % Do the substitution in remain_c2 7481% h:=err_catch_sub(cadr sb,caddr sb,remain_c2); 7482% if h then << 7483% write"In order to avoid a singularity when doing substitutions"$ 7484% terpri()$ 7485% write"the supposed to be more general solution was transformed:"$ 7486% terpri()$ 7487% mathprint sb$ 7488% remain_c2:=h; 7489% singular_ex_cp:=nil; 7490% regular_sb:=delete(sb,regular_sb); 7491% try_to_sub:=delete(a,try_to_sub); 7492% try_to_sub_cp:=nil; 7493% >> else singular_ex_cp:=cdr singular_ex_cp 7494% >> else singular_ex_cp:=cdr singular_ex_cp 7495% >> % while singular_ex_cp 7496% >> % if car try_to_sub_cp passes first test 7497% >>$ % while try_to_sub_cp 7498% >>$ % for each sb 7499 7500 % Do the remaining assignments of solution 1 7501 sb:=append(regular_sb,singular_sb); % all remaining assignments of solution 1 7502 while sb and remain_c2 do << 7503 a:=car sb; sb:=cdr sb; 7504 remain_c2_cp:=remain_c2$ 7505 remain_c2:=err_catch_sub(cadr a,caddr a,remain_c2); 7506 if tr_merge then 7507 if null remain_c2 then 7508 <<write"The following subst. was singular: "$mathprint a>> 7509 else << 7510 write"Remaining substitution: ";mathprint a$ 7511 %write"remain_c2="$mathprint remain_c2 7512 >> 7513 >>$ 7514 7515 if null remain_c2 then remain_c2:=remain_c2_cp 7516 else remain_c2_cp:=remain_c2; 7517 7518 % Compute all values modulo gb, drop all zeros 7519 remain_c2_cp:=cdr remain_c2_cp$ 7520 while remain_c2_cp and 7521 (zerop car remain_c2_cp or 7522 (gb and zerop algebraic(preduce(num lisp car remain_c2_cp,gb)))) do 7523 remain_c2_cp:=cdr remain_c2_cp; 7524 7525 if remain_c2_cp then << % s1 is NOT a special case of s2 7526 7527 remain_c2_cp:=remain_c2$ 7528 if tr_merge then <<write"remain_c2="$ 7529 print_indexed_list(cdr remain_c2_cp)>>$ 7530 7531 % Is there a contradiction of the type that the equivalence of two 7532 % assignments, a8=A (from sol1), a8=B (from sol2) requires 0=A-B 7533 % which got transformed into an expression C which is built only 7534 % from free parameters of sol1 and therefore should not vanish? 7535 7536 h:=cadddr sol1; % all free parameters in sol1 7537 while h and << 7538 if tr_merge then write"Substitution of ",car h," by: "$ 7539 repeat << % find a random integer for the free parameter 7540 a:=1+random(10000); % that gives a regular substitution 7541 if tr_merge then <<write a$terpri()>>$ 7542 a:=err_catch_sub(car h,a,remain_c2_cp) 7543 >> until a; 7544 remain_c2_cp:=a; 7545 while a and ((not numberp car a) or (zerop car a)) do a:=cdr a; 7546 not a 7547 >> do h:=cdr h; 7548 7549 if h then return << 7550 write"In the following S1 stands for ",s1,"and S2 stands for ",s2," . ", 7551 "Solution S1 fulfills all conditions of solution S2 when conditions", 7552 "are made denominator free. But, after rewriting solution S2 so that", 7553 "all free parameters of solution S1 are also free parameters of S2", 7554 "then the new solution S2 now requires the vanishing of an expression", 7555 "in these free parameters which is not allowed by S1. Therefore S1", 7556 "is not a special case of S2."$ 7557 nil 7558 >>$ 7559 7560 if tr_merge and remain_c2_cp then 7561 <<write"remain_c2_cp after subst = "$mathprint cons('list,remain_c2)>>$ 7562 write"Solution ",s1," is not less restrictive than solution"$terpri()$ 7563 write s2," and fulfills all conditions of solution ",s2," ."$terpri()$ 7564 write"But it was not possible for the program to re-formulate solution "$ 7565 terpri()$ write s2," to include both solutions in a single set of"$terpri()$ 7566 write"assignments without vanishing denominators. :-( "$ 7567 terpri()$ 7568 return nil 7569 7570 >> else return << % return the new s2 as s1 IS a special case of s2 7571 7572 % Which inequality is to be dropped? 7573 ineq2:=car cddddr sol2$ 7574 7575 while ineq2 do << 7576 ine:=car ineq2; 7577 % ine should not have denominators, so no extra precautions for substitution: 7578 for each a in ass1 do ine:=reval(subst(caddr a,cadr a,ine)); 7579 if not zerop reval ine then ineqnew:=cons(car ineq2,ineqnew) 7580 else ineqdrop:=cons(car ineq2,ineqdrop)$ 7581 ineq2:=cdr ineq2 7582 >>$ 7583 7584 if absorb then << 7585 7586 % transform the general solution if that was necessary and 7587 % updating the list of free parameters 7588 h:=cons('list,ass2); 7589 b:=cadddr sol2; 7590 if tr_merge then << 7591 write"h0="$print_indexed_list(h)$ 7592 write"dropped_assign_in_s2="$print_indexed_list(dropped_assign_in_s2)$ 7593 write"new_assign_in_s2="$print_indexed_list(new_assign_in_s2)$ 7594 >>$ 7595 for each a in dropped_assign_in_s2 do 7596 <<h:=delete(a,h);b:=cons(reval cadr a,b)>>$ 7597 if tr_merge then <<write"h1="$print_indexed_list(h)>>$ 7598 new_eqn:=cons('list,cadr sol2)$ 7599 for each a in reverse new_assign_in_s2 do if h then << 7600 b:=delete(reval cadr a,b)$ 7601 if tr_merge then <<write"a=",a$terpri()$write"h2="$print_indexed_list(h)>>$ 7602 h:=err_catch_sub(cadr a,caddr a,h); 7603 new_eqn:=err_catch_sub(cadr a,caddr a,new_eqn); 7604 if null new_eqn then h:=nil 7605 else 7606 new_eqn:=algebraic(for each hh in new_eqn collect num hh); 7607 if h then h:=reval append(h,list a) 7608 >>$ 7609 if null h then 7610 write"A seemingly successful transformation of ",s2, 7611 "went singular when performing the transformation ", 7612 "finally on the whole solution." 7613 else << 7614 % the following is an improvement even on the original solution: 7615 % reduce the rhs of assignments with the remaining equations 7616 7617 % Bring the new set of remaining equations into the form of a Groebner Basis 7618 if cdr new_eqn then algebraic << 7619 if length new_eqn > 1 then << 7620 torder(lisp(cons('list,b)),lex); 7621 gb:=groebner new_eqn; % maybe covering this in a shell in case it 7622 % takes too long 7623 if tr_merge then write "gb=",gb$ 7624 >>$ 7625 % Simplifying each rhs of h using gb 7626 lisp (h:=cons('list,for each hh in cdr h collect 7627 if (pairp caddr hh) and 7628 ((caaddr hh = 'quotient) or 7629 ((caaddr hh = '!*sq) and (denr cadr caddr hh neq 1)) 7630 ) then hh else 7631 {'equal,cadr hh,algebraic preduce(lisp caddr hh,gb)}))$ 7632 >>$ 7633 7634 % delete the redundant solution 7635 sol_list:=delete(s1,sol_list); % system bldmsg ("rm %s",s1); 7636 7637 % save the generalized solution (ineqor of sol2 untouched) 7638 save_solution(cdr new_eqn,cdr h,b,ineqnew,cadr cddddr sol2,s2)$ 7639 7640 >> 7641 >>; 7642 7643 if absorb and null h then nil 7644 else << 7645 % report the merging 7646 if null ineqdrop then << 7647 write"Strange: merging ",s1," and ",s2," without dropping inequalities!"$ 7648 terpri()$ 7649 write"Probably ",s2," had already been merged with ",s1, 7650 " or similar before."$ terpri() 7651 >> else 7652 if print_ then << 7653 write"Solution ",s2," includes ",s1," by dropping "$ 7654 if length ineqdrop = 1 then write"inequality" 7655 else write"inequalities"$terpri()$ 7656 for each ine in ineqdrop do mathprint ine 7657 >>; 7658 s2 % the more general solution 7659 >> 7660 >> 7661end$ 7662 7663symbolic procedure prepare_sol_list$ 7664% Clarifies which list of solutions to be used for merging or printing 7665begin scalar s,h$ 7666 7667 change_prompt_to ""$ 7668 7669 % reading in sol_list 7670 setq(s,bldmsg("%w%w",session_,"sol_list")); 7671 if not filep s then list_sol_on_disk() else << 7672 in s; 7673 if null sol_list or zerop length sol_list then list_sol_on_disk() else << 7674 h:=length sol_list$ 7675 write"Do you want to see the list of names of the "$ 7676 if h=1 then write"single solution? " 7677 else write h," solutions? (y/n) "$ 7678 h:=termread()$ 7679 if h='y then <<terpri()$ write sol_list$terpri()$ terpri()>>$ 7680 write"Is this the list to work on (Y) "$terpri()$ 7681 write"or shall all solution files of this session in the "$ terpri()$ 7682 write"current directory be collected and used? (N): "$ 7683 h:=termread()$ 7684 if h='n then << 7685 list_sol_on_disk()$ 7686 write"The following list is used:"$terpri()$ terpri()$ 7687 write sol_list$terpri()$ terpri() 7688 >> 7689 >> 7690 >>$ 7691 restore_interactive_prompt()$ 7692end$ 7693 7694symbolic operator merge_sol$ 7695symbolic procedure merge_sol$ 7696begin scalar sol_cp,sl1,sl2,s1,s2,s3,sol1,sol2,echo_bak,semic_bak$ 7697 7698 if null session_ then ask_for_session() else << 7699 write "Do you want to merge solutions computed in this session,"$ 7700 terpri()$ 7701 if not yesp "i.e. since loading CRACK the last time? " then 7702 ask_for_session() 7703 >>$ 7704 7705 prepare_sol_list()$ 7706 7707 % % At fist sort sol_list by the number of free unknowns 7708 % for each s1 in sol_list do << 7709 % in s1; 7710 % s2:=if null cadddr backup_ then 0 else length cadddr backup_; 7711 % if cadr backup_ then s2:=s2 - length cadr backup_; 7712 % sol_cp:=cons((s2 . s1),sol_cp) 7713 % >>$ 7714 % sol_cp:=idx_sort(sol_cp)$ 7715 % while sol_cp do <<sl1:=cons(cdar sol_cp,sl1);sol_cp:=cdr sol_cp>>$ 7716 7717 sol_cp:=sol_list$ 7718 sl1:=sol_cp$ 7719 7720 if sl1 then 7721 while sl1 and cdr sl1 do << 7722 s1:=car sl1; sl1:=cdr sl1; 7723 %infile s1; 7724 echo_bak:=!*echo; semic_bak:=semic!*; 7725 semic!*:='!$; in s1$ 7726 !*echo:=echo_bak; semic!*:=semic_bak; 7727 sol1:=backup_; backup_:=nil$ 7728 if print_ then <<write"Comparing ",s1," with:"$terpri()>>$ 7729 7730 sl2:=sl1; 7731 while sl2 do << 7732 s2:=car sl2; sl2:=cdr sl2; 7733 %infile s2$ 7734 echo_bak:=!*echo; semic_bak:=semic!*; 7735 semic!*:='!$; in s2$ 7736 !*echo:=echo_bak; semic!*:=semic_bak; 7737 sol2:=backup_; backup_:=nil$ 7738 if print_ then <<write" ",s2$terpri()>>$ 7739 7740 if (null car sol1) and (null car sol2) then % no dependencies, ie alg. problem 7741 % We assume that each remaining equation determines one unknown 7742 if (length cadddr sol1 - length cadr sol1) < 7743 (length cadddr sol2 - length cadr sol2) then s3:=merge_two(s1,sol1,s2,sol2,t) 7744 else 7745 if (length cadddr sol1 - length cadr sol1) > 7746 (length cadddr sol2 - length cadr sol2) then s3:=merge_two(s2,sol2,s1,sol1,t) 7747 else << 7748 if null (s3:=merge_two(s1,sol1,s2,sol2,t)) then 7749 s3:=merge_two(s2,sol2,s1,sol1,t); 7750 if s3 then << 7751 write"Strange: ",s1," is contained in ",s2$terpri()$ 7752 write"but both have same number of free unknowns!"$terpri()$ 7753 write"One of them has probably undergone earlier merging"$ 7754 terpri()$ 7755 >> 7756 >>$ 7757 if s3=s1 then sl1:=delete(s2,sl1) else % not to pair s2 later 7758 if s3=s2 then sl2:=nil % to continue with next element in sl1 7759 >> 7760 >>; 7761 7762 save_sol_list() 7763end$ 7764 7765symbolic procedure save_sol_list$ 7766% write the content of sol_list in the bu???-sol_list file. 7767begin scalar s,a,ofl!*bak,save$ 7768 setq(s,bldmsg("%w%w",session_,"sol_list")); 7769 7770 % out s; 7771 a := open(s, 'output); 7772 ofl!*bak:=ofl!*$ 7773 ofl!*:=s$ % any value neq nil, to avoid problem with redfront 7774 save:=wrs a; 7775 7776 write"off echo$ "$ terpri()$ 7777 if null sol_list then write"sol_list:=nil" 7778 else << 7779 write"sol_list:='"$ 7780 print sol_list$ 7781 >>$ 7782 write"$"$terpri()$ 7783 write"end$"$terpri()$ 7784 7785 % shut s 7786 wrs save$ 7787 ofl!*:=ofl!*bak$ 7788 close a; 7789end$ 7790 7791symbolic procedure delete_empty_sol_list_file()$ 7792if null sol_list and 7793 not filep process_counter and 7794 null reduce_call 7795then system bldmsg ("rm %w%w",session_,"sol_list")$ 7796 7797symbolic procedure add_to_sol_list$ % Sergey's version 7798if sol_list then 7799begin scalar fl,fpid,file,pipein,st,cnt,a,save,ofl!*bak; %,fd 7800 7801 file := bldmsg("%wsol_list",session_); 7802 fpid := bldmsg("%s.%w",file,getpid()); 7803 7804 cnt:=0; 7805 repeat << 7806 fl := rename!-file(file, fpid); 7807 % fl := system bldmsg ("mv %s %s",file,fpid); 7808 if null fl then << % file does not exist, is it currently changed? 7809 % The following lines are PSL specific "@" 7810 pipein:=pipe!-open(bldmsg("ls %s*",file),'input)$ 7811 st:=channelreadline pipein$ %st="bu123456-sol_list11221121" 7812 close pipein$ 7813 7814 if st neq "" then sleep 1 else % file is currently changed 7815 if cnt<4 then << % file does not seem to exist nor being changed 7816 cnt:=add1 cnt$ 7817 sleep 1 7818 >> else << % file has most likely never existed --> create fpid 7819 %out fpid; 7820 a:=open(fpid,'output); 7821 ofl!*bak:=ofl!*$ 7822 ofl!*:=fpid$ % any value neq nil, to avoid problem with redfront 7823 save:=wrs a; 7824 write"off echo$ "$ terpri()$ 7825 write"sol_list:='"$ 7826 print sol_list$write"$"$terpri()$ 7827 write"end$"$terpri()$ 7828 %shut fpid; 7829 wrs save$ 7830 ofl!*:=ofl!*bak$ 7831 close a; 7832 fl:=t 7833 >> 7834 >> 7835 >> until fl; 7836 7837 %we have successfully renamed (or created) the file 7838 7839 backup_:=sol_list; 7840 in fpid; 7841 7842 sol_list:=union(sol_list,backup_); 7843 7844 %out fpid; 7845 a:=open(fpid,'output); 7846 ofl!*bak:=ofl!*$ 7847 ofl!*:=fpid$ % any value neq nil, to avoid problem with redfront 7848 save:=wrs a; 7849 write"off echo$ "$ terpri()$ 7850 write"sol_list:='"$ 7851 print sol_list$write"$"$terpri()$ 7852 write"end$"$terpri()$ 7853 %shut fpid; 7854 wrs save$ 7855 ofl!*:=ofl!*bak$ 7856 close a; 7857 7858 repeat << 7859 fl := rename!-file(fpid, file); 7860 if null fl then sleep 1 7861 >> until fl; 7862 7863 % old only for unix: 7864 % fl:=1$ 7865 % repeat << 7866 % fl := system bldmsg ("mv %s %s",fpid,file); 7867 % if fl neq 0 then sleep 1 7868 % >> until fl=0; 7869 7870% fd := nil; 7871% while not fd do << 7872% sleep 1; 7873% fl := system bldmsg ("cp %s %s",fpid,file); 7874% fd := if fl = 0 then t else nil; 7875% if fd then fd := filestatus(file,nil) 7876% >>; 7877 7878% fd := nil; 7879% while not fd do << 7880% sleep 1; 7881% fl := system bldmsg ("rm %s",fpid); 7882% fd := if fl = 0 then t else nil 7883% >>; 7884 7885end $ 7886 7887symbolic procedure ask_for_session$ 7888<<change_prompt_to "Name of the session in double quotes (e.g. ""bu263393-""): "$ 7889 terpri()$ session_:=termread()$ 7890 restore_interactive_prompt() 7891>>$ 7892 7893symbolic operator pri_sol$ 7894symbolic procedure pri_sol(sin,assgn,crout,html,solcount,fname,prind)$ 7895% print the single solution sin 7896begin scalar a,b,c,sout,echo_bak,semic_bak,aa,save,ofl!*bak$ 7897 echo_bak:=!*echo; semic_bak:=semic!*; 7898 semic!*:='!$; in sin$ 7899 !*echo:=echo_bak; semic!*:=semic_bak; 7900 7901 if html then << 7902 setq(sout,bldmsg("%w%w%d%w",fname,"-s",solcount,".html")); 7903 %out sout; 7904 aa:=open(sout,'output); 7905 ofl!*bak:=ofl!*$ 7906 ofl!*:=sout$ % any value neq nil, to avoid problem with redfront 7907 save:=wrs aa; 7908 7909 write"<html>"$terpri()$ 7910 terpri()$ 7911 write"<head>"$terpri()$ 7912 write"<meta http-equiv=""Content-Type"" content=""text/html;"$terpri()$ 7913 write"charset=iso-8859-1"">"$terpri()$ 7914 write"<title>Solution ",solcount," to problem ",prind,"</title>"$terpri()$ 7915 write"</head>"$terpri()$ 7916 terpri()$ 7917 write"<BODY TEXT=""#000000"" BGCOLOR=""#FFFFFF"">"$terpri()$ 7918 terpri()$ 7919 write"<CENTER><H2>Solution ",solcount," to problem ",prind,"</H2>"$terpri()$ 7920 write"<HR>"$terpri()$ 7921 if cadr backup_ then <<write"<A HREF=""#1"">Remaining equations</A> | "$ 7922 terpri()>>$ 7923 write"<A HREF=""#2"">Expressions</A> | "$terpri()$ 7924 write"<A HREF=""#3"">Parameters</A> | "$terpri()$ 7925 write"<A HREF=""#4"">Inequalities</A> | "$terpri()$ 7926 write"<A HREF=""#5"">Relevance</A> | "$terpri()$ 7927 write"<A HREF=",prind,".html>Back to problem ",prind,"</A> "$ 7928 write"</CENTER>"$terpri()$ 7929 terpri() 7930 >>$ 7931 for each a in car backup_ do 7932 for each b in cdr a do 7933 algebraic(depend(lisp(car a),lisp b)); 7934 backup_:=cdr backup_; 7935 terpri()$ 7936 if html then write"<!-- "$ 7937 write">>>=======>>> SOLUTION ",sin," <<<=======<<<"$ 7938 if html then write" --> "$ 7939 terpri()$terpri()$ 7940 7941 if assgn or html then << 7942 if car backup_ then << 7943 if html then << 7944 write"<HR><A NAME=""1""></A><H3>Equations</H3>"$terpri()$ 7945 write"The following unsolved equations remain:"$terpri()$ 7946 write"<pre>"$ 7947 >> else write"Equations:"$ 7948 for each a in car backup_ do mathprint {'equal,0,a}$ 7949 if html then <<write"</pre>"$terpri()>> 7950 >>$ 7951 7952 if html then << 7953 write"<HR><A NAME=""2""></A><H3>Expressions</H3>"$terpri()$ 7954 write"The solution is given through the following expressions:"$terpri()$ 7955 write"<pre>"$terpri()$ 7956 for each a in cadr backup_ do mathprint a$ 7957 write"</pre>"$terpri() 7958 >> else << 7959 b:=nil; 7960 for each a in cadr backup_ do 7961% if not sqzerop caddr a then 7962 b:=cons({'equal,cadr a, 7963 if pairp caddr a and car caddr a='!*sq then cadr caddr a 7964 else simp caddr a},b); 7965 print_forg(b,nil) 7966 >>$ 7967 terpri()$ 7968 7969 if html then << 7970 write"<HR><A NAME=""3""></A><H3>Parameters</H3>"$terpri()$ 7971 write"Apart from the condition that they must not vanish to give"$terpri()$ 7972 write"a non-trivial solution and a non-singular solution with"$terpri()$ 7973 write"non-vanishing denominators, the following parameters are free:"$terpri()$ 7974 write"<pre> "$ 7975 fctprint caddr backup_; 7976 write"</pre>"$terpri() 7977 >> else << 7978 write length caddr backup_," free unknowns: "$ listprint caddr backup_; 7979 print_ineq ((for each a in cadddr backup_ collect simp a) . 7980 (for each a in car cddddr backup_ collect % each a is an or-inequality 7981 for each b in a collect % each b represents an expression 7982 for each c in b collect % in form of factors c 7983 simp c))$ 7984 >>$ 7985 7986 if html then << 7987 write"<HR><A NAME=""4""></A><H3>Inequalities</H3>"$terpri()$ 7988 write"In the following not identically vanishing expressions are shown."$ terpri()$ 7989 write"<pre> "$ 7990 mathprint cons('list,cadddr backup_); 7991 write"</pre>"$terpri()$ 7992 7993 if cddddr backup_ and car cddddr backup_ then << 7994 write"Next come so-called OR-lists of FACTOR-lists in the following sense."$terpri()$ 7995 write"Each FACTOR-list represents the factors of an expression and at least one of"$terpri()$ 7996 write"these expressions must not vanish in each OR-list. In other words, in each"$terpri()$ 7997 write"OR-list at least one FACTOR-list must not vanish, i.e. none of the expressions"$terpri()$ 7998 write"in the FACTOR-list may vanish.<BR>"$terpri()$ 7999 8000 for each a in car cddddr backup_ do << 8001 write"OR-list:"$terpri()$ 8002 write"<pre> "$ 8003 mathprint cons('list,for each b in a collect cons('list,b)); 8004 write"</pre>"$terpri() 8005 >> 8006 8007 >> 8008 8009 >>$ 8010 >>$ 8011 8012 if html then << 8013 write"<HR><A NAME=""5""></A><H3>Relevance for the application:</H3>"$ 8014 terpri()$ 8015 % A text for the relevance should be generated in crack_out() 8016 write"<pre>" 8017 >>$ 8018 if crout or html then << 8019 algebraic ( 8020 crack_out(lisp cons('list,car backup_), 8021 lisp cons('list,cadr backup_), 8022 lisp cons('list,caddr backup_), 8023 lisp cons('list,cadddr backup_), 8024 lisp solcount))$ 8025 >>$ 8026 if html then << 8027 write"</pre>"$terpri()$ 8028 write"<HR>"$terpri()$ 8029 write"</body>"$terpri()$ 8030 write"</html>"$terpri()$ 8031 %shut sout 8032 wrs save$ 8033 ofl!*:=ofl!*bak$ 8034 close aa; 8035 >>$ 8036 backup_:=nil 8037end$ 8038 8039symbolic operator print_all_sol$ 8040symbolic procedure print_all_sol$ 8041begin scalar a,assgn,crout,natbak,print_more_bak,fname,solcount, 8042 html,prind,print_bak$ 8043 8044 write"This is a reminder for you to read in any file CRACK_OUT.RED"$ 8045 terpri()$ 8046 write"with a procedure CRACK_OUT() in case that is necessary to display"$ 8047 terpri()$ 8048 write"results following from solutions to be printed."$ 8049 terpri()$ terpri()$ 8050 8051 if null session_ then ask_for_session() else << 8052 write "Do you want to print solutions computed in this session,"$ 8053 terpri()$ 8054 if not yesp "i.e. since loading CRACK the last time? " then 8055 ask_for_session()$ 8056 >>$ 8057 8058 prepare_sol_list()$ 8059 8060 natbak:=!*nat$ print_more_bak:=print_more$ print_more:=t$ 8061 print_bak:=print_$ print_:=100000$ 8062 if yesp "Do you want to generate an html file for each solution? " 8063 then << 8064 html:=t$ 8065 terpri()$ 8066 write "What is the file name (including the path)"$ 8067 terpri()$ 8068 write "that shall be used (in double quotes) ? "$ 8069 terpri()$ 8070 write "(A suffix '-si' will be added for each solution 'i'.) "$ 8071 change_prompt_to ""$ 8072 fname:=termread()$terpri()$ 8073 write "What is a short name for the problem? "$ 8074 prind:=termread()$ 8075 restore_interactive_prompt()$ 8076 terpri()$ 8077 >> else << 8078 if yesp "Do you want to see the computed value of each function? " 8079 then assgn:=t$ 8080 if yesp "Do you want procedure `crack_out' to be called? " then << 8081 crout:=t; 8082 if flin_ and fhom_ then 8083 if yesp "Do you want to print less (e.g. no symmetries)? " 8084 then print_more:=nil$ 8085 if not yesp 8086 "Do you want natural output (no if you want to paste and copy)? " 8087 then !*nat:=nil$ 8088 >>$ 8089 >>$ 8090 solcount:=0$ 8091 fsub_:=nil$ % in case a computation has been interrupted 8092 % fsub_ may not be nil but should be nil for 8093 % printing the assignments in each solution 8094 for each a in sol_list do << 8095 solcount:=add1 solcount$ 8096 pri_sol(a,assgn,crout,html,solcount,fname,prind)$ 8097 >>$ 8098 !*nat:=natbak; 8099 print_:=print_bak$ 8100 print_more:=print_more_bak 8101end$ 8102 8103symbolic procedure frequent_factors(pdes)$ 8104% look for pde in pdes which can be factorized 8105begin scalar p,pv,f,fcl,fcc,h,nf$ %,h1$ 8106 8107 for each p in pdes do << 8108 pv:=get(p,'fac)$ 8109 if pairp pv then << 8110 % pv:=cdr pv$ % drop 'times to get the list of factors in p 8111 8112 nf:=length pv$ % the number of factors 8113 % increment the counter of appearances of each factor 8114 % the minimal number of factors of an equation of which f is a factor 8115 % and the number of such equations 8116 % fcc={ {# of appearences of factor, 8117 % {min # of factors of an equation of which f is a factor, 8118 % # of such equations}, 8119 % the factor now in SQ-form 8120 % }, ...} 8121% h1:=pv$ 8122% while h1 do << % for each factor 8123 while pv do << % for each factor 8124% f:=car h1; h1:=cdr h1; 8125 f:=car pv; pv:=cdr pv; 8126 8127 fcc:=fcl$ 8128 8129 % fcl is list of lists, see above 8130 while fcc and (caddar fcc neq f) do fcc:=cdr fcc$ 8131 8132 if fcc then << % factor had already appeared 8133 h:={add1 caar fcc, 8134 if nf<caadar fcc then {nf,1} else 8135 if nf=caadar fcc then {nf,add1 cadr cadar fcc} else 8136 cadar fcc, 8137 f}; 8138 rplaca(fcc,h); 8139 >> else % factor is new 8140 fcl:=cons({1,{nf,1},f},fcl) 8141 >>$ % done for all factors 8142 >> 8143 >>$ % looked at all factorizable equations 8144 return rev_idx_sort fcl$ 8145end$ % of frequent_factors 8146 8147symbolic procedure print_factors(pdes)$ 8148begin scalar fcl,p,q$ 8149 fcl:=reverse frequent_factors pdes$ 8150 write"Number of occurences, eqn of fewest # of factors, the factor: "$terpri()$ 8151 for each p in fcl do 8152 if (q:=pdeweightSF(numr caddr p,ftem_))>print_ then 8153 <<write car p,",",cadr p," : ",no_of_tm_sf numr caddr p," terms"$terpri()>> 8154 else 8155 <<write car p,",",cadr p," : "$ 8156 p:={'!*sq,caddr p,t}$ 8157 if q=1 then <<write reval p$terpri()>> 8158 else mathprint p 8159 >> 8160end$ 8161 8162symbolic procedure frequent_coefficients(pdes)$ 8163begin scalar s,g,cl,h,p,q,r$ 8164 % cl is a list of all coefficients 8165 % cl = { (coeff . (list_of_eqn . list_of_fnc)) , ... } 8166 8167 for each s in pdes do 8168 if fcteval(s) and (g:=get(s,'fcteval_nli)) then 8169 for each h in g do << 8170 q:=simplifySQ(car h,ftem_,t,nil,nil)$ 8171 for each r in q do 8172 if null (p:=assoc(r,cl)) then cl:=cons((r . ({s} . {cdr h})),cl) 8173 else << 8174 cl:=delete(p,cl); 8175 cl:=cons((r . ( union({s},cadr p) . union({cdr h},cddr p) )),cl) 8176 >> 8177 >>; 8178 cl:=for each h in cl collect (min(length cadr h,length cddr h) . car h)$ 8179 return rev_idx_sort cl 8180end$ 8181 8182symbolic procedure print_coefficients(pdes)$ 8183begin scalar cl,p,q$ 8184 write"This can take longer."$terpri()$ 8185 write"The shown number is the minimum of "$terpri()$ 8186 write"- the number of different equations in which the coefficient occurs and"$terpri()$ 8187 write"- the number of different functions of which this is a coefficient."$terpri()$ 8188 write"# of subst., the coeff.: "$terpri()$ 8189 cl:=reverse frequent_coefficients pdes$ 8190 for each p in cl do 8191 if (q:=pdeweightSF(numr cdr p,ftem_))>print_ then << 8192 write car p," : ",no_of_tm_sf numr cdr p," terms"$ terpri() 8193 >> else << 8194 write car p," : "$ 8195 p:={'!*sq,cdr p,t}$ 8196 if q=1 then <<write reval p$terpri()>> 8197 else mathprint p 8198 >> 8199end$ 8200 8201symbolic procedure case_on_most_frequ_factors(arglist)$ 8202begin scalar h,maxf,best,h3,h4; 8203 h:=frequent_factors car arglist$ 8204 if null h then return nil$ 8205 maxf:=caar h$ 8206 8207 % find a factor which has at least 20% of the max number of 8208 % appearences of the most frequent factor but occurs in an 8209 % equation with the fewest factors 8210% best:=car h; h:=cdr h; 8211 while h and (((caar h)*10-maxf*2)>0) do << 8212 8213 % Check whether this factor set to zero provides a substitution 8214 % without case distinction 8215 if not pairp caddar h then h4:=t 8216 else << 8217 h3:=mkeqSQ(caddar h,nil,nil,ftem_,vl_,allflags_,t,list(0),nil,nil)$ 8218 % the last argument is nil to avoid having a lasting effect on pdes 8219 fcteval(h3)$ 8220 h4:=get(h3,'fcteval_lin) or get(h3,'fcteval_nca)$ 8221 drop_pde(h3,nil,nil)$ 8222 >>$ 8223 8224 % Check whether this factor set to non-zero changes a substitution from 8225 % needing a case distinction to not needing a case distinction 8226 % ... to be done 8227 8228 if h4 and 8229 ((null best ) or 8230 ( (caadar h)<(caadr best) ) or 8231 (((caadar h)=(caadr best)) and 8232 ((cadadr car h)>(cadadr best))) ) 8233 then best:=car h; 8234 h:=cdr h 8235 >>$ 8236 8237 return 8238 if best then split_into_cases({car arglist,cadr arglist, 8239 caddr arglist,caddr best}) 8240 else nil 8241end$ 8242 8243symbolic procedure sol_in_list(set1,set2,sol_list2)$ 8244begin scalar set2cp,s1,s2,found,sol1,sol2,same_sets,echo_bak,semic_bak$ 8245 while set1 do << 8246 s1:=car set1; set1:=cdr set1; 8247 %infile s1; 8248 echo_bak:=!*echo; semic_bak:=semic!*; 8249 semic!*:='!$; in s1$ 8250 !*echo:=echo_bak; semic!*:=semic_bak; 8251 sol1:=backup_; backup_:=nil$ 8252 set2cp:=set2$ 8253 found:=nil$ 8254 while set2cp and not found do << 8255 s2:=car set2cp; set2cp:=cdr set2cp; 8256 %infile s2; 8257 echo_bak:=!*echo; semic_bak:=semic!*; 8258 semic!*:='!$; in s2$ 8259 !*echo:=echo_bak; semic!*:=semic_bak; 8260 sol2:=backup_; backup_:=nil$ 8261 found:=merge_two(s1,sol1,s2,sol2,nil)$ 8262 >>; 8263 if not found then << 8264 same_sets:=nil; 8265 if print_ then << 8266 write"Solution ",s1," is not included in ",sol_list2$ 8267 terpri() 8268 >> 8269 >> 8270 >>$ 8271 return same_sets 8272end$ 8273 8274symbolic operator same_sol_sets$ 8275symbolic procedure same_sol_sets$ 8276begin scalar session_bak,set1,set2,sol_list1,sol_list2,echo_bak,semic_bak$ 8277 session_bak:=session_; 8278 write"Two sets of solutions are compared whether they are identical."$ 8279 8280 write"What is the name of the session that produced the first set of solutions?"$ 8281 terpri()$ 8282 write"(CRACK will look for the file `sessionname'+`sol_list'.)"$terpri()$ 8283 ask_for_session()$ 8284 8285 % reading in sol_list 8286 setq(sol_list1,bldmsg("%w%w",session_,"sol_list")); 8287 %infile sol_list1; 8288 echo_bak:=!*echo; semic_bak:=semic!*; 8289 semic!*:='!$; in sol_list1$ 8290 !*echo:=echo_bak; semic!*:=semic_bak; 8291 set1:=sol_list$ 8292 8293 write"What is the name of the session that produced the second set of solutions?"$ 8294 terpri()$ 8295 ask_for_session()$ 8296 8297 % reading in sol_list 8298 setq(sol_list2,bldmsg("%w%w",session_,"sol_list")); 8299 %infile sol_list2; 8300 echo_bak:=!*echo; semic_bak:=semic!*; 8301 semic!*:='!$; 8302 in sol_list2$ 8303 !*echo:=echo_bak; semic!*:=semic_bak; 8304 set2:=sol_list$ 8305 8306 session_:=session_bak$ 8307 8308 % 1. Check that all solutions in set1 are included in set2. 8309 8310 sol_in_list(set1,set2,sol_list2)$ 8311 sol_in_list(set2,set1,sol_list1)$ 8312 8313end$ 8314 8315symbolic operator clear_session_files$ 8316symbolic procedure clear_session_files$ 8317begin scalar s$ 8318 s:=explode session_; 8319 s:=compress cons(car s,cdddr s)$ 8320 setq(s,bldmsg("%w%w%w","rm ??",s,"*"))$ 8321 system s$ 8322end$ 8323 8324symbolic procedure list_sol_on_disk$ 8325% Find all so* solution files with the current session_ number in 8326% the current directory and write them into the bu????-sol_list file. 8327begin scalar s,chn,xx,oldcase$ 8328 s:=level_string(session_)$ 8329 s:=explode s$ 8330 s:=compress cons(car s,cons('s,cons('o,cdddr s)))$ 8331 system bldmsg("ls %s* > %w%w",s,session_,"sol_list")$ 8332 chn := open(bldmsg("%w%w",session_,"sol_list"),'input); 8333 chn := rds chn; 8334 sol_list:=nil$ 8335 8336!#if (memq 'csl lispsystem!*) 8337 % "@" 8338 rederr "CSL problem: 2 x non-portable PSL code: input!-case"; 8339!#endif 8340 8341 oldcase := input!-case NIL; 8342 while (xx := read()) and (xx neq int2id 4) do 8343 sol_list:=cons(bldmsg("%w",xx),sol_list)$ 8344 close rds chn$ 8345 save_sol_list()$ 8346 input!-case oldcase; 8347 8348end$ 8349 8350symbolic procedure fnc_of_new_var$ 8351% input: global variables: done_trafo,depl!* 8352% output: all functions depending on (new) lhs variables in done_trafo 8353begin scalar h4,h5,h6$ 8354 h4:=for each h5 in cdr done_trafo join 8355 for each h6 in cdr h5 collect cadr h6$ 8356%write"h4=",h4$ terpri()$ 8357%write"depl!*=",depl!*$ terpri()$ 8358 % then find all functions of these new variables 8359 h5:=nil$ 8360 for each h6 in depl!* do 8361 if not freeoflist(h6,h4) then h5:=cons(car h6,h5)$ 8362 return h5 8363end$ 8364 8365symbolic procedure copy!-file(n1, n2)$ 8366begin 8367 scalar f1, f2, c, saveraise; 8368 saveraise := !*raise . !*lower; 8369 !*raise := !*lower := nil; 8370 if null (f1 := open(n1, 'input)) then return nil; 8371 if null (f2 := open(n2, 'output)) then << 8372 close f1; 8373 return nil >>; 8374 f1 := rds f1; 8375 f2 := wrs f2; 8376 while (c := readch()) neq '!$eof!$ do prin2 c; 8377 close rds f1; 8378 close wrs f2; 8379 !*raise := car saveraise; 8380 !*lower := cdr saveraise; 8381 return t; 8382end$ 8383 8384!#if (memq 'csl lispsystem!*) 8385 8386% CSL can do the simpler case directly. 8387symbolic procedure delete!-file!-exact fi$ 8388 delete!-file fi$ 8389 8390!#else 8391 8392symbolic procedure delete!-file!-exact fi$ 8393 if (memq('linux!-gnu, lispsystem!*) or 8394 memq('cygwin, lispsystem!*) or 8395 memq('unix, lispsystem!*)) and 8396 not memq('win32, lispsystem!*) and 8397 not memq('win64, lispsystem!*) then system bldmsg("rm -f %w", fi) 8398% On Windows I only delete the file if it exists, so that I avoid messages 8399% that otherwise intrude. 8400 else if filep fi then system bldmsg("del ""%w""", fi)$ 8401 8402!#endif 8403 8404% to have ? or * actively matching in file name 8405 8406!#if (and (memq 'csl lispsystem!*) (not (memq 'jlisp lispsystem!*))) 8407 8408% Comment of Arthur C. Norman: 8409% If I assume that Java 7 with its version of the nio package is 8410% available then supporting this in Jlisp would be easy. However I will 8411% wait before I move to that. 8412 8413symbolic procedure delete!-file!-match fi$ 8414 delete!-wildcard fi$ 8415 8416!#else 8417 8418symbolic procedure delete!-file!-match fi$ 8419% Note that a Macintosh is "unix" for the purposes of the test here. 8420 if (memq('linux!-gnu, lispsystem!*) or 8421 memq('cygwin, lispsystem!*) or 8422 memq('unix, lispsystem!*)) and 8423 not memq('win32, lispsystem!*) and 8424 not memq('win64, lispsystem!*) then system bldmsg("rm -f %s", fi) 8425% Comments of Arthur C. Norman: 8426% On Windows if there are no files matching the pattern you specify you will 8427% get an ugly message saying "Could Not Find FILE". I hope that the quote 8428% marks I put in protect any whitespace within the pathname used, but 8429% neverthless allow wildcards to be interpreted. 8430 else begin 8431% On Windows if you go "del" with a pattern that does not match any files 8432% then an unwanted message is displayed. To avoid that I will create a file 8433% that matches the pattern so that there is always something worth deleting. 8434 scalar u; 8435% I will turn every "?" or "*" into an "x" to get a name suitable for a 8436% single file. 8437 for each c in explode fi do 8438 if c = '!? or c = '!* then u := 'x . u 8439 else u := c . u; 8440 u := compress reverse u; 8441% Opening the file for output and then closing the stream should leave 8442% an empty file for me to delete. 8443 u := open(u, 'output); 8444 if u then close u; 8445 return system bldmsg("del ""%s""", fi) 8446 end$ 8447 8448!#endif 8449 8450!#if (memq 'psl lispsystem!*) 8451 8452% Rename fromname to toname and return t on success. 8453% (it is defined in csl) 8454 8455symbolic procedure rename!-file(fromname, toname)$ 8456 begin 8457 if system bldmsg("mv %w %w", fromname, toname) = 0 then return t 8458 else return nil 8459 end$ 8460 8461!#endif 8462 8463endmodule$ 8464 8465%******************************************************************** 8466module uniquify$ 8467%******************************************************************** 8468% Routines to replace kernels by unique instances in 'standard' expressions. 8469% Replacement is done in place for performance and space savings. 8470% Author: Eberhard Schruefer, Oct 2007 8471 8472symbolic procedure uniquifysq u$ 8473 begin 8474 uniquifyf numr u; 8475 uniquifyf denr u; 8476 return u 8477 end$ 8478 8479symbolic procedure uniquifyf u$ 8480 begin 8481 if domainp u then return nil 8482 else if atom mvar u then nil 8483 else rplaca(lpow u,uniquifyk mvar u); 8484 uniquifyf lc u; 8485 uniquifyf red u; 8486 return u 8487 end$ 8488 8489%symbolic procedure uniquifyk u$ 8490% begin scalar x; 8491% x := fkern u; 8492% if memq('used!*,cddr x) then return car x 8493% else aconc(x,'used!*); 8494% for each arg in cdr u do 8495% if atom arg then nil 8496% else uniquifyk arg; 8497% return car x 8498% end$ 8499 8500symbolic procedure uniquifyk u$ 8501 begin scalar x; 8502 if sfp u then uniquifyf u; 8503 x := fkern u; 8504 if sfp car x then return car x; 8505 if memq('used!*,cddr x) then return car x 8506 else aconc(x,'used!*); 8507 for each arg in cdr u do 8508 if atom arg then nil 8509 else uniquifyk arg; 8510 return car x 8511 end$ 8512 8513symbolic procedure uniquifykord u$ 8514 for each j in u collect if atom j then j 8515 else uniquifyk j$ 8516 8517symbolic procedure uniquifydepl u$ 8518 for each j in u collect if atom car j then j 8519 else (uniquifyk car j . cdr j)$ 8520 8521symbolic procedure uniquifyasymplis u$ 8522 for each j in u collect if atom car j then j 8523 else (uniquifyk car j . cdr j)$ 8524 8525symbolic procedure uniquenesssq u$ 8526<<uniquenessf numr u; 8527 uniquenessf denr u; 8528>>$ 8529 8530symbolic procedure UniquifyAll(pdes,forg)$ 8531begin scalar a,b,c$ 8532 for each a in pdes do << 8533 uniquifysq get(a,'sqval); 8534 if pairp get(a,'fac) then 8535 for each b in get(a,'fac) do uniquifysq b; 8536 for each b in get(a,'fcteval_lin) do uniquifysq car b; 8537 for each b in get(a,'fcteval_nca) do uniquifysq car b; 8538 for each b in get(a,'fcteval_nli) do uniquifysq car b; 8539 for each b in get(a,'fct_nli_lin) do uniquifysq car b; 8540 for each b in get(a,'fct_nli_nca) do uniquifysq car b; 8541 for each b in get(a,'fct_nli_nli) do uniquifysq car b; 8542 for each b in get(a,'fct_nli_nus) do uniquifysq car b 8543 >>; 8544 for each a in forg do if pairp a and car a = 'equal then uniquifysq caddr a; 8545 for each a in ineq_ do uniquifysq a; 8546 for each a in ineq_or do 8547 for each b in a do 8548 for each c in b do uniquifysq c 8549end$ 8550 8551symbolic procedure uniquenessf u$ 8552begin 8553 if domainp u then return; 8554 if null domainp u 8555 and null atom mvar u 8556 then if null atsoc(mvar u,get(car mvar u,'klist)) 8557 then write "head kernel of ",u," is not unique!"; 8558 uniquenessf lc u; 8559 uniquenessf red u; 8560end$ 8561 8562endmodule$ 8563 8564%******************************************************************** 8565module parseformoutput$ 8566%******************************************************************** 8567% Parser for polynomials generated by FORM. 8568% Parses directly into REDUCE standard forms. 8569% For this to be correct kernel ordering in FORM 8570% and REDUCE must be the same and 'on highfirst;' 8571% must be isssued in generating FORM output. 8572% 8573% Syntax: formoutputread <filename>; 8574% Alternate syntax: formoutput <FORM polynomial>; (currently not maintained) 8575% Result: REDUCE prefix sq. 8576% 8577% Author: Eberhard Schruefer, Oct 2007 8578% 8579% Needs module uniquify. 8580 8581fluid '(!*msg !*int semic!*)$ 8582 8583global '(cursym!* nxtsym!*)$ 8584 8585symbolic procedure formoutstat$ 8586 begin scalar x,y,s,!*msg; 8587 newtok '((!+) formoutplus); 8588 newtok '((!-) formoutminus); 8589 flag('(formoutplus),'delim); 8590 flag('(formoutminus),'delim); 8591 if nxtsym!* eq '!- then scan(); 8592 if cursym!* eq 'formoutminus then s := -1 8593 else s := 1; 8594 x := y := formoutterm(s,xread t); 8595 if cursym!* eq '!*semicol!* then go to b; 8596 a: if cursym!* eq 'formoutminus then s := -1 8597 else s := 1; 8598 plantlowerterm(y,formoutterm(s,xread t)); 8599 if null domainp y and red y then y := red y; 8600 if null(cursym!* eq '!*semicol!*) then go to a; 8601 b: remflag('(formoutplus),'delim); 8602 remflag('(formoutminus),'delim); 8603 newtok '((!+) plus); 8604 newtok '((!-) difference); 8605% write x; 8606% return mkquote x 8607 end$ 8608 8609put('formoutput,'stat,'formoutstat)$ 8610 8611symbolic procedure formoutputread u$ 8612 begin scalar x,y,s,!*msg,ichan,oldichan,!*int,semic; 8613 ichan := open(mkfil!* u,'input); 8614 oldichan := rds ichan; 8615 newtok '((!+) formoutplus); 8616 newtok '((!-) formoutminus); 8617 flag('(formoutplus),'delim); 8618 flag('(formoutminus),'delim); 8619 semic := semic!*; 8620 scan(); 8621 if cursym!* eq 'formoutminus then <<s := -1; scan()>> 8622 else s := 1; 8623 x := y := formoutterm(s,xread1 t); 8624 if cursym!* eq '!*semicol!* then go to b; 8625 a: if cursym!* eq 'formoutminus then s := -1 8626 else s := 1; 8627 plantlowerterm(y,formoutterm(s,xread t)); 8628 if null domainp y and red y then y := red y; 8629 if null(cursym!* eq '!*semicol!*) then go to a; 8630 b: remflag('(formoutplus),'delim); 8631 remflag('(formoutminus),'delim); 8632 newtok '((!+) plus); 8633 newtok '((!-) difference); 8634 rds oldichan; 8635 close ichan; 8636 semic!* := semic; 8637 return if domainp x then x else mk!*sq((if alg_poly then x 8638 else reorder x) ./ 1) 8639 % alg_poly test only if FORM does not use REDUCE ordering of non-atomar kernels. 8640 8641 end$ 8642 8643 8644symbolic procedure formoutterm(s,u)$ 8645 begin scalar numc; 8646 if null eqcar(u,'times) 8647 then return if numberp u then u*s 8648 else if atom u then u .** 1 .* s .+ nil 8649 else if car u eq 'quotient then '!:rn!: . (cadr u ./ caddr u) 8650 else if car u eq 'expt 8651 then (if atom cadr u then cadr u 8652 else uniquifyk cadr u) .** caddr u .* s .+ nil 8653 else uniquifyk u .** 1 .* s .+ nil; 8654 u := cdr u; 8655 numc := s; 8656 if numberp car u then <<numc := s*car u; u := cdr u>>; 8657 if eqcar(car u,'quotient) then <<numc := '!:rn!: . ((s*cadar u) ./ caddar u); 8658 u := cdr u>>; 8659 return formoutnestterm(u,numc) 8660 end$ 8661 8662symbolic procedure formoutnestterm(u,numc)$ 8663 if null u then numc 8664 else if atom car u then car u .** 1 .* formoutnestterm(cdr u,numc) .+ nil 8665 else if caar u eq 'expt 8666 then (if atom cadar u then cadar u else uniquifyk cadar u) .** caddar u .* 8667 formoutnestterm(cdr u,numc) .+ nil 8668 else uniquifyk car u .** 1 .* formoutnestterm(cdr u,numc) .+ nil$ 8669 8670symbolic procedure plantlowerterm(u,v)$ 8671 if domainp v then rplacd(u,v) 8672 else if (mvar u eq mvar v) and (ldeg u = ldeg v) 8673 then begin 8674 a: if domainp v then go to c; 8675 v := lc v; u := lc u; 8676 if (mvar u eq mvar v) and (ldeg u = ldeg v) 8677 then go to a; 8678 c: if null red u then return rplacd(u,v); 8679 b: u := red u; 8680 go to c; 8681 end 8682 else rplacd(u,v)$ 8683 8684endmodule$ 8685 8686%******************************************************************** 8687module writefrm$ 8688%******************************************************************** 8689% Very raw printing functions for SQ's, intended for generating input 8690% to FORM. The written expression is terminated by a semicolon. 8691% Only rational numbers are supported as domain. 8692% 8693% Syntax: writesqfrm <standard quotien>$ 8694% 8695% Author: Eberhard Schruefer, Nov 2007, with a modification by 8696% Winfried Neun to allow piping (to FORM) 8697 8698symbolic procedure writesqfrm u$ 8699 begin 8700 if denr u = 1 then <<writefrm numr u; prin2t ";">> 8701 else if numberp denr u 8702 then if red numr u 8703 then <<prin2 "("; writefrm numr u; prin2 ")/"; 8704 writefrm denr u; prin2t ";">> 8705 else <<writefrm numr u; prin2 "/"; 8706 writefrm denr u; prin2 ";">> 8707 else if numberp numr u or null red numr u 8708 then <<writefrm numr u; prin2 "/("; 8709 writefrm denr u; prin2t ");">> 8710 else <<prin2 "("; writefrm numr u; prin2 ")/("; 8711 writefrm denr u; prin2t ");">> 8712 end$ 8713 8714symbolic procedure writesffrm u$ 8715 begin <<writefrm u; prin2t ";">> end$ 8716 8717symbolic procedure writefrm1 u$ 8718 begin scalar y; 8719 if domainp u then return if u = 1 then prin2 u 8720 else writedomain u; 8721 if atom mvar u then prin2 mvar u else writekern mvar u; 8722 if not(ldeg u = 1) then <<prin2 "^"; prin2 ldeg u>>; 8723 y := lc u; 8724 if domainp y then return if y = 1 then prin2 " " 8725 else <<prin2 " * "; 8726 writedomain y; 8727 prin2 " " >>; 8728 if null red y then return <<prin2 " * "; writefrm1 y>>; 8729 prin2 "* ("; 8730 a: writefrm1(lt y .+ nil); 8731 y := red y; 8732 if domainp y then go to b; 8733 if y then prin2 " + "; 8734 go to a; 8735 b: if numberp y and minusp y then <<prin2 " - "; y := -y>> 8736 else if y then prin2 " + "; 8737 if y then writefrm1 y; 8738 if y then prin2 ") " else prin2 ")" 8739 end$ 8740 8741symbolic procedure writefrm u$ 8742 begin 8743 a: if domainp u then go to b; 8744 writefrm1(lt u .+ nil); 8745 u := red u; 8746 if numberp u and minusp u 8747 then <<prin2 " - "; u := -u>> 8748 else if u then prin2 " + "; 8749 go to a; 8750 b: if u then prin2 u; 8751 end$ 8752 8753symbolic procedure writekern u$ 8754 begin 8755 prin2 car u; 8756 prin2 "("; 8757 a: u := cdr u; 8758 if null u then go to b; 8759 if atom car u or numberp car u then prin2 car u 8760 else writekern car u; 8761 if cdr u then prin2 ","; 8762 go to a; 8763 b: prin2 ")" 8764 end$ 8765 8766symbolic procedure writedomain u$ 8767 begin 8768 if numberp u and minusp u 8769 then << prin2 "("; prin2 u; prin2 ")">> 8770 else if eqcar(u,'!:rn!:) 8771 then << prin2 "("; prin2 cadr u; prin2 "/"; 8772 prin2 cddr u; prin2 ")">> 8773 else prin2 u 8774 end$ 8775 8776 8777endmodule$ 8778 8779%******************************************************************** 8780module consistency_checks$ 8781%******************************************************************** 8782% Routines for checking integrity of data 8783% Author: Thomas Wolf Dec 2001 8784 8785% old prefix form: 8786%symbolic procedure check_history(pdes)$ 8787%begin scalar p,q,h,k$ 8788% for each p in pdes do << 8789% h:=get(p,'histry_); 8790% for each q in pdes do 8791% h:=subst(prepsq get(q,'sqval),q,h)$ 8792% if not zerop reval {'DIFFERENCE,prepsq get(p,'sqval),h} then << 8793% write"The history value of ",p," is not correct!"$ 8794% k:=t$ 8795% terpri() 8796% >> 8797% >>$ 8798% if null k then <<write"History data are consistent."$ terpri()>> 8799%end$ 8800 8801% new sq-from: 8802symbolic procedure check_history(pdes)$ 8803begin scalar p,q,h,k$ 8804 for each p in pdes do << 8805 h:=simp get(p,'histry_); 8806 for each q in pdes do 8807 h:=subsq(h,{(q . {'!*sq,get(q,'sqval),t})})$ 8808 if not sqzerop subtrsq(get(p,'sqval),h) then << 8809 write"The history value of ",p," is not correct!"$ 8810 k:=t$ 8811 terpri() 8812 >> 8813 >>$ 8814 if null k then <<write"History data are consistent."$ terpri()>> 8815end$ 8816 8817%------------------------------- 8818 8819symbolic procedure check_globals$ 8820% to check validity of global variables at start of CRACK 8821begin scalar flag, var$ 8822 8823 % The integer variables 8824 foreach var in global_list_integer do 8825 if not fixp eval(var) then << 8826 terpri()$ 8827 write var, " needs to be an integer: ", eval(var)," is invalid"$ 8828 flag := var 8829 >>$ 8830 8831 % Now for integer variables allowed to be nil 8832 foreach var in global_list_ninteger do 8833 if not fixp eval(var) and eval(var) neq nil then << 8834 terpri()$ 8835 write var, " needs to be an integer or nil: ", 8836 eval(var)," is invalid"$ 8837 flag := var 8838 >>$ 8839 8840 % Finally variables containing any number 8841 foreach var in global_list_float do 8842 if not numberp eval(var) then << 8843 terpri()$ 8844 write var, " needs to be a number: ", eval(var)," is invalid"$ 8845 flag := var 8846 >>$ 8847 8848 return flag 8849end$ 8850 8851%------------------------------- 8852 8853symbolic procedure InternTest(pdes,forg)$ 8854begin scalar a,b,c$ 8855 for each a in pdes do << 8856 uniquenesssq get(a,'sqval); 8857 if pairp get(a,'fac) then 8858 for each b in get(a,'fac) do uniquenesssq b; 8859 for each b in get(a,'fcteval_lin) do uniquenesssq car b; 8860 for each b in get(a,'fcteval_nca) do uniquenesssq car b; 8861 for each b in get(a,'fcteval_nli) do uniquenesssq car b; 8862 for each b in get(a,'fct_nli_lin) do uniquenesssq car b; 8863 for each b in get(a,'fct_nli_nca) do uniquenesssq car b; 8864 for each b in get(a,'fct_nli_nli) do uniquenesssq car b; 8865 for each b in get(a,'fct_nli_nus) do uniquenesssq car b 8866 >>; 8867 8868 for each a in forg do if pairp a and car a = 'equal then uniquenesssq caddr a; 8869 for each a in ineq_ do uniquenesssq a; 8870 for each a in ineq_or do 8871 for each b in a do 8872 for each c in b do uniquenesssq c 8873end$ 8874 8875%------------------------------- 8876 8877endmodule$ 8878 8879%******************************************************************** 8880module treeofcases$ 8881%******************************************************************** 8882% Routines for storeing and updating the tree of cases 8883% Author: Thomas Wolf, May 2010 8884 8885symbolic procedure list_current_case_assumptions$ 8886if null keep_case_tree then write"To list all case assumptions the ", 8887 " computation had to be started with keep_case_tree:=t ." else 8888if null session_ then write"Either there have no case distinctions been", 8889 " made yet or the current computation is a side computation for", 8890 " which case assumptions are not stored in a case tree" else 8891if null level_ then write"There have no case distinctions been made yet" else 8892begin scalar lv,ct,ctf,echo_bak,semic_bak,nat_bak$ 8893 comment 8894 The procedure prints all cases that lead to the current situation. 8895 The purpose is to for a difficult case which can not be finished now 8896 because it leads to too large and too many equations, to list the 8897 current extra equations and inequalities to add them to the original 8898 system and start fresh being in this case from the beginning and 8899 probably make earlier use of the extra information from the cases 8900 and reach a smaller system that can be solved. 8901 Also it probably is a sub-case which has solutions and therefore is hard to 8902 solve, so it may be interesting to figure which of the case assumptions 8903 do not exclude solutions. If one has different situations which are hard to 8904 solve then one could take the intersection of all the assumptions of both 8905 cases and see which assumptions are in both situaions. 8906 global variables used: 8907 session_ = "bu626868-" 8908 level_ = (3 "c2" 1 1) 8909 $ 8910 lv:=reverse level_$ 8911 8912 % ct is the case tree 8913 8914 % the file name 8915 ctf:=explode session_$ 8916 ctf:=bldmsg("%w",compress cons(car ctf,cons('c,cons('t,cdddr ctf))))$ 8917 8918 if null filep ctf then return <<write"There is no file ",ctf;nil>>$ 8919 8920 % read case tree ct from file 8921 echo_bak:=!*echo; semic_bak:=semic!*; 8922 semic!*:='!$; in ctf$ 8923 !*echo:=echo_bak; semic!*:=semic_bak; 8924 ct:=backup_; backup_:=nil$ 8925 nat_bak:=!*nat$ off nat$ 8926 8927 while lv do << 8928 ct:=cdddr ct$ 8929 while cdr ct and caadr ct neq car lv do ct:=cdr ct; 8930 if null cdr ct then <<write"### ERROR in CaseTree: case not found in ct, lv=",lv$ 8931 terpri()>> 8932 else << 8933 %write"case: ",caadr ct$ 8934 terpri()$ 8935 if null cadadr ct then <<write"0 <> ";mathprint car cddadr ct>> 8936 else <<write"0 = ";mathprint cadadr ct>>$ 8937 ct:=cadr ct; 8938 lv:=cdr lv 8939 >> 8940 >>$ 8941 if !*nat neq nat_bak then on nat$ 8942 8943end$ 8944 8945%------------ 8946% to speed up 8947% - the calls of consistenttree() can be commented out 8948% - the line with @@@@@ can be un-commented to cut the completely 8949% solved branches out of the case tree 8950%------------ 8951 8952symbolic procedure consistenttree(ct,lv)$ 8953% - It can not be that a case is solved if at least 8954% one of its sub-cases is unsolved. 8955% - It can not be that a case is not completely solved but the 8956% crack backup file does not exist. 8957 8958if ct and cddddr ct then 8959if zerop cadddr ct then 8960write "### ERROR in CaseTree: Case ",append(lv,{car ct})," has not started", 8961 " but has already sub-cases!" 8962 else 8963begin scalar ctc,un$ 8964 ctc:=cddddr ct; 8965 lv:=append(lv,{car ct}); 8966 while ctc do << 8967 consistenttree(car ctc,lv)$ 8968 if cadddr car ctc < 2 then un:=t$ 8969 ctc:=cdr ctc 8970 >>; 8971 % The following situation happens regularly when the last subcase 8972 % has just been completed and should therefore not be reported. 8973 % if cadddr ct < 2 and null un then 8974 % write "### ERROR in CaseTree: Case ",lv," is not finished", 8975 % " but all subcases are completed!"$ 8976 if cadddr ct > 1 and un then 8977 write "### ERROR in CaseTree: Case ",lv," is completed", 8978 " but not all subcases are completed!"$ 8979end$ 8980 8981%=========== 8982 8983symbolic procedure CaseTree(inp)$ 8984% inp is of one of the 3 types: 8985% {{'equal,0,pf}} : a new case pf= 0 is to start 8986% {{'ineq ,0,pf}} : a new case pf<>0 is to start 8987% n (a digit) : the current case is to be closed, n = # of solutions 8988 8989if session_ and % Otherwise the current computation is a side computation 8990 % which should not interfere with the case tree. 8991 keep_case_tree then 8992begin 8993 comment 8994 The stored list is nil, or no file is stored if no case 8995 distinction has happened yet. 8996 8997 A single subcase has the structure: {a1,a2,a3,a4[,a5[,..]]} 8998 These are recursively nested. 8999 9000 a1 : the number of the subcase, i.e. 9001 1 : the first subcase, or 9002 2 : the second subcase, or (rarely) 9003 "2c1." : the 1st copy of the 2nd subcase 9004 a2 : if not nil then this is the expression assumed TO VANISH 9005 in this subcase, form: prefix form or prefixed SQ-form 9006 a3 : if not nil then this is the expression assumed NOT TO VANISH 9007 in this subcase, form: prefix form or prefixed SQ-form 9008 a4 : work status, i.e. 9009 0 : not started yet 9010 1 : has been started 9011 >1 : completed, is the number of solutions + 2 9012 a5,... : sub-cases of this case, non if a4=0 or a4=1 and no yet splitted 9013 9014 global variables used: 9015 session_ = "bu626868-" 9016 level_ = (3 "c2" 1 1) 9017 $ 9018 9019 scalar lv,ct,ctc,ctf,echo_bak,semic_bak,fl,fpid,newsplit,newfile,maxtries, 9020 a,save,ofl!*bak$ 9021 9022 if pairp inp and % i.e. this update is not about a subcase being finished 9023 car level_ = 1 then << % a new splitting into sub-cases is started 9024 newsplit:=t$ 9025 lv:=reverse cdr level_$ 9026 >> else lv:=reverse level_$ 9027 9028 % ct is the case tree 9029 9030 % the file name 9031 ctf:=explode session_$ 9032 ctf:=bldmsg("%w",compress cons(car ctf,cons('c,cons('t,cdddr ctf))))$ 9033 9034 if null lv and 9035 null filep ctf then <<newfile:=t;ct:={nil,nil,nil,1}>> % i.e. no subcases yet 9036 else << 9037 9038 % move file 9039 fpid := bldmsg("%s.%w",ctf,getpid()); 9040 maxtries:=0; 9041 repeat << 9042 fl := rename!-file(ctf, fpid); 9043 % old, only for unix: fl := system bldmsg ("mv %s %s",ctf,fpid)$ 9044 maxtries:=add1 maxtries; 9045 if null fl then sleep 0.5 9046 >> until fl or (maxtries=5); 9047 if maxtries=5 then return << 9048 write"### ERROR in CaseTree: file ",ctf," not found."$ terpri()$ 9049 write"--> No more tries. (keep_case_tree:=nil)"$terpri()$ 9050 nil 9051 >>$ 9052 9053 % read case tree ct from file 9054 echo_bak:=!*echo; semic_bak:=semic!*; 9055 semic!*:='!$; in fpid$ 9056 !*echo:=echo_bak; semic!*:=semic_bak; 9057 ct:=backup_; backup_:=nil$ 9058 9059 >>$ 9060 9061 ctc:=ct$ 9062 while lv do << 9063 ctc:=cdddr ctc$ 9064 while cdr ctc and caadr ctc neq car lv do ctc:=cdr ctc; 9065 if null cdr ctc then <<write"### ERROR in CaseTree: case not found in ct, lv=",lv$ 9066 terpri()>> 9067 else << 9068 ctc:=cadr ctc; 9069 lv:=cdr lv 9070 >> 9071 >>$ 9072 9073 ctc:=cdddr ctc$ 9074 9075 % now is lv=nil 9076 % adding a new case distinction: 9077 if pairp inp and % this case is started now, but .. 9078 cdr ctc % subcases of this have already been allocated before 9079 then <<write"### ERROR in CaseTree: lv=nil, cdr ctc="$eqprint cdr ctc$ 9080 terpri()>> 9081 else 9082 if newsplit then 9083 if caar inp = 'equal then 9084 if zerop cadar inp then rplacd(ctc,{{1,caddar inp,nil,1},{2,nil,caddar inp,0}}) 9085 else rplacd(ctc,{{1,cadar inp,nil,1},{2,nil,cadar inp,0}}) 9086 else 9087 if zerop cadar inp then rplacd(ctc,{{1,nil,caddar inp,1},{2,caddar inp,nil,0}}) 9088 else rplacd(ctc,{{1,nil,cadar inp,1},{2,cadar inp,nil,0}}) 9089 else 9090 if pairp inp then rplaca(ctc,1) % this case is now started 9091 else << 9092 if null inp then rplaca(ctc,2) % this case is finished it 9093 else rplaca(ctc,2+inp)$ % has inp-many solutions 9094 % rplacd(ctc,nil) % @@@@@ This line deletes completed cases. It should be 9095 % commented out if a statistics about successful 9096 % assumptions shall be performed 9097 >>$ 9098 9099 consistenttree(ct,nil)$ 9100 9101 if newfile then << % write the file 9102 %out ctf; 9103 a:=open(ctf,'output); 9104 ofl!*bak:=ofl!*$ 9105 ofl!*:=ctf$ % any value neq nil, to avoid problem with redfront 9106 save:=wrs a; 9107 9108 write"off echo$ "$ 9109 write"backup_:= '"$ 9110 print ct$ 9111 write" $"$ terpri()$ 9112 write"end$"$ terpri()$ 9113 9114 %shut ctf 9115 wrs save$ 9116 ofl!*:=ofl!*bak$ 9117 close a; 9118 9119 >> else << 9120 % write renamed file 9121 %out fpid; 9122 a:=open(fpid,'output); 9123 ofl!*bak:=ofl!*$ 9124 ofl!*:=fpid$ % any value neq nil, to avoid problem with redfront 9125 save:=wrs a; 9126 9127 write"off echo$ "$ 9128 write"backup_:= '"$ 9129 print ct$ 9130 write" $"$ terpri()$ 9131 write "end$"$ terpri()$ 9132 %shut fpid$ 9133 wrs save$ 9134 ofl!*:=ofl!*bak$ 9135 close a; 9136 9137 % move back renamed file 9138 maxtries:=0; 9139 repeat << 9140 fl := rename!-file(fpid,ctf); 9141 % old for unix only: fl := system bldmsg ("mv %s %s",fpid,ctf); 9142 maxtries:=add1 maxtries; 9143 if null fl then sleep 0.5 9144 >> until fl or (maxtries=5); 9145 9146 >> 9147end$ 9148 9149%=========== 9150 9151symbolic procedure find_unsolved_case$ 9152% uses global variables session_ (input) and level_ (output) 9153begin scalar ctf,fpid,fl,ct,ctc,ctcc,soln,condi,echo_bak,semic_bak, 9154 maxtries,a,save,ofl!*bak$ 9155 9156 % the file name 9157 ctf:=explode session_$ 9158 ctf:=bldmsg("%w",compress cons(car ctf,cons('c,cons('t,cdddr ctf))))$ 9159 9160 % move file 9161 fpid := bldmsg("%s.%w",ctf,getpid()); 9162 maxtries:=0; 9163 repeat << 9164 fl := rename!-file(ctf, fpid); 9165 % old for unix: fl := system bldmsg ("mv %s %s",ctf,fpid)$ 9166 maxtries:=add1 maxtries; 9167 if null fl then sleep 1 9168 >> until fl or (maxtries=5); 9169 if maxtries=5 then return << 9170 write"### ERROR in CaseTree: file ",ctf," not found"$ 9171 nil 9172 >>$ 9173 9174 % read case tree ct from file 9175 echo_bak:=!*echo; semic_bak:=semic!*; 9176 semic!*:='!$; in fpid$ 9177 !*echo:=echo_bak; semic!*:=semic_bak; 9178 ct:=backup_; backup_:=nil$ 9179 9180 if cadddr ct>1 then goto fino; % The whole computation is completed. 9181 9182 again1: % Search re-starts here if a case has been found, which has 9183 % all its sub-cases solved but the case itself has not been 9184 % marked yet as completely solved. Then this case is marked 9185 % as solved and search starts again here from the root of 9186 % the case tree. 9187 9188 level_:=nil$ 9189 ctc:=ct; 9190 9191 again2: % to be jumped to when one goes deeper into an unsolved 9192 % subcase 9193 9194 % it is known that cadddr ctc < 2, i.e. that this case is not yet completely 9195 % solved which is definitely true for the root 9196 if cddddr ctc then << % i.e. if subcases have been generated 9197 % then find an unsolved subcase. 9198 ctcc:=cddddr ctc; % ctcc is the list of subcases 9199 soln:=0; % the total # of solutions found in subcases 9200 % to be used if all subcases are solved 9201 while ctcc and cadddr car ctcc > 1 do << % step through all solved cases 9202 soln:=soln+cadddr car ctcc - 2; 9203 ctcc:=cdr ctcc 9204 >>$ 9205 if null ctcc then << % all subcases have been solved 9206 9207 system bldmsg("rm %w",level_string(session_)); 9208 if ctc=ct then goto fino % the whole problem is solved 9209 else << % this case is solved 9210 rplaca(cdddr ctc,soln+2)$% mark this case as solved 9211 goto again1 % start seaarching again from root 9212 >> 9213 >> else << % an unsolved subcase is found 9214 ctc:=car ctcc$ 9215 level_:=cons(car ctc,level_)$ 9216 goto again2 9217 >> 9218 >>; 9219 9220 condi:= if cadr ctc then {'equal,cadr ctc,0} 9221 else {'neq, caddr ctc,0}$ 9222 if cadddr ctc = 0 then rplaca(cdddr ctc,1)$ % as this computation 9223 % is about to start 9224 consistenttree(ct,nil)$ 9225 9226 % write renamed file 9227 %out fpid; 9228 a:=open(fpid,'output); 9229 ofl!*bak:=ofl!*$ 9230 ofl!*:=fpid$ % any value neq nil, to avoid problem with redfront 9231 save:=wrs a; 9232 9233 write"off echo$ "$ 9234 write"backup_:= '"$ 9235 print ct$ 9236 write" $"$ terpri()$ 9237 write "end$"$ terpri()$ 9238 9239 %shut fpid$ 9240 wrs save$ 9241 ofl!*:=ofl!*bak$ 9242 close a; 9243 9244 fino: 9245 9246 % move back renamed file 9247 repeat << 9248 fl := rename!-file(fpid,ctf); 9249 % old for unix: fl := system bldmsg ("mv %s %s",fpid,ctf); 9250 if null fl then sleep 1 9251 >> until fl$ 9252 9253 return condi 9254 9255end$ 9256 9257%=========== 9258 9259symbolic operator crackpickup$ 9260symbolic procedure crackpickup$ 9261begin scalar s,level_bak,levstri; 9262 terpri()$ 9263 old_history:=nil$ 9264 if null session_ then ask_for_session() else << 9265 write "Do you want to compute remaining cases left over in this session,"$ 9266 terpri()$ 9267 if not yesp "i.e. since loading CRACK the last time? " then 9268 ask_for_session()$ 9269 >>$ 9270 9271 while s:=find_unsolved_case() do << 9272 9273 level_bak:=level_$ 9274 level_:=cdr level_$ 9275 write"Computation of the case ",reverse level_bak$ terpri()$ 9276 levstri:=level_string(session_)$ 9277 9278 old_history:= 9279 if car s = 'neq then {'rb,levstri, 9280 'as,'level_,{'quote,level_bak}, 9281 'n,cadr s} 9282 else {'rb,levstri, 9283 'as,'level_,{'quote,level_bak}, 9284 'r,'n,'new_pde,cadr s,2}$ 9285 9286 algebraic(off batch_mode); 9287 algebraic(crack({},{},{},{})); 9288 9289 >> 9290 9291end$ 9292 9293%=========== 9294 9295symbolic procedure delete_case_tree$ 9296begin scalar ctf$ 9297 ctf:=explode session_$ 9298 ctf:=bldmsg("%w",compress cons(car ctf,cons('c,cons('t,cdddr ctf))))$ 9299 if filep ctf then delete!-file!-exact ctf$ 9300end$ 9301 9302endmodule$ 9303 9304%******************************************************************** 9305module let_rule_handling$ 9306%******************************************************************** 9307% Routines that work with LET rules 9308% Author: Thomas Wolf, April 2015 9309 9310symbolic procedure copyrule2eqn(h,pdes)$ 9311% h = {'replaceby,f, {'!*sq,...,t}} 9312begin scalar l$ 9313 l:=mkeqSQ(simp!* {'DIFFERENCE,cadr h,caddr h},nil,nil,ftem_,vl_, 9314 allflags_,t,list(0),nil,pdes)$ 9315 pdes:=eqinsert(l,pdes); 9316 return pdes 9317end$ 9318 9319symbolic procedure moverule2eqn(h,pdes)$ 9320% h = {'replaceby,f, {'!*sq,...,t}} 9321<< 9322 userrules_:=delete(h,userrules_); 9323 pdes:=copyrule2eqn(h,pdes)$ 9324 algebraic(clearrules lisp {'list,h})$ 9325 pdes 9326>>$ 9327 9328symbolic procedure add_a_rule(pdes,forg)$ 9329begin scalar l,s,h,pl,dnr; 9330 change_prompt_to ""$ 9331 write"In the LET-rule you are going to add you can not introduce "$ 9332 terpri()$ 9333 write"new functions to be computed. If your LET-rules involve "$ 9334 terpri()$ 9335 write"such functions then you have to add equations before which "$ 9336 terpri()$ 9337 write"involve these functions in order to introduce the functions "$ 9338 terpri()$ 9339 write"to the program. "$terpri()$ terpri()$ 9340 write"You can either"$ terpri()$ 9341 write"- give the name (terminated by ;) of a rule list to be "$terpri()$ 9342 write" activated that has been defined before the call of CRACK, or"$ 9343 terpri()$ 9344 write"- give the name (terminated by ;) of an equation which "$terpri()$ 9345 write" is to be converted to a LET rule, or"$terpri()$ 9346 write"- type in the new LET-rule in the form like"$terpri()$ 9347 write" sqrt(e)**(-~x*log(~y)/~z) => y**(-x/z/2); : "$terpri()$ 9348 l:=termxread()$ 9349 if atom l then 9350 if member(l,pdes) then <<pl:=l;rule_from_pde(l)>> 9351 else <<pl:=nil;algebraic(let lisp l)>> 9352 else << 9353 userrules_:=cons('list,cons(l,cdr userrules_))$ 9354 algebraic (write "The new list of user defined rules: ", 9355 lisp userrules_)$ 9356 terpri()$ 9357 >>$ 9358 write"Shall all current LET-rules be applied to all current ", 9359 "equations NOW (y/n)? "$ 9360 l:=termread()$ 9361 if (l='y) or (l='Y) then << 9362 algebraic(let lisp userrules_); 9363 if null pl then << 9364 write"Give an equation name to which the LET-rule should not be applied ", 9365 "now or press ENTER if the rule should be applied to all equations: "$ 9366 pl:=termread()$ 9367 >>$ 9368 s:=pdes; 9369 for each h in s do 9370 if h neq pl and null contradiction_ then << 9371 l:=mkeqSQ(get(h,'sqval),nil,nil,get(h,'fcts),get(h,'vars), 9372 allflags_,t,list(0),nil,pdes)$ 9373 if l and (get(h,'sqval) neq get(l,'sqval)) then << 9374 pdes:=drop_pde(h,pdes,nil)$ 9375 pdes:=eqinsert(l,pdes) 9376 >> 9377 >>$ 9378 9379 algebraic(clearrules lisp userrules_)$ 9380 9381 % substitutions need to be added as equations 9382 for each h in cdr userrules_ do 9383 if null contradiction_ then pdes:=copyrule2eqn(h,pdes)$ 9384 9385 >>$ 9386 9387 write"Shall all current LET-rules be applied to simplify all ", 9388 "computed functions/constants (forg) NOW (y/n)? "$ 9389 l:=termread()$ 9390 if (l='y) or (l='Y) then << 9391 algebraic(let lisp userrules_); 9392 forg:=for each h in forg collect 9393 if atom h then h % currently only simplification of right hand sides 9394 else 9395 if (car h='equal) then << 9396 dnr:=simp!* {'!*sq,(denr caddr h. 1),nil}; 9397 if sqzerop dnr then <<contradiction_:=t$ 9398 terpri()$write"##### ERROR: When applying LET rules in the denominator of the ", 9399 "forg entry: ",h," then the denominator becomes zero!! #####"$ 9400 terpri()$ 9401 nil 9402 >> else << 9403 h:=list('equal,cadr h, simp!* {'!*sq, caddr h, nil}); 9404 put(cadr h,'fcts,sort_according_to(smemberl(ftem_,caddr h),ftem_)); 9405 h 9406 >> 9407 >> else h$ 9408 algebraic(clearrules lisp userrules_)$ 9409 >>$ 9410 9411 terpri()$ 9412 write"Warning: Changes of equations based on LET-rules"$terpri()$ 9413 write"are not recorded in the history of equations."$terpri()$ 9414 9415 return {pdes,forg} 9416end$ 9417 9418symbolic procedure clear_a_rule(pdes)$ 9419begin scalar l,s; 9420 change_prompt_to ""$ 9421 write"These are all the user defined rules: "$ terpri()$ 9422 algebraic (write lisp userrules_); 9423 write"You can either"$ terpri()$ 9424 write"- give the number of a rule above to be dropped, or "$ terpri()$ 9425 write"- give the name of a rule list to be disabled that was "$ terpri()$ 9426 write" activated already before the call of CRACK, or "$ terpri()$ 9427 write"- enter 0 to return to menu: "$ 9428 l:=termread()$ 9429 if l neq 0 then 9430 if not fixp l then << 9431 algebraic(clearrules lisp l)$ 9432 write"Rule list ",l," has been disabled."$terpri() 9433 >> else 9434 if l > sub1 length userrules_ then << 9435 write"This number is too big."$terpri() 9436 >> else << 9437 s:=cdr userrules_$ 9438 while l>1 do <<l:=sub1 l;s:=cdr s>>; 9439 9440 write"Apart from being copied as an equation, should it also be deleted as 9441 rule? (Y/N) "$ l:=termread()$ 9442 repeat l:=termread() until (l='y) or (l='n); 9443 pdes:= if l='y then moverule2eqn(car s,pdes) 9444 else copyrule2eqn(car s,pdes)$ 9445 algebraic (write lisp userrules_); 9446 terpri()$ 9447 >>; 9448 return pdes 9449end$ 9450 9451symbolic procedure ss_modulo$ 9452begin scalar l$ 9453 terpri()$ 9454 repeat << 9455 write"Enter a number modulo which computations shall be performed, like 65537."$ 9456 write"If the number is not a prime number then the next prime number is taken: "$ 9457 l:=termread() 9458 >> until fixp l and l>1; 9459 modular_comp:=nextprime (l-1); 9460 setmod modular_comp 9461end$ 9462 9463symbolic procedure start_stop_modulo()$ 9464begin scalar l; 9465 change_prompt_to ""$ 9466 if modular_comp then << 9467 l:=setmod 1; setmod l; 9468 if l neq modular_comp then << 9469 write"### WARNING: The setmod value ",l," is not equal modular_comp=", 9470 modular_comp,"!"$terpri() 9471 >>$ 9472 repeat << 9473 write"Currently computations are done modulo ",l$terpri()$ 9474 write"To change this number enter c "$ terpri()$ 9475 write"To stop modular computations enter p "$ terpri()$ 9476 write"To return to menu enter 0 : "$ 9477 l:=termread() 9478 >> until (l='p) or (l='c) or (l=0); 9479 if l='c then ss_modulo() else 9480 if l='p then modular_comp:=nil 9481 >> else << 9482 repeat << 9483 write"To start computation modular a number enter t "$ terpri()$ 9484 write"To return to menu enter 0 "$ 9485 l:=termread() 9486 >> until (l='t) or (l=0); 9487 if l='t then ss_modulo() 9488 >> 9489end$ 9490 9491endmodule$ 9492 9493end$ 9494 9495% tr err_catch_groeb 9496% tr err_catch_readin 9497% tr err_catch_solve 9498% tr err_catch_odesolve 9499% tr err_catch_minsub 9500% tr err_catch_gb 9501% tr err_catch_sub 9502% tr ecs_SQ 9503% tr err_catch_int 9504% tr err_catch_reval 9505% tr err_catch_fac 9506% tr err_catch_fac2 9507% tr err_catch_fac3 9508% tr err_catch_gcd 9509% tr err_catch_preduce 9510 9511% tr updateSQ 9512% tr err_catch_fac2 9513% tr sffac 9514% tr simplifySQ 9515% tr sort_according_to 9516% tr pdeweightSF 9517% tr stardep3 9518% tr sep_var 9519% tr new_ineq_from_equ_SQ 9520