lisp/calc/calc-fin.el

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