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