lisp/calc/calc-fin.el

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