Fix GTK font name parsing to allow numbers in names (Bug#7853).
[emacs.git] / lisp / calc / calc-fin.el
blob78eb1447ec130b65d9f1f131758fd4c1ce9a82b3
1 ;;; calc-fin.el --- financial functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
6 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
9 ;; This file is part of GNU Emacs.
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 3 of the License, or
14 ;; (at your option) any later version.
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.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Commentary:
26 ;;; Code:
28 ;; This file is autoloaded from calc-ext.el.
30 (require 'calc-ext)
31 (require 'calc-macs)
33 ;;; Financial functions.
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)))
42 (calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3)))))))
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)))))
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)))
58 (calc-enter-result 3 "fv" (cons 'calcFunc-fv (calc-top-list-n 3)))))))
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)))
67 (calc-enter-result 3 "pmt" (cons 'calcFunc-pmt (calc-top-list-n 3)))))))
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
78 (calc-top-list-n 3)))))))
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))
91 (calc-top-list-n 3)))))))
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)
98 (calc-vector-op "irr" 'calcFunc-irr arg))))
100 (defun calc-fin-sln ()
101 (interactive)
102 (calc-slow-wrapper
103 (calc-enter-result 3 "sln" (cons 'calcFunc-sln (calc-top-list-n 3)))))
105 (defun calc-fin-syd ()
106 (interactive)
107 (calc-slow-wrapper
108 (calc-enter-result 4 "syd" (cons 'calcFunc-syd (calc-top-list-n 4)))))
110 (defun calc-fin-ddb ()
111 (interactive)
112 (calc-slow-wrapper
113 (calc-enter-result 4 "ddb" (cons 'calcFunc-ddb (calc-top-list-n 4)))))
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))))
124 (t x)))
126 (defun calc-convert-percent ()
127 (interactive)
128 (calc-slow-wrapper
129 (calc-pop-push-record 1 "c%" (calc-to-percentage (calc-top-n 1)))))
131 (defun calc-percent-change ()
132 (interactive)
133 (calc-slow-wrapper
134 (let ((res (calc-normalize (cons 'calcFunc-relch (calc-top-list 2)))))
135 (calc-pop-push-record 2 "%ch" (calc-to-percentage res)))))
138 ;;; Financial functions.
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))
147 (math-div (or lump 0) p)))))
148 (put 'calcFunc-pv 'math-expandable t)
150 (defun calcFunc-pvl (rate num amount)
151 (calcFunc-pv rate num 0 amount))
152 (put 'calcFunc-pvl 'math-expandable t)
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))
162 (math-div (or lump 0) p)))))
163 (put 'calcFunc-pvb 'math-expandable t)
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)))
175 accum)))
176 (put 'calcFunc-npv 'math-expandable t)
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)))
188 accum)))
189 (put 'calcFunc-npvb 'math-expandable t)
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))
198 (math-mul (or initial 0) p)))))
199 (put 'calcFunc-fv 'math-expandable t)
201 (defun calcFunc-fvl (rate num amount)
202 (calcFunc-fv rate num 0 amount))
203 (put 'calcFunc-fvl 'math-expandable t)
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))
213 (math-mul (or initial 0) p)))))
214 (put 'calcFunc-fvb 'math-expandable t)
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)
223 (math-sub 1 (math-div 1 p))))))
224 (put 'calcFunc-pmt 'math-expandable t)
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))
232 (math-add 1 rate))))))
233 (put 'calcFunc-pmtb 'math-expandable t)
235 (defun calcFunc-nper (rate pmt amount &optional lump)
236 (math-compute-nper rate pmt amount lump nil))
237 (put 'calcFunc-nper 'math-expandable t)
239 (defun calcFunc-nperb (rate pmt amount &optional lump)
240 (math-compute-nper rate pmt amount lump 'b))
241 (put 'calcFunc-nperb 'math-expandable t)
243 (defun calcFunc-nperl (rate pmt amount)
244 (math-compute-nper rate pmt amount nil 'l))
245 (put 'calcFunc-nperl 'math-expandable t)
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)
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)))
290 (math-reject-arg pmt "*Payment too small to cover interest rate"))))))
292 (defun calcFunc-rate (num pmt amount &optional lump)
293 (math-compute-rate num pmt amount lump 'calcFunc-pv))
295 (defun calcFunc-rateb (num pmt amount &optional lump)
296 (math-compute-rate num pmt amount lump 'calcFunc-pvb))
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)
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)
320 root)))
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
330 (math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1)))
332 (defun calcFunc-irr (&rest vecs)
333 (math-compute-irr vecs 'calcFunc-npv))
335 (defun calcFunc-irrb (&rest vecs)
336 (math-compute-irr vecs 'calcFunc-npvb))
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)
348 root)))
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
356 (math-reject-arg num 'numberp)))
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)))
372 (math-div (math-sub cost salvage) life)))
373 (put 'calcFunc-sln 'math-expandable t)
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)))
387 (math-div (math-mul (math-sub cost salvage)
388 (math-add (math-sub life period) 1))
389 (math-div (math-mul life (math-add life 1)) 2))))
390 (put 'calcFunc-syd 'math-expandable t)
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))
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)))
409 res)))
411 (provide 'calc-fin)
413 ;; arch-tag: 82f30ca8-d02f-4b33-84b4-bb6ecd84597b
414 ;;; calc-fin.el ends here