Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SHDK_2.ZIP/SHFINANC.PAS

Pascal/Delphi Source File | 1992-05-18 | 13.7 KB | 473 lines

{$I SHDEFINE.INC}

{$I SHUNITSW.INC}

{V-}
unit ShFinanc;
{Part of the SkyHawk collection of TP development tools}
{Copyright 1988-90 by W.G. Madison and Associates, Ltd.}
{All rights reserved.}

             {This product, in either compiled  or source form,
             together  with all associated files and  documents
             is  proprietary  to  Madison  and  Associates. All
             rights  reserved.  Exportation  of this program or
             any of its component files or documentation in any
             form to member  countries of the European Economic
             Community (EEC) without express written permission
             of  the  author   or  Madison  and  Associates  is
             forbidden.}

{To calculate various financial type functions.

Author:   W.G. Madison              Date:   May, 1989
}

interface

uses
  TpCrt,
  TpString,
  Tp8087,
  ShUtilPk,
  ShErrMsg;

type
  AnnType   = (Ordinary, Due);
{$IFOPT N-}
  extended = real;
{$ENDIF}

const
  finOK                     = 0;
  finErrParamTooSmall       = 200;
  finIntOutOfRange          = 201;
  finIllegalNumPeriods      = 202;
  finUnknownAnnuityType     = 203;
  finIllegalPresentValue    = 204;
  fin80x87error             = 205;
  finNoConvergence          = 206;
  finIndeterminateForm      = 207;

  {80x87 errors}
  finInvalidOperation       =  1;
  finDenormalizedOperand    =  2;
  finDivideByZero           =  4;
  finOverflow               =  8;
  finUnderflow              = 16;

  FW  = 17;
  DP  = 10;
  IW  =  6;

var
  finError,
  fin87error  : word;

procedure finErrCheckOn;
{Turns error checking on. Errors will abort program with a message.}

procedure finErrCheckOff;
{Turns error checking off. Results will be returned by function
 finErrCode.}

function finErrCode : word;
{Returns the error code from the last operation, and resets the error
 code to zero (finOK).}

function fin87errCode : word;
{Returns the 80x87 error code if finErrCode has returned fin80x87error.}

function finErrMsg(Code : word) : string;
{Returns the error message corresponding to the supplied Code.}

function CompPresVal(N : integer; I : extended) : extended;
{The compound present value of 1 for N periods at I.}

function CompAmount(N : integer; I : extended) : extended;
{The compound amount of 1 for N periods at I.}

function AnnuityPresVal(N     : integer;
                        I     : extended;
                        AType : AnnType) : extended;
{The present value of an annuity (of type AType) of 1 for N payment
 periods at an interest rate of I per period.}

function AnnuityAmount(N : integer;
                       I : extended;
                       AType : AnnType) : extended;
{The amount of an annuity (of type AType) of 1 for N payment periods at
 an interest rate of I per period.}

function NumPay(PresVal,
                I       : extended;
                AType   : AnnType) : integer;
{The number of payments needed to retire a mortgage of 1 whose present
 value is PresVal at an interest rate of I per period.}

function R(Rexp : extended; Count : integer) : extended;
{Returns Rexp correctly rounded to Count places to the right of the
 decimal point.}

function IfromPresVal(PresVal : extended;
                      N       : integer;
                      AType   : AnnType;
                      Err     : extended) : extended;
{The interest rate of an annuity (of type AType) of 1 whose present
 value is PresVal for N payments, where Err is the allowable absolute
 error of calculation.}

implementation

const
  HaltOnErrors  : boolean = true;
  ErrorCode     : word    = 0;
  Error87Code   : word    = 0;

  LoMsgNum                = 200;
  HiMsgNum                = 207;
  ErrMsgs       : array[LoMsgNum..HiMsgNum] of string[50] =
                         ('Error parameter too small.',
                          'Interest parameter out of range.',
                          'Number of periods <= 0.',
                          'Annuity type must be ''Ordinary'' or ''Due''.',
                          'Illegal Present Value.',
                          '80x87 error - ',
                          'Iterative procedure; value does not converge.',
                          'Indeterminate for N = 1; Type = DUE');

  Err87Msgs     : array[1..5] of string[50] =
                         ('Invalid operation (e.g., LN(-1)).',
                          'Denormalized operand.',
                          'Divide by zero.',
                          'Overflow error.',
                          'Underflow error.');

  ValStr        : string  = '';

procedure finErrCheckOn;
{Turns error checking on. Errors will abort program with a message.}
  begin {finErrCheckOn}
{$IFNDEF HaltOnFinancError}
    HaltOnErrors := true;
  {$IFOPT N+}
    Exceptions8087(true);
  {$ENDIF}
{$ENDIF}
    end; {finErrCheckOn}

procedure finErrCheckOff;
{Turns error checking off. Results will be returned by function
 finErrCode.}
  begin {finErrCheckOff}
{$IFNDEF HaltOnFinancError}
    HaltOnErrors := false;
  {$IFOPT N+}
    Exceptions8087(false);
  {$ENDIF}
{$ENDIF}
    end; {finErrCheckOff}

