1 ;;; calc-fin.el --- financial functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <belanger@truman.edu>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY. No author or distributor
12 ;; accepts responsibility to anyone for the consequences of using it
13 ;; or for whether it serves any particular purpose or works at all,
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public
15 ;; License for full details.
17 ;; Everyone is granted permission to copy, modify and redistribute
18 ;; GNU Emacs, but only under the conditions described in the
19 ;; GNU Emacs General Public License. A copy of this license is
20 ;; supposed to have been given to you along with GNU Emacs so you
21 ;; can know your rights and responsibilities. It should be in a
22 ;; file named COPYING. Among other things, the copyright notice
23 ;; and this notice must be preserved on all copies.
29 ;; This file is autoloaded from calc-ext.el.
34 ;;; Financial functions.
39 (if (calc-is-hyperbolic)
40 (calc-enter-result 3 "pvl" (cons 'calcFunc-pvl
(calc-top-list-n 3)))
42 (calc-enter-result 3 "pvb" (cons 'calcFunc-pvb
(calc-top-list-n 3)))
43 (calc-enter-result 3 "pv" (cons 'calcFunc-pv
(calc-top-list-n 3)))))))
45 (defun calc-fin-npv (arg)
49 (calc-vector-op "npvb" 'calcFunc-npvb
(1+ arg
))
50 (calc-vector-op "npv" 'calcFunc-npv
(1+ arg
)))))
55 (if (calc-is-hyperbolic)
56 (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl
(calc-top-list-n 3)))
58 (calc-enter-result 3 "fvb" (cons 'calcFunc-fvb
(calc-top-list-n 3)))
59 (calc-enter-result 3 "fv" (cons 'calcFunc-fv
(calc-top-list-n 3)))))))
61 (defun calc-fin-pmt ()
64 (if (calc-is-hyperbolic)
65 (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl
(calc-top-list-n 3)))
67 (calc-enter-result 3 "pmtb" (cons 'calcFunc-pmtb
(calc-top-list-n 3)))
68 (calc-enter-result 3 "pmt" (cons 'calcFunc-pmt
(calc-top-list-n 3)))))))
70 (defun calc-fin-nper ()
73 (if (calc-is-hyperbolic)
74 (calc-enter-result 3 "nprl" (cons 'calcFunc-nperl
(calc-top-list-n 3)))
76 (calc-enter-result 3 "nprb" (cons 'calcFunc-nperb
78 (calc-enter-result 3 "nper" (cons 'calcFunc-nper
79 (calc-top-list-n 3)))))))
81 (defun calc-fin-rate ()
84 (calc-pop-push-record 3
85 (if (calc-is-hyperbolic) "ratl"
86 (if (calc-is-inverse) "ratb" "rate"))
89 (cons (if (calc-is-hyperbolic) 'calcFunc-ratel
90 (if (calc-is-hyperbolic) 'calcFunc-rateb
92 (calc-top-list-n 3)))))))
94 (defun calc-fin-irr (arg)
98 (calc-vector-op "irrb" 'calcFunc-irrb arg
)
99 (calc-vector-op "irr" 'calcFunc-irr arg
))))
101 (defun calc-fin-sln ()
104 (calc-enter-result 3 "sln" (cons 'calcFunc-sln
(calc-top-list-n 3)))))
106 (defun calc-fin-syd ()
109 (calc-enter-result 4 "syd" (cons 'calcFunc-syd
(calc-top-list-n 4)))))
111 (defun calc-fin-ddb ()
114 (calc-enter-result 4 "ddb" (cons 'calcFunc-ddb
(calc-top-list-n 4)))))
117 (defun calc-to-percentage (x)
118 (cond ((Math-objectp x
)
119 (setq x
(math-mul x
100))
120 (if (Math-num-integerp x
)
121 (setq x
(math-trunc x
)))
122 (list 'calcFunc-percent x
))
124 (cons 'vec
(mapcar 'calc-to-percentage
(cdr x
))))
127 (defun calc-convert-percent ()
130 (calc-pop-push-record 1 "c%" (calc-to-percentage (calc-top-n 1)))))
132 (defun calc-percent-change ()
135 (let ((res (calc-normalize (cons 'calcFunc-relch
(calc-top-list 2)))))
136 (calc-pop-push-record 2 "%ch" (calc-to-percentage res
)))))
139 ;;; Financial functions.
141 (defun calcFunc-pv (rate num amount
&optional lump
)
142 (math-check-financial rate num
)
143 (math-with-extra-prec 2
144 (let ((p (math-pow (math-add 1 rate
) num
)))
145 (math-add (math-mul amount
146 (math-div (math-sub 1 (math-div 1 p
))
148 (math-div (or lump
0) p
)))))
149 (put 'calcFunc-pv
'math-expandable t
)
151 (defun calcFunc-pvl (rate num amount
)
152 (calcFunc-pv rate num
0 amount
))
153 (put 'calcFunc-pvl
'math-expandable t
)
155 (defun calcFunc-pvb (rate num amount
&optional lump
)
156 (math-check-financial rate num
)
157 (math-with-extra-prec 2
158 (let* ((p (math-pow (math-add 1 rate
) num
)))
159 (math-add (math-mul amount
160 (math-div (math-mul (math-sub 1 (math-div 1 p
))
163 (math-div (or lump
0) p
)))))
164 (put 'calcFunc-pvb
'math-expandable t
)
166 (defun calcFunc-npv (rate &rest flows
)
167 (math-check-financial rate
1)
168 (math-with-extra-prec 2
169 (let* ((flat (math-flatten-many-vecs flows
))
170 (pp (math-add 1 rate
))
173 (while (setq flat
(cdr flat
))
174 (setq accum
(math-add accum
(math-div (car flat
) p
))
177 (put 'calcFunc-npv
'math-expandable t
)
179 (defun calcFunc-npvb (rate &rest flows
)
180 (math-check-financial rate
1)
181 (math-with-extra-prec 2
182 (let* ((flat (math-flatten-many-vecs flows
))
183 (pp (math-add 1 rate
))
186 (while (setq flat
(cdr flat
))
187 (setq accum
(math-add accum
(math-div (car flat
) p
))
190 (put 'calcFunc-npvb
'math-expandable t
)
192 (defun calcFunc-fv (rate num amount
&optional initial
)
193 (math-check-financial rate num
)
194 (math-with-extra-prec 2
195 (let ((p (math-pow (math-add 1 rate
) num
)))
196 (math-add (math-mul amount
197 (math-div (math-sub p
1)
199 (math-mul (or initial
0) p
)))))
200 (put 'calcFunc-fv
'math-expandable t
)
202 (defun calcFunc-fvl (rate num amount
)
203 (calcFunc-fv rate num
0 amount
))
204 (put 'calcFunc-fvl
'math-expandable t
)
206 (defun calcFunc-fvb (rate num amount
&optional initial
)
207 (math-check-financial rate num
)
208 (math-with-extra-prec 2
209 (let ((p (math-pow (math-add 1 rate
) num
)))
210 (math-add (math-mul amount
211 (math-div (math-mul (math-sub p
1)
214 (math-mul (or initial
0) p
)))))
215 (put 'calcFunc-fvb
'math-expandable t
)
217 (defun calcFunc-pmt (rate num amount
&optional lump
)
218 (math-check-financial rate num
)
219 (math-with-extra-prec 2
220 (let ((p (math-pow (math-add 1 rate
) num
)))
221 (math-div (math-mul (math-sub amount
222 (math-div (or lump
0) p
))
224 (math-sub 1 (math-div 1 p
))))))
225 (put 'calcFunc-pmt
'math-expandable t
)
227 (defun calcFunc-pmtb (rate num amount
&optional lump
)
228 (math-check-financial rate num
)
229 (math-with-extra-prec 2
230 (let ((p (math-pow (math-add 1 rate
) num
)))
231 (math-div (math-mul (math-sub amount
(math-div (or lump
0) p
)) rate
)
232 (math-mul (math-sub 1 (math-div 1 p
))
233 (math-add 1 rate
))))))
234 (put 'calcFunc-pmtb
'math-expandable t
)
236 (defun calcFunc-nper (rate pmt amount
&optional lump
)
237 (math-compute-nper rate pmt amount lump nil
))
238 (put 'calcFunc-nper
'math-expandable t
)
240 (defun calcFunc-nperb (rate pmt amount
&optional lump
)
241 (math-compute-nper rate pmt amount lump
'b
))
242 (put 'calcFunc-nperb
'math-expandable t
)
244 (defun calcFunc-nperl (rate pmt amount
)
245 (math-compute-nper rate pmt amount nil
'l
))
246 (put 'calcFunc-nperl
'math-expandable t
)
248 (defun math-compute-nper (rate pmt amount lump bflag
)
249 (and lump
(math-zerop lump
)
251 (and lump
(math-zerop pmt
)
255 (or (math-objectp rate
) (and math-expand-formulas
(null lump
))
256 (math-reject-arg rate
'numberp
))
257 (and (math-zerop rate
)
258 (math-reject-arg rate
'nonzerop
))
259 (or (math-objectp pmt
) (and math-expand-formulas
(null lump
))
260 (math-reject-arg pmt
'numberp
))
261 (or (math-objectp amount
) (and math-expand-formulas
(null lump
))
262 (math-reject-arg amount
'numberp
))
265 (or (math-objectp lump
)
266 (math-reject-arg lump
'numberp
))
267 (let ((root (math-find-root (list 'calcFunc-eq
272 '(var DUMMY var-DUMMY
)
276 '(var DUMMY var-DUMMY
)
279 (if (math-vectorp root
)
282 (math-with-extra-prec 2
283 (let ((temp (if (eq bflag
'l
)
284 (math-div amount pmt
)
285 (math-sub 1 (math-div (math-mul amount rate
)
287 (math-mul pmt
(math-add 1 rate
))
289 (if (or (math-posp temp
) math-expand-formulas
)
290 (math-neg (calcFunc-log temp
(math-add 1 rate
)))
291 (math-reject-arg pmt
"*Payment too small to cover interest rate"))))))
293 (defun calcFunc-rate (num pmt amount
&optional lump
)
294 (math-compute-rate num pmt amount lump
'calcFunc-pv
))
296 (defun calcFunc-rateb (num pmt amount
&optional lump
)
297 (math-compute-rate num pmt amount lump
'calcFunc-pvb
))
299 (defun math-compute-rate (num pmt amount lump func
)
300 (or (math-objectp num
)
301 (math-reject-arg num
'numberp
))
302 (or (math-objectp pmt
)
303 (math-reject-arg pmt
'numberp
))
304 (or (math-objectp amount
)
305 (math-reject-arg amount
'numberp
))
308 (math-reject-arg lump
'numberp
))
309 (let ((root (math-find-root (list 'calcFunc-eq
311 '(var DUMMY var-DUMMY
)
316 '(var DUMMY var-DUMMY
)
317 '(intv 3 (float 1 -
4) 1)
319 (if (math-vectorp root
)
323 (defun calcFunc-ratel (num pmt amount
)
324 (or (math-objectp num
) math-expand-formulas
325 (math-reject-arg num
'numberp
))
326 (or (math-objectp pmt
) math-expand-formulas
327 (math-reject-arg pmt
'numberp
))
328 (or (math-objectp amount
) math-expand-formulas
329 (math-reject-arg amount
'numberp
))
330 (math-with-extra-prec 2
331 (math-sub (math-pow (math-div pmt amount
) (math-div 1 num
)) 1)))
333 (defun calcFunc-irr (&rest vecs
)
334 (math-compute-irr vecs
'calcFunc-npv
))
336 (defun calcFunc-irrb (&rest vecs
)
337 (math-compute-irr vecs
'calcFunc-npvb
))
339 (defun math-compute-irr (vecs func
)
340 (let* ((flat (math-flatten-many-vecs vecs
))
341 (root (math-find-root (list func
342 '(var DUMMY var-DUMMY
)
344 '(var DUMMY var-DUMMY
)
345 '(intv 3 (float 1 -
4) 1)
347 (if (math-vectorp root
)
351 (defun math-check-financial (rate num
)
352 (or (math-objectp rate
) math-expand-formulas
353 (math-reject-arg rate
'numberp
))
354 (and (math-zerop rate
)
355 (math-reject-arg rate
'nonzerop
))
356 (or (math-objectp num
) math-expand-formulas
357 (math-reject-arg num
'numberp
)))
360 (defun calcFunc-sln (cost salvage life
&optional period
)
361 (or (math-realp cost
) math-expand-formulas
362 (math-reject-arg cost
'realp
))
363 (or (math-realp salvage
) math-expand-formulas
364 (math-reject-arg salvage
'realp
))
365 (or (math-realp life
) math-expand-formulas
366 (math-reject-arg life
'realp
))
367 (if (math-zerop life
) (math-reject-arg life
'nonzerop
))
369 (if (math-num-integerp period
)
370 (or (Math-lessp life period
) (not (math-posp period
)))
371 (math-reject-arg period
'integerp
)))
373 (math-div (math-sub cost salvage
) life
)))
374 (put 'calcFunc-sln
'math-expandable t
)
376 (defun calcFunc-syd (cost salvage life period
)
377 (or (math-realp cost
) math-expand-formulas
378 (math-reject-arg cost
'realp
))
379 (or (math-realp salvage
) math-expand-formulas
380 (math-reject-arg salvage
'realp
))
381 (or (math-realp life
) math-expand-formulas
382 (math-reject-arg life
'realp
))
383 (if (math-zerop life
) (math-reject-arg life
'nonzerop
))
384 (or (math-realp period
) math-expand-formulas
385 (math-reject-arg period
'realp
))
386 (if (or (Math-lessp life period
) (not (math-posp period
)))
388 (math-div (math-mul (math-sub cost salvage
)
389 (math-add (math-sub life period
) 1))
390 (math-div (math-mul life
(math-add life
1)) 2))))
391 (put 'calcFunc-syd
'math-expandable t
)
393 (defun calcFunc-ddb (cost salvage life period
)
394 (if (math-messy-integerp period
) (setq period
(math-trunc period
)))
395 (or (integerp period
) (math-reject-arg period
'fixnump
))
396 (or (math-realp cost
) (math-reject-arg cost
'realp
))
397 (or (math-realp salvage
) (math-reject-arg salvage
'realp
))
398 (or (math-realp life
) (math-reject-arg life
'realp
))
399 (if (math-zerop life
) (math-reject-arg life
'nonzerop
))
400 (if (or (Math-lessp life period
) (<= period
0))
404 (while (>= (setq period
(1- period
)) 0)
405 (setq res
(math-div (math-mul book
2) life
)
406 book
(math-sub book res
))
407 (if (Math-lessp book salvage
)
408 (setq res
(math-add res
(math-sub book salvage
))
414 ;;; arch-tag: 82f30ca8-d02f-4b33-84b4-bb6ecd84597b
415 ;;; calc-fin.el ends here