view lisp/calc/calc-fin.el @ 97528:184bb2071e3f

mail/: Add new (temporary) libaries for which to test Rmail/mbox such that Rmail/babyl is not affected. This creates a facility/feature called "pmail" (analagous to "rmail") that can be used independently from Rmail for testing purposes. The plan is to replace the "rmail" files eventually and remove "pmail" entirely at that point. In the interim, interested developers can use either Rmail or Pmail or both (which is not recommended for the casual User or the faint of heart).

;;; calc-fin.el --- financial functions for Calc

;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: David Gillespie <[e-mail]>
;; Maintainer: Jay Belanger <[e-mail]>

;; This file is part of GNU Emacs.

;; 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 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

;; This file is autoloaded from calc-ext.el.

(require 'calc-ext)
(require 'calc-macs)

;;; 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)))

(provide 'calc-fin)

;; arch-tag: 82f30ca8-d02f-4b33-84b4-bb6ecd84597b
;;; calc-fin.el ends here