function finErrCode : word;
{Returns the error code from the last operation, and resets the error
 code to zero (finOK).}
  begin {finErrCode}
    finErrCode := ErrorCode;
{$IFOPT N+}
    if ErrorCode = fin80x87error then
      Error87Code := Error8087 and $1F;
{$ELSE}
    Error87Code := 0;
{$ENDIF}
    ErrorCode := 0;
    end; {finErrCode}

function fin87errCode : word;
{Returns the 80x87 error code if finErrCode has returned fin80x87error.}
  begin {fin87errCode}
    fin87errCode  := Error87Code;
    Error87Code := 0;
    end; {fin87errCode}

function finErrMsg(Code : word) : string;
{Returns the error message corresponding to the supplied Code.}
  var
    Msg1,
    Msg2  : string;
    C87   : word;
    T1    : byte;
  begin {finErrMsg}
    case Code of
      finOK       : Msg1 := '';
      LoMsgNum..HiMsgNum
                  : Msg1 := '(Error ' + Long2Str(Code) + ') ' + ErrMsgs[Code];
      else          Msg1 := 'Unknown error code ' + Long2Str(Code);
      end; {case}
    if ValStr <> '' then begin
      Msg1 := Msg1 + ValStr;
      ValStr := '';
      end;
    Msg2 := '';
    T1 := 0;
    if Code = fin80x87error then begin
      C87 := fin87errCode;
      while C87 <> 0 do begin
        inc(T1);
        if (C87 and 1) <> 0 then
          Msg2 := Msg2 + ^M^J^I + Err87Msgs[T1];
        C87 := C87 shr 1;
        end; {while}
      end; {if}
    finErrMsg := Msg1 + Msg2;
    end; {finErrMsg}

procedure ProcessError(Code : word; Source : string);
  begin {ProcessError}
    if HaltOnErrors then
      HaltMsg(Code, ErrMsgs[Code] + ' (' + Source + ')')
    else
      ErrorCode := Code;
    end; {ProcessError}

function CompPresVal(N : integer; I : extended) : extended;
{The compound present value of 1 for N periods at I.}
var
  XN  : extended;
begin
  if N <= 0 then begin
    Str(N:IW, ValStr);
    ProcessError(finIllegalNumPeriods, 'CompPresVal');
    exit;
    end;
  if (I <= 0.0) or (I >= 1.0) then begin
    Str(I:FW:DP, ValStr);
    ProcessError(finIntOutOfRange, 'CompPresVal');
    exit;
    end;
  XN := N;
  CompPresVal := Exp(Ln(1.0 + I) * (-XN));
  end;

function CompAmount(N : integer; I : extended) : extended;
{The compound amount of 1 for N periods at I.}
var
  XN  : extended;
begin
  if N <= 0 then begin
    Str(N:IW, ValStr);
    ProcessError(finIllegalNumPeriods, 'CompAmount');
    exit;
    end;
  if (I <= 0.0) or (I >= 1.0) then begin
    Str(I:FW:DP, ValStr);
    ProcessError(finIntOutOfRange, 'CompAmount');
    exit;
    end;
  XN  := N;
  CompAmount := Exp(Ln(1.0 + I) * XN);
  end;

function AnnuityPresVal(N     : integer;
                        I     : extended;
                        AType : AnnType) : extended;
{The present value of an annuity of 1 for N payment periods at an
 interest rate of I per period.}
var
  CPV : extended;
begin
  if N <= 0 then begin
    Str(N:IW, ValStr);
    ProcessError(finIllegalNumPeriods, 'AnnuityPresVal');
    exit;
    end;
  if (I <= 0.0) or (I >= 1.0) then begin
    Str(I:FW:DP, ValStr);
    ProcessError(finIntOutOfRange, 'AnnuityPresVal');
    exit;
    end;
  CPV := 1.0 - CompPresVal(N, I);
  case AType of
    Ordinary  : AnnuityPresVal := CPV / I;
    Due       : AnnuityPresVal := (1.0 + I) * CPV / I;
    else        begin
                  ProcessError(finUnknownAnnuityType, 'AnnuityPresVal');
                  exit;
                  end;
    end; {case}
  end;

function AnnuityAmount
              (N : integer; I : extended; AType : AnnType) : extended;
{The amount of an annuity of 1 for N payment periods at an
 interest rate of I per period.}
var
  CA  : extended;
begin
  if N <= 0 then begin
    Str(N:IW, ValStr);
    ProcessError(finIllegalNumPeriods, 'AnnuityAmount');
    exit;
    end;
  if (I <= 0.0) or (I >= 1.0) then begin
    Str(I:FW:DP, ValStr);
    ProcessError(finIntOutOfRange, 'AnnuityAmount');
    exit;
    end;
  CA := CompAmount(N, I) - 1.0;
  case AType of
    Ordinary  : AnnuityAmount := CA / I;
    Due       : AnnuityAmount := (1.0 + I) * CA / I;
    else        begin
                  ProcessError(finUnknownAnnuityType, 'AnnuityAmount');
                  exit;
                  end;
    end; {case}
  end;

