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