code.delx.au - gnu-emacs/blob - 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 ;; Maintainer: Colin Walters <walters@debian.org>
   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 (require 'calc-ext)
  31
  32 (require 'calc-macs)
  33
  34 (defun calc-Need-calc-fin () nil)
  35
  36
  37 ;;; Financial functions.
  38
  39 (defun calc-fin-pv ()
  40   (interactive)
  41   (calc-slow-wrapper
  42    (if (calc-is-hyperbolic)
  43        (calc-enter-result 3 "pvl" (cons 'calcFunc-pvl (calc-top-list-n 3)))
  44      (if (calc-is-inverse)
  45          (calc-enter-result 3 "pvb" (cons 'calcFunc-pvb (calc-top-list-n 3)))
  46        (calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3)))))))
  47
  48 (defun calc-fin-npv (arg)
  49   (interactive "p")
  50   (calc-slow-wrapper
  51    (if (calc-is-inverse)
  52        (calc-vector-op "npvb" 'calcFunc-npvb (1+ arg))
  53      (calc-vector-op "npv" 'calcFunc-npv (1+ arg)))))
  54
  55 (defun calc-fin-fv ()
  56   (interactive)
  57   (calc-slow-wrapper
  58    (if (calc-is-hyperbolic)
  59        (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
  60      (if (calc-is-inverse)
  61          (calc-enter-result 3 "fvb" (cons 'calcFunc-fvb (calc-top-list-n 3)))
  62        (calc-enter-result 3 "fv" (cons 'calcFunc-fv (calc-top-list-n 3)))))))
  63
  64 (defun calc-fin-pmt ()
  65   (interactive)
  66   (calc-slow-wrapper
  67    (if (calc-is-hyperbolic)
  68        (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
  69      (if (calc-is-inverse)
  70          (calc-enter-result 3 "pmtb" (cons 'calcFunc-pmtb (calc-top-list-n 3)))
  71        (calc-enter-result 3 "pmt" (cons 'calcFunc-pmt (calc-top-list-n 3)))))))
  72
  73 (defun calc-fin-nper ()
  74   (interactive)
  75   (calc-slow-wrapper
  76    (if (calc-is-hyperbolic)
  77        (calc-enter-result 3 "nprl" (cons 'calcFunc-nperl (calc-top-list-n 3)))
  78      (if (calc-is-inverse)
  79          (calc-enter-result 3 "nprb" (cons 'calcFunc-nperb
  80                                            (calc-top-list-n 3)))
  81        (calc-enter-result 3 "nper" (cons 'calcFunc-nper
  82                                          (calc-top-list-n 3)))))))
  83
  84 (defun calc-fin-rate ()
  85   (interactive)
  86   (calc-slow-wrapper
  87    (calc-pop-push-record 3
  88                          (if (calc-is-hyperbolic) "ratl"
  89                            (if (calc-is-inverse) "ratb" "rate"))
  90                          (calc-to-percentage
  91                           (calc-normalize
  92                            (cons (if (calc-is-hyperbolic) 'calcFunc-ratel
  93                                    (if (calc-is-hyperbolic) 'calcFunc-rateb
  94                                      'calcFunc-rate))
  95                                  (calc-top-list-n 3)))))))
  96
  97 (defun calc-fin-irr (arg)
  98   (interactive "P")
  99   (calc-slow-wrapper
 100    (if (calc-is-inverse)
 101        (calc-vector-op "irrb" 'calcFunc-irrb arg)
 102      (calc-vector-op "irr" 'calcFunc-irr arg))))
 103
 104 (defun calc-fin-sln ()
 105   (interactive)
 106   (calc-slow-wrapper
 107    (calc-enter-result 3 "sln" (cons 'calcFunc-sln (calc-top-list-n 3)))))
 108
 109 (defun calc-fin-syd ()
 110   (interactive)
 111   (calc-slow-wrapper
 112    (calc-enter-result 4 "syd" (cons 'calcFunc-syd (calc-top-list-n 4)))))
 113
 114 (defun calc-fin-ddb ()
 115   (interactive)
 116   (calc-slow-wrapper
 117    (calc-enter-result 4 "ddb" (cons 'calcFunc-ddb (calc-top-list-n 4)))))
 118
 119
 120 (defun calc-to-percentage (x)
 121   (cond ((Math-objectp x)
 122          (setq x (math-mul x 100))
 123          (if (Math-num-integerp x)
 124              (setq x (math-trunc x)))
 125          (list 'calcFunc-percent x))
 126         ((Math-vectorp x)
 127          (cons 'vec (mapcar 'calc-to-percentage (cdr x))))
 128         (t x)))
 129
 130 (defun calc-convert-percent ()
 131   (interactive)
 132   (calc-slow-wrapper
 133    (calc-pop-push-record 1 "c%" (calc-to-percentage (calc-top-n 1)))))
 134
 135 (defun calc-percent-change ()
 136   (interactive)
 137   (calc-slow-wrapper
 138    (let ((res (calc-normalize (cons 'calcFunc-relch (calc-top-list 2)))))
 139      (calc-pop-push-record 2 "%ch" (calc-to-percentage res)))))
 140
 141
 142 ;;; Financial functions.
 143
 144 (defun calcFunc-pv (rate num amount &optional lump)
 145   (math-check-financial rate num)
 146   (math-with-extra-prec 2
 147     (let ((p (math-pow (math-add 1 rate) num)))
 148       (math-add (math-mul amount
 149                           (math-div (math-sub 1 (math-div 1 p))
 150                                     rate))
 151                 (math-div (or lump 0) p)))))
 152 (put 'calcFunc-pv 'math-expandable t)
 153
 154 (defun calcFunc-pvl (rate num amount)
 155   (calcFunc-pv rate num 0 amount))
 156 (put 'calcFunc-pvl 'math-expandable t)
 157
 158 (defun calcFunc-pvb (rate num amount &optional lump)
 159   (math-check-financial rate num)
 160   (math-with-extra-prec 2
 161     (let* ((p (math-pow (math-add 1 rate) num)))
 162       (math-add (math-mul amount
 163                           (math-div (math-mul (math-sub 1 (math-div 1 p))
 164                                               (math-add 1 rate))
 165                                     rate))
 166                 (math-div (or lump 0) p)))))
 167 (put 'calcFunc-pvb 'math-expandable t)
 168
 169 (defun calcFunc-npv (rate &rest flows)
 170   (math-check-financial rate 1)
 171   (math-with-extra-prec 2
 172     (let* ((flat (math-flatten-many-vecs flows))
 173            (pp (math-add 1 rate))
 174            (p pp)
 175            (accum 0))
 176       (while (setq flat (cdr flat))
 177         (setq accum (math-add accum (math-div (car flat) p))
 178               p (math-mul p pp)))
 179       accum)))
 180 (put 'calcFunc-npv 'math-expandable t)
 181
 182 (defun calcFunc-npvb (rate &rest flows)
 183   (math-check-financial rate 1)
 184   (math-with-extra-prec 2
 185     (let* ((flat (math-flatten-many-vecs flows))
 186            (pp (math-add 1 rate))
 187            (p 1)
 188            (accum 0))
 189       (while (setq flat (cdr flat))
 190         (setq accum (math-add accum (math-div (car flat) p))
 191               p (math-mul p pp)))
 192       accum)))
 193 (put 'calcFunc-npvb 'math-expandable t)
 194
 195 (defun calcFunc-fv (rate num amount &optional initial)
 196   (math-check-financial rate num)
 197   (math-with-extra-prec 2
 198     (let ((p (math-pow (math-add 1 rate) num)))
 199       (math-add (math-mul amount
 200                           (math-div (math-sub p 1)
 201                                     rate))
 202                 (math-mul (or initial 0) p)))))
 203 (put 'calcFunc-fv 'math-expandable t)
 204
 205 (defun calcFunc-fvl (rate num amount)
 206   (calcFunc-fv rate num 0 amount))
 207 (put 'calcFunc-fvl 'math-expandable t)
 208
 209 (defun calcFunc-fvb (rate num amount &optional initial)
 210   (math-check-financial rate num)
 211   (math-with-extra-prec 2
 212     (let ((p (math-pow (math-add 1 rate) num)))
 213       (math-add (math-mul amount
 214                           (math-div (math-mul (math-sub p 1)
 215                                               (math-add 1 rate))
 216                                     rate))
 217                 (math-mul (or initial 0) p)))))
 218 (put 'calcFunc-fvb 'math-expandable t)
 219
 220 (defun calcFunc-pmt (rate num amount &optional lump)
 221   (math-check-financial rate num)
 222   (math-with-extra-prec 2
 223     (let ((p (math-pow (math-add 1 rate) num)))
 224       (math-div (math-mul (math-sub amount
 225                                     (math-div (or lump 0) p))
 226                           rate)
 227                 (math-sub 1 (math-div 1 p))))))
 228 (put 'calcFunc-pmt 'math-expandable t)
 229
 230 (defun calcFunc-pmtb (rate num amount &optional lump)
 231   (math-check-financial rate num)
 232   (math-with-extra-prec 2
 233     (let ((p (math-pow (math-add 1 rate) num)))
 234       (math-div (math-mul (math-sub amount (math-div (or lump 0) p)) rate)
 235                 (math-mul (math-sub 1 (math-div 1 p))
 236                           (math-add 1 rate))))))
 237 (put 'calcFunc-pmtb 'math-expandable t)
 238
 239 (defun calcFunc-nper (rate pmt amount &optional lump)
 240   (math-compute-nper rate pmt amount lump nil))
 241 (put 'calcFunc-nper 'math-expandable t)
 242
 243 (defun calcFunc-nperb (rate pmt amount &optional lump)
 244   (math-compute-nper rate pmt amount lump 'b))
 245 (put 'calcFunc-nperb 'math-expandable t)
 246
 247 (defun calcFunc-nperl (rate pmt amount)
 248   (math-compute-nper rate pmt amount nil 'l))
 249 (put 'calcFunc-nperl 'math-expandable t)
 250
 251 (defun math-compute-nper (rate pmt amount lump bflag)
 252   (and lump (math-zerop lump)
 253        (setq lump nil))
 254   (and lump (math-zerop pmt)
 255        (setq amount lump
 256              lump nil
 257              bflag 'l))
 258   (or (math-objectp rate) (and math-expand-formulas (null lump))
 259       (math-reject-arg rate 'numberp))
 260   (and (math-zerop rate)
 261        (math-reject-arg rate 'nonzerop))
 262   (or (math-objectp pmt) (and math-expand-formulas (null lump))
 263       (math-reject-arg pmt 'numberp))
 264   (or (math-objectp amount) (and math-expand-formulas (null lump))
 265       (math-reject-arg amount 'numberp))
 266   (if lump
 267       (progn
 268         (or (math-objectp lump)
 269             (math-reject-arg lump 'numberp))
 270         (let ((root (math-find-root (list 'calcFunc-eq
 271                                           (list (if bflag
 272                                                     'calcFunc-pvb
 273                                                   'calcFunc-pv)
 274                                                 rate
 275                                                 '(var DUMMY var-DUMMY)
 276                                                 pmt
 277                                                 lump)
 278                                           amount)
 279                                     '(var DUMMY var-DUMMY)
 280                                     '(intv 3 0 100)
 281                                     t)))
 282           (if (math-vectorp root)
 283               (nth 1 root)
 284             root)))
 285     (math-with-extra-prec 2
 286       (let ((temp (if (eq bflag 'l)
 287                       (math-div amount pmt)
 288                     (math-sub 1 (math-div (math-mul amount rate)
 289                                           (if bflag
 290                                               (math-mul pmt (math-add 1 rate))
 291                                             pmt))))))
 292         (if (or (math-posp temp) math-expand-formulas)
 293             (math-neg (calcFunc-log temp (math-add 1 rate)))
 294           (math-reject-arg pmt "*Payment too small to cover interest rate"))))))
 295
 296 (defun calcFunc-rate (num pmt amount &optional lump)
 297   (math-compute-rate num pmt amount lump 'calcFunc-pv))
 298
 299 (defun calcFunc-rateb (num pmt amount &optional lump)
 300   (math-compute-rate num pmt amount lump 'calcFunc-pvb))
 301
 302 (defun math-compute-rate (num pmt amount lump func)
 303   (or (math-objectp num)
 304       (math-reject-arg num 'numberp))
 305   (or (math-objectp pmt)
 306       (math-reject-arg pmt 'numberp))
 307   (or (math-objectp amount)
 308       (math-reject-arg amount 'numberp))
 309   (or (null lump)
 310       (math-objectp lump)
 311       (math-reject-arg lump 'numberp))
 312   (let ((root (math-find-root (list 'calcFunc-eq
 313                                     (list func
 314                                           '(var DUMMY var-DUMMY)
 315                                           num
 316                                           pmt
 317                                           (or lump 0))
 318                                     amount)
 319                               '(var DUMMY var-DUMMY)
 320                               '(intv 3 (float 1 -4) 1)
 321                               t)))
 322     (if (math-vectorp root)
 323         (nth 1 root)
 324       root)))
 325
 326 (defun calcFunc-ratel (num pmt amount)
 327   (or (math-objectp num) math-expand-formulas
 328       (math-reject-arg num 'numberp))
 329   (or (math-objectp pmt) math-expand-formulas
 330       (math-reject-arg pmt 'numberp))
 331   (or (math-objectp amount) math-expand-formulas
 332       (math-reject-arg amount 'numberp))
 333   (math-with-extra-prec 2
 334     (math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1)))
 335
 336 (defun calcFunc-irr (&rest vecs)
 337   (math-compute-irr vecs 'calcFunc-npv))
 338
 339 (defun calcFunc-irrb (&rest vecs)
 340   (math-compute-irr vecs 'calcFunc-npvb))
 341
 342 (defun math-compute-irr (vecs func)
 343   (let* ((flat (math-flatten-many-vecs vecs))
 344          (root (math-find-root (list func
 345                                      '(var DUMMY var-DUMMY)
 346                                      flat)
 347                                '(var DUMMY var-DUMMY)
 348                                '(intv 3 (float 1 -4) 1)
 349                                t)))
 350     (if (math-vectorp root)
 351         (nth 1 root)
 352       root)))
 353
 354 (defun math-check-financial (rate num)
 355   (or (math-objectp rate) math-expand-formulas
 356       (math-reject-arg rate 'numberp))
 357   (and (math-zerop rate)
 358        (math-reject-arg rate 'nonzerop))
 359   (or (math-objectp num) math-expand-formulas
 360       (math-reject-arg num 'numberp)))
 361
 362
 363 (defun calcFunc-sln (cost salvage life &optional period)
 364   (or (math-realp cost) math-expand-formulas
 365       (math-reject-arg cost 'realp))
 366   (or (math-realp salvage) math-expand-formulas
 367       (math-reject-arg salvage 'realp))
 368   (or (math-realp life) math-expand-formulas
 369       (math-reject-arg life 'realp))
 370   (if (math-zerop life) (math-reject-arg life 'nonzerop))
 371   (if (and period
 372            (if (math-num-integerp period)
 373                (or (Math-lessp life period) (not (math-posp period)))
 374              (math-reject-arg period 'integerp)))
 375       0
 376     (math-div (math-sub cost salvage) life)))
 377 (put 'calcFunc-sln 'math-expandable t)
 378
 379 (defun calcFunc-syd (cost salvage life period)
 380   (or (math-realp cost) math-expand-formulas
 381       (math-reject-arg cost 'realp))
 382   (or (math-realp salvage) math-expand-formulas
 383       (math-reject-arg salvage 'realp))
 384   (or (math-realp life) math-expand-formulas
 385       (math-reject-arg life 'realp))
 386   (if (math-zerop life) (math-reject-arg life 'nonzerop))
 387   (or (math-realp period) math-expand-formulas
 388       (math-reject-arg period 'realp))
 389   (if (or (Math-lessp life period) (not (math-posp period)))
 390       0
 391     (math-div (math-mul (math-sub cost salvage)
 392                         (math-add (math-sub life period) 1))
 393               (math-div (math-mul life (math-add life 1)) 2))))
 394 (put 'calcFunc-syd 'math-expandable t)
 395
 396 (defun calcFunc-ddb (cost salvage life period)
 397   (if (math-messy-integerp period) (setq period (math-trunc period)))
 398   (or (integerp period) (math-reject-arg period 'fixnump))
 399   (or (math-realp cost) (math-reject-arg cost 'realp))
 400   (or (math-realp salvage) (math-reject-arg salvage 'realp))
 401   (or (math-realp life) (math-reject-arg life 'realp))
 402   (if (math-zerop life) (math-reject-arg life 'nonzerop))
 403   (if (or (Math-lessp life period) (<= period 0))
 404       0
 405     (let ((book cost)
 406           (res 0))
 407       (while (>= (setq period (1- period)) 0)
 408         (setq res (math-div (math-mul book 2) life)
 409               book (math-sub book res))
 410         (if (Math-lessp book salvage)
 411             (setq res (math-add res (math-sub book salvage))
 412                   book salvage)))
 413       res)))
 414
 415 ;;; calc-fin.el ends here