function NumPay(PresVal, I : extended; AType : AnnType) : integer;
{The number of payments needed to retire a mortgage of 1 whose present
 value is PresVal at an interest rate of I per period.}
begin
  if (I <= 0.0) or (I > 1.0) then begin
    Str(I:FW:DP, ValStr);
    ProcessError(finIntOutOfRange, 'NumPay');
    exit;
    end;
  case AType of
    Ordinary  : ;
    Due       : PresVal := PresVal / (1.0 + I);
    else        begin
                  ProcessError(finUnknownAnnuityType, 'NumPay');
                  exit;
                  end;
    end; {case}
  if (PresVal <= 0) or (PresVal >= (1.0 / I)) then begin
    Str(PresVal:FW:DP, ValStr);
    ProcessError(finIllegalPresentValue, 'NumPay');
    exit;
    end;
  NumPay := -Round(Ln(1.0 - (PresVal * I)) / Ln(1.0 + I));
  end;

function R(Rexp : extended; Count : integer) : extended;
{Returns Rexp correctly rounded to Count places to the right of the
 decimal point.}
var
  R1  : extended;
begin
  R1 := Exp(Ln(10.0) * Count);
  R := Int(((Rexp * R1) + 0.5)) / R1;
  end;

function IfromPresVal(PresVal : extended;
                      N       : integer;
                      AType   : AnnType;
                      Err     : extended) : extended;
{The interest rate of an ordinary annuity of 1 whose present value is
 PresVal for N payments, where Err is the allowable absolute error of
 calculation.}

const
{$IFDEF Gen87}
  MinErr = 1.0E-16;
{$ELSE}
  MinErr = 1.0E-9;
{$ENDIF}

var
  UorD    : (Up, Down);
  B1      : boolean;
  Last,
  MErr,
  Q1,
  Q2,
  ANI,
  Intvl,
  Trial   : extended;

begin
  if N <= 0 then begin
    Str(N:IW, ValStr);
    ProcessError(finIllegalNumPeriods, 'IfromPresVal');
    exit;
    end;
  if (N = 1) and (AType = Due) then begin
    ProcessError(finIndeterminateForm, 'IfromPresVal');
    exit;
    end;
  if Err < MinErr then begin
    Str(Err:FW:DP, ValStr);
    ProcessError(finErrParamTooSmall, 'IfromPresVal');
    exit;
    end;
  if not (AType in [Ordinary..Due]) then
    begin
      ProcessError(finUnknownAnnuityType, 'IfromPresVal');
      exit;
      end;
  if (PresVal <= 0) or (PresVal >= (1.0 * N)) then begin
    Str(PresVal:FW:DP, ValStr);
    ProcessError(finIllegalPresentValue, 'IfromPresVal');
    exit;
    end;
  UorD := Up;
  Intvl := 0.001;
  Trial := 0.01;

  MErr  := -1.0 * Err;
  repeat
    while Intvl >= Trial do
      Intvl := Intvl * 0.1;
    case UorD of
      Up    : begin
                while (PresVal <= AnnuityPresVal(N, Trial, AType)) and
                      (Trial <= 1.0 - Intvl) do begin
                  ANI := AnnuityPresVal(N, Trial, AType);
                  if ANI = Last then begin
                    Str(ANI:FW:DP, ValStr);
                    ProcessError(finNoConvergence, 'IfromPresVal');
                    exit;
                    end
                  else
                    Last := ANI;
                  Q1 := ANI / PresVal;
                  Q2 := 1.0 - Q1;
                  if (Q2 <= Err) and (Q2 >= MErr) then begin
                    IfromPresVal := Trial;
                    exit;
                    end;
                  Trial := Trial + Intvl;
                  end;
                end;
      Down  : begin
                while (PresVal > AnnuityPresVal(N, Trial, AType)) and
                      (Trial >= Intvl) do begin
                  ANI := AnnuityPresVal(N, Trial, AType);
                  if ANI = Last then begin
                    Str(ANI:FW:DP, ValStr);
                    ProcessError(finNoConvergence, 'IfromPresVal');
                    exit
                    end
                  else
                    Last := ANI;
                  Q1 := ANI / PresVal;
                  Q2 := 1.0 - Q1;
                  if (Q2 >= Err) and (Q2 <= MErr) then begin
                    IfromPresVal := Trial;
                    exit;
                    end;
                  Trial := Trial - Intvl;
                  end;
                end;
      end; {case}
    Intvl := 0.1 * Intvl;
    boolean(UorD) := not (boolean(UorD));  {Flip the value of UorD}
    ANI := AnnuityPresVal(N, Trial, AType);
    Q1 := ANI / PresVal;
    Q2 := 1.0 - Q1;
    B1 := (Q2 >= Err) and (Q2 <= MErr);
    until B1;
  IfromPresVal := Trial;
  end; {IfromPresVal}
end.