1;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;; 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;;; The data in this file contains enhancments. ;;;;; 4;;; ;;;;; 5;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;; 6;;; All rights reserved ;;;;; 7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; 9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 11(in-package :maxima) 12 13(macsyma-module algsys) 14 15(load-macsyma-macros ratmac) 16 17;;This is the algsys package. 18 19;;It solves systems of polynomial equations by straight-forward 20;;resultant hackery. Other possible methods seem worse: 21;;the Buchberger-Spear canonical ideal basis algorithm is slow, 22;;and the "resolvent" method (see van der Waerden, section 79) 23;;blows up in time and space. The "resultant" 24;;method (see the following sections of van der Waerden and 25;;Macaulay's book - Algebraic Theory of Modular Systems) looks 26;;good, but it requires the evaluation of large determinants. 27;;Unless some hack (such as prs's for evaluating resultants of 28;;two polynomials) is developed for multi-polynomial resultants, 29;;this method will remain impractical. 30 31;;Some other possible ideas: Keeping the total number of equations constant, 32;;in an effort to reduce extraneous solutions, or Reducing to a linear 33;;equation before taking resultants. 34 35(declare-top (special $algdelta $ratepsilon $algepsilon $keepfloat 36 varlist genvar *roots *failures $ratprint $numer $ratfac 37 $solvefactors $dispflag $breakup 38 *tvarxlist* errorsw $programmode *ivar* errset $polyfactor 39 bindlist loclist $float $infeval)) 40 41;;note if $algepsilon is too large you may lose some roots. 42 43(defmvar $algdelta 1e-5 ) 44 45(defmvar $%rnum_list '((mlist)) 46 "Upon exit from ALGSYS this is bound to a list of the %RNUMS 47 which where introduced into the expression. Useful for mapping 48 over and using as an argument to SUBST.") 49 50(defmvar $realonly nil "If t only real solutions are returned.") 51 52(defmvar realonlyratnum nil 53 "A REALROOTS hack for RWG. Causes ALGSYS to retain rational numbers 54 returned by REALROOTS when REALONLY is TRUE." 55 in-core) 56 57(defmvar $algexact nil "If t ALGSYS always calls SOLVE to try to MAXIMA-FIND exact 58 solutions.") 59 60(defmvar algnotexact nil 61 "A hack for RWG for univariate polys. Causes SOLVE not to get called 62 so that sqrts and cube roots will not be generated." 63 in-core) 64 65(defmacro merrset (l) 66 `(let ((errset t) (unbind (cons bindlist loclist)) val) 67 (setq val (errset ,l)) 68 (when (null val) (errlfun1 unbind)) 69 val)) 70 71(defmfun $algsys (lhslist varxlist &aux varlist genvar) 72 ;; (declare (special varxlist)) ;;?? 73 (setq $%rnum_list (list '(mlist))) 74 (cond ((not ($listp lhslist)) 75 (merror (intl:gettext "algsys: first argument must be a list; found ~M") lhslist)) 76 ((not ($listp varxlist)) 77 (merror (intl:gettext "algsys: second argument must be a list; found ~M") varxlist))) 78 (let ((tlhslist nil) (*tvarxlist* nil) (solnlist nil) ($ratprint nil) 79 ;; GCL seems to read 1e-7 as zero, but only when compiling. Incantations 80 ;; based on 1d-7, 1l-7 etc. don't seem to make any difference. 81 ($ratepsilon #-gcl 1e-7 82 #+gcl (float 1/10000000)) 83 ($keepfloat nil) 84 (varlist (reverse (cdr varxlist))) 85 (genvar nil) ($ratfac nil) ($breakup nil) 86 ($solvefactors nil) (*roots nil) (*failures nil) 87 (*ivar* nil) ($polyfactor nil) (varxl nil) 88 ($infeval nil) ($numer nil) ($float nil) 89 (numerflg $numer)) 90 (dolist (var (cdr ($listofvars (list '(mlist simp) lhslist varxlist)))) 91 (if (and (symbolp var) (not (constant var))) 92 (setq varxl (cons var varxl)))) 93 (orderpointer varlist) 94 (setq tlhslist 95 (mapcar #'(lambda (q) (cadr (ratf (meqhk q)))) 96 (cdr lhslist))) 97 (setq *ivar* (caadr (ratf '$%i))) 98 (setq *tvarxlist* 99 (mapcar #'(lambda (q) 100 (if (mnump q) 101 (merror (intl:gettext "algsys: variable cannot be a number; found ~M") q) 102 (caadr (ratf q)))) 103 (cdr varxlist))) 104 (putorder *tvarxlist*) 105 (mbinding (varxl varxl) 106 (setq solnlist 107 (mapcar #'(lambda (q) 108 (addmlist 109 (bbsorteqns 110 (addparam (roundroots1 q) varxlist)))) 111 (algsys tlhslist)))) 112 (remorder *tvarxlist*) 113 (setq solnlist (addmlist solnlist)) 114 (if numerflg 115 (let (($numer t) ($float t)) 116 (resimplify solnlist)) 117 solnlist))) 118 119;;; (CONDENSESOLNL TEMPSOLNL) 120;;; 121;;; Condense a solution list, discarding any solution that is a special case of 122;;; another one. (For example, if the list contained [x=1, y=1] as a solution, 123;;; but also just [x=1], then the first solution would be discarded) 124;;; 125;;; Destructively modifies TEMPSOLNL 126(defun condensesolnl (tempsolnl) 127 (let (solnl) 128 (mapl (lambda (q) 129 (unless (subsetl (cdr q) (car q)) 130 (push (car q) solnl))) 131 (sort tempsolnl #'(lambda (a b) (> (length a) (length b))))) 132 solnl)) 133 134;;; (SUBSETL L1 S2) 135;;; 136;;; Check whether some element of L1 is a subset of S2 (comparing elements with 137;;; ALIKE1). As a special case, if S2 is '(NIL) then return true. 138(defun subsetl (l1 s2) 139 (or (equal s2 '(nil)) 140 (member-if (lambda (x) 141 (subsetp x s2 :test #'alike1)) 142 l1))) 143 144(defun algsys (tlhslist) 145 (condensesolnl 146 (mapcan #'algsys0 147 (distrep (mapcar #'lofactors tlhslist))))) 148 149(defun algsys0 (tlhslist) 150 (cond ((null tlhslist) (list nil)) 151 ((equal tlhslist (list nil)) nil) 152 (t (algsys1 tlhslist)))) 153 154(defun algsys1 (tlhslist) 155 (destructuring-bind (resulteq . vartorid) (findleastvar tlhslist) 156 (bakalevel (algsys 157 (mapcar #'(lambda (q) 158 (if (among vartorid q) 159 (presultant q resulteq vartorid) 160 q)) 161 (remove resulteq tlhslist :test #'equal))) 162 tlhslist vartorid))) 163 164(defun addmlist (l) 165 (cons '(mlist) l)) 166 167(defmacro what-the-$ev (&rest l) 168 ;; macro for calling $EV when you are not really 169 ;; sure why you are calling it, but you want the 170 ;; features of multiple evaluations and unpredictabiltiy 171 ;; anyway. 172 `(meval (list '($ev) ,@l))) 173 174(defun rootsp (asolnset eqn) ;eqn is ((MLIST) eq deriv) 175 (let (rr ($keepfloat t) ($numer t) ($float t)) 176 (setq rr (what-the-$ev eqn asolnset)) ; ratsimp? 177 (cond ((and (complexnump (cadr rr)) (complexnump (caddr rr))) 178 (< (cabs (cadr rr)) 179 (* $algdelta (max 1 (cabs (caddr rr)))))) 180 (t nil)))) 181 182(defun round1 (a) 183 (cond ((floatp a) 184 (setq a (maxima-rationalize a)) 185 (fpcofrat1 (car a) (cdr a))) 186 (t a))) 187 188(defun roundrhs (eqn) 189 (list (car eqn) (cadr eqn) (round1 (caddr eqn)))) 190 191(defun roundroots1 (lsoln) 192 (mapcar #'roundrhs lsoln)) 193 194(defun bbsorteqns (l) 195 (sort (copy-list l) #'orderlessp)) 196 197(defun putorder (tempvarl) 198 (do ((n 1 (1+ n)) 199 (tempvarl tempvarl (cdr tempvarl))) 200 ((null tempvarl) nil) 201 (putprop (car tempvarl) n 'varorder))) 202 203(defun remorder (gvarl) 204 (mapc #'(lambda (x) (remprop x 'varorder)) gvarl)) 205 206 207(defun orderlessp (eqn1 eqn2) 208 (< (get (caadr (ratf (cadr eqn1))) 'varorder) 209 (get (caadr (ratf (cadr eqn2))) 'varorder))) 210 211(defun addparam (asolnsetl varxlist) 212 (cond ((= (length asolnsetl) (length *tvarxlist*)) 213 asolnsetl) 214 (t 215 (do ((tvarxl (cdr varxlist) (cdr tvarxl)) 216 (defvar (mapcar #'cadr asolnsetl)) 217 (var) (param)) 218 ((null tvarxl) asolnsetl) 219 (setq var (car tvarxl)) 220 (cond ((memalike var defvar) nil) 221 (t (setq param (make-param) 222 asolnsetl (cons (list '(mequal) var param) 223 (cdr (maxima-substitute 224 param var 225 (addmlist asolnsetl))))))))))) 226 227(declare-top (special *vardegs*)) 228 229;;; (FINDLEASTVAR LHSL) 230;;; 231;;; Iterate over the polynomials in LHSL, trying to find a "least var", which is 232;;; a variable that will hopefully be easiest to solve for. Variables from 233;;; *TVARXLIST* and their products are considered. 234;;; 235;;; For example, if *TVARXLIST* contains x, y and we only considered the 236;;; polynomial x^3 + y^2 + x then we'd have a least var of y with degree 2. If c 237;;; is not in *TVARXLIST* then we'd get the same answer from x^3 + c*y^2 + x 238;;; because such variables are just ignored. However, x^3 + x^2*y^2 would yield 239;;; x with degree 3 because the mixed term x^2*y^2 has higher total degree. 240;;; 241;;; The function returns the polynomial with the variable with minimal maximum 242;;; degree (as described above), together with that variable. 243;;; 244;;; Mixed terms are mostly ignored, but consider this pair of polynomials: 245;;; [x*y+1, x^3+1]. In the first polynomial, the only non-constant term is 246;;; mixed. Its degree in the first polynomial is 2 which is less than 3, so that 247;;; first polynomial is returned along with its leading variable. 248(defun findleastvar (lhsl) 249 (let ((*vardegs*) 250 (leasteq) (leastvar) 251 ;; most-positive-fixnum is larger than any polynomial degree, so we can 252 ;; initialise with this and be certain to replace it on the first 253 ;; iteration. 254 (leastdeg most-positive-fixnum)) 255 (declare (special *vardegs*)) 256 (loop 257 for teq in lhsl 258 for *vardegs* = (getvardegs teq) 259 for tdeg = (killvardegsc teq) 260 do (loop 261 for q in *vardegs* 262 if (<= (cdr q) leastdeg) 263 do (setq leastdeg (cdr q) 264 leasteq teq 265 leastvar (car q))) 266 if (< tdeg leastdeg) 267 do (setq leastdeg tdeg 268 leasteq teq 269 leastvar (car teq))) 270 (cons leasteq leastvar))) 271 272;;; DO-POLY-TERMS 273;;; 274;;; Iterate over the terms in a polynomial, POLY, executing BODY with LE and LC 275;;; bound to the exponent and coefficient respectively of each term. If RESULT 276;;; is non-NIL, it is evaluated to give a result when the iteration finishes. 277(defmacro do-poly-terms ((le lc poly &optional result) &body body) 278 (let ((pt (gensym))) 279 `(do ((,pt (p-terms ,poly) (pt-red ,pt))) 280 ((null ,pt) ,result) 281 (let ((,le (pt-le ,pt)) 282 (,lc (pt-lc ,pt))) 283 ,@body)))) 284 285;;; (KILLVARDEGSC POLY) 286;;; 287;;; For each monomial in POLY that is mixed in the variables in *VARDEGS* 288;;; (i.e. has more than one variable from *VARDEGS* with positive exponent), 289;;; iterate over all but the first variable, checking to see whether its degree 290;;; in the monomial is at least as high as that in *VARDEGS*. If so, delete that 291;;; variable and its degree from *VARDEGS*. 292;;; 293;;; Returns the maximum total degree of any term in the polynomial, summing 294;;; degrees over the variables in *VARDEGS*. 295(defun killvardegsc (poly) 296 (if (pconstp poly) 297 0 298 (let ((tdeg 0)) 299 (do-poly-terms (le lc poly tdeg) 300 (setf tdeg (max tdeg (+ le 301 (if (= le 0) 302 (killvardegsc lc) 303 (killvardegsn lc))))))))) 304 305;;; (KILLVARDEGSN POLY) 306;;; 307;;; For each monomial in POLY, look at its degree in each variable in 308;;; *TVARXLIST*. If the degree is at least as high as that recorded in 309;;; *VARDEGS*, delete that variable and its degree from *VARDEGS*. 310;;; 311;;; Returns the maximum total degree of any term in the polynomial, summing 312;;; degrees over the variables in *VARDEGS*. 313(defun killvardegsn (poly) 314 (declare (special *vardegs*)) 315 (cond 316 ((pconstp poly) 0) 317 (t 318 (let ((x (assoc (p-var poly) *vardegs* :test #'eq))) 319 (when (and x (<= (cdr x) (p-le poly))) 320 (setq *vardegs* (delete x *vardegs* :test #'equal)))) 321 (let ((tdeg 0)) 322 (do-poly-terms (le lc poly tdeg) 323 (setf tdeg (max tdeg (+ le (killvardegsn lc))))))))) 324 325;;; (GETVARDEGS POLY) 326;;; 327;;; Return degrees of POLY's monomials in the variables for which we're 328;;; solving. Ignores mixed terms (like x*y). Results are returned as an alist 329;;; with elements (VAR . DEGREE). 330;;; 331;;; For example, if *TVARXLIST* is '(x y) and we are looking at the polynomial 332;;; x^2 + y^2, we have 333;;; 334;;; (GETVARDEGS '(X 2 1 0 (Y 2 1))) => ((X . 2) (Y . 2)) 335;;; 336;;; Variables that aren't in *TVARXLIST* are assumed to come after those that 337;;; are. For example c*x^2 would look like 338;;; 339;;; (GETVARDEGS '(X 2 (C 1 1))) => ((X . 2)) 340;;; 341;;; Mixed powers are ignored, so x*y + y looks like: 342;;; 343;;; (GETVARDEGS '(X 1 (Y 1 1) 0 (Y 1 1))) => ((Y . 1)) 344 345(defun getvardegs (poly) 346 (cond ((pconstp poly) nil) 347 ((pconstp (caddr poly)) 348 (cons (cons (car poly) (cadr poly)) 349 (getvardegs (ptterm (cdr poly) 0)))) 350 (t (getvardegs (ptterm (cdr poly) 0))))) 351 352(declare-top (unspecial *vardegs*)) 353 354(defun pconstp (poly) 355 (or (atom poly) (not (member (car poly) *tvarxlist* :test #'eq)))) 356 357;;; (PFREEOFMAINVARSP POLY) 358;;; 359;;; If POLY isn't a polynomial in the variables for which we're solving, 360;;; disrep it and simplify appropriately. 361(defun pfreeofmainvarsp (poly) 362 (if (or (atom poly) 363 (member (car poly) *tvarxlist* :test #'eq)) 364 poly 365 (simplify-after-subst (pdis poly)))) 366 367;;; (LOFACTORS POLY) 368;;; 369;;; If POLY is a polynomial in one of the variables for which we're solving, 370;;; then factor it into a list of factors (where the result returns factors 371;;; alternating with their multiplicity in the same way as PFACTOR). 372;;; 373;;; If POLY is not a polynomial in one of the solution variables, return NIL. 374(defun lofactors (poly) 375 (let ((main-var-poly (pfreeofmainvarsp poly))) 376 (cond 377 ((pzerop main-var-poly) '(0)) 378 379 ;; If POLY isn't a polynomial in our chosen variables, RADCAN will return 380 ;; something whose CAR is a cons. In that case, or if the polynomial is 381 ;; something like a number, there are no factors to extract. 382 ((or (atom main-var-poly) 383 (not (atom (car main-var-poly)))) 384 nil) 385 386 (t 387 (do ((tfactors (pfactor main-var-poly) (cddr tfactors)) 388 (lfactors)) 389 ((null tfactors) lfactors) 390 (let ((main-var-factor (pfreeofmainvarsp (car tfactors)))) 391 (cond 392 ((pzerop main-var-factor) 393 (return (list 0))) 394 ((and (not (atom main-var-factor)) 395 (atom (car main-var-factor))) 396 (push (pabs main-var-factor) lfactors))))))))) 397 398;;; (COMBINEY LISTOFL) 399;;; 400;;; Combine "independent" lists in LISTOFL. If all the lists have empty pairwise 401;;; intersections, this returns all selections of items, one from each 402;;; list. Destructively modifies LISTOFL. 403;;; 404;;; Selections are built up starting at the last list. When building, if there 405;;; would be a repeated element because the list we're about to select from has 406;;; nonempty intersection with an existing partial selections then elements from 407;;; the current list aren't added to this selection. 408;;; 409;;; COMBINEY guarantees that no list in the result has two elements that are 410;;; ALIKE1 each other. 411;;; 412;;; This is used to enumerate combinations of solutions from multiple 413;;; equations. Each entry in LISTOFL is a list of possible solutions for an 414;;; equation. A solution for the set of equations is found by looking at 415;;; (compatible) combinations of solutions. 416;;; 417;;; (I don't know why the non-disjoint behaviour works like this. RJS 1/2015) 418(defun combiney (listofl) 419 (unless (member nil listofl) 420 (combiney1 (delete '(0) listofl :test #'equal)))) 421 422;;; DB (2016-09-13) Commit a158b1547 introduced a regression (SF bug 3210) 423;;; It: - restructured combiney 424;;; - used ":test #'alike1" in place of "test #'equal" in combiney1 425;;; Reverting the change to combiney1 restores previous behaviour. 426;;; I don't understand algsys internals and haven't analysed this further. 427(defun combiney1 (listofl) 428 (cond ((null listofl) (list nil)) 429 (t (mapcan #'(lambda (r) 430 (if (intersection (car listofl) r :test #'equal) 431 (list r) 432 (mapcar #'(lambda (q) (cons q r)) (car listofl)))) 433 (combiney1 (cdr listofl)))))) 434 435(defun midpnt (l) 436 (rhalf (rplus* (car l) (cadr l)))) 437 438(defun rflot (l) 439 (let ((rr (midpnt l))) 440 (if realonlyratnum (list '(rat) (car rr) (cdr rr)) 441 (/ (+ 0.0 (car rr)) (cdr rr))))) 442 443(defun memberroot (a x eps) 444 (cond ((null x) nil) 445 ((< (abs (- a (car x))) 446 (/ (+ 0.0 (car eps)) (cdr eps))) 447 t) 448 (t (memberroot a (cdr x) eps)))) 449 450(defun commonroots (eps solnl1 solnl2) 451 (cond ((null solnl1) nil) 452 ((memberroot (car solnl1) solnl2 eps) 453 (cons (car solnl1) (commonroots eps (cdr solnl1) solnl2))) 454 (t (commonroots eps (cdr solnl1) solnl2)))) 455 456;; (REMOVE-MULT L) 457;; 458;; Return a copy of L with all elements in odd positions removed. This is so 459;; named because some code returns roots and multiplicities in the format 460;; 461;; (ROOT0 MULT0 ROOT1 MULT1 ... ROOTN MULTN) 462;; 463;; Calling REMOVE-MULT on such a list removes the multiplicities. 464(defun remove-mult (l) 465 (and l (cons (car l) (remove-mult (cddr l))))) 466 467(defun punivarp (poly) 468 ;; Check if called with the number zero, return nil. 469 ;; Related bugs: SF[609466], SF[1430379], SF[1663399] 470 (when (and (numberp poly) (= poly 0)) (return-from punivarp nil)) 471 (do ((l (cdr poly) (cddr l))) 472 ((null l) t) 473 (or (numberp (cadr l)) 474 (and (eq (caadr l) *ivar*) 475 (punivarp (cadr l))) 476 (return nil)))) 477 478;; (REALONLY ROOTSL) 479;; 480;; Return only the elements of ROOTSL whose $IMAGPART simplifies to zero with 481;; SRATSIMP. (Note that this a subset of "the real roots", because SRATSIMP may 482;; not be able to check that a given expression is zero) 483(defun realonly (rootsl) 484 (remove-if-not (lambda (root) 485 (equal 0 (sratsimp ($imagpart (caddr root))))) 486 rootsl)) 487 488 489(defun presultant (p1 p2 var) 490 (cadr (ratf (simplify ($resultant (pdis p1) (pdis p2) (pdis (list var 1 1))))))) 491 492(defun ptimeftrs (l) 493 (prog (ll) 494 (setq ll (cddr l)) 495 (cond ((null ll) (return (car l))) 496 (t (return (ptimes (car l) (ptimeftrs ll))))))) 497 498;; (EBAKSUBST SOLNL LHSL) 499;; 500;; Substitute a solution for one variable back into the "left hand side 501;; list". If the equation had to be solved for multiple variables, this allows 502;; us to use the solution for a first variable to feed in to the equation for 503;; the next one along. 504;; 505;; As well as doing the obvious substitution, EBAKSUBST also simplifies with 506;; $RADCAN (presumably, E stands for Exponential) 507(defun ebaksubst (solnl lhsl) 508 (mapcar #'(lambda (q) (ebaksubst1 solnl q)) lhsl)) 509 510(defun ebaksubst1 (solnl q) 511 (let ((e ($substitute `((mlist) ,@solnl) (pdis q)))) 512 (setq e (simplify-after-subst e)) 513 (cadr (ratf e)))) 514 515(defun baksubst (solnl lhsl) 516 (setq lhsl (delete 't (mapcar #'(lambda (q) (car (merrset (baksubst1 solnl q)))) 517 lhsl) 518 :test #'eq)) ;catches arith. ovfl 519 (if (member nil lhsl :test #'eq) 520 (list nil) 521 lhsl)) 522 523(defun baksubst1 (solnl poly) 524 (let* (($keepfloat (not $realonly)) ;sturm1 needs poly with 525 (poly1 ;integer coefs 526 (cdr (ratf (what-the-$ev (pdis poly) 527 (cons '(mlist) solnl) 528 '$numer))))) 529 (cond ((and (complexnump (pdis (car poly1))) 530 (numberp (cdr poly1))) 531 (rootsp (cons '(mlist) solnl) 532 (list '(mlist) (pdis poly) (tayapprox poly)))) 533 (t (car poly1))))) 534 535(defun complexnump (p) 536 (let ((p (cadr (ratf ($ratsimp p))))) 537 (or (numberp p) 538 (eq (pdis (pget (car p))) '$%i)))) 539 540;; (SIMPLIFY-AFTER-SUBST EXPR) 541;; 542;; Simplify EXPR after substitution of a partial solution. 543;; 544;; Focus is on constant expressions: 545;; o failure to reduce a constant expression that is equivalent 546;; to zero causes solutions to be falsely rejected 547;; o some operations, such as the reduction of nested square roots, 548;; requires known sign and ordering of all terms 549;; o inappropriate simplification by $RADCAN introduced errors 550;; $radcan(sqrt(-1/(1+%i))) => exhausts heap 551;; $radcan(sqrt(6-3^(3/2))) > 0 => sqrt(sqrt(3)-2)*sqrt(3)*%i < 0 552;; 553;; Problems from bug reports showed that further simplification of 554;; non-constant terms, with incomplete information, could lead to 555;; missed roots or unwanted complexity. 556;; 557;; $ratsimp with algebraic:true can transform 558;; sqrt(2)*sqrt(-1/(sqrt(3)*%i+1)) => (sqrt(3)*%i)/2+1/2 559;; but $rectform is required for 560;; sqrt(sqrt(3)*%i-1)) => (sqrt(3)*%i)/sqrt(2)+1/sqrt(2) 561;; and $rootscontract is required for 562;; sqrt(34)-sqrt(2)*sqrt(17) => 0 563(defun simplify-after-subst (expr) 564 "Simplify expression after substitution" 565 (let (($keepfloat t) ($algebraic t) (e expr) 566 e1 e2 tmp (growth-factor 1.2) 567 (genvar nil) (varlist nil) 568 ($rootsconmode t) ($radexpand t)) 569 ;; Try two approaches 570 ;; 1) ratsimp 571 ;; 2) if $constantp(e) sqrtdenest + rectform + rootscontract + ratsimp 572 ;; take smallest expression 573 (setq e1 (sratsimp e)) 574 (if ($constantp e) 575 (progn 576 (setq e (sqrtdenest e)) 577 ;; Rectform does more than is wanted. A function that denests and 578 ;; rationalizes nested complex radicals would be better. 579 ;; Limit expression growth. The factor is based on trials. 580 (setq tmp ($rectform e)) 581 (when (< (conssize tmp) (* growth-factor (conssize e))) 582 (setq e tmp)) 583 (setq e ($rootscontract e)) 584 (setq e2 (sratsimp e)) 585 (if (< (conssize e1) (conssize e2)) e1 e2)) 586 e1))) 587 588;; (BAKALEVEL SOLNL LHSL VAR) 589;; 590;;; Recursively try to find a solution to the list of polynomials in LHSL. SOLNL 591;;; should be a non-empty list of partial solutions (for example, these might be 592;;; solutions we've already found for x when we're solving for x and y). 593;;; 594;;; BAKALEVEL works over each partial solution. This should itself be a list. If 595;;; it is non-nil, it is a list of equations for the variables we're trying to 596;;; solve for ("x = 3 + y" etc.). In this case, BAKALEVEL substitutes these 597;;; solutions into the system of equations and then tries to solve the 598;;; result. On success, it merges the partial solutions in SOLNL with those it 599;;; gets recursively. 600;;; 601;;; If a partial solution is nil, we don't yet have any partial information. If 602;;; there is only a single polynomial to solve in LHSL, we try to solve it in 603;;; the given variable, VAR. Otherwise we choose a variable of lowest degree 604;;; (with FINDLEASTVAR), solve for that (with CALLSOLVE) and then recurse. 605(defun bakalevel (solnl lhsl var) 606 (loop for q in solnl nconcing (bakalevel1 q lhsl var))) 607 608(defun bakalevel1 (solnl lhsl var) 609 (cond 610 ((not (exactonly solnl)) 611 (mergesoln solnl (apprsys (baksubst solnl lhsl)))) 612 (solnl 613 (mergesoln solnl (algsys (ebaksubst solnl lhsl)))) 614 ((cdr lhsl) 615 (let ((poly-and-var (findleastvar lhsl))) 616 (bakalevel (callsolve poly-and-var) 617 (remove (car poly-and-var) lhsl :test #'equal) 618 var))) 619 (t (callsolve (cons (car lhsl) var))))) 620 621;; (EVERY-ATOM PRED X) 622;; 623;; Evaluates to true if (PRED Y) is true for every atom Y in the cons tree X. 624(defun every-atom (pred x) 625 (if (atom x) 626 (funcall pred x) 627 (and (every-atom pred (car x)) 628 (every-atom pred (cdr x))))) 629 630;; (EXACTONLY SOLNL) 631;; 632;; True if the list of solutions doesn't contain any terms that look inexact 633;; (just floating point numbers, unless realonlyratnum is true) 634(defun exactonly (solnl) 635 (every-atom (lambda (x) 636 (and (not (floatp x)) 637 (or (null realonlyratnum) 638 (not (eq x 'rat))))) 639 solnl)) 640 641;; (MERGESOLN ASOLN SOLNL) 642;; 643;; For each solution S in SOLNL, evaluate each element of ASOLN in light of S 644;; and, collecting up the results and prepending them to S. If evaluating an 645;; element in light of S caused an error, ignore the combination of ASOLN and S. 646(defun mergesoln (asoln solnl) 647 (let ((unbind (cons bindlist loclist)) 648 (errorsw t)) 649 (macrolet ((catch-error-t (&body body) 650 `(let ((result (catch 'errorsw ,@body))) 651 (when (eq result t) 652 (errlfun1 unbind)) 653 result))) 654 (loop 655 for q in solnl 656 for result = 657 (catch-error-t 658 (append (mapcar (lambda (r) 659 (what-the-$ev r (cons '(mlist) q))) 660 asoln) 661 q)) 662 if (not (eq result t)) collect result)))) 663 664;; (CALLSOLVE PV) 665;; 666;; Try to solve a polynomial with respect to the given variable. PV is a cons 667;; pair (POLY . VAR). On success, return a list of solutions. Each solution is 668;; itself a list, whose elements are equalities (one for each variable in the 669;; equation). If we determine that there aren't any solutions, return '(NIL). 670;; 671;; If POLY is in more than one variable or if it can clearly be solved by the 672;; quadratic formula (BIQUADRATICP), we always call SOLVE to try to get an exact 673;; solution. Similarly if the user has set the $ALGEXACT variable to true. 674;; 675;; Otherwise, or if SOLVE fails, we try to find an approximate solution with a 676;; call to CALLAPPRS. 677;; 678;; SOLVE introduces solutions with nested radicals, which causes problems 679;; in EBAKSUBST1. Try to clean up the solutions now. 680(defun callsolve (pv) 681 (mapcar #'callsolve2 (callsolve1 pv))) 682 683(defun callsolve1 (pv) 684 (let ((poly (car pv)) 685 (var (cdr pv)) 686 (varlist varlist) 687 (genvar genvar) 688 (*roots nil) 689 (*failures nil) 690 ($programmode t)) 691 (cond ((or $algexact 692 (not (punivarp poly)) 693 (biquadraticp poly)) 694 ;; Call SOLVE to try to solve POLY. When it returns, the solutions it 695 ;; found end up in *ROOTS. *FAILURES contains expressions that, if 696 ;; solved, would lead to further solutions. 697 (solve (pdis poly) (pdis (list var 1 1)) 1) 698 (if (null (or *roots *failures)) 699 ;; We're certain there are no solutions 700 (list nil) 701 ;; Try to find approximate solutions to the terms that SOLVE gave 702 ;; up on (in *FAILURES) and remove any roots from SOLVE that 703 ;; aren't known to be real if $REALONLY is true. 704 (append (mapcan (lambda (q) 705 (callapprs (cadr (ratf (meqhk q))))) 706 (remove-mult *failures)) 707 (mapcar #'list 708 (if $realonly 709 (realonly (remove-mult *roots)) 710 (remove-mult *roots)))))) 711 (t (callapprs poly))))) 712 713(defun callsolve2 (l) 714 "Simplify solution returned by callsolve1" 715 ;; l is a single element list '((mequal simp) var expr) 716 (let ((e (first l))) 717 `(((,(mop e)) ,(second e) ,(simplify-after-subst (third e)))))) 718 719;;; (BIQUADRATICP POLY) 720;;; 721;;; Check whether POLY is biquadratic in its main variable: either of degree at 722;;; most two or of degree four and with only even powers. 723(defun biquadraticp (poly) 724 (or (atom poly) 725 (if algnotexact 726 (< (p-le poly) 2) 727 (or (< (p-le poly) 3) 728 (and (= (p-le poly) 4) (biquadp1 (p-red poly))))))) 729 730(defun biquadp1 (terms) 731 (or (null terms) 732 (and (or (= (pt-le terms) 2) (= (pt-le terms) 0)) 733 (biquadp1 (pt-red terms))))) 734 735;;; (CALLAPPRS POLY) 736;;; 737;;; Try to find approximate solutions to POLY, which should be a polynomial in a 738;;; single variable. Uses STURM1 if we're only after real roots (because 739;;; $REALONLY is set). Otherwise, calls $ALLROOTS. 740(defun callapprs (poly) 741 (unless (punivarp poly) 742 (merror (intl:gettext "algsys: Couldn't reduce system to a polynomial in one variable."))) 743 (let ($dispflag) 744 (if $realonly 745 (let ((dis-var (pdis (list (car poly) 1 1)))) 746 (mapcar #'(lambda (q) 747 (list (list '(mequal) dis-var (rflot q)))) 748 (sturm1 poly (cons 1 $algepsilon)))) 749 (mapcar #'list 750 (let* (($programmode t) 751 (roots (cdr ($allroots (pdis poly))))) 752 (if (eq (caaar roots) 'mequal) 753 roots 754 (cdr roots))))))) 755 756(defun apprsys (lhsl) 757 (cond ((null lhsl) (list nil)) 758 (t 759 (do ((tlhsl lhsl (cdr tlhsl))) (nil) 760 (cond ((null tlhsl) 761 ;; SHOULD TRY TO BE MORE SPECIFIC: "TOO COMPLICATED" IN WHAT SENSE?? 762 (merror (intl:gettext "algsys: system too complicated; give up."))) 763 ((pconstp (car tlhsl)) (return nil)) 764 ((punivarp (car tlhsl)) 765 (return (bakalevel (callapprs (car tlhsl)) 766 lhsl nil)))))))) 767 768(defun tayapprox (p) 769 (cons '(mplus) 770 (mapcar #'(lambda (x) 771 (list '(mycabs) (pdis (ptimes (list x 1 1) 772 (pderivative p x))))) 773 (listovars p)))) 774 775(defun mycabs (x) 776 (and (complexnump x) (cabs x))) 777 778;;; (DISTREP LOL) 779;;; 780;;; Take selections from LOL, a list of lists, using COMBINEY. When used by 781;;; ALGSYS, the elements of the lists are per-equation solutions for some system 782;;; of equations. COMBINEY combines the per-equation solutions into prospective 783;;; solutions for the entire system. 784;;; 785;;; These prospective solutions are then filtered with CONDENSESOLNL, which 786;;; discards special cases of more general solutions. 787;;; 788;;; (I don't understand why this reversal has to be here, but we get properly 789;;; wrong solutions to some of the testsuite functions without it. Come back to 790;;; this... RJS 1/2015) 791(defun distrep (lol) 792 (condensesolnl (mapcar #'reverse (combiney lol)))) 793 794(defun exclude (l1 l2) 795 (cond ((null l2) 796 nil) 797 ((member (car l2) l1 :test #'equal) 798 (exclude l1 (cdr l2))) 799 (t 800 (cons (car l2) (exclude l1 (cdr l2)))))) 801