1;;; calc-fin.el --- financial 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;;; Financial functions.
36
37(defun calc-fin-pv ()
38  (interactive)
39  (calc-slow-wrapper
40   (if (calc-is-hyperbolic)
41       (calc-enter-result 3 "pvl" (cons 'calcFunc-pvl (calc-top-list-n 3)))
42     (if (calc-is-inverse)
43	 (calc-enter-result 3 "pvb" (cons 'calcFunc-pvb (calc-top-list-n 3)))
44       (calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3)))))))
45
46(defun calc-fin-npv (arg)
47  (interactive "p")
48  (calc-slow-wrapper
49   (if (calc-is-inverse)
50       (calc-vector-op "npvb" 'calcFunc-npvb (1+ arg))
51     (calc-vector-op "npv" 'calcFunc-npv (1+ arg)))))
52
53(defun calc-fin-fv ()
54  (interactive)
55  (calc-slow-wrapper
56   (if (calc-is-hyperbolic)
57       (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
58     (if (calc-is-inverse)
59	 (calc-enter-result 3 "fvb" (cons 'calcFunc-fvb (calc-top-list-n 3)))
60       (calc-enter-result 3 "fv" (cons 'calcFunc-fv (calc-top-list-n 3)))))))
61
62(defun calc-fin-pmt ()
63  (interactive)
64  (calc-slow-wrapper
65   (if (calc-is-hyperbolic)
66       (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
67     (if (calc-is-inverse)
68	 (calc-enter-result 3 "pmtb" (cons 'calcFunc-pmtb (calc-top-list-n 3)))
69       (calc-enter-result 3 "pmt" (cons 'calcFunc-pmt (calc-top-list-n 3)))))))
70
71(defun calc-fin-nper ()
72  (interactive)
73  (calc-slow-wrapper
74   (if (calc-is-hyperbolic)
75       (calc-enter-result 3 "nprl" (cons 'calcFunc-nperl (calc-top-list-n 3)))
76     (if (calc-is-inverse)
77	 (calc-enter-result 3 "nprb" (cons 'calcFunc-nperb
78					   (calc-top-list-n 3)))
79       (calc-enter-result 3 "nper" (cons 'calcFunc-nper
80					 (calc-top-list-n 3)))))))
81
82(defun calc-fin-rate ()
83  (interactive)
84  (calc-slow-wrapper
85   (calc-pop-push-record 3
86			 (if (calc-is-hyperbolic) "ratl"
87			   (if (calc-is-inverse) "ratb" "rate"))
88			 (calc-to-percentage
89			  (calc-normalize
90			   (cons (if (calc-is-hyperbolic) 'calcFunc-ratel
91				   (if (calc-is-hyperbolic) 'calcFunc-rateb
92				     'calcFunc-rate))
93				 (calc-top-list-n 3)))))))
94
95(defun calc-fin-irr (arg)
96  (interactive "P")
97  (calc-slow-wrapper
98   (if (calc-is-inverse)
99       (calc-vector-op "irrb" 'calcFunc-irrb arg)
100     (calc-vector-op "irr" 'calcFunc-irr arg))))
101
102(defun calc-fin-sln ()
103  (interactive)
104  (calc-slow-wrapper
105   (calc-enter-result 3 "sln" (cons 'calcFunc-sln (calc-top-list-n 3)))))
106
107(defun calc-fin-syd ()
108  (interactive)
109  (calc-slow-wrapper
110   (calc-enter-result 4 "syd" (cons 'calcFunc-syd (calc-top-list-n 4)))))
111
112(defun calc-fin-ddb ()
113  (interactive)
114  (calc-slow-wrapper
115   (calc-enter-result 4 "ddb" (cons 'calcFunc-ddb (calc-top-list-n 4)))))
116
117
118(defun calc-to-percentage (x)
119  (cond ((Math-objectp x)
120	 (setq x (math-mul x 100))
121	 (if (Math-num-integerp x)
122	     (setq x (math-trunc x)))
123	 (list 'calcFunc-percent x))
124	((Math-vectorp x)
125	 (cons 'vec (mapcar 'calc-to-percentage (cdr x))))
126	(t x)))
127
128(defun calc-convert-percent ()
129  (interactive)
130  (calc-slow-wrapper
131   (calc-pop-push-record 1 "c%" (calc-to-percentage (calc-top-n 1)))))
132
133(defun calc-percent-change ()
134  (interactive)
135  (calc-slow-wrapper
136   (let ((res (calc-normalize (cons 'calcFunc-relch (calc-top-list 2)))))
137     (calc-pop-push-record 2 "%ch" (calc-to-percentage res)))))
138
139
140;;; Financial functions.
141
142(defun calcFunc-pv (rate num amount &optional lump)
143  (math-check-financial rate num)
144  (math-with-extra-prec 2
145    (let ((p (math-pow (math-add 1 rate) num)))
146      (math-add (math-mul amount
147			  (math-div (math-sub 1 (math-div 1 p))
148				    rate))
149		(math-div (or lump 0) p)))))
150(put 'calcFunc-pv 'math-expandable t)
151
152(defun calcFunc-pvl (rate num amount)
153  (calcFunc-pv rate num 0 amount))
154(put 'calcFunc-pvl 'math-expandable t)
155
156(defun calcFunc-pvb (rate num amount &optional lump)
157  (math-check-financial rate num)
158  (math-with-extra-prec 2
159    (let* ((p (math-pow (math-add 1 rate) num)))
160      (math-add (math-mul amount
161			  (math-div (math-mul (math-sub 1 (math-div 1 p))
162					      (math-add 1 rate))
163				    rate))
164		(math-div (or lump 0) p)))))
165(put 'calcFunc-pvb 'math-expandable t)
166
167(defun calcFunc-npv (rate &rest flows)
168  (math-check-financial rate 1)
169  (math-with-extra-prec 2
170    (let* ((flat (math-flatten-many-vecs flows))
171	   (pp (math-add 1 rate))
172	   (p pp)
173	   (accum 0))
174      (while (setq flat (cdr flat))
175	(setq accum (math-add accum (math-div (car flat) p))
176	      p (math-mul p pp)))
177      accum)))
178(put 'calcFunc-npv 'math-expandable t)
179
180(defun calcFunc-npvb (rate &rest flows)
181  (math-check-financial rate 1)
182  (math-with-extra-prec 2
183    (let* ((flat (math-flatten-many-vecs flows))
184	   (pp (math-add 1 rate))
185	   (p 1)
186	   (accum 0))
187      (while (setq flat (cdr flat))
188	(setq accum (math-add accum (math-div (car flat) p))
189	      p (math-mul p pp)))
190      accum)))
191(put 'calcFunc-npvb 'math-expandable t)
192
193(defun calcFunc-fv (rate num amount &optional initial)
194  (math-check-financial rate num)
195  (math-with-extra-prec 2
196    (let ((p (math-pow (math-add 1 rate) num)))
197      (math-add (math-mul amount
198			  (math-div (math-sub p 1)
199				    rate))
200		(math-mul (or initial 0) p)))))
201(put 'calcFunc-fv 'math-expandable t)
202
203(defun calcFunc-fvl (rate num amount)
204  (calcFunc-fv rate num 0 amount))
205(put 'calcFunc-fvl 'math-expandable t)
206
207(defun calcFunc-fvb (rate num amount &optional initial)
208  (math-check-financial rate num)
209  (math-with-extra-prec 2
210    (let ((p (math-pow (math-add 1 rate) num)))
211      (math-add (math-mul amount
212			  (math-div (math-mul (math-sub p 1)
213					      (math-add 1 rate))
214				    rate))
215		(math-mul (or initial 0) p)))))
216(put 'calcFunc-fvb 'math-expandable t)
217
218(defun calcFunc-pmt (rate num amount &optional lump)
219  (math-check-financial rate num)
220  (math-with-extra-prec 2
221    (let ((p (math-pow (math-add 1 rate) num)))
222      (math-div (math-mul (math-sub amount
223				    (math-div (or lump 0) p))
224			  rate)
225		(math-sub 1 (math-div 1 p))))))
226(put 'calcFunc-pmt 'math-expandable t)
227
228(defun calcFunc-pmtb (rate num amount &optional lump)
229  (math-check-financial rate num)
230  (math-with-extra-prec 2
231    (let ((p (math-pow (math-add 1 rate) num)))
232      (math-div (math-mul (math-sub amount (math-div (or lump 0) p)) rate)
233		(math-mul (math-sub 1 (math-div 1 p))
234			  (math-add 1 rate))))))
235(put 'calcFunc-pmtb 'math-expandable t)
236
237(defun calcFunc-nper (rate pmt amount &optional lump)
238  (math-compute-nper rate pmt amount lump nil))
239(put 'calcFunc-nper 'math-expandable t)
240
241(defun calcFunc-nperb (rate pmt amount &optional lump)
242  (math-compute-nper rate pmt amount lump 'b))
243(put 'calcFunc-nperb 'math-expandable t)
244
245(defun calcFunc-nperl (rate pmt amount)
246  (math-compute-nper rate pmt amount nil 'l))
247(put 'calcFunc-nperl 'math-expandable t)
248
249(defun math-compute-nper (rate pmt amount lump bflag)
250  (and lump (math-zerop lump)
251       (setq lump nil))
252  (and lump (math-zerop pmt)
253       (setq amount lump
254	     lump nil
255	     bflag 'l))
256  (or (math-objectp rate) (and math-expand-formulas (null lump))
257      (math-reject-arg rate 'numberp))
258  (and (math-zerop rate)
259       (math-reject-arg rate 'nonzerop))
260  (or (math-objectp pmt) (and math-expand-formulas (null lump))
261      (math-reject-arg pmt 'numberp))
262  (or (math-objectp amount) (and math-expand-formulas (null lump))
263      (math-reject-arg amount 'numberp))
264  (if lump
265      (progn
266	(or (math-objectp lump)
267	    (math-reject-arg lump 'numberp))
268	(let ((root (math-find-root (list 'calcFunc-eq
269					  (list (if bflag
270						    'calcFunc-pvb
271						  'calcFunc-pv)
272						rate
273						'(var DUMMY var-DUMMY)
274						pmt
275						lump)
276					  amount)
277				    '(var DUMMY var-DUMMY)
278				    '(intv 3 0 100)
279				    t)))
280	  (if (math-vectorp root)
281	      (nth 1 root)
282	    root)))
283    (math-with-extra-prec 2
284      (let ((temp (if (eq bflag 'l)
285		      (math-div amount pmt)
286		    (math-sub 1 (math-div (math-mul amount rate)
287					  (if bflag
288					      (math-mul pmt (math-add 1 rate))
289					    pmt))))))
290	(if (or (math-posp temp) math-expand-formulas)
291	    (math-neg (calcFunc-log temp (math-add 1 rate)))
292	  (math-reject-arg pmt "*Payment too small to cover interest rate"))))))
293
294(defun calcFunc-rate (num pmt amount &optional lump)
295  (math-compute-rate num pmt amount lump 'calcFunc-pv))
296
297(defun calcFunc-rateb (num pmt amount &optional lump)
298  (math-compute-rate num pmt amount lump 'calcFunc-pvb))
299
300(defun math-compute-rate (num pmt amount lump func)
301  (or (math-objectp num)
302      (math-reject-arg num 'numberp))
303  (or (math-objectp pmt)
304      (math-reject-arg pmt 'numberp))
305  (or (math-objectp amount)
306      (math-reject-arg amount 'numberp))
307  (or (null lump)
308      (math-objectp lump)
309      (math-reject-arg lump 'numberp))
310  (let ((root (math-find-root (list 'calcFunc-eq
311				    (list func
312					  '(var DUMMY var-DUMMY)
313					  num
314					  pmt
315					  (or lump 0))
316				    amount)
317			      '(var DUMMY var-DUMMY)
318			      '(intv 3 (float 1 -4) 1)
319			      t)))
320    (if (math-vectorp root)
321	(nth 1 root)
322      root)))
323
324(defun calcFunc-ratel (num pmt amount)
325  (or (math-objectp num) math-expand-formulas
326      (math-reject-arg num 'numberp))
327  (or (math-objectp pmt) math-expand-formulas
328      (math-reject-arg pmt 'numberp))
329  (or (math-objectp amount) math-expand-formulas
330      (math-reject-arg amount 'numberp))
331  (math-with-extra-prec 2
332    (math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1)))
333
334(defun calcFunc-irr (&rest vecs)
335  (math-compute-irr vecs 'calcFunc-npv))
336
337(defun calcFunc-irrb (&rest vecs)
338  (math-compute-irr vecs 'calcFunc-npvb))
339
340(defun math-compute-irr (vecs func)
341  (let* ((flat (math-flatten-many-vecs vecs))
342	 (root (math-find-root (list func
343				     '(var DUMMY var-DUMMY)
344				     flat)
345			       '(var DUMMY var-DUMMY)
346			       '(intv 3 (float 1 -4) 1)
347			       t)))
348    (if (math-vectorp root)
349	(nth 1 root)
350      root)))
351
352(defun math-check-financial (rate num)
353  (or (math-objectp rate) math-expand-formulas
354      (math-reject-arg rate 'numberp))
355  (and (math-zerop rate)
356       (math-reject-arg rate 'nonzerop))
357  (or (math-objectp num) math-expand-formulas
358      (math-reject-arg num 'numberp)))
359
360
361(defun calcFunc-sln (cost salvage life &optional period)
362  (or (math-realp cost) math-expand-formulas
363      (math-reject-arg cost 'realp))
364  (or (math-realp salvage) math-expand-formulas
365      (math-reject-arg salvage 'realp))
366  (or (math-realp life) math-expand-formulas
367      (math-reject-arg life 'realp))
368  (if (math-zerop life) (math-reject-arg life 'nonzerop))
369  (if (and period
370	   (if (math-num-integerp period)
371	       (or (Math-lessp life period) (not (math-posp period)))
372	     (math-reject-arg period 'integerp)))
373      0
374    (math-div (math-sub cost salvage) life)))
375(put 'calcFunc-sln 'math-expandable t)
376
377(defun calcFunc-syd (cost salvage life period)
378  (or (math-realp cost) math-expand-formulas
379      (math-reject-arg cost 'realp))
380  (or (math-realp salvage) math-expand-formulas
381      (math-reject-arg salvage 'realp))
382  (or (math-realp life) math-expand-formulas
383      (math-reject-arg life 'realp))
384  (if (math-zerop life) (math-reject-arg life 'nonzerop))
385  (or (math-realp period) math-expand-formulas
386      (math-reject-arg period 'realp))
387  (if (or (Math-lessp life period) (not (math-posp period)))
388      0
389    (math-div (math-mul (math-sub cost salvage)
390			(math-add (math-sub life period) 1))
391	      (math-div (math-mul life (math-add life 1)) 2))))
392(put 'calcFunc-syd 'math-expandable t)
393
394(defun calcFunc-ddb (cost salvage life period)
395  (if (math-messy-integerp period) (setq period (math-trunc period)))
396  (or (integerp period) (math-reject-arg period 'fixnump))
397  (or (math-realp cost) (math-reject-arg cost 'realp))
398  (or (math-realp salvage) (math-reject-arg salvage 'realp))
399  (or (math-realp life) (math-reject-arg life 'realp))
400  (if (math-zerop life) (math-reject-arg life 'nonzerop))
401  (if (or (Math-lessp life period) (<= period 0))
402      0
403    (let ((book cost)
404	  (res 0))
405      (while (>= (setq period (1- period)) 0)
406	(setq res (math-div (math-mul book 2) life)
407	      book (math-sub book res))
408	(if (Math-lessp book salvage)
409	    (setq res (math-add res (math-sub book salvage))
410		  book salvage)))
411      res)))
412
413(provide 'calc-fin)
414
415;;; arch-tag: 82f30ca8-d02f-4b33-84b4-bb6ecd84597b
416;;; calc-fin.el ends here
417