cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-alg.el

   1 ;; Calculator for GNU Emacs, part II [calc-alg.el]
   2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
   3 ;; Written by Dave Gillespie, daveg@synaptics.com.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is distributed in the hope that it will be useful,
   8 ;; but WITHOUT ANY WARRANTY.  No author or distributor
   9 ;; accepts responsibility to anyone for the consequences of using it
  10 ;; or for whether it serves any particular purpose or works at all,
  11 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12 ;; License for full details.
  13
  14 ;; Everyone is granted permission to copy, modify and redistribute
  15 ;; GNU Emacs, but only under the conditions described in the
  16 ;; GNU Emacs General Public License.   A copy of this license is
  17 ;; supposed to have been given to you along with GNU Emacs so you
  18 ;; can know your rights and responsibilities.  It should be in a
  19 ;; file named COPYING.  Among other things, the copyright notice
  20 ;; and this notice must be preserved on all copies.
  21
  22
  23
  24 ;; This file is autoloaded from calc-ext.el.
  25 (require 'calc-ext)
  26
  27 (require 'calc-macs)
  28
  29 (defun calc-Need-calc-alg () nil)
  30
  31
  32 ;;; Algebra commands.
  33
  34 (defun calc-alg-evaluate (arg)
  35   (interactive "p")
  36   (calc-slow-wrapper
  37    (calc-with-default-simplification
  38     (let ((math-simplify-only nil))
  39       (calc-modify-simplify-mode arg)
  40       (calc-enter-result 1 "dsmp" (calc-top 1)))))
  41 )
  42
  43 (defun calc-modify-simplify-mode (arg)
  44   (if (= (math-abs arg) 2)
  45       (setq calc-simplify-mode 'alg)
  46     (if (>= (math-abs arg) 3)
  47         (setq calc-simplify-mode 'ext)))
  48   (if (< arg 0)
  49       (setq calc-simplify-mode (list calc-simplify-mode)))
  50 )
  51
  52 (defun calc-simplify ()
  53   (interactive)
  54   (calc-slow-wrapper
  55    (calc-with-default-simplification
  56     (calc-enter-result 1 "simp" (math-simplify (calc-top-n 1)))))
  57 )
  58
  59 (defun calc-simplify-extended ()
  60   (interactive)
  61   (calc-slow-wrapper
  62    (calc-with-default-simplification
  63     (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1)))))
  64 )
  65
  66 (defun calc-expand-formula (arg)
  67   (interactive "p")
  68   (calc-slow-wrapper
  69    (calc-with-default-simplification
  70     (let ((math-simplify-only nil))
  71       (calc-modify-simplify-mode arg)
  72       (calc-enter-result 1 "expf"
  73                          (if (> arg 0)
  74                              (let ((math-expand-formulas t))
  75                                (calc-top-n 1))
  76                            (let ((top (calc-top-n 1)))
  77                              (or (math-expand-formula top)
  78                                  top)))))))
  79 )
  80
  81 (defun calc-factor (arg)
  82   (interactive "P")
  83   (calc-slow-wrapper
  84    (calc-unary-op "fctr" (if (calc-is-hyperbolic)
  85                              'calcFunc-factors 'calcFunc-factor)
  86                   arg))
  87 )
  88
  89 (defun calc-expand (n)
  90   (interactive "P")
  91   (calc-slow-wrapper
  92    (calc-enter-result 1 "expa"
  93                       (append (list 'calcFunc-expand
  94                                     (calc-top-n 1))
  95                               (and n (list (prefix-numeric-value n))))))
  96 )
  97
  98 (defun calc-collect (&optional var)
  99   (interactive "sCollect terms involving: ")
 100   (calc-slow-wrapper
 101    (if (or (equal var "") (equal var "$") (null var))
 102        (calc-enter-result 2 "clct" (cons 'calcFunc-collect
 103                                          (calc-top-list-n 2)))
 104      (let ((var (math-read-expr var)))
 105        (if (eq (car-safe var) 'error)
 106            (error "Bad format in expression: %s" (nth 1 var)))
 107        (calc-enter-result 1 "clct" (list 'calcFunc-collect
 108                                          (calc-top-n 1)
 109                                          var)))))
 110 )
 111
 112 (defun calc-apart (arg)
 113   (interactive "P")
 114   (calc-slow-wrapper
 115    (calc-unary-op "aprt" 'calcFunc-apart arg))
 116 )
 117
 118 (defun calc-normalize-rat (arg)
 119   (interactive "P")
 120   (calc-slow-wrapper
 121    (calc-unary-op "nrat" 'calcFunc-nrat arg))
 122 )
 123
 124 (defun calc-poly-gcd (arg)
 125   (interactive "P")
 126   (calc-slow-wrapper
 127    (calc-binary-op "pgcd" 'calcFunc-pgcd arg))
 128 )
 129
 130 (defun calc-poly-div (arg)
 131   (interactive "P")
 132   (calc-slow-wrapper
 133    (setq calc-poly-div-remainder nil)
 134    (calc-binary-op "pdiv" 'calcFunc-pdiv arg)
 135    (if (and calc-poly-div-remainder (null arg))
 136        (progn
 137          (calc-clear-command-flag 'clear-message)
 138          (calc-record calc-poly-div-remainder "prem")
 139          (if (not (Math-zerop calc-poly-div-remainder))
 140              (message "(Remainder was %s)"
 141                       (math-format-flat-expr calc-poly-div-remainder 0))
 142            (message "(No remainder)")))))
 143 )
 144
 145 (defun calc-poly-rem (arg)
 146   (interactive "P")
 147   (calc-slow-wrapper
 148    (calc-binary-op "prem" 'calcFunc-prem arg))
 149 )
 150
 151 (defun calc-poly-div-rem (arg)
 152   (interactive "P")
 153   (calc-slow-wrapper
 154    (if (calc-is-hyperbolic)
 155        (calc-binary-op "pdvr" 'calcFunc-pdivide arg)
 156      (calc-binary-op "pdvr" 'calcFunc-pdivrem arg)))
 157 )
 158
 159 (defun calc-substitute (&optional oldname newname)
 160   (interactive "sSubstitute old: ")
 161   (calc-slow-wrapper
 162    (let (old new (num 1) expr)
 163      (if (or (equal oldname "") (equal oldname "$") (null oldname))
 164          (setq new (calc-top-n 1)
 165                old (calc-top-n 2)
 166                expr (calc-top-n 3)
 167                num 3)
 168        (or newname
 169            (progn (calc-unread-command ?\C-a)
 170                   (setq newname (read-string (concat "Substitute old: "
 171                                                      oldname
 172                                                      ", new: ")
 173                                              oldname))))
 174        (if (or (equal newname "") (equal newname "$") (null newname))
 175            (setq new (calc-top-n 1)
 176                  expr (calc-top-n 2)
 177                  num 2)
 178          (setq new (if (stringp newname) (math-read-expr newname) newname))
 179          (if (eq (car-safe new) 'error)
 180              (error "Bad format in expression: %s" (nth 1 new)))
 181          (setq expr (calc-top-n 1)))
 182        (setq old (if (stringp oldname) (math-read-expr oldname) oldname))
 183        (if (eq (car-safe old) 'error)
 184            (error "Bad format in expression: %s" (nth 1 old)))
 185        (or (math-expr-contains expr old)
 186            (error "No occurrences found.")))
 187      (calc-enter-result num "sbst" (math-expr-subst expr old new))))
 188 )
 189
 190
 191 (defun calc-has-rules (name)
 192   (setq name (calc-var-value name))
 193   (and (consp name)
 194        (memq (car name) '(vec calcFunc-assign calcFunc-condition))
 195        name)
 196 )
 197
 198 (defun math-recompile-eval-rules ()
 199   (setq math-eval-rules-cache (and (calc-has-rules 'var-EvalRules)
 200                                    (math-compile-rewrites
 201                                     '(var EvalRules var-EvalRules)))
 202         math-eval-rules-cache-other (assq nil math-eval-rules-cache)
 203         math-eval-rules-cache-tag (calc-var-value 'var-EvalRules))
 204 )
 205
 206
 207 ;;; Try to expand a formula according to its definition.
 208 (defun math-expand-formula (expr)
 209   (and (consp expr)
 210        (symbolp (car expr))
 211        (or (get (car expr) 'calc-user-defn)
 212            (get (car expr) 'math-expandable))
 213        (let ((res (let ((math-expand-formulas t))
 214                     (apply (car expr) (cdr expr)))))
 215          (and (not (eq (car-safe res) (car expr)))
 216               res)))
 217 )
 218
 219
 220
 221
 222 ;;; True if A comes before B in a canonical ordering of expressions.  [P X X]
 223 (defun math-beforep (a b)   ; [Public]
 224   (cond ((and (Math-realp a) (Math-realp b))
 225          (let ((comp (math-compare a b)))
 226            (or (eq comp -1)
 227                (and (eq comp 0)
 228                     (not (equal a b))
 229                     (> (length (memq (car-safe a)
 230                                      '(bigneg nil bigpos frac float)))
 231                        (length (memq (car-safe b)
 232                                      '(bigneg nil bigpos frac float))))))))
 233         ((equal b '(neg (var inf var-inf))) nil)
 234         ((equal a '(neg (var inf var-inf))) t)
 235         ((equal a '(var inf var-inf)) nil)
 236         ((equal b '(var inf var-inf)) t)
 237         ((Math-realp a)
 238          (if (and (eq (car-safe b) 'intv) (math-intv-constp b))
 239              (if (or (math-beforep a (nth 2 b)) (Math-equal a (nth 2 b)))
 240                  t
 241                nil)
 242            t))
 243         ((Math-realp b)
 244          (if (and (eq (car-safe a) 'intv) (math-intv-constp a))
 245              (if (math-beforep (nth 2 a) b)
 246                  t
 247                nil)
 248            nil))
 249         ((and (eq (car a) 'intv) (eq (car b) 'intv)
 250               (math-intv-constp a) (math-intv-constp b))
 251          (let ((comp (math-compare (nth 2 a) (nth 2 b))))
 252            (cond ((eq comp -1) t)
 253                  ((eq comp 1) nil)
 254                  ((and (memq (nth 1 a) '(2 3)) (memq (nth 1 b) '(0 1))) t)
 255                  ((and (memq (nth 1 a) '(0 1)) (memq (nth 1 b) '(2 3))) nil)
 256                  ((eq (setq comp (math-compare (nth 3 a) (nth 3 b))) -1) t)
 257                  ((eq comp 1) nil)
 258                  ((and (memq (nth 1 a) '(0 2)) (memq (nth 1 b) '(1 3))) t)
 259                  (t nil))))
 260         ((not (eq (not (Math-objectp a)) (not (Math-objectp b))))
 261          (Math-objectp a))
 262         ((eq (car a) 'var)
 263          (if (eq (car b) 'var)
 264              (string-lessp (symbol-name (nth 1 a)) (symbol-name (nth 1 b)))
 265            (not (Math-numberp b))))
 266         ((eq (car b) 'var) (Math-numberp a))
 267         ((eq (car a) (car b))
 268          (while (and (setq a (cdr a) b (cdr b)) a
 269                      (equal (car a) (car b))))
 270          (and b
 271               (or (null a)
 272                   (math-beforep (car a) (car b)))))
 273         (t (string-lessp (symbol-name (car a)) (symbol-name (car b)))))
 274 )
 275
 276
 277 (defun math-simplify-extended (a)
 278   (let ((math-living-dangerously t))
 279     (math-simplify a))
 280 )
 281 (fset 'calcFunc-esimplify (symbol-function 'math-simplify-extended))
 282
 283 (defun math-simplify (top-expr)
 284   (let ((math-simplifying t)
 285         (top-only (consp calc-simplify-mode))
 286         (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules)
 287                                  '((var AlgSimpRules var-AlgSimpRules)))
 288                             (and math-living-dangerously
 289                                  (calc-has-rules 'var-ExtSimpRules)
 290                                  '((var ExtSimpRules var-ExtSimpRules)))
 291                             (and math-simplifying-units
 292                                  (calc-has-rules 'var-UnitSimpRules)
 293                                  '((var UnitSimpRules var-UnitSimpRules)))
 294                             (and math-integrating
 295                                  (calc-has-rules 'var-IntegSimpRules)
 296                                  '((var IntegSimpRules var-IntegSimpRules)))))
 297         res)
 298     (if top-only
 299         (let ((r simp-rules))
 300           (setq res (math-simplify-step (math-normalize top-expr))
 301                 calc-simplify-mode '(nil)
 302                 top-expr (math-normalize res))
 303           (while r
 304             (setq top-expr (math-rewrite top-expr (car r)
 305                                          '(neg (var inf var-inf)))
 306                   r (cdr r))))
 307       (calc-with-default-simplification
 308        (while (let ((r simp-rules))
 309                 (setq res (math-normalize top-expr))
 310                 (while r
 311                   (setq res (math-rewrite res (car r))
 312                         r (cdr r)))
 313                 (not (equal top-expr (setq res (math-simplify-step res)))))
 314          (setq top-expr res)))))
 315   top-expr
 316 )
 317 (fset 'calcFunc-simplify (symbol-function 'math-simplify))
 318
 319 ;;; The following has a "bug" in that if any recursive simplifications
 320 ;;; occur only the first handler will be tried; this doesn't really
 321 ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
 322 (defun math-simplify-step (a)
 323   (if (Math-primp a)
 324       a
 325     (let ((aa (if (or top-only
 326                       (memq (car a) '(calcFunc-quote calcFunc-condition
 327                                                      calcFunc-evalto)))
 328                   a
 329                 (cons (car a) (mapcar 'math-simplify-step (cdr a))))))
 330       (and (symbolp (car aa))
 331            (let ((handler (get (car aa) 'math-simplify)))
 332              (and handler
 333                   (while (and handler
 334                               (equal (setq aa (or (funcall (car handler) aa)
 335                                                   aa))
 336                                      a))
 337                     (setq handler (cdr handler))))))
 338       aa))
 339 )
 340
 341
 342 (defun math-need-std-simps ()
 343   ;; Placeholder, to synchronize autoloading.
 344 )
 345
 346 (math-defsimplify (+ -)
 347   (math-simplify-plus))
 348
 349 (defun math-simplify-plus ()
 350   (cond ((and (memq (car-safe (nth 1 expr)) '(+ -))
 351               (Math-numberp (nth 2 (nth 1 expr)))
 352               (not (Math-numberp (nth 2 expr))))
 353          (let ((x (nth 2 expr))
 354                (op (car expr)))
 355            (setcar (cdr (cdr expr)) (nth 2 (nth 1 expr)))
 356            (setcar expr (car (nth 1 expr)))
 357            (setcar (cdr (cdr (nth 1 expr))) x)
 358            (setcar (nth 1 expr) op)))
 359         ((and (eq (car expr) '+)
 360               (Math-numberp (nth 1 expr))
 361               (not (Math-numberp (nth 2 expr))))
 362          (let ((x (nth 2 expr)))
 363            (setcar (cdr (cdr expr)) (nth 1 expr))
 364            (setcar (cdr expr) x))))
 365   (let ((aa expr)
 366         aaa temp)
 367     (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
 368       (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 expr)
 369                                        (eq (car aaa) '-) (eq (car expr) '-) t))
 370           (progn
 371             (setcar (cdr (cdr expr)) temp)
 372             (setcar expr '+)
 373             (setcar (cdr (cdr aaa)) 0)))
 374       (setq aa (nth 1 aa)))
 375     (if (setq temp (math-combine-sum aaa (nth 2 expr)
 376                                      nil (eq (car expr) '-) t))
 377         (progn
 378           (setcar (cdr (cdr expr)) temp)
 379           (setcar expr '+)
 380           (setcar (cdr aa) 0)))
 381     expr)
 382 )
 383
 384 (math-defsimplify *
 385   (math-simplify-times))
 386
 387 (defun math-simplify-times ()
 388   (if (eq (car-safe (nth 2 expr)) '*)
 389       (and (math-beforep (nth 1 (nth 2 expr)) (nth 1 expr))
 390            (or (math-known-scalarp (nth 1 expr) t)
 391                (math-known-scalarp (nth 1 (nth 2 expr)) t))
 392            (let ((x (nth 1 expr)))
 393              (setcar (cdr expr) (nth 1 (nth 2 expr)))
 394              (setcar (cdr (nth 2 expr)) x)))
 395     (and (math-beforep (nth 2 expr) (nth 1 expr))
 396          (or (math-known-scalarp (nth 1 expr) t)
 397              (math-known-scalarp (nth 2 expr) t))
 398          (let ((x (nth 2 expr)))
 399            (setcar (cdr (cdr expr)) (nth 1 expr))
 400            (setcar (cdr expr) x))))
 401   (let ((aa expr)
 402         aaa temp
 403         (safe t) (scalar (math-known-scalarp (nth 1 expr))))
 404     (if (and (Math-ratp (nth 1 expr))
 405              (setq temp (math-common-constant-factor (nth 2 expr))))
 406         (progn
 407           (setcar (cdr (cdr expr))
 408                   (math-cancel-common-factor (nth 2 expr) temp))
 409           (setcar (cdr expr) (math-mul (nth 1 expr) temp))))
 410     (while (and (eq (car-safe (setq aaa (nth 2 aa))) '*)
 411                 safe)
 412       (if (setq temp (math-combine-prod (nth 1 expr) (nth 1 aaa) nil nil t))
 413           (progn
 414             (setcar (cdr expr) temp)
 415             (setcar (cdr aaa) 1)))
 416       (setq safe (or scalar (math-known-scalarp (nth 1 aaa) t))
 417             aa (nth 2 aa)))
 418     (if (and (setq temp (math-combine-prod aaa (nth 1 expr) nil nil t))
 419              safe)
 420         (progn
 421           (setcar (cdr expr) temp)
 422           (setcar (cdr (cdr aa)) 1)))
 423     (if (and (eq (car-safe (nth 1 expr)) 'frac)
 424              (memq (nth 1 (nth 1 expr)) '(1 -1)))
 425         (math-div (math-mul (nth 2 expr) (nth 1 (nth 1 expr)))
 426                   (nth 2 (nth 1 expr)))
 427       expr))
 428 )
 429
 430 (math-defsimplify /
 431   (math-simplify-divide))
 432
 433 (defun math-simplify-divide ()
 434   (let ((np (cdr expr))
 435         (nover nil)
 436         (nn (and (or (eq (car expr) '/) (not (Math-realp (nth 2 expr))))
 437                  (math-common-constant-factor (nth 2 expr))))
 438         n op)
 439     (if nn
 440         (progn
 441           (setq n (and (or (eq (car expr) '/) (not (Math-realp (nth 1 expr))))
 442                        (math-common-constant-factor (nth 1 expr))))
 443           (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n))
 444               (progn
 445                 (setcar (cdr expr) (math-mul (nth 2 nn) (nth 1 expr)))
 446                 (setcar (cdr (cdr expr))
 447                         (math-cancel-common-factor (nth 2 expr) nn))
 448                 (if (and (math-negp nn)
 449                          (setq op (assq (car expr) calc-tweak-eqn-table)))
 450                     (setcar expr (nth 1 op))))
 451             (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
 452                 (progn
 453                   (setcar (cdr expr)
 454                           (math-cancel-common-factor (nth 1 expr) n))
 455                   (setcar (cdr (cdr expr))
 456                           (math-cancel-common-factor (nth 2 expr) n))
 457                   (if (and (math-negp n)
 458                            (setq op (assq (car expr) calc-tweak-eqn-table)))
 459                       (setcar expr (nth 1 op))))))))
 460     (if (and (eq (car-safe (car np)) '/)
 461              (math-known-scalarp (nth 2 expr) t))
 462         (progn
 463           (setq np (cdr (nth 1 expr)))
 464           (while (eq (car-safe (setq n (car np))) '*)
 465             (and (math-known-scalarp (nth 2 n) t)
 466                  (math-simplify-divisor (cdr n) (cdr (cdr expr)) nil t))
 467             (setq np (cdr (cdr n))))
 468           (math-simplify-divisor np (cdr (cdr expr)) nil t)
 469           (setq nover t
 470                 np (cdr (cdr (nth 1 expr))))))
 471     (while (eq (car-safe (setq n (car np))) '*)
 472       (and (math-known-scalarp (nth 2 n) t)
 473            (math-simplify-divisor (cdr n) (cdr (cdr expr)) nover t))
 474       (setq np (cdr (cdr n))))
 475     (math-simplify-divisor np (cdr (cdr expr)) nover t)
 476     expr)
 477 )
 478
 479 (defun math-simplify-divisor (np dp nover dover)
 480   (cond ((eq (car-safe (car dp)) '/)
 481          (math-simplify-divisor np (cdr (car dp)) nover dover)
 482          (and (math-known-scalarp (nth 1 (car dp)) t)
 483               (math-simplify-divisor np (cdr (cdr (car dp)))
 484                                      nover (not dover))))
 485         ((or (or (eq (car expr) '/)
 486                  (let ((signs (math-possible-signs (car np))))
 487                    (or (memq signs '(1 4))
 488                        (and (memq (car expr) '(calcFunc-eq calcFunc-neq))
 489                             (eq signs 5))
 490                        math-living-dangerously)))
 491              (math-numberp (car np)))
 492          (let ((n (car np))
 493                d dd temp op
 494                (safe t) (scalar (math-known-scalarp n)))
 495            (while (and (eq (car-safe (setq d (car dp))) '*)
 496                        safe)
 497              (math-simplify-one-divisor np (cdr d))
 498              (setq safe (or scalar (math-known-scalarp (nth 1 d) t))
 499                    dp (cdr (cdr d))))
 500            (if safe
 501                (math-simplify-one-divisor np dp)))))
 502 )
 503
 504 (defun math-simplify-one-divisor (np dp)
 505   (if (setq temp (math-combine-prod (car np) (car dp) nover dover t))
 506       (progn
 507         (and (not (memq (car expr) '(/ calcFunc-eq calcFunc-neq)))
 508              (math-known-negp (car dp))
 509              (setq op (assq (car expr) calc-tweak-eqn-table))
 510              (setcar expr (nth 1 op)))
 511         (setcar np (if nover (math-div 1 temp) temp))
 512         (setcar dp 1))
 513     (and dover (not nover) (eq (car expr) '/)
 514          (eq (car-safe (car dp)) 'calcFunc-sqrt)
 515          (Math-integerp (nth 1 (car dp)))
 516          (progn
 517            (setcar np (math-mul (car np)
 518                                 (list 'calcFunc-sqrt (nth 1 (car dp)))))
 519            (setcar dp (nth 1 (car dp))))))
 520 )
 521
 522 (defun math-common-constant-factor (expr)
 523   (if (Math-realp expr)
 524       (if (Math-ratp expr)
 525           (and (not (memq expr '(0 1 -1)))
 526                (math-abs expr))
 527         (if (math-ratp (setq expr (math-to-simple-fraction expr)))
 528             (math-common-constant-factor expr)))
 529     (if (memq (car expr) '(+ - cplx sdev))
 530         (let ((f1 (math-common-constant-factor (nth 1 expr)))
 531               (f2 (math-common-constant-factor (nth 2 expr))))
 532           (and f1 f2
 533                (not (eq (setq f1 (math-frac-gcd f1 f2)) 1))
 534                f1))
 535       (if (memq (car expr) '(* polar))
 536           (math-common-constant-factor (nth 1 expr))
 537         (if (eq (car expr) '/)
 538             (or (math-common-constant-factor (nth 1 expr))
 539                 (and (Math-integerp (nth 2 expr))
 540                      (list 'frac 1 (math-abs (nth 2 expr)))))))))
 541 )
 542
 543 (defun math-cancel-common-factor (expr val)
 544   (if (memq (car-safe expr) '(+ - cplx sdev))
 545       (progn
 546         (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val))
 547         (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val))
 548         expr)
 549     (if (eq (car-safe expr) '*)
 550         (math-mul (math-cancel-common-factor (nth 1 expr) val) (nth 2 expr))
 551       (math-div expr val)))
 552 )
 553
 554 (defun math-frac-gcd (a b)
 555   (if (Math-zerop a)
 556       b
 557     (if (Math-zerop b)
 558         a
 559       (if (and (Math-integerp a)
 560                (Math-integerp b))
 561           (math-gcd a b)
 562         (and (Math-integerp a) (setq a (list 'frac a 1)))
 563         (and (Math-integerp b) (setq b (list 'frac b 1)))
 564         (math-make-frac (math-gcd (nth 1 a) (nth 1 b))
 565                         (math-gcd (nth 2 a) (nth 2 b))))))
 566 )
 567
 568 (math-defsimplify %
 569   (math-simplify-mod))
 570
 571 (defun math-simplify-mod ()
 572   (and (Math-realp (nth 2 expr))
 573        (Math-posp (nth 2 expr))
 574        (let ((lin (math-is-linear (nth 1 expr)))
 575              t1 t2 t3)
 576          (or (and lin
 577                   (or (math-negp (car lin))
 578                       (not (Math-lessp (car lin) (nth 2 expr))))
 579                   (list '%
 580                         (list '+
 581                               (math-mul (nth 1 lin) (nth 2 lin))
 582                               (math-mod (car lin) (nth 2 expr)))
 583                         (nth 2 expr)))
 584              (and lin
 585                   (not (math-equal-int (nth 1 lin) 1))
 586                   (math-num-integerp (nth 1 lin))
 587                   (math-num-integerp (nth 2 expr))
 588                   (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 expr)))
 589                   (not (math-equal-int t1 1))
 590                   (list '*
 591                         t1
 592                         (list '%
 593                               (list '+
 594                                     (math-mul (math-div (nth 1 lin) t1)
 595                                               (nth 2 lin))
 596                                     (let ((calc-prefer-frac t))
 597                                       (math-div (car lin) t1)))
 598                               (math-div (nth 2 expr) t1))))
 599              (and (math-equal-int (nth 2 expr) 1)
 600                   (math-known-integerp (if lin
 601                                            (math-mul (nth 1 lin) (nth 2 lin))
 602                                          (nth 1 expr)))
 603                   (if lin (math-mod (car lin) 1) 0)))))
 604 )
 605
 606 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
 607                                calcFunc-gt calcFunc-leq calcFunc-geq)
 608   (if (= (length expr) 3)
 609       (math-simplify-ineq)))
 610
 611 (defun math-simplify-ineq ()
 612   (let ((np (cdr expr))
 613         n)
 614     (while (memq (car-safe (setq n (car np))) '(+ -))
 615       (math-simplify-add-term (cdr (cdr n)) (cdr (cdr expr))
 616                               (eq (car n) '-) nil)
 617       (setq np (cdr n)))
 618     (math-simplify-add-term np (cdr (cdr expr)) nil (eq np (cdr expr)))
 619     (math-simplify-divide)
 620     (let ((signs (math-possible-signs (cons '- (cdr expr)))))
 621       (or (cond ((eq (car expr) 'calcFunc-eq)
 622                  (or (and (eq signs 2) 1)
 623                      (and (memq signs '(1 4 5)) 0)))
 624                 ((eq (car expr) 'calcFunc-neq)
 625                  (or (and (eq signs 2) 0)
 626                      (and (memq signs '(1 4 5)) 1)))
 627                 ((eq (car expr) 'calcFunc-lt)
 628                  (or (and (eq signs 1) 1)
 629                      (and (memq signs '(2 4 6)) 0)))
 630                 ((eq (car expr) 'calcFunc-gt)
 631                  (or (and (eq signs 4) 1)
 632                      (and (memq signs '(1 2 3)) 0)))
 633                 ((eq (car expr) 'calcFunc-leq)
 634                  (or (and (eq signs 4) 0)
 635                      (and (memq signs '(1 2 3)) 1)))
 636                 ((eq (car expr) 'calcFunc-geq)
 637                  (or (and (eq signs 1) 0)
 638                      (and (memq signs '(2 4 6)) 1))))
 639           expr)))
 640 )
 641
 642 (defun math-simplify-add-term (np dp minus lplain)
 643   (or (math-vectorp (car np))
 644       (let ((rplain t)
 645             n d dd temp)
 646         (while (memq (car-safe (setq n (car np) d (car dp))) '(+ -))
 647           (setq rplain nil)
 648           (if (setq temp (math-combine-sum n (nth 2 d)
 649                                            minus (eq (car d) '+) t))
 650               (if (or lplain (eq (math-looks-negp temp) minus))
 651                   (progn
 652                     (setcar np (setq n (if minus (math-neg temp) temp)))
 653                     (setcar (cdr (cdr d)) 0))
 654                 (progn
 655                   (setcar np 0)
 656                   (setcar (cdr (cdr d)) (setq n (if (eq (car d) '+)
 657                                                     (math-neg temp)
 658                                                   temp))))))
 659           (setq dp (cdr d)))
 660         (if (setq temp (math-combine-sum n d minus t t))
 661             (if (or lplain
 662                     (and (not rplain)
 663                          (eq (math-looks-negp temp) minus)))
 664                 (progn
 665                   (setcar np (setq n (if minus (math-neg temp) temp)))
 666                   (setcar dp 0))
 667               (progn
 668                 (setcar np 0)
 669                 (setcar dp (setq n (math-neg temp))))))))
 670 )
 671
 672 (math-defsimplify calcFunc-sin
 673   (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
 674            (nth 1 (nth 1 expr)))
 675       (and (math-looks-negp (nth 1 expr))
 676            (math-neg (list 'calcFunc-sin (math-neg (nth 1 expr)))))
 677       (and (eq calc-angle-mode 'rad)
 678            (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
 679              (and n
 680                   (math-known-sin (car n) (nth 1 n) 120 0))))
 681       (and (eq calc-angle-mode 'deg)
 682            (let ((n (math-integer-plus (nth 1 expr))))
 683              (and n
 684                   (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))
 685       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
 686            (list 'calcFunc-sqrt (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))
 687       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
 688            (math-div (nth 1 (nth 1 expr))
 689                      (list 'calcFunc-sqrt
 690                            (math-add 1 (math-sqr (nth 1 (nth 1 expr)))))))
 691       (let ((m (math-should-expand-trig (nth 1 expr))))
 692         (and m (integerp (car m))
 693              (let ((n (car m)) (a (nth 1 m)))
 694                (list '+
 695                      (list '* (list 'calcFunc-sin (list '* (1- n) a))
 696                            (list 'calcFunc-cos a))
 697                      (list '* (list 'calcFunc-cos (list '* (1- n) a))
 698                            (list 'calcFunc-sin a)))))))
 699 )
 700
 701 (math-defsimplify calcFunc-cos
 702   (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
 703            (nth 1 (nth 1 expr)))
 704       (and (math-looks-negp (nth 1 expr))
 705            (list 'calcFunc-cos (math-neg (nth 1 expr))))
 706       (and (eq calc-angle-mode 'rad)
 707            (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
 708              (and n
 709                   (math-known-sin (car n) (nth 1 n) 120 300))))
 710       (and (eq calc-angle-mode 'deg)
 711            (let ((n (math-integer-plus (nth 1 expr))))
 712              (and n
 713                   (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))
 714       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
 715            (list 'calcFunc-sqrt (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))
 716       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
 717            (math-div 1
 718                      (list 'calcFunc-sqrt
 719                            (math-add 1 (math-sqr (nth 1 (nth 1 expr)))))))
 720       (let ((m (math-should-expand-trig (nth 1 expr))))
 721         (and m (integerp (car m))
 722              (let ((n (car m)) (a (nth 1 m)))
 723                (list '-
 724                      (list '* (list 'calcFunc-cos (list '* (1- n) a))
 725                            (list 'calcFunc-cos a))
 726                      (list '* (list 'calcFunc-sin (list '* (1- n) a))
 727                            (list 'calcFunc-sin a)))))))
 728 )
 729
 730 (defun math-should-expand-trig (x &optional hyperbolic)
 731   (let ((m (math-is-multiple x)))
 732     (and math-living-dangerously
 733          m (or (and (integerp (car m)) (> (car m) 1))
 734                (equal (car m) '(frac 1 2)))
 735          (or math-integrating
 736              (memq (car-safe (nth 1 m))
 737                    (if hyperbolic
 738                        '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)
 739                      '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan)))
 740              (and (eq (car-safe (nth 1 m)) 'calcFunc-ln)
 741                   (eq hyperbolic 'exp)))
 742          m))
 743 )
 744
 745 (defun math-known-sin (plus n mul off)
 746   (setq n (math-mul n mul))
 747   (and (math-num-integerp n)
 748        (setq n (math-mod (math-add (math-trunc n) off) 240))
 749        (if (>= n 120)
 750            (and (setq n (math-known-sin plus (- n 120) 1 0))
 751                 (math-neg n))
 752          (if (> n 60)
 753              (setq n (- 120 n)))
 754          (if (math-zerop plus)
 755              (and (or calc-symbolic-mode
 756                       (memq n '(0 20 60)))
 757                   (cdr (assq n
 758                              '( (0 . 0)
 759                                 (10 . (/ (calcFunc-sqrt
 760                                           (- 2 (calcFunc-sqrt 3))) 2))
 761                                 (12 . (/ (- (calcFunc-sqrt 5) 1) 4))
 762                                 (15 . (/ (calcFunc-sqrt
 763                                           (- 2 (calcFunc-sqrt 2))) 2))
 764                                 (20 . (/ 1 2))
 765                                 (24 . (* (^ (/ 1 2) (/ 3 2))
 766                                          (calcFunc-sqrt
 767                                           (- 5 (calcFunc-sqrt 5)))))
 768                                 (30 . (/ (calcFunc-sqrt 2) 2))
 769                                 (36 . (/ (+ (calcFunc-sqrt 5) 1) 4))
 770                                 (40 . (/ (calcFunc-sqrt 3) 2))
 771                                 (45 . (/ (calcFunc-sqrt
 772                                           (+ 2 (calcFunc-sqrt 2))) 2))
 773                                 (48 . (* (^ (/ 1 2) (/ 3 2))
 774                                          (calcFunc-sqrt
 775                                           (+ 5 (calcFunc-sqrt 5)))))
 776                                 (50 . (/ (calcFunc-sqrt
 777                                           (+ 2 (calcFunc-sqrt 3))) 2))
 778                                 (60 . 1)))))
 779            (cond ((eq n 0) (math-normalize (list 'calcFunc-sin plus)))
 780                  ((eq n 60) (math-normalize (list 'calcFunc-cos plus)))
 781                  (t nil)))))
 782 )
 783
 784 (math-defsimplify calcFunc-tan
 785   (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
 786            (nth 1 (nth 1 expr)))
 787       (and (math-looks-negp (nth 1 expr))
 788            (math-neg (list 'calcFunc-tan (math-neg (nth 1 expr)))))
 789       (and (eq calc-angle-mode 'rad)
 790            (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
 791              (and n
 792                   (math-known-tan (car n) (nth 1 n) 120))))
 793       (and (eq calc-angle-mode 'deg)
 794            (let ((n (math-integer-plus (nth 1 expr))))
 795              (and n
 796                   (math-known-tan (car n) (nth 1 n) '(frac 2 3)))))
 797       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
 798            (math-div (nth 1 (nth 1 expr))
 799                      (list 'calcFunc-sqrt
 800                            (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
 801       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
 802            (math-div (list 'calcFunc-sqrt
 803                            (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))
 804                      (nth 1 (nth 1 expr))))
 805       (let ((m (math-should-expand-trig (nth 1 expr))))
 806         (and m
 807              (if (equal (car m) '(frac 1 2))
 808                  (math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m)))
 809                            (list 'calcFunc-sin (nth 1 m)))
 810                (math-div (list 'calcFunc-sin (nth 1 expr))
 811                          (list 'calcFunc-cos (nth 1 expr)))))))
 812 )
 813
 814 (defun math-known-tan (plus n mul)
 815   (setq n (math-mul n mul))
 816   (and (math-num-integerp n)
 817        (setq n (math-mod (math-trunc n) 120))
 818        (if (> n 60)
 819            (and (setq n (math-known-tan plus (- 120 n) 1))
 820                 (math-neg n))
 821          (if (math-zerop plus)
 822              (and (or calc-symbolic-mode
 823                       (memq n '(0 30 60)))
 824                   (cdr (assq n '( (0 . 0)
 825                                   (10 . (- 2 (calcFunc-sqrt 3)))
 826                                   (12 . (calcFunc-sqrt
 827                                          (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
 828                                   (15 . (- (calcFunc-sqrt 2) 1))
 829                                   (20 . (/ (calcFunc-sqrt 3) 3))
 830                                   (24 . (calcFunc-sqrt
 831                                          (- 5 (* 2 (calcFunc-sqrt 5)))))
 832                                   (30 . 1)
 833                                   (36 . (calcFunc-sqrt
 834                                          (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
 835                                   (40 . (calcFunc-sqrt 3))
 836                                   (45 . (+ (calcFunc-sqrt 2) 1))
 837                                   (48 . (calcFunc-sqrt
 838                                          (+ 5 (* 2 (calcFunc-sqrt 5)))))
 839                                   (50 . (+ 2 (calcFunc-sqrt 3)))
 840                                   (60 . (var uinf var-uinf))))))
 841            (cond ((eq n 0) (math-normalize (list 'calcFunc-tan plus)))
 842                  ((eq n 60) (math-normalize (list '/ -1
 843                                                   (list 'calcFunc-tan plus))))
 844                  (t nil)))))
 845 )
 846
 847 (math-defsimplify calcFunc-sinh
 848   (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
 849            (nth 1 (nth 1 expr)))
 850       (and (math-looks-negp (nth 1 expr))
 851            (math-neg (list 'calcFunc-sinh (math-neg (nth 1 expr)))))
 852       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
 853            math-living-dangerously
 854            (list 'calcFunc-sqrt (math-sub (math-sqr (nth 1 (nth 1 expr))) 1)))
 855       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
 856            math-living-dangerously
 857            (math-div (nth 1 (nth 1 expr))
 858                      (list 'calcFunc-sqrt
 859                            (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
 860       (let ((m (math-should-expand-trig (nth 1 expr) t)))
 861         (and m (integerp (car m))
 862              (let ((n (car m)) (a (nth 1 m)))
 863                (if (> n 1)
 864                    (list '+
 865                          (list '* (list 'calcFunc-sinh (list '* (1- n) a))
 866                                (list 'calcFunc-cosh a))
 867                          (list '* (list 'calcFunc-cosh (list '* (1- n) a))
 868                                (list 'calcFunc-sinh a))))))))
 869 )
 870
 871 (math-defsimplify calcFunc-cosh
 872   (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
 873            (nth 1 (nth 1 expr)))
 874       (and (math-looks-negp (nth 1 expr))
 875            (list 'calcFunc-cosh (math-neg (nth 1 expr))))
 876       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
 877            math-living-dangerously
 878            (list 'calcFunc-sqrt (math-add (math-sqr (nth 1 (nth 1 expr))) 1)))
 879       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
 880            math-living-dangerously
 881            (math-div 1
 882                      (list 'calcFunc-sqrt
 883                            (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
 884       (let ((m (math-should-expand-trig (nth 1 expr) t)))
 885         (and m (integerp (car m))
 886              (let ((n (car m)) (a (nth 1 m)))
 887                (if (> n 1)
 888                    (list '+
 889                          (list '* (list 'calcFunc-cosh (list '* (1- n) a))
 890                                (list 'calcFunc-cosh a))
 891                          (list '* (list 'calcFunc-sinh (list '* (1- n) a))
 892                                (list 'calcFunc-sinh a))))))))
 893 )
 894
 895 (math-defsimplify calcFunc-tanh
 896   (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
 897            (nth 1 (nth 1 expr)))
 898       (and (math-looks-negp (nth 1 expr))
 899            (math-neg (list 'calcFunc-tanh (math-neg (nth 1 expr)))))
 900       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
 901            math-living-dangerously
 902            (math-div (nth 1 (nth 1 expr))
 903                      (list 'calcFunc-sqrt
 904                            (math-add (math-sqr (nth 1 (nth 1 expr))) 1))))
 905       (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
 906            math-living-dangerously
 907            (math-div (list 'calcFunc-sqrt
 908                            (math-sub (math-sqr (nth 1 (nth 1 expr))) 1))
 909                      (nth 1 (nth 1 expr))))
 910       (let ((m (math-should-expand-trig (nth 1 expr) t)))
 911         (and m
 912              (if (equal (car m) '(frac 1 2))
 913                  (math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1)
 914                            (list 'calcFunc-sinh (nth 1 m)))
 915                (math-div (list 'calcFunc-sinh (nth 1 expr))
 916                          (list 'calcFunc-cosh (nth 1 expr)))))))
 917 )
 918
 919 (math-defsimplify calcFunc-arcsin
 920   (or (and (math-looks-negp (nth 1 expr))
 921            (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 expr)))))
 922       (and (eq (nth 1 expr) 1)
 923            (math-quarter-circle t))
 924       (and (equal (nth 1 expr) '(frac 1 2))
 925            (math-div (math-half-circle t) 6))
 926       (and math-living-dangerously
 927            (eq (car-safe (nth 1 expr)) 'calcFunc-sin)
 928            (nth 1 (nth 1 expr)))
 929       (and math-living-dangerously
 930            (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
 931            (math-sub (math-quarter-circle t)
 932                      (nth 1 (nth 1 expr)))))
 933 )
 934
 935 (math-defsimplify calcFunc-arccos
 936   (or (and (eq (nth 1 expr) 0)
 937            (math-quarter-circle t))
 938       (and (eq (nth 1 expr) -1)
 939            (math-half-circle t))
 940       (and (equal (nth 1 expr) '(frac 1 2))
 941            (math-div (math-half-circle t) 3))
 942       (and (equal (nth 1 expr) '(frac -1 2))
 943            (math-div (math-mul (math-half-circle t) 2) 3))
 944       (and math-living-dangerously
 945            (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
 946            (nth 1 (nth 1 expr)))
 947       (and math-living-dangerously
 948            (eq (car-safe (nth 1 expr)) 'calcFunc-sin)
 949            (math-sub (math-quarter-circle t)
 950                      (nth 1 (nth 1 expr)))))
 951 )
 952
 953 (math-defsimplify calcFunc-arctan
 954   (or (and (math-looks-negp (nth 1 expr))
 955            (math-neg (list 'calcFunc-arctan (math-neg (nth 1 expr)))))
 956       (and (eq (nth 1 expr) 1)
 957            (math-div (math-half-circle t) 4))
 958       (and math-living-dangerously
 959            (eq (car-safe (nth 1 expr)) 'calcFunc-tan)
 960            (nth 1 (nth 1 expr))))
 961 )
 962
 963 (math-defsimplify calcFunc-arcsinh
 964   (or (and (math-looks-negp (nth 1 expr))
 965            (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 expr)))))
 966       (and (eq (car-safe (nth 1 expr)) 'calcFunc-sinh)
 967            (or math-living-dangerously
 968                (math-known-realp (nth 1 (nth 1 expr))))
 969            (nth 1 (nth 1 expr))))
 970 )
 971
 972 (math-defsimplify calcFunc-arccosh
 973   (and (eq (car-safe (nth 1 expr)) 'calcFunc-cosh)
 974        (or math-living-dangerously
 975            (math-known-realp (nth 1 (nth 1 expr))))
 976        (nth 1 (nth 1 expr)))
 977 )
 978
 979 (math-defsimplify calcFunc-arctanh
 980   (or (and (math-looks-negp (nth 1 expr))
 981            (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 expr)))))
 982       (and (eq (car-safe (nth 1 expr)) 'calcFunc-tanh)
 983            (or math-living-dangerously
 984                (math-known-realp (nth 1 (nth 1 expr))))
 985            (nth 1 (nth 1 expr))))
 986 )
 987
 988 (math-defsimplify calcFunc-sqrt
 989   (math-simplify-sqrt)
 990 )
 991
 992 (defun math-simplify-sqrt ()
 993   (or (and (eq (car-safe (nth 1 expr)) 'frac)
 994            (math-div (list 'calcFunc-sqrt (math-mul (nth 1 (nth 1 expr))
 995                                                     (nth 2 (nth 1 expr))))
 996                      (nth 2 (nth 1 expr))))
 997       (let ((fac (if (math-objectp (nth 1 expr))
 998                      (math-squared-factor (nth 1 expr))
 999                    (math-common-constant-factor (nth 1 expr)))))
1000         (and fac (not (eq fac 1))
1001              (math-mul (math-normalize (list 'calcFunc-sqrt fac))
1002                        (math-normalize
1003                         (list 'calcFunc-sqrt
1004                               (math-cancel-common-factor (nth 1 expr) fac))))))
1005       (and math-living-dangerously
1006            (or (and (eq (car-safe (nth 1 expr)) '-)
1007                     (math-equal-int (nth 1 (nth 1 expr)) 1)
1008                     (eq (car-safe (nth 2 (nth 1 expr))) '^)
1009                     (math-equal-int (nth 2 (nth 2 (nth 1 expr))) 2)
1010                     (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr))))
1011                                  'calcFunc-sin)
1012                              (list 'calcFunc-cos
1013                                    (nth 1 (nth 1 (nth 2 (nth 1 expr))))))
1014                         (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr))))
1015                                  'calcFunc-cos)
1016                              (list 'calcFunc-sin
1017                                    (nth 1 (nth 1 (nth 2 (nth 1 expr))))))))
1018                (and (eq (car-safe (nth 1 expr)) '-)
1019                     (math-equal-int (nth 2 (nth 1 expr)) 1)
1020                     (eq (car-safe (nth 1 (nth 1 expr))) '^)
1021                     (math-equal-int (nth 2 (nth 1 (nth 1 expr))) 2)
1022                     (and (eq (car-safe (nth 1 (nth 1 (nth 1 expr))))
1023                              'calcFunc-cosh)
1024                          (list 'calcFunc-sinh
1025                                (nth 1 (nth 1 (nth 1 (nth 1 expr)))))))
1026                (and (eq (car-safe (nth 1 expr)) '+)
1027                     (let ((a (nth 1 (nth 1 expr)))
1028                           (b (nth 2 (nth 1 expr))))
1029                       (and (or (and (math-equal-int a 1)
1030                                     (setq a b b (nth 1 (nth 1 expr))))
1031                                (math-equal-int b 1))
1032                            (eq (car-safe a) '^)
1033                            (math-equal-int (nth 2 a) 2)
1034                            (or (and (eq (car-safe (nth 1 a)) 'calcFunc-sinh)
1035                                     (list 'calcFunc-cosh (nth 1 (nth 1 a))))
1036                                (and (eq (car-safe (nth 1 a)) 'calcFunc-tan)
1037                                     (list '/ 1 (list 'calcFunc-cos
1038                                                      (nth 1 (nth 1 a)))))))))
1039                (and (eq (car-safe (nth 1 expr)) '^)
1040                     (list '^
1041                           (nth 1 (nth 1 expr))
1042                           (math-div (nth 2 (nth 1 expr)) 2)))
1043                (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt)
1044                     (list '^ (nth 1 (nth 1 expr)) (math-div 1 4)))
1045                (and (memq (car-safe (nth 1 expr)) '(* /))
1046                     (list (car (nth 1 expr))
1047                           (list 'calcFunc-sqrt (nth 1 (nth 1 expr)))
1048                           (list 'calcFunc-sqrt (nth 2 (nth 1 expr)))))
1049                (and (memq (car-safe (nth 1 expr)) '(+ -))
1050                     (not (math-any-floats (nth 1 expr)))
1051                     (let ((f (calcFunc-factors (calcFunc-expand
1052                                                 (nth 1 expr)))))
1053                       (and (math-vectorp f)
1054                            (or (> (length f) 2)
1055                                (> (nth 2 (nth 1 f)) 1))
1056                            (let ((out 1) (rest 1) (sums 1) fac pow)
1057                              (while (setq f (cdr f))
1058                                (setq fac (nth 1 (car f))
1059                                      pow (nth 2 (car f)))
1060                                (if (> pow 1)
1061                                    (setq out (math-mul out (math-pow
1062                                                             fac (/ pow 2)))
1063                                          pow (% pow 2)))
1064                                (if (> pow 0)
1065                                    (if (memq (car-safe fac) '(+ -))
1066                                        (setq sums (math-mul-thru sums fac))
1067                                      (setq rest (math-mul rest fac)))))
1068                              (and (not (and (eq out 1) (memq rest '(1 -1))))
1069                                   (math-mul
1070                                    out
1071                                    (list 'calcFunc-sqrt
1072                                          (math-mul sums rest)))))))))))
1073 )
1074
1075 ;;; Rather than factoring x into primes, just check for the first ten primes.
1076 (defun math-squared-factor (x)
1077   (if (Math-integerp x)
1078       (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1079             (fac 1)
1080             res)
1081         (while prsqr
1082           (if (eq (cdr (setq res (math-idivmod x (car prsqr)))) 0)
1083               (setq x (car res)
1084                     fac (math-mul fac (car prsqr)))
1085             (setq prsqr (cdr prsqr))))
1086         fac))
1087 )
1088
1089 (math-defsimplify calcFunc-exp
1090   (math-simplify-exp (nth 1 expr))
1091 )
1092
1093 (defun math-simplify-exp (x)
1094   (or (and (eq (car-safe x) 'calcFunc-ln)
1095            (nth 1 x))
1096       (and math-living-dangerously
1097            (or (and (eq (car-safe x) 'calcFunc-arcsinh)
1098                     (math-add (nth 1 x)
1099                               (list 'calcFunc-sqrt
1100                                     (math-add (math-sqr (nth 1 x)) 1))))
1101                (and (eq (car-safe x) 'calcFunc-arccosh)
1102                     (math-add (nth 1 x)
1103                               (list 'calcFunc-sqrt
1104                                     (math-sub (math-sqr (nth 1 x)) 1))))
1105                (and (eq (car-safe x) 'calcFunc-arctanh)
1106                     (math-div (list 'calcFunc-sqrt (math-add 1 (nth 1 x)))
1107                               (list 'calcFunc-sqrt (math-sub 1 (nth 1 x)))))
1108                (let ((m (math-should-expand-trig x 'exp)))
1109                  (and m (integerp (car m))
1110                       (list '^ (list 'calcFunc-exp (nth 1 m)) (car m))))))
1111       (and calc-symbolic-mode
1112            (math-known-imagp x)
1113            (let* ((ip (calcFunc-im x))
1114                   (n (math-linear-in ip '(var pi var-pi)))
1115                   s c)
1116              (and n
1117                   (setq s (math-known-sin (car n) (nth 1 n) 120 0))
1118                   (setq c (math-known-sin (car n) (nth 1 n) 120 300))
1119                   (list '+ c (list '* s '(var i var-i)))))))
1120 )
1121
1122 (math-defsimplify calcFunc-ln
1123   (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-exp)
1124            (or math-living-dangerously
1125                (math-known-realp (nth 1 (nth 1 expr))))
1126            (nth 1 (nth 1 expr)))
1127       (and (eq (car-safe (nth 1 expr)) '^)
1128            (equal (nth 1 (nth 1 expr)) '(var e var-e))
1129            (or math-living-dangerously
1130                (math-known-realp (nth 2 (nth 1 expr))))
1131            (nth 2 (nth 1 expr)))
1132       (and calc-symbolic-mode
1133            (math-known-negp (nth 1 expr))
1134            (math-add (list 'calcFunc-ln (math-neg (nth 1 expr)))
1135                      '(var pi var-pi)))
1136       (and calc-symbolic-mode
1137            (math-known-imagp (nth 1 expr))
1138            (let* ((ip (calcFunc-im (nth 1 expr)))
1139                   (ips (math-possible-signs ip)))
1140              (or (and (memq ips '(4 6))
1141                       (math-add (list 'calcFunc-ln ip)
1142                                 '(/ (* (var pi var-pi) (var i var-i)) 2)))
1143                  (and (memq ips '(1 3))
1144                       (math-sub (list 'calcFunc-ln (math-neg ip))
1145                                 '(/ (* (var pi var-pi) (var i var-i)) 2)))))))
1146 )
1147
1148 (math-defsimplify ^
1149   (math-simplify-pow))
1150
1151 (defun math-simplify-pow ()
1152   (or (and math-living-dangerously
1153            (or (and (eq (car-safe (nth 1 expr)) '^)
1154                     (list '^
1155                           (nth 1 (nth 1 expr))
1156                           (math-mul (nth 2 expr) (nth 2 (nth 1 expr)))))
1157                (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt)
1158                     (list '^
1159                           (nth 1 (nth 1 expr))
1160                           (math-div (nth 2 expr) 2)))
1161                (and (memq (car-safe (nth 1 expr)) '(* /))
1162                     (list (car (nth 1 expr))
1163                           (list '^ (nth 1 (nth 1 expr)) (nth 2 expr))
1164                           (list '^ (nth 2 (nth 1 expr)) (nth 2 expr))))))
1165       (and (math-equal-int (nth 1 expr) 10)
1166            (eq (car-safe (nth 2 expr)) 'calcFunc-log10)
1167            (nth 1 (nth 2 expr)))
1168       (and (equal (nth 1 expr) '(var e var-e))
1169            (math-simplify-exp (nth 2 expr)))
1170       (and (eq (car-safe (nth 1 expr)) 'calcFunc-exp)
1171            (not math-integrating)
1172            (list 'calcFunc-exp (math-mul (nth 1 (nth 1 expr)) (nth 2 expr))))
1173       (and (equal (nth 1 expr) '(var i var-i))
1174            (math-imaginary-i)
1175            (math-num-integerp (nth 2 expr))
1176            (let ((x (math-mod (math-trunc (nth 2 expr)) 4)))
1177              (cond ((eq x 0) 1)
1178                    ((eq x 1) (nth 1 expr))
1179                    ((eq x 2) -1)
1180                    ((eq x 3) (math-neg (nth 1 expr))))))
1181       (and math-integrating
1182            (integerp (nth 2 expr))
1183            (>= (nth 2 expr) 2)
1184            (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
1185                     (math-mul (math-pow (nth 1 expr) (- (nth 2 expr) 2))
1186                               (math-sub 1
1187                                         (math-sqr
1188                                          (list 'calcFunc-sin
1189                                                (nth 1 (nth 1 expr)))))))
1190                (and (eq (car-safe (nth 1 expr)) 'calcFunc-cosh)
1191                     (math-mul (math-pow (nth 1 expr) (- (nth 2 expr) 2))
1192                               (math-add 1
1193                                         (math-sqr
1194                                          (list 'calcFunc-sinh
1195                                                (nth 1 (nth 1 expr)))))))))
1196       (and (eq (car-safe (nth 2 expr)) 'frac)
1197            (Math-ratp (nth 1 expr))
1198            (Math-posp (nth 1 expr))
1199            (if (equal (nth 2 expr) '(frac 1 2))
1200                (list 'calcFunc-sqrt (nth 1 expr))
1201              (let ((flr (math-floor (nth 2 expr))))
1202                (and (not (Math-zerop flr))
1203                     (list '* (list '^ (nth 1 expr) flr)
1204                           (list '^ (nth 1 expr)
1205                                 (math-sub (nth 2 expr) flr)))))))
1206       (and (eq (math-quarter-integer (nth 2 expr)) 2)
1207            (let ((temp (math-simplify-sqrt)))
1208              (and temp
1209                   (list '^ temp (math-mul (nth 2 expr) 2))))))
1210 )
1211
1212 (math-defsimplify calcFunc-log10
1213   (and (eq (car-safe (nth 1 expr)) '^)
1214        (math-equal-int (nth 1 (nth 1 expr)) 10)
1215        (or math-living-dangerously
1216            (math-known-realp (nth 2 (nth 1 expr))))
1217        (nth 2 (nth 1 expr)))
1218 )
1219
1220
1221 (math-defsimplify calcFunc-erf
1222   (or (and (math-looks-negp (nth 1 expr))
1223            (math-neg (list 'calcFunc-erf (math-neg (nth 1 expr)))))
1224       (and (eq (car-safe (nth 1 expr)) 'calcFunc-conj)
1225            (list 'calcFunc-conj (list 'calcFunc-erf (nth 1 (nth 1 expr))))))
1226 )
1227
1228 (math-defsimplify calcFunc-erfc
1229   (or (and (math-looks-negp (nth 1 expr))
1230            (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 expr)))))
1231       (and (eq (car-safe (nth 1 expr)) 'calcFunc-conj)
1232            (list 'calcFunc-conj (list 'calcFunc-erfc (nth 1 (nth 1 expr))))))
1233 )
1234
1235
1236 (defun math-linear-in (expr term &optional always)
1237   (if (math-expr-contains expr term)
1238       (let* ((calc-prefer-frac t)
1239              (p (math-is-polynomial expr term 1)))
1240         (and (cdr p)
1241              p))
1242     (and always (list expr 0)))
1243 )
1244
1245 (defun math-multiple-of (expr term)
1246   (let ((p (math-linear-in expr term)))
1247     (and p
1248          (math-zerop (car p))
1249          (nth 1 p)))
1250 )
1251
1252 (defun math-integer-plus (expr)
1253   (cond ((Math-integerp expr)
1254          (list 0 expr))
1255         ((and (memq (car expr) '(+ -))
1256               (Math-integerp (nth 1 expr)))
1257          (list (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))
1258                (nth 1 expr)))
1259         ((and (memq (car expr) '(+ -))
1260               (Math-integerp (nth 2 expr)))
1261          (list (nth 1 expr)
1262                (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))))
1263         (t nil))   ; not perfect, but it'll do
1264 )
1265
1266 (defun math-is-linear (expr &optional always)
1267   (let ((offset nil)
1268         (coef nil))
1269     (if (eq (car-safe expr) '+)
1270         (if (Math-objectp (nth 1 expr))
1271             (setq offset (nth 1 expr)
1272                   expr (nth 2 expr))
1273           (if (Math-objectp (nth 2 expr))
1274               (setq offset (nth 2 expr)
1275                     expr (nth 1 expr))))
1276       (if (eq (car-safe expr) '-)
1277           (if (Math-objectp (nth 1 expr))
1278               (setq offset (nth 1 expr)
1279                     expr (math-neg (nth 2 expr)))
1280             (if (Math-objectp (nth 2 expr))
1281                 (setq offset (math-neg (nth 2 expr))
1282                       expr (nth 1 expr))))))
1283     (setq coef (math-is-multiple expr always))
1284     (if offset
1285         (list offset (or (car coef) 1) (or (nth 1 coef) expr))
1286       (if coef
1287           (cons 0 coef))))
1288 )
1289
1290 (defun math-is-multiple (expr &optional always)
1291   (or (if (eq (car-safe expr) '*)
1292           (if (Math-objectp (nth 1 expr))
1293               (list (nth 1 expr) (nth 2 expr)))
1294         (if (eq (car-safe expr) '/)
1295             (if (and (Math-objectp (nth 1 expr))
1296                      (not (math-equal-int (nth 1 expr) 1)))
1297                 (list (nth 1 expr) (math-div 1 (nth 2 expr)))
1298               (if (Math-objectp (nth 2 expr))
1299                   (list (math-div 1 (nth 2 expr)) (nth 1 expr))
1300                 (let ((res (math-is-multiple (nth 1 expr))))
1301                   (if res
1302                       (list (car res)
1303                             (math-div (nth 2 (nth 1 expr)) (nth 2 expr)))
1304                     (setq res (math-is-multiple (nth 2 expr)))
1305                     (if res
1306                         (list (math-div 1 (car res))
1307                               (math-div (nth 1 expr)
1308                                         (nth 2 (nth 2 expr)))))))))
1309           (if (eq (car-safe expr) 'neg)
1310               (list -1 (nth 1 expr)))))
1311       (if (Math-objvecp expr)
1312           (and (eq always 1)
1313                (list expr 1))
1314         (and always
1315              (list 1 expr))))
1316 )
1317
1318 (defun calcFunc-lin (expr &optional var)
1319   (if var
1320       (let ((res (math-linear-in expr var t)))
1321         (or res (math-reject-arg expr "Linear term expected"))
1322         (list 'vec (car res) (nth 1 res) var))
1323     (let ((res (math-is-linear expr t)))
1324       (or res (math-reject-arg expr "Linear term expected"))
1325       (cons 'vec res)))
1326 )
1327
1328 (defun calcFunc-linnt (expr &optional var)
1329   (if var
1330       (let ((res (math-linear-in expr var)))
1331         (or res (math-reject-arg expr "Linear term expected"))
1332         (list 'vec (car res) (nth 1 res) var))
1333     (let ((res (math-is-linear expr)))
1334       (or res (math-reject-arg expr "Linear term expected"))
1335       (cons 'vec res)))
1336 )
1337
1338 (defun calcFunc-islin (expr &optional var)
1339   (if (and (Math-objvecp expr) (not var))
1340       0
1341     (calcFunc-lin expr var)
1342     1)
1343 )
1344
1345 (defun calcFunc-islinnt (expr &optional var)
1346   (if (Math-objvecp expr)
1347       0
1348     (calcFunc-linnt expr var)
1349     1)
1350 )
1351
1352
1353
1354
1355 ;;; Simple operations on expressions.
1356
1357 ;;; Return number of ocurrences of thing in expr, or nil if none.
1358 (defun math-expr-contains-count (expr thing)
1359   (cond ((equal expr thing) 1)
1360         ((Math-primp expr) nil)
1361         (t
1362          (let ((num 0))
1363            (while (setq expr (cdr expr))
1364              (setq num (+ num (or (math-expr-contains-count
1365                                    (car expr) thing) 0))))
1366            (and (> num 0)
1367                 num))))
1368 )
1369
1370 (defun math-expr-contains (expr thing)
1371   (cond ((equal expr thing) 1)
1372         ((Math-primp expr) nil)
1373         (t
1374          (while (and (setq expr (cdr expr))
1375                      (not (math-expr-contains (car expr) thing))))
1376          expr))
1377 )
1378
1379 ;;; Return non-nil if any variable of thing occurs in expr.
1380 (defun math-expr-depends (expr thing)
1381   (if (Math-primp thing)
1382       (and (eq (car-safe thing) 'var)
1383            (math-expr-contains expr thing))
1384     (while (and (setq thing (cdr thing))
1385                 (not (math-expr-depends expr (car thing)))))
1386     thing)
1387 )
1388
1389 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1390 (defun math-expr-subst (expr old new)
1391   (math-expr-subst-rec expr)
1392 )
1393 (fset 'calcFunc-subst (symbol-function 'math-expr-subst))
1394
1395 (defun math-expr-subst-rec (expr)
1396   (cond ((equal expr old) new)
1397         ((Math-primp expr) expr)
1398         ((memq (car expr) '(calcFunc-deriv
1399                             calcFunc-tderiv))
1400          (if (= (length expr) 2)
1401              (if (equal (nth 1 expr) old)
1402                  (append expr (list new))
1403                expr)
1404            (list (car expr) (nth 1 expr)
1405                  (math-expr-subst-rec (nth 2 expr)))))
1406         (t
1407          (cons (car expr)
1408                (mapcar 'math-expr-subst-rec (cdr expr)))))
1409 )
1410
1411 ;;; Various measures of the size of an expression.
1412 (defun math-expr-weight (expr)
1413   (if (Math-primp expr)
1414       1
1415     (let ((w 1))
1416       (while (setq expr (cdr expr))
1417         (setq w (+ w (math-expr-weight (car expr)))))
1418       w))
1419 )
1420
1421 (defun math-expr-height (expr)
1422   (if (Math-primp expr)
1423       0
1424     (let ((h 0))
1425       (while (setq expr (cdr expr))
1426         (setq h (max h (math-expr-height (car expr)))))
1427       (1+ h)))
1428 )
1429
1430
1431
1432
1433 ;;; Polynomial operations (to support the integrator and solve-for).
1434
1435 (defun calcFunc-collect (expr base)
1436   (let ((p (math-is-polynomial expr base 50 t)))
1437     (if (cdr p)
1438         (math-normalize   ; fix selection bug
1439          (math-build-polynomial-expr p base))
1440       expr))
1441 )
1442
1443 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1444 ;;; else return nil if not in polynomial form.  If "loose", coefficients
1445 ;;; may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1446 (defun math-is-polynomial (expr var &optional degree loose)
1447   (let* ((math-poly-base-variable (if loose
1448                                       (if (eq loose 'gen) var '(var XXX XXX))
1449                                     math-poly-base-variable))
1450          (poly (math-is-poly-rec expr math-poly-neg-powers)))
1451     (and (or (null degree)
1452              (<= (length poly) (1+ degree)))
1453          poly))
1454 )
1455
1456 (defun math-is-poly-rec (expr negpow)
1457   (math-poly-simplify
1458    (or (cond ((or (equal expr var)
1459                   (eq (car-safe expr) '^))
1460               (let ((pow 1)
1461                     (expr expr))
1462                 (or (equal expr var)
1463                     (setq pow (nth 2 expr)
1464                           expr (nth 1 expr)))
1465                 (or (eq math-poly-mult-powers 1)
1466                     (setq pow (let ((m (math-is-multiple pow 1)))
1467                                 (and (eq (car-safe (car m)) 'cplx)
1468                                      (Math-zerop (nth 1 (car m)))
1469                                      (setq m (list (nth 2 (car m))
1470                                                    (math-mul (nth 1 m)
1471                                                              '(var i var-i)))))
1472                                 (and (if math-poly-mult-powers
1473                                          (equal math-poly-mult-powers
1474                                                 (nth 1 m))
1475                                        (setq math-poly-mult-powers (nth 1 m)))
1476                                      (or (equal expr var)
1477                                          (eq math-poly-mult-powers 1))
1478                                      (car m)))))
1479                 (if (consp pow)
1480                     (progn
1481                       (setq pow (math-to-simple-fraction pow))
1482                       (and (eq (car-safe pow) 'frac)
1483                            math-poly-frac-powers
1484                            (equal expr var)
1485                            (setq math-poly-frac-powers
1486                                  (calcFunc-lcm math-poly-frac-powers
1487                                                (nth 2 pow))))))
1488                 (or (memq math-poly-frac-powers '(1 nil))
1489                     (setq pow (math-mul pow math-poly-frac-powers)))
1490                 (if (integerp pow)
1491                     (if (and (= pow 1)
1492                              (equal expr var))
1493                         (list 0 1)
1494                       (if (natnump pow)
1495                           (let ((p1 (if (equal expr var)
1496                                         (list 0 1)
1497                                       (math-is-poly-rec expr nil)))
1498                                 (n pow)
1499                                 (accum (list 1)))
1500                             (and p1
1501                                  (or (null degree)
1502                                      (<= (* (1- (length p1)) n) degree))
1503                                  (progn
1504                                    (while (>= n 1)
1505                                      (setq accum (math-poly-mul accum p1)
1506                                            n (1- n)))
1507                                    accum)))
1508                         (and negpow
1509                              (math-is-poly-rec expr nil)
1510                              (setq math-poly-neg-powers
1511                                    (cons (math-pow expr (- pow))
1512                                          math-poly-neg-powers))
1513                              (list (list '^ expr pow))))))))
1514              ((Math-objectp expr)
1515               (list expr))
1516              ((memq (car expr) '(+ -))
1517               (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1518                 (and p1
1519                      (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1520                        (and p2
1521                             (math-poly-mix p1 1 p2
1522                                            (if (eq (car expr) '+) 1 -1)))))))
1523              ((eq (car expr) 'neg)
1524               (mapcar 'math-neg (math-is-poly-rec (nth 1 expr) negpow)))
1525              ((eq (car expr) '*)
1526               (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1527                 (and p1
1528                      (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1529                        (and p2
1530                             (or (null degree)
1531                                 (<= (- (+ (length p1) (length p2)) 2) degree))
1532                             (math-poly-mul p1 p2))))))
1533              ((eq (car expr) '/)
1534               (and (or (not (math-poly-depends (nth 2 expr) var))
1535                        (and negpow
1536                             (math-is-poly-rec (nth 2 expr) nil)
1537                             (setq math-poly-neg-powers
1538                                   (cons (nth 2 expr) math-poly-neg-powers))))
1539                    (not (Math-zerop (nth 2 expr)))
1540                    (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1541                      (mapcar (function (lambda (x) (math-div x (nth 2 expr))))
1542                              p1))))
1543              ((and (eq (car expr) 'calcFunc-exp)
1544                    (equal var '(var e var-e)))
1545               (math-is-poly-rec (list '^ var (nth 1 expr)) negpow))
1546              ((and (eq (car expr) 'calcFunc-sqrt)
1547                    math-poly-frac-powers)
1548               (math-is-poly-rec (list '^ (nth 1 expr) '(frac 1 2)) negpow))
1549              (t nil))
1550        (and (or (not (math-poly-depends expr var))
1551                 loose)
1552             (not (eq (car expr) 'vec))
1553             (list expr))))
1554 )
1555
1556 ;;; Check if expr is a polynomial in var; if so, return its degree.
1557 (defun math-polynomial-p (expr var)
1558   (cond ((equal expr var) 1)
1559         ((Math-primp expr) 0)
1560         ((memq (car expr) '(+ -))
1561          (let ((p1 (math-polynomial-p (nth 1 expr) var))
1562                p2)
1563            (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1564                 (max p1 p2))))
1565         ((eq (car expr) '*)
1566          (let ((p1 (math-polynomial-p (nth 1 expr) var))
1567                p2)
1568            (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1569                 (+ p1 p2))))
1570         ((eq (car expr) 'neg)
1571          (math-polynomial-p (nth 1 expr) var))
1572         ((and (eq (car expr) '/)
1573               (not (math-poly-depends (nth 2 expr) var)))
1574          (math-polynomial-p (nth 1 expr) var))
1575         ((and (eq (car expr) '^)
1576               (natnump (nth 2 expr)))
1577          (let ((p1 (math-polynomial-p (nth 1 expr) var)))
1578            (and p1 (* p1 (nth 2 expr)))))
1579         ((math-poly-depends expr var) nil)
1580         (t 0))
1581 )
1582
1583 (defun math-poly-depends (expr var)
1584   (if math-poly-base-variable
1585       (math-expr-contains expr math-poly-base-variable)
1586     (math-expr-depends expr var))
1587 )
1588
1589 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1590 (defun math-polynomial-base (mpb-top-expr &optional mpb-pred)
1591   (or mpb-pred
1592       (setq mpb-pred (function (lambda (base) (math-polynomial-p
1593                                                mpb-top-expr base)))))
1594   (or (let ((const-ok nil))
1595         (math-polynomial-base-rec mpb-top-expr))
1596       (let ((const-ok t))
1597         (math-polynomial-base-rec mpb-top-expr)))
1598 )
1599
1600 (defun math-polynomial-base-rec (mpb-expr)
1601   (and (not (Math-objvecp mpb-expr))
1602        (or (and (memq (car mpb-expr) '(+ - *))
1603                 (or (math-polynomial-base-rec (nth 1 mpb-expr))
1604                     (math-polynomial-base-rec (nth 2 mpb-expr))))
1605            (and (memq (car mpb-expr) '(/ neg))
1606                 (math-polynomial-base-rec (nth 1 mpb-expr)))
1607            (and (eq (car mpb-expr) '^)
1608                 (math-polynomial-base-rec (nth 1 mpb-expr)))
1609            (and (eq (car mpb-expr) 'calcFunc-exp)
1610                 (math-polynomial-base-rec '(var e var-e)))
1611            (and (or const-ok (math-expr-contains-vars mpb-expr))
1612                 (funcall mpb-pred mpb-expr)
1613                 mpb-expr)))
1614 )
1615
1616 ;;; Return non-nil if expr refers to any variables.
1617 (defun math-expr-contains-vars (expr)
1618   (or (eq (car-safe expr) 'var)
1619       (and (not (Math-primp expr))
1620            (progn
1621              (while (and (setq expr (cdr expr))
1622                          (not (math-expr-contains-vars (car expr)))))
1623              expr)))
1624 )
1625
1626 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1627 ;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil.
1628 (defun math-poly-simplify (p)
1629   (and p
1630        (if (Math-zerop (nth (1- (length p)) p))
1631            (let ((pp (copy-sequence p)))
1632              (while (and (cdr pp)
1633                          (Math-zerop (nth (1- (length pp)) pp)))
1634                (setcdr (nthcdr (- (length pp) 2) pp) nil))
1635              pp)
1636          p))
1637 )
1638
1639 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1640 ;;; coefficients ac, bc.  Result may be unsimplified.
1641 (defun math-poly-mix (a ac b bc)
1642   (and (or a b)
1643        (cons (math-add (math-mul (or (car a) 0) ac)
1644                        (math-mul (or (car b) 0) bc))
1645              (math-poly-mix (cdr a) ac (cdr b) bc)))
1646 )
1647
1648 (defun math-poly-zerop (a)
1649   (or (null a)
1650       (and (null (cdr a)) (Math-zerop (car a))))
1651 )
1652
1653 ;;; Multiply two polynomials in list form.
1654 (defun math-poly-mul (a b)
1655   (and a b
1656        (math-poly-mix b (car a)
1657                       (math-poly-mul (cdr a) (cons 0 b)) 1))
1658 )
1659
1660 ;;; Build an expression from a polynomial list.
1661 (defun math-build-polynomial-expr (p var)
1662   (if p
1663       (if (Math-numberp var)
1664           (math-with-extra-prec 1
1665             (let* ((rp (reverse p))
1666                    (accum (car rp)))
1667               (while (setq rp (cdr rp))
1668                 (setq accum (math-add (car rp) (math-mul accum var))))
1669               accum))
1670         (let* ((rp (reverse p))
1671                (n (1- (length rp)))
1672                (accum (math-mul (car rp) (math-pow var n)))
1673                term)
1674           (while (setq rp (cdr rp))
1675             (setq n (1- n))
1676             (or (math-zerop (car rp))
1677                 (setq accum (list (if (math-looks-negp (car rp)) '- '+)
1678                                   accum
1679                                   (math-mul (if (math-looks-negp (car rp))
1680                                                 (math-neg (car rp))
1681                                               (car rp))
1682                                             (math-pow var n))))))
1683           accum))
1684     0)
1685 )
1686
1687
1688 (defun math-to-simple-fraction (f)
1689   (or (and (eq (car-safe f) 'float)
1690            (or (and (>= (nth 2 f) 0)
1691                     (math-scale-int (nth 1 f) (nth 2 f)))
1692                (and (integerp (nth 1 f))
1693                     (> (nth 1 f) -1000)
1694                     (< (nth 1 f) 1000)
1695                     (math-make-frac (nth 1 f)
1696                                     (math-scale-int 1 (- (nth 2 f)))))))
1697       f)
1698 )
1699