Mercurial > emacs
comparison lisp/calc/calc-fin.el @ 40785:2fb9d407ae73
Initial import of Calc 2.02f.
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Tue, 06 Nov 2001 18:59:06 +0000 |
parents | |
children | 73f364fd8aaa |
comparison
equal
deleted
inserted
replaced
40784:d57f74c55909 | 40785:2fb9d407ae73 |
---|---|
1 ;; Calculator for GNU Emacs, part II [calc-fin.el] | |
2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. | |
3 ;; Written by Dave Gillespie, daveg@synaptics.com. | |
4 | |
5 ;; This file is part of GNU Emacs. | |
6 | |
7 ;; GNU Emacs is distributed in the hope that it will be useful, | |
8 ;; but WITHOUT ANY WARRANTY. No author or distributor | |
9 ;; accepts responsibility to anyone for the consequences of using it | |
10 ;; or for whether it serves any particular purpose or works at all, | |
11 ;; unless he says so in writing. Refer to the GNU Emacs General Public | |
12 ;; License for full details. | |
13 | |
14 ;; Everyone is granted permission to copy, modify and redistribute | |
15 ;; GNU Emacs, but only under the conditions described in the | |
16 ;; GNU Emacs General Public License. A copy of this license is | |
17 ;; supposed to have been given to you along with GNU Emacs so you | |
18 ;; can know your rights and responsibilities. It should be in a | |
19 ;; file named COPYING. Among other things, the copyright notice | |
20 ;; and this notice must be preserved on all copies. | |
21 | |
22 | |
23 | |
24 ;; This file is autoloaded from calc-ext.el. | |
25 (require 'calc-ext) | |
26 | |
27 (require 'calc-macs) | |
28 | |
29 (defun calc-Need-calc-fin () nil) | |
30 | |
31 | |
32 ;;; Financial functions. | |
33 | |
34 (defun calc-fin-pv () | |
35 (interactive) | |
36 (calc-slow-wrapper | |
37 (if (calc-is-hyperbolic) | |
38 (calc-enter-result 3 "pvl" (cons 'calcFunc-pvl (calc-top-list-n 3))) | |
39 (if (calc-is-inverse) | |
40 (calc-enter-result 3 "pvb" (cons 'calcFunc-pvb (calc-top-list-n 3))) | |
41 (calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3)))))) | |
42 ) | |
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)) | |
49 (calc-vector-op "npv" 'calcFunc-npv (1+ arg)))) | |
50 ) | |
51 | |
52 (defun calc-fin-fv () | |
53 (interactive) | |
54 (calc-slow-wrapper | |
55 (if (calc-is-hyperbolic) | |
56 (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3))) | |
57 (if (calc-is-inverse) | |
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)))))) | |
60 ) | |
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 | |
72 (defun calc-fin-nper () | |
73 (interactive) | |
74 (calc-slow-wrapper | |
75 (if (calc-is-hyperbolic) | |
76 (calc-enter-result 3 "nprl" (cons 'calcFunc-nperl (calc-top-list-n 3))) | |
77 (if (calc-is-inverse) | |
78 (calc-enter-result 3 "nprb" (cons 'calcFunc-nperb | |
79 (calc-top-list-n 3))) | |
80 (calc-enter-result 3 "nper" (cons 'calcFunc-nper | |
81 (calc-top-list-n 3)))))) | |
82 ) | |
83 | |
84 (defun calc-fin-rate () | |
85 (interactive) | |
86 (calc-slow-wrapper | |
87 (calc-pop-push-record 3 | |
88 (if (calc-is-hyperbolic) "ratl" | |
89 (if (calc-is-inverse) "ratb" "rate")) | |
90 (calc-to-percentage | |
91 (calc-normalize | |
92 (cons (if (calc-is-hyperbolic) 'calcFunc-ratel | |
93 (if (calc-is-hyperbolic) 'calcFunc-rateb | |
94 'calcFunc-rate)) | |
95 (calc-top-list-n 3)))))) | |
96 ) | |
97 | |
98 (defun calc-fin-irr (arg) | |
99 (interactive "P") | |
100 (calc-slow-wrapper | |
101 (if (calc-is-inverse) | |
102 (calc-vector-op "irrb" 'calcFunc-irrb arg) | |
103 (calc-vector-op "irr" 'calcFunc-irr arg))) | |
104 ) | |
105 | |
106 (defun calc-fin-sln () | |
107 (interactive) | |
108 (calc-slow-wrapper | |
109 (calc-enter-result 3 "sln" (cons 'calcFunc-sln (calc-top-list-n 3)))) | |
110 ) | |
111 | |
112 (defun calc-fin-syd () | |
113 (interactive) | |
114 (calc-slow-wrapper | |
115 (calc-enter-result 4 "syd" (cons 'calcFunc-syd (calc-top-list-n 4)))) | |
116 ) | |
117 | |
118 (defun calc-fin-ddb () | |
119 (interactive) | |
120 (calc-slow-wrapper | |
121 (calc-enter-result 4 "ddb" (cons 'calcFunc-ddb (calc-top-list-n 4)))) | |
122 ) | |
123 | |
124 | |
125 (defun calc-to-percentage (x) | |
126 (cond ((Math-objectp x) | |
127 (setq x (math-mul x 100)) | |
128 (if (Math-num-integerp x) | |
129 (setq x (math-trunc x))) | |
130 (list 'calcFunc-percent x)) | |
131 ((Math-vectorp x) | |
132 (cons 'vec (mapcar 'calc-to-percentage (cdr x)))) | |
133 (t x)) | |
134 ) | |
135 | |
136 (defun calc-convert-percent () | |
137 (interactive) | |
138 (calc-slow-wrapper | |
139 (calc-pop-push-record 1 "c%" (calc-to-percentage (calc-top-n 1)))) | |
140 ) | |
141 | |
142 (defun calc-percent-change () | |
143 (interactive) | |
144 (calc-slow-wrapper | |
145 (let ((res (calc-normalize (cons 'calcFunc-relch (calc-top-list 2))))) | |
146 (calc-pop-push-record 2 "%ch" (calc-to-percentage res)))) | |
147 ) | |
148 | |
149 | |
150 | |
151 | |
152 | |
153 ;;; Financial functions. | |
154 | |
155 (defun calcFunc-pv (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-sub 1 (math-div 1 p)) | |
161 rate)) | |
162 (math-div (or lump 0) p)))) | |
163 ) | |
164 (put 'calcFunc-pv 'math-expandable t) | |
165 | |
166 (defun calcFunc-pvl (rate num amount) | |
167 (calcFunc-pv rate num 0 amount) | |
168 ) | |
169 (put 'calcFunc-pvl 'math-expandable t) | |
170 | |
171 (defun calcFunc-pvb (rate num amount &optional lump) | |
172 (math-check-financial rate num) | |
173 (math-with-extra-prec 2 | |
174 (let* ((p (math-pow (math-add 1 rate) num))) | |
175 (math-add (math-mul amount | |
176 (math-div (math-mul (math-sub 1 (math-div 1 p)) | |
177 (math-add 1 rate)) | |
178 rate)) | |
179 (math-div (or lump 0) p)))) | |
180 ) | |
181 (put 'calcFunc-pvb 'math-expandable t) | |
182 | |
183 (defun calcFunc-npv (rate &rest flows) | |
184 (math-check-financial rate 1) | |
185 (math-with-extra-prec 2 | |
186 (let* ((flat (math-flatten-many-vecs flows)) | |
187 (pp (math-add 1 rate)) | |
188 (p pp) | |
189 (accum 0)) | |
190 (while (setq flat (cdr flat)) | |
191 (setq accum (math-add accum (math-div (car flat) p)) | |
192 p (math-mul p pp))) | |
193 accum)) | |
194 ) | |
195 (put 'calcFunc-npv 'math-expandable t) | |
196 | |
197 (defun calcFunc-npvb (rate &rest flows) | |
198 (math-check-financial rate 1) | |
199 (math-with-extra-prec 2 | |
200 (let* ((flat (math-flatten-many-vecs flows)) | |
201 (pp (math-add 1 rate)) | |
202 (p 1) | |
203 (accum 0)) | |
204 (while (setq flat (cdr flat)) | |
205 (setq accum (math-add accum (math-div (car flat) p)) | |
206 p (math-mul p pp))) | |
207 accum)) | |
208 ) | |
209 (put 'calcFunc-npvb 'math-expandable t) | |
210 | |
211 (defun calcFunc-fv (rate num amount &optional initial) | |
212 (math-check-financial rate num) | |
213 (math-with-extra-prec 2 | |
214 (let ((p (math-pow (math-add 1 rate) num))) | |
215 (math-add (math-mul amount | |
216 (math-div (math-sub p 1) | |
217 rate)) | |
218 (math-mul (or initial 0) p)))) | |
219 ) | |
220 (put 'calcFunc-fv 'math-expandable t) | |
221 | |
222 (defun calcFunc-fvl (rate num amount) | |
223 (calcFunc-fv rate num 0 amount) | |
224 ) | |
225 (put 'calcFunc-fvl 'math-expandable t) | |
226 | |
227 (defun calcFunc-fvb (rate num amount &optional initial) | |
228 (math-check-financial rate num) | |
229 (math-with-extra-prec 2 | |
230 (let ((p (math-pow (math-add 1 rate) num))) | |
231 (math-add (math-mul amount | |
232 (math-div (math-mul (math-sub p 1) | |
233 (math-add 1 rate)) | |
234 rate)) | |
235 (math-mul (or initial 0) p)))) | |
236 ) | |
237 (put 'calcFunc-fvb 'math-expandable t) | |
238 | |
239 (defun calcFunc-pmt (rate num amount &optional lump) | |
240 (math-check-financial rate num) | |
241 (math-with-extra-prec 2 | |
242 (let ((p (math-pow (math-add 1 rate) num))) | |
243 (math-div (math-mul (math-sub amount | |
244 (math-div (or lump 0) p)) | |
245 rate) | |
246 (math-sub 1 (math-div 1 p))))) | |
247 ) | |
248 (put 'calcFunc-pmt 'math-expandable t) | |
249 | |
250 (defun calcFunc-pmtb (rate num amount &optional lump) | |
251 (math-check-financial rate num) | |
252 (math-with-extra-prec 2 | |
253 (let ((p (math-pow (math-add 1 rate) num))) | |
254 (math-div (math-mul (math-sub amount (math-div (or lump 0) p)) rate) | |
255 (math-mul (math-sub 1 (math-div 1 p)) | |
256 (math-add 1 rate))))) | |
257 ) | |
258 (put 'calcFunc-pmtb 'math-expandable t) | |
259 | |
260 (defun calcFunc-nper (rate pmt amount &optional lump) | |
261 (math-compute-nper rate pmt amount lump nil) | |
262 ) | |
263 (put 'calcFunc-nper 'math-expandable t) | |
264 | |
265 (defun calcFunc-nperb (rate pmt amount &optional lump) | |
266 (math-compute-nper rate pmt amount lump 'b) | |
267 ) | |
268 (put 'calcFunc-nperb 'math-expandable t) | |
269 | |
270 (defun calcFunc-nperl (rate pmt amount) | |
271 (math-compute-nper rate pmt amount nil 'l) | |
272 ) | |
273 (put 'calcFunc-nperl 'math-expandable t) | |
274 | |
275 (defun math-compute-nper (rate pmt amount lump bflag) | |
276 (and lump (math-zerop lump) | |
277 (setq lump nil)) | |
278 (and lump (math-zerop pmt) | |
279 (setq amount lump | |
280 lump nil | |
281 bflag 'l)) | |
282 (or (math-objectp rate) (and math-expand-formulas (null lump)) | |
283 (math-reject-arg rate 'numberp)) | |
284 (and (math-zerop rate) | |
285 (math-reject-arg rate 'nonzerop)) | |
286 (or (math-objectp pmt) (and math-expand-formulas (null lump)) | |
287 (math-reject-arg pmt 'numberp)) | |
288 (or (math-objectp amount) (and math-expand-formulas (null lump)) | |
289 (math-reject-arg amount 'numberp)) | |
290 (if lump | |
291 (progn | |
292 (or (math-objectp lump) | |
293 (math-reject-arg lump 'numberp)) | |
294 (let ((root (math-find-root (list 'calcFunc-eq | |
295 (list (if bflag | |
296 'calcFunc-pvb | |
297 'calcFunc-pv) | |
298 rate | |
299 '(var DUMMY var-DUMMY) | |
300 pmt | |
301 lump) | |
302 amount) | |
303 '(var DUMMY var-DUMMY) | |
304 '(intv 3 0 100) | |
305 t))) | |
306 (if (math-vectorp root) | |
307 (nth 1 root) | |
308 root))) | |
309 (math-with-extra-prec 2 | |
310 (let ((temp (if (eq bflag 'l) | |
311 (math-div amount pmt) | |
312 (math-sub 1 (math-div (math-mul amount rate) | |
313 (if bflag | |
314 (math-mul pmt (math-add 1 rate)) | |
315 pmt)))))) | |
316 (if (or (math-posp temp) math-expand-formulas) | |
317 (math-neg (calcFunc-log temp (math-add 1 rate))) | |
318 (math-reject-arg pmt "*Payment too small to cover interest rate"))))) | |
319 ) | |
320 | |
321 (defun calcFunc-rate (num pmt amount &optional lump) | |
322 (math-compute-rate num pmt amount lump 'calcFunc-pv) | |
323 ) | |
324 | |
325 (defun calcFunc-rateb (num pmt amount &optional lump) | |
326 (math-compute-rate num pmt amount lump 'calcFunc-pvb) | |
327 ) | |
328 | |
329 (defun math-compute-rate (num pmt amount lump func) | |
330 (or (math-objectp num) | |
331 (math-reject-arg num 'numberp)) | |
332 (or (math-objectp pmt) | |
333 (math-reject-arg pmt 'numberp)) | |
334 (or (math-objectp amount) | |
335 (math-reject-arg amount 'numberp)) | |
336 (or (null lump) | |
337 (math-objectp lump) | |
338 (math-reject-arg lump 'numberp)) | |
339 (let ((root (math-find-root (list 'calcFunc-eq | |
340 (list func | |
341 '(var DUMMY var-DUMMY) | |
342 num | |
343 pmt | |
344 (or lump 0)) | |
345 amount) | |
346 '(var DUMMY var-DUMMY) | |
347 '(intv 3 (float 1 -4) 1) | |
348 t))) | |
349 (if (math-vectorp root) | |
350 (nth 1 root) | |
351 root)) | |
352 ) | |
353 | |
354 (defun calcFunc-ratel (num pmt amount) | |
355 (or (math-objectp num) math-expand-formulas | |
356 (math-reject-arg num 'numberp)) | |
357 (or (math-objectp pmt) math-expand-formulas | |
358 (math-reject-arg pmt 'numberp)) | |
359 (or (math-objectp amount) math-expand-formulas | |
360 (math-reject-arg amount 'numberp)) | |
361 (math-with-extra-prec 2 | |
362 (math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1)) | |
363 ) | |
364 | |
365 (defun calcFunc-irr (&rest vecs) | |
366 (math-compute-irr vecs 'calcFunc-npv) | |
367 ) | |
368 | |
369 (defun calcFunc-irrb (&rest vecs) | |
370 (math-compute-irr vecs 'calcFunc-npvb) | |
371 ) | |
372 | |
373 (defun math-compute-irr (vecs func) | |
374 (let* ((flat (math-flatten-many-vecs vecs)) | |
375 (root (math-find-root (list func | |
376 '(var DUMMY var-DUMMY) | |
377 flat) | |
378 '(var DUMMY var-DUMMY) | |
379 '(intv 3 (float 1 -4) 1) | |
380 t))) | |
381 (if (math-vectorp root) | |
382 (nth 1 root) | |
383 root)) | |
384 ) | |
385 | |
386 (defun math-check-financial (rate num) | |
387 (or (math-objectp rate) math-expand-formulas | |
388 (math-reject-arg rate 'numberp)) | |
389 (and (math-zerop rate) | |
390 (math-reject-arg rate 'nonzerop)) | |
391 (or (math-objectp num) math-expand-formulas | |
392 (math-reject-arg num 'numberp)) | |
393 ) | |
394 | |
395 | |
396 (defun calcFunc-sln (cost salvage life &optional period) | |
397 (or (math-realp cost) math-expand-formulas | |
398 (math-reject-arg cost 'realp)) | |
399 (or (math-realp salvage) math-expand-formulas | |
400 (math-reject-arg salvage 'realp)) | |
401 (or (math-realp life) math-expand-formulas | |
402 (math-reject-arg life 'realp)) | |
403 (if (math-zerop life) (math-reject-arg life 'nonzerop)) | |
404 (if (and period | |
405 (if (math-num-integerp period) | |
406 (or (Math-lessp life period) (not (math-posp period))) | |
407 (math-reject-arg period 'integerp))) | |
408 0 | |
409 (math-div (math-sub cost salvage) life)) | |
410 ) | |
411 (put 'calcFunc-sln 'math-expandable t) | |
412 | |
413 (defun calcFunc-syd (cost salvage life period) | |
414 (or (math-realp cost) math-expand-formulas | |
415 (math-reject-arg cost 'realp)) | |
416 (or (math-realp salvage) math-expand-formulas | |
417 (math-reject-arg salvage 'realp)) | |
418 (or (math-realp life) math-expand-formulas | |
419 (math-reject-arg life 'realp)) | |
420 (if (math-zerop life) (math-reject-arg life 'nonzerop)) | |
421 (or (math-realp period) math-expand-formulas | |
422 (math-reject-arg period 'realp)) | |
423 (if (or (Math-lessp life period) (not (math-posp period))) | |
424 0 | |
425 (math-div (math-mul (math-sub cost salvage) | |
426 (math-add (math-sub life period) 1)) | |
427 (math-div (math-mul life (math-add life 1)) 2))) | |
428 ) | |
429 (put 'calcFunc-syd 'math-expandable t) | |
430 | |
431 (defun calcFunc-ddb (cost salvage life period) | |
432 (if (math-messy-integerp period) (setq period (math-trunc period))) | |
433 (or (integerp period) (math-reject-arg period 'fixnump)) | |
434 (or (math-realp cost) (math-reject-arg cost 'realp)) | |
435 (or (math-realp salvage) (math-reject-arg salvage 'realp)) | |
436 (or (math-realp life) (math-reject-arg life 'realp)) | |
437 (if (math-zerop life) (math-reject-arg life 'nonzerop)) | |
438 (if (or (Math-lessp life period) (<= period 0)) | |
439 0 | |
440 (let ((book cost) | |
441 (res 0)) | |
442 (while (>= (setq period (1- period)) 0) | |
443 (setq res (math-div (math-mul book 2) life) | |
444 book (math-sub book res)) | |
445 (if (Math-lessp book salvage) | |
446 (setq res (math-add res (math-sub book salvage)) | |
447 book salvage))) | |
448 res)) | |
449 ) | |
450 | |
451 | |
452 |