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