lisp/calc/calc-fin.el

   1 ;;; calc-fin.el --- financial functions for Calc
   2
   3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 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 3 of the License, or
  14 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 ;; This file is autoloaded from calc-ext.el.
  29
  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)))
  42        (calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3)))))))
  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 (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)))))))
  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)))
  67        (calc-enter-result 3 "pmt" (cons 'calcFunc-pmt (calc-top-list-n 3)))))))
  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
  78                                          (calc-top-list-n 3)))))))
  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))
  91                                  (calc-top-list-n 3)))))))
  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)
  98      (calc-vector-op "irr" 'calcFunc-irr arg))))
  99
 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)))))
 104
 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)))))
 109
 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)))))
 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))))
 124         (t x)))
 125
 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)))))
 130
 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)))))
 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))
 147                 (math-div (or lump 0) p)))))
 148 (put 'calcFunc-pv 'math-expandable t)
 149
 150 (defun calcFunc-pvl (rate num amount)
 151   (calcFunc-pv rate num 0 amount))
 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))
 162                 (math-div (or lump 0) p)))))
 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)))
 175       accum)))
 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)))
 188       accum)))
 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))
 198                 (math-mul (or initial 0) p)))))
 199 (put 'calcFunc-fv 'math-expandable t)
 200
 201 (defun calcFunc-fvl (rate num amount)
 202   (calcFunc-fv rate num 0 amount))
 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))
 213                 (math-mul (or initial 0) p)))))
 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)
 223                 (math-sub 1 (math-div 1 p))))))
 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))
 232                           (math-add 1 rate))))))
 233 (put 'calcFunc-pmtb 'math-expandable t)
 234
 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)
 238
 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)
 242
 243 (defun calcFunc-nperl (rate pmt amount)
 244   (math-compute-nper rate pmt amount nil 'l))
 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)))
 290           (math-reject-arg pmt "*Payment too small to cover interest rate"))))))
 291
 292 (defun calcFunc-rate (num pmt amount &optional lump)
 293   (math-compute-rate num pmt amount lump 'calcFunc-pv))
 294
 295 (defun calcFunc-rateb (num pmt amount &optional lump)
 296   (math-compute-rate num pmt amount lump 'calcFunc-pvb))
 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)
 320       root)))
 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
 330     (math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1)))
 331
 332 (defun calcFunc-irr (&rest vecs)
 333   (math-compute-irr vecs 'calcFunc-npv))
 334
 335 (defun calcFunc-irrb (&rest vecs)
 336   (math-compute-irr vecs 'calcFunc-npvb))
 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)
 348       root)))
 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
 356       (math-reject-arg num 'numberp)))
 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
 372     (math-div (math-sub cost salvage) life)))
 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))
 389               (math-div (math-mul life (math-add life 1)) 2))))
 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)))
 409       res)))
 410
 411 (provide 'calc-fin)
 412
 413 ;; arch-tag: 82f30ca8-d02f-4b33-84b4-bb6ecd84597b
 414 ;;; calc-fin.el ends here