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

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