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