;;; calc-alg.el --- algebraic functions for Calc
;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
-;; Maintainer: Jay Belanger <belanger@truman.edu>
+;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(defun calc-simplify ()
(interactive)
(calc-slow-wrapper
- (calc-with-default-simplification
- (calc-enter-result 1 "simp" (math-simplify (calc-top-n 1))))))
+ (let ((top (calc-top-n 1)))
+ (if (calc-is-inverse)
+ (setq top
+ (let ((calc-simplify-mode nil))
+ (math-normalize (math-trig-rewrite top)))))
+ (if (calc-is-hyperbolic)
+ (setq top
+ (let ((calc-simplify-mode nil))
+ (math-normalize (math-hyperbolic-trig-rewrite top)))))
+ (calc-with-default-simplification
+ (calc-enter-result 1 "simp" (math-simplify top))))))
(defun calc-simplify-extended ()
(interactive)
(defalias 'calcFunc-esimplify 'math-simplify-extended)
-;; math-top-only is local to math-simplify, but is used by
+;;; Rewrite the trig functions in a form easier to simplify.
+(defun math-trig-rewrite (fn)
+ "Rewrite trigonometric functions in terms of sines and cosines."
+ (cond
+ ((not (consp fn))
+ fn)
+ ((eq (car-safe fn) 'calcFunc-sec)
+ (list '/ 1 (cons 'calcFunc-cos (math-trig-rewrite (cdr fn)))))
+ ((eq (car-safe fn) 'calcFunc-csc)
+ (list '/ 1 (cons 'calcFunc-sin (math-trig-rewrite (cdr fn)))))
+ ((eq (car-safe fn) 'calcFunc-tan)
+ (let ((newfn (math-trig-rewrite (cdr fn))))
+ (list '/ (cons 'calcFunc-sin newfn)
+ (cons 'calcFunc-cos newfn))))
+ ((eq (car-safe fn) 'calcFunc-cot)
+ (let ((newfn (math-trig-rewrite (cdr fn))))
+ (list '/ (cons 'calcFunc-cos newfn)
+ (cons 'calcFunc-sin newfn))))
+ (t
+ (mapcar 'math-trig-rewrite fn))))
+
+(defun math-hyperbolic-trig-rewrite (fn)
+ "Rewrite hyperbolic functions in terms of sinhs and coshs."
+ (cond
+ ((not (consp fn))
+ fn)
+ ((eq (car-safe fn) 'calcFunc-sech)
+ (list '/ 1 (cons 'calcFunc-cosh (math-hyperbolic-trig-rewrite (cdr fn)))))
+ ((eq (car-safe fn) 'calcFunc-csch)
+ (list '/ 1 (cons 'calcFunc-sinh (math-hyperbolic-trig-rewrite (cdr fn)))))
+ ((eq (car-safe fn) 'calcFunc-tanh)
+ (let ((newfn (math-hyperbolic-trig-rewrite (cdr fn))))
+ (list '/ (cons 'calcFunc-sinh newfn)
+ (cons 'calcFunc-cosh newfn))))
+ ((eq (car-safe fn) 'calcFunc-coth)
+ (let ((newfn (math-hyperbolic-trig-rewrite (cdr fn))))
+ (list '/ (cons 'calcFunc-cosh newfn)
+ (cons 'calcFunc-sinh newfn))))
+ (t
+ (mapcar 'math-hyperbolic-trig-rewrite fn))))
+
+;; math-top-only is local to math-simplify, but is used by
;; math-simplify-step, which is called by math-simplify.
(defvar math-top-only)
aaa temp)
(while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
(if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 math-simplify-expr)
- (eq (car aaa) '-)
+ (eq (car aaa) '-)
(eq (car math-simplify-expr) '-) t))
(progn
(setcar (cdr (cdr math-simplify-expr)) temp)
(setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) temp))))
(while (and (eq (car-safe (setq aaa (nth 2 aa))) '*)
safe)
- (if (setq temp (math-combine-prod (nth 1 math-simplify-expr)
+ (if (setq temp (math-combine-prod (nth 1 math-simplify-expr)
(nth 1 aaa) nil nil t))
(progn
(setcar (cdr math-simplify-expr) temp)
(setcar (cdr (cdr aa)) 1)))
(if (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
(memq (nth 1 (nth 1 math-simplify-expr)) '(1 -1)))
- (math-div (math-mul (nth 2 math-simplify-expr)
+ (math-div (math-mul (nth 2 math-simplify-expr)
(nth 1 (nth 1 math-simplify-expr)))
(nth 2 (nth 1 math-simplify-expr)))
math-simplify-expr)))
(defun math-simplify-divide ()
(let ((np (cdr math-simplify-expr))
(nover nil)
- (nn (and (or (eq (car math-simplify-expr) '/)
+ (nn (and (or (eq (car math-simplify-expr) '/)
(not (Math-realp (nth 2 math-simplify-expr))))
(math-common-constant-factor (nth 2 math-simplify-expr))))
n op)
(if nn
(progn
- (setq n (and (or (eq (car math-simplify-expr) '/)
+ (setq n (and (or (eq (car math-simplify-expr) '/)
(not (Math-realp (nth 1 math-simplify-expr))))
(math-common-constant-factor (nth 1 math-simplify-expr))))
(if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n))
(progn
- (setcar (cdr math-simplify-expr)
+ (setcar (cdr math-simplify-expr)
(math-mul (nth 2 nn) (nth 1 math-simplify-expr)))
(setcar (cdr (cdr math-simplify-expr))
(math-cancel-common-factor (nth 2 math-simplify-expr) nn))
(setcar (cdr (cdr math-simplify-expr))
(math-cancel-common-factor (nth 2 math-simplify-expr) n))
(if (and (math-negp n)
- (setq op (assq (car math-simplify-expr)
+ (setq op (assq (car math-simplify-expr)
calc-tweak-eqn-table)))
(setcar math-simplify-expr (nth 1 op))))))))
(if (and (eq (car-safe (car np)) '/)
(defvar math-simplify-divisor-nover)
(defvar math-simplify-divisor-dover)
-(defun math-simplify-divisor (np dp math-simplify-divisor-nover
+(defun math-simplify-divisor (np dp math-simplify-divisor-nover
math-simplify-divisor-dover)
(cond ((eq (car-safe (car dp)) '/)
- (math-simplify-divisor np (cdr (car dp))
- math-simplify-divisor-nover
+ (math-simplify-divisor np (cdr (car dp))
+ math-simplify-divisor-nover
math-simplify-divisor-dover)
(and (math-known-scalarp (nth 1 (car dp)) t)
(math-simplify-divisor np (cdr (cdr (car dp)))
- math-simplify-divisor-nover
+ math-simplify-divisor-nover
(not math-simplify-divisor-dover))))
((or (or (eq (car math-simplify-expr) '/)
(let ((signs (math-possible-signs (car np))))
math-living-dangerously)))
(math-numberp (car np)))
(let (d
- (safe t)
+ (safe t)
(scalar (math-known-scalarp (car np))))
(while (and (eq (car-safe (setq d (car dp))) '*)
safe)
(math-simplify-one-divisor np dp))))))
(defun math-simplify-one-divisor (np dp)
- (let ((temp (math-combine-prod (car np) (car dp) math-simplify-divisor-nover
+ (let ((temp (math-combine-prod (car np) (car dp) math-simplify-divisor-nover
math-simplify-divisor-dover t))
op)
- (if temp
+ (if temp
(progn
(and (not (memq (car math-simplify-expr) '(/ calcFunc-eq calcFunc-neq)))
(math-known-negp (car dp))
(setcar math-simplify-expr (nth 1 op)))
(setcar np (if math-simplify-divisor-nover (math-div 1 temp) temp))
(setcar dp 1))
- (and math-simplify-divisor-dover (not math-simplify-divisor-nover)
+ (and math-simplify-divisor-dover (not math-simplify-divisor-nover)
(eq (car math-simplify-expr) '/)
(eq (car-safe (car dp)) 'calcFunc-sqrt)
(Math-integerp (nth 1 (car dp)))
(math-simplify-add-term (cdr (cdr n)) (cdr (cdr math-simplify-expr))
(eq (car n) '-) nil)
(setq np (cdr n)))
- (math-simplify-add-term np (cdr (cdr math-simplify-expr)) nil
+ (math-simplify-add-term np (cdr (cdr math-simplify-expr)) nil
(eq np (cdr math-simplify-expr)))
(math-simplify-divide)
(let ((signs (math-possible-signs (cons '- (cdr math-simplify-expr)))))
(and n
(math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
- (list 'calcFunc-sqrt (math-sub 1 (math-sqr
+ (list 'calcFunc-sqrt (math-sub 1 (math-sqr
(nth 1 (nth 1 math-simplify-expr))))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
(math-div (nth 1 (nth 1 math-simplify-expr))
(list 'calcFunc-sqrt
- (math-add 1 (math-sqr
+ (math-add 1 (math-sqr
(nth 1 (nth 1 math-simplify-expr)))))))
(let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
(and m (integerp (car m))
(and n
(math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
- (list 'calcFunc-sqrt
+ (list 'calcFunc-sqrt
(math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
(math-div 1
(list 'calcFunc-sqrt
- (math-add 1
+ (math-add 1
(math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
(let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
(and m (integerp (car m))
(and n
(math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300)))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
- (math-div
+ (math-div
1
- (list 'calcFunc-sqrt
+ (list 'calcFunc-sqrt
(math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
- (math-div
+ (math-div
1
(nth 1 (nth 1 math-simplify-expr))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
(list 'calcFunc-sqrt
- (math-add 1
+ (math-add 1
(math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
(math-defsimplify calcFunc-csc
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
(math-div 1 (nth 1 (nth 1 math-simplify-expr))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
- (math-div
+ (math-div
1
- (list 'calcFunc-sqrt (math-sub 1 (math-sqr
+ (list 'calcFunc-sqrt (math-sub 1 (math-sqr
(nth 1 (nth 1 math-simplify-expr)))))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
(math-div (list 'calcFunc-sqrt
- (math-add 1 (math-sqr
+ (math-add 1 (math-sqr
(nth 1 (nth 1 math-simplify-expr)))))
(nth 1 (nth 1 math-simplify-expr))))))
(math-neg (list 'calcFunc-sinh (math-neg (nth 1 math-simplify-expr)))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
math-living-dangerously
- (list 'calcFunc-sqrt
+ (list 'calcFunc-sqrt
(math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
math-living-dangerously
(list 'calcFunc-cosh (math-neg (nth 1 math-simplify-expr))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
math-living-dangerously
- (list 'calcFunc-sqrt
+ (list 'calcFunc-sqrt
(math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
math-living-dangerously
(list 'calcFunc-sech (math-neg (nth 1 math-simplify-expr))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
math-living-dangerously
- (math-div
+ (math-div
1
- (list 'calcFunc-sqrt
+ (list 'calcFunc-sqrt
(math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
math-living-dangerously
(math-div 1 (nth 1 (nth 1 math-simplify-expr))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
math-living-dangerously
- (math-div
+ (math-div
1
- (list 'calcFunc-sqrt
+ (list 'calcFunc-sqrt
(math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
math-living-dangerously
(defun math-simplify-sqrt ()
(or (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
- (math-div (list 'calcFunc-sqrt
+ (math-div (list 'calcFunc-sqrt
(math-mul (nth 1 (nth 1 math-simplify-expr))
(nth 2 (nth 1 math-simplify-expr))))
(nth 2 (nth 1 math-simplify-expr))))
(math-mul (math-normalize (list 'calcFunc-sqrt fac))
(math-normalize
(list 'calcFunc-sqrt
- (math-cancel-common-factor
+ (math-cancel-common-factor
(nth 1 math-simplify-expr) fac))))))
(and math-living-dangerously
(or (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
(and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
'calcFunc-cos)
(list 'calcFunc-sin
- (nth 1 (nth 1 (nth 2
+ (nth 1 (nth 1 (nth 2
(nth 1 math-simplify-expr))))))))
(and (eq (car-safe (nth 1 math-simplify-expr)) '-)
(math-equal-int (nth 2 (nth 1 math-simplify-expr)) 1)
(or (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
(list '^
(nth 1 (nth 1 math-simplify-expr))
- (math-mul (nth 2 math-simplify-expr)
+ (math-mul (nth 2 math-simplify-expr)
(nth 2 (nth 1 math-simplify-expr)))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
(list '^
(math-div (nth 2 math-simplify-expr) 2)))
(and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
(list (car (nth 1 math-simplify-expr))
- (list '^ (nth 1 (nth 1 math-simplify-expr))
+ (list '^ (nth 1 (nth 1 math-simplify-expr))
(nth 2 math-simplify-expr))
- (list '^ (nth 2 (nth 1 math-simplify-expr))
+ (list '^ (nth 2 (nth 1 math-simplify-expr))
(nth 2 math-simplify-expr))))))
(and (math-equal-int (nth 1 math-simplify-expr) 10)
(eq (car-safe (nth 2 math-simplify-expr)) 'calcFunc-log10)
(math-simplify-exp (nth 2 math-simplify-expr)))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
(not math-integrating)
- (list 'calcFunc-exp (math-mul (nth 1 (nth 1 math-simplify-expr))
+ (list 'calcFunc-exp (math-mul (nth 1 (nth 1 math-simplify-expr))
(nth 2 math-simplify-expr))))
(and (equal (nth 1 math-simplify-expr) '(var i var-i))
(math-imaginary-i)
(integerp (nth 2 math-simplify-expr))
(>= (nth 2 math-simplify-expr) 2)
(or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
- (math-mul (math-pow (nth 1 math-simplify-expr)
+ (math-mul (math-pow (nth 1 math-simplify-expr)
(- (nth 2 math-simplify-expr) 2))
(math-sub 1
(math-sqr
(list 'calcFunc-sin
(nth 1 (nth 1 math-simplify-expr)))))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
- (math-mul (math-pow (nth 1 math-simplify-expr)
+ (math-mul (math-pow (nth 1 math-simplify-expr)
(- (nth 2 math-simplify-expr) 2))
(math-add 1
(math-sqr
(or (and (math-looks-negp (nth 1 math-simplify-expr))
(math-neg (list 'calcFunc-erf (math-neg (nth 1 math-simplify-expr)))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
- (list 'calcFunc-conj
+ (list 'calcFunc-conj
(list 'calcFunc-erf (nth 1 (nth 1 math-simplify-expr)))))))
(math-defsimplify calcFunc-erfc
(or (and (math-looks-negp (nth 1 math-simplify-expr))
(math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 math-simplify-expr)))))
(and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
- (list 'calcFunc-conj
+ (list 'calcFunc-conj
(list 'calcFunc-erfc (nth 1 (nth 1 math-simplify-expr)))))))
(defun calcFunc-collect (expr base)
(let ((p (math-is-polynomial expr base 50 t)))
(if (cdr p)
- (math-normalize ; fix selection bug
- (math-build-polynomial-expr p base))
- expr)))
+ (math-build-polynomial-expr (mapcar 'math-normalize p) base)
+ (car p))))
;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
-;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
+;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
-;; The variables math-is-poly-degree and math-is-poly-loose are local to
-;; math-is-polynomial, but are used by math-is-poly-rec
+;; These variables are local to math-is-polynomial, but are used by
+;; math-is-poly-rec.
(defvar math-is-poly-degree)
(defvar math-is-poly-loose)
+(defvar var)
(defun math-is-polynomial (expr var &optional math-is-poly-degree math-is-poly-loose)
(let* ((math-poly-base-variable (if math-is-poly-loose
(let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
(and p2
(or (null math-is-poly-degree)
- (<= (- (+ (length p1) (length p2)) 2)
+ (<= (- (+ (length p1) (length p2)) 2)
math-is-poly-degree))
(math-poly-mul p1 p2))))))
((eq (car expr) '/)
(provide 'calc-alg)
-;;; arch-tag: 52e7dcdf-9688-464d-a02b-4bbe789348d0
+;; arch-tag: 52e7dcdf-9688-464d-a02b-4bbe789348d0
;;; calc-alg.el ends here