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

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