cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-fin.el

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