lisp/calc/calc-fin.el

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