1 files changed, 452 insertions, 0 deletions
diff --git a/lisp/calc/calc-fin.el b/lisp/calc/calc-fin.el
new file mode 100644
index 00000000000..70d8dcd84f8
--- /dev/null
+++ b/lisp/calc/calc-fin.el
@@ -0,0 +1,452 @@
+;; Calculator for GNU Emacs, part II [calc-fin.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY.  No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing.  Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; GNU Emacs, but only under the conditions described in the
+;; GNU Emacs General Public License.   A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities.  It should be in a
+;; file named COPYING.  Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+
+
+;; This file is autoloaded from calc-ext.el.
+(require 'calc-ext)
+
+(require 'calc-macs)
+
+(defun calc-Need-calc-fin () nil)
+
+
+;;; Financial functions.
+
+(defun calc-fin-pv ()
+  (interactive)
+  (calc-slow-wrapper
+   (if (calc-is-hyperbolic)
+       (calc-enter-result 3 "pvl" (cons 'calcFunc-pvl (calc-top-list-n 3)))
+     (if (calc-is-inverse)
+	 (calc-enter-result 3 "pvb" (cons 'calcFunc-pvb (calc-top-list-n 3)))
+       (calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3))))))
+)
+
+(defun calc-fin-npv (arg)
+  (interactive "p")
+  (calc-slow-wrapper
+   (if (calc-is-inverse)
+       (calc-vector-op "npvb" 'calcFunc-npvb (1+ arg))
+     (calc-vector-op "npv" 'calcFunc-npv (1+ arg))))
+)
+
+(defun calc-fin-fv ()
+  (interactive)
+  (calc-slow-wrapper
+   (if (calc-is-hyperbolic)
+       (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
+     (if (calc-is-inverse)
+	 (calc-enter-result 3 "fvb" (cons 'calcFunc-fvb (calc-top-list-n 3)))
+       (calc-enter-result 3 "fv" (cons 'calcFunc-fv (calc-top-list-n 3))))))
+)
+
+(defun calc-fin-pmt ()
+  (interactive)
+  (calc-slow-wrapper
+   (if (calc-is-hyperbolic)
+       (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
+     (if (calc-is-inverse)
+	 (calc-enter-result 3 "pmtb" (cons 'calcFunc-pmtb (calc-top-list-n 3)))
+       (calc-enter-result 3 "pmt" (cons 'calcFunc-pmt (calc-top-list-n 3))))))
+)
+
+(defun calc-fin-nper ()
+  (interactive)
+  (calc-slow-wrapper
+   (if (calc-is-hyperbolic)
+       (calc-enter-result 3 "nprl" (cons 'calcFunc-nperl (calc-top-list-n 3)))
+     (if (calc-is-inverse)
+	 (calc-enter-result 3 "nprb" (cons 'calcFunc-nperb
+					   (calc-top-list-n 3)))
+       (calc-enter-result 3 "nper" (cons 'calcFunc-nper
+					 (calc-top-list-n 3))))))
+)
+
+(defun calc-fin-rate ()
+  (interactive)
+  (calc-slow-wrapper
+   (calc-pop-push-record 3
+			 (if (calc-is-hyperbolic) "ratl"
+			   (if (calc-is-inverse) "ratb" "rate"))
+			 (calc-to-percentage
+			  (calc-normalize
+			   (cons (if (calc-is-hyperbolic) 'calcFunc-ratel
+				   (if (calc-is-hyperbolic) 'calcFunc-rateb
+				     'calcFunc-rate))
+				 (calc-top-list-n 3))))))
+)
+
+(defun calc-fin-irr (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-inverse)
+       (calc-vector-op "irrb" 'calcFunc-irrb arg)
+     (calc-vector-op "irr" 'calcFunc-irr arg)))
+)
+
+(defun calc-fin-sln ()
+  (interactive)
+  (calc-slow-wrapper
+   (calc-enter-result 3 "sln" (cons 'calcFunc-sln (calc-top-list-n 3))))
+)
+
+(defun calc-fin-syd ()
+  (interactive)
+  (calc-slow-wrapper
+   (calc-enter-result 4 "syd" (cons 'calcFunc-syd (calc-top-list-n 4))))
+)
+
+(defun calc-fin-ddb ()
+  (interactive)
+  (calc-slow-wrapper
+   (calc-enter-result 4 "ddb" (cons 'calcFunc-ddb (calc-top-list-n 4))))
+)
+
+
+(defun calc-to-percentage (x)
+  (cond ((Math-objectp x)
+	 (setq x (math-mul x 100))
+	 (if (Math-num-integerp x)
+	     (setq x (math-trunc x)))
+	 (list 'calcFunc-percent x))
+	((Math-vectorp x)
+	 (cons 'vec (mapcar 'calc-to-percentage (cdr x))))
+	(t x))
+)
+
+(defun calc-convert-percent ()
+  (interactive)
+  (calc-slow-wrapper
+   (calc-pop-push-record 1 "c%" (calc-to-percentage (calc-top-n 1))))
+)
+
+(defun calc-percent-change ()
+  (interactive)
+  (calc-slow-wrapper
+   (let ((res (calc-normalize (cons 'calcFunc-relch (calc-top-list 2)))))
+     (calc-pop-push-record 2 "%ch" (calc-to-percentage res))))
+)
+
+
+
+
+
+;;; Financial functions.
+
+(defun calcFunc-pv (rate num amount &optional lump)
+  (math-check-financial rate num)
+  (math-with-extra-prec 2
+    (let ((p (math-pow (math-add 1 rate) num)))
+      (math-add (math-mul amount
+			  (math-div (math-sub 1 (math-div 1 p))
+				    rate))
+		(math-div (or lump 0) p))))
+)
+(put 'calcFunc-pv 'math-expandable t)
+
+(defun calcFunc-pvl (rate num amount)
+  (calcFunc-pv rate num 0 amount)
+)
+(put 'calcFunc-pvl 'math-expandable t)
+
+(defun calcFunc-pvb (rate num amount &optional lump)
+  (math-check-financial rate num)
+  (math-with-extra-prec 2
+    (let* ((p (math-pow (math-add 1 rate) num)))
+      (math-add (math-mul amount
+			  (math-div (math-mul (math-sub 1 (math-div 1 p))
+					      (math-add 1 rate))
+				    rate))
+		(math-div (or lump 0) p))))
+)
+(put 'calcFunc-pvb 'math-expandable t)
+
+(defun calcFunc-npv (rate &rest flows)
+  (math-check-financial rate 1)
+  (math-with-extra-prec 2
+    (let* ((flat (math-flatten-many-vecs flows))
+	   (pp (math-add 1 rate))
+	   (p pp)
+	   (accum 0))
+      (while (setq flat (cdr flat))
+	(setq accum (math-add accum (math-div (car flat) p))
+	      p (math-mul p pp)))
+      accum))
+)
+(put 'calcFunc-npv 'math-expandable t)
+
+(defun calcFunc-npvb (rate &rest flows)
+  (math-check-financial rate 1)
+  (math-with-extra-prec 2
+    (let* ((flat (math-flatten-many-vecs flows))
+	   (pp (math-add 1 rate))
+	   (p 1)
+	   (accum 0))
+      (while (setq flat (cdr flat))
+	(setq accum (math-add accum (math-div (car flat) p))
+	      p (math-mul p pp)))
+      accum))
+)
+(put 'calcFunc-npvb 'math-expandable t)
+
+(defun calcFunc-fv (rate num amount &optional initial)
+  (math-check-financial rate num)
+  (math-with-extra-prec 2
+    (let ((p (math-pow (math-add 1 rate) num)))
+      (math-add (math-mul amount
+			  (math-div (math-sub p 1)
+				    rate))
+		(math-mul (or initial 0) p))))
+)
+(put 'calcFunc-fv 'math-expandable t)
+
+(defun calcFunc-fvl (rate num amount)
+  (calcFunc-fv rate num 0 amount)
+)
+(put 'calcFunc-fvl 'math-expandable t)
+
+(defun calcFunc-fvb (rate num amount &optional initial)
+  (math-check-financial rate num)
+  (math-with-extra-prec 2
+    (let ((p (math-pow (math-add 1 rate) num)))
+      (math-add (math-mul amount
+			  (math-div (math-mul (math-sub p 1)
+					      (math-add 1 rate))
+				    rate))
+		(math-mul (or initial 0) p))))
+)
+(put 'calcFunc-fvb 'math-expandable t)
+
+(defun calcFunc-pmt (rate num amount &optional lump)
+  (math-check-financial rate num)
+  (math-with-extra-prec 2
+    (let ((p (math-pow (math-add 1 rate) num)))
+      (math-div (math-mul (math-sub amount
+				    (math-div (or lump 0) p))
+			  rate)
+		(math-sub 1 (math-div 1 p)))))
+)
+(put 'calcFunc-pmt 'math-expandable t)
+
+(defun calcFunc-pmtb (rate num amount &optional lump)
+  (math-check-financial rate num)
+  (math-with-extra-prec 2
+    (let ((p (math-pow (math-add 1 rate) num)))
+      (math-div (math-mul (math-sub amount (math-div (or lump 0) p)) rate)
+		(math-mul (math-sub 1 (math-div 1 p))
+			  (math-add 1 rate)))))
+)
+(put 'calcFunc-pmtb 'math-expandable t)
+
+(defun calcFunc-nper (rate pmt amount &optional lump)
+  (math-compute-nper rate pmt amount lump nil)
+)
+(put 'calcFunc-nper 'math-expandable t)
+
+(defun calcFunc-nperb (rate pmt amount &optional lump)
+  (math-compute-nper rate pmt amount lump 'b)
+)
+(put 'calcFunc-nperb 'math-expandable t)
+
+(defun calcFunc-nperl (rate pmt amount)
+  (math-compute-nper rate pmt amount nil 'l)
+)
+(put 'calcFunc-nperl 'math-expandable t)
+
+(defun math-compute-nper (rate pmt amount lump bflag)
+  (and lump (math-zerop lump)
+       (setq lump nil))
+  (and lump (math-zerop pmt)
+       (setq amount lump
+	     lump nil
+	     bflag 'l))
+  (or (math-objectp rate) (and math-expand-formulas (null lump))
+      (math-reject-arg rate 'numberp))
+  (and (math-zerop rate)
+       (math-reject-arg rate 'nonzerop))
+  (or (math-objectp pmt) (and math-expand-formulas (null lump))
+      (math-reject-arg pmt 'numberp))
+  (or (math-objectp amount) (and math-expand-formulas (null lump))
+      (math-reject-arg amount 'numberp))
+  (if lump
+      (progn
+	(or (math-objectp lump)
+	    (math-reject-arg lump 'numberp))
+	(let ((root (math-find-root (list 'calcFunc-eq
+					  (list (if bflag
+						    'calcFunc-pvb
+						  'calcFunc-pv)
+						rate
+						'(var DUMMY var-DUMMY)
+						pmt
+						lump)
+					  amount)
+				    '(var DUMMY var-DUMMY)
+				    '(intv 3 0 100)
+				    t)))
+	  (if (math-vectorp root)
+	      (nth 1 root)
+	    root)))
+    (math-with-extra-prec 2
+      (let ((temp (if (eq bflag 'l)
+		      (math-div amount pmt)
+		    (math-sub 1 (math-div (math-mul amount rate)
+					  (if bflag
+					      (math-mul pmt (math-add 1 rate))
+					    pmt))))))
+	(if (or (math-posp temp) math-expand-formulas)
+	    (math-neg (calcFunc-log temp (math-add 1 rate)))
+	  (math-reject-arg pmt "*Payment too small to cover interest rate")))))
+)
+
+(defun calcFunc-rate (num pmt amount &optional lump)
+  (math-compute-rate num pmt amount lump 'calcFunc-pv)
+)
+
+(defun calcFunc-rateb (num pmt amount &optional lump)
+  (math-compute-rate num pmt amount lump 'calcFunc-pvb)
+)
+
+(defun math-compute-rate (num pmt amount lump func)
+  (or (math-objectp num)
+      (math-reject-arg num 'numberp))
+  (or (math-objectp pmt)
+      (math-reject-arg pmt 'numberp))
+  (or (math-objectp amount)
+      (math-reject-arg amount 'numberp))
+  (or (null lump)
+      (math-objectp lump)
+      (math-reject-arg lump 'numberp))
+  (let ((root (math-find-root (list 'calcFunc-eq
+				    (list func
+					  '(var DUMMY var-DUMMY)
+					  num
+					  pmt
+					  (or lump 0))
+				    amount)
+			      '(var DUMMY var-DUMMY)
+			      '(intv 3 (float 1 -4) 1)
+			      t)))
+    (if (math-vectorp root)
+	(nth 1 root)
+      root))
+)
+
+(defun calcFunc-ratel (num pmt amount)
+  (or (math-objectp num) math-expand-formulas
+      (math-reject-arg num 'numberp))
+  (or (math-objectp pmt) math-expand-formulas
+      (math-reject-arg pmt 'numberp))
+  (or (math-objectp amount) math-expand-formulas
+      (math-reject-arg amount 'numberp))
+  (math-with-extra-prec 2
+    (math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1))
+)
+
+(defun calcFunc-irr (&rest vecs)
+  (math-compute-irr vecs 'calcFunc-npv)
+)
+
+(defun calcFunc-irrb (&rest vecs)
+  (math-compute-irr vecs 'calcFunc-npvb)
+)
+
+(defun math-compute-irr (vecs func)
+  (let* ((flat (math-flatten-many-vecs vecs))
+	 (root (math-find-root (list func
+				     '(var DUMMY var-DUMMY)
+				     flat)
+			       '(var DUMMY var-DUMMY)
+			       '(intv 3 (float 1 -4) 1)
+			       t)))
+    (if (math-vectorp root)
+	(nth 1 root)
+      root))
+)
+
+(defun math-check-financial (rate num)
+  (or (math-objectp rate) math-expand-formulas
+      (math-reject-arg rate 'numberp))
+  (and (math-zerop rate)
+       (math-reject-arg rate 'nonzerop))
+  (or (math-objectp num) math-expand-formulas
+      (math-reject-arg num 'numberp))
+)
+
+
+(defun calcFunc-sln (cost salvage life &optional period)
+  (or (math-realp cost) math-expand-formulas
+      (math-reject-arg cost 'realp))
+  (or (math-realp salvage) math-expand-formulas
+      (math-reject-arg salvage 'realp))
+  (or (math-realp life) math-expand-formulas
+      (math-reject-arg life 'realp))
+  (if (math-zerop life) (math-reject-arg life 'nonzerop))
+  (if (and period
+	   (if (math-num-integerp period)
+	       (or (Math-lessp life period) (not (math-posp period)))
+	     (math-reject-arg period 'integerp)))
+      0
+    (math-div (math-sub cost salvage) life))
+)
+(put 'calcFunc-sln 'math-expandable t)
+
+(defun calcFunc-syd (cost salvage life period)
+  (or (math-realp cost) math-expand-formulas
+      (math-reject-arg cost 'realp))
+  (or (math-realp salvage) math-expand-formulas
+      (math-reject-arg salvage 'realp))
+  (or (math-realp life) math-expand-formulas
+      (math-reject-arg life 'realp))
+  (if (math-zerop life) (math-reject-arg life 'nonzerop))
+  (or (math-realp period) math-expand-formulas
+      (math-reject-arg period 'realp))
+  (if (or (Math-lessp life period) (not (math-posp period)))
+      0
+    (math-div (math-mul (math-sub cost salvage)
+			(math-add (math-sub life period) 1))
+	      (math-div (math-mul life (math-add life 1)) 2)))
+)
+(put 'calcFunc-syd 'math-expandable t)
+
+(defun calcFunc-ddb (cost salvage life period)
+  (if (math-messy-integerp period) (setq period (math-trunc period)))
+  (or (integerp period) (math-reject-arg period 'fixnump))
+  (or (math-realp cost) (math-reject-arg cost 'realp))
+  (or (math-realp salvage) (math-reject-arg salvage 'realp))
+  (or (math-realp life) (math-reject-arg life 'realp))
+  (if (math-zerop life) (math-reject-arg life 'nonzerop))
+  (if (or (Math-lessp life period) (<= period 0))
+      0
+    (let ((book cost)
+	  (res 0))
+      (while (>= (setq period (1- period)) 0)
+	(setq res (math-div (math-mul book 2) life)
+	      book (math-sub book res))
+	(if (Math-lessp book salvage)
+	    (setq res (math-add res (math-sub book salvage))
+		  book salvage)))
+      res))
+)
+
+
+