(* A Turbo Pascal common unit for the computer programs in Timo
Salmi and Ilkka Virtanen "Measuring the Long-Run Profitability of
the Firm; A Simulation Evaluation of the Financial Statement Based
IRR Estimation Methods" *)

unit SMUCTPU;

interface

(* The header of the program *)
procedure HEADER (progName, progDesc, progVers,
                  progDate, prefix : string);

(* Delete trailing white spaces from a string *)
function TRAILFN (sj : string) : string;

(* Get substrings from a string *)
function PARSERFN (sj : string; PartNumber : integer) : string;

(* Generalized power function for Turbo Pascal *)
function GENPOWFN (number, exponent : real) : real;

(* Minimum of two integers *)
function MINIFN (a, b : integer) : integer;

(* Maximum of two integers *)
function MAXIFN (a, b : integer) : integer;

(* A normally distributed random value with zero-mean and unit-variance *)
function RNDNRMFN : real;

(* Test whether a file exists *)
function FILEXIST (name : string) : boolean;

implementation

Uses Dos;

(* The header of the program *)
procedure HEADER (progName, progDesc, progVers,
                  progDate, prefix : string);
begin
  writeln;
  writeln (prefix, progName, '; ', progDesc);
  writeln (prefix, 'Copyright (c) by Timo Salmi and Ilkka Virtanen ',
           '(Ver. ', progVers, ') ', progDate);
  writeln (prefix, 'Department of Accounting and Business Finance; ',
           'Department of ');
  writeln (prefix, 'Mathematics and Statistics, ',
           'University of Vaasa, Finland');
end;  (* header *)

(* Delete leading white spaces from a string *)
function LEADFN (sj : string) : string;
var i, p : byte;
begin
  p := Length (sj); i := 1;
  while (i <= p) and (sj[i] <= #32) do i := i + 1;
  leadfn := Copy (sj, i, p-i+1);
end;  (* leadfn *)

(* Delete trailing white spaces from a string *)
function TRAILFN (sj : string) : string;
var i : byte;
begin
  i := Length (sj);
  while (i > 0) and (sj[i] <= #32) do i := i - 1;
  sj[0] := chr(i); trailfn := sj;
end;  (* trailfn *)

(* Number of substrings in a string *)
function PARSENFN (sj : string) : integer;
var i, n, p : integer;
begin
  p := Length(sj);
  n := 0;
  i := 1;
  repeat
    while (sj[i] <= #32) and (i <= p) do Inc(i);
    if i > p then begin parsenfn := n; exit; end;
    while (sj[i] > #32) and (i <= p) do Inc(i);
    Inc(n);
    if i > p then begin parsenfn := n; exit; end;
  until false;
end;  (* parsenfn *)

(* Get substrings from a string *)
function PARSERFN (sj : string; PartNumber : integer) : string;
var i, j, n, p : integer;
    stash      : string;
begin
  if (PartNumber < 1) or (PartNumber > PARSENFN(sj)) then
    begin PARSERFN := ''; exit; end;
  p := Length(sj);
  n := 0;
  i := 1;
  repeat
    while (sj[i] <= #32) and (i <= p) do Inc(i);
    Inc(n);
    if n = PartNumber then
      begin
        j := 0;
        while (sj[i] > #32) and (i <= p) do
          begin
            Inc(j);
            stash[0] := chr(j);
            stash[j] := sj[i];
            Inc(i);
          end;
        PARSERFN := stash;
        exit;
      end
     else
       while (sj[i] > #32) and (i <= p) do Inc(i);
  until false;
end;  (* parserfn *)

(* Generalized power function for Turbo Pascal *)
function GENPOWFN (number, exponent : real) : real;
begin
  if (exponent = 0.0) then
    genpowfn := 1.0
  else if number = 0.0 then
    genpowfn := 0.0
  else if abs(exponent*Ln(abs(number))) > 87.498 then
    begin writeln ('Overflow in GENPOWFN expression'); halt; end
  else if number > 0.0 then
    genpowfn := Exp(exponent*Ln(number))
  else if (number < 0.0) and (Frac(exponent) = 0.0) then
    if Odd(Round(exponent)) then
      genpowfn := -GENPOWFN (-number, exponent)
    else
      genpowfn :=  GENPOWFN (-number, exponent)
  else
    begin writeln ('Invalid GENPOWFN expression'); halt; end;
end;  (* genpowfn *)

(* Minimum of two integers *)
function MINIFN (a, b : integer) : integer;
begin
  if a < b then minifn := a else minifn := b;
end;  (* minifn *)

(* Maximum of two integers *)
function MAXIFN (a, b : integer) : integer;
begin
  if a > b then maxifn := a else maxifn := b;
end;  (* maxifn *)

(* A normally distributed random value with zero-mean and unit-variance *)
function RNDNRMFN : real;
var v1, v2, z : real;
begin
  repeat
    v1 := 2.0 * Random - 1.0;
    v2 := 2.0 * Random - 1.0;
    z := v1*v1 + v2*v2;
  until (abs(z) > 1.0E-10) and (z <= 1.0);
  RNDNRMFN := v2 * Sqrt (-2.0 * ln(z) / z);
end;  (* rndnrmfn *)

(* Test whether a file exists *)
function FILEXIST (name : string) : boolean;
var f  : file;
    a  : word;
begin
  assign (f, name);
  GetFAttr (f, a);
  filexist := false;
  if DosError = 0 then
    if ((a and Directory) = 0) and ((a and VolumeId) = 0) then
      filexist := true;
end; (* filexist *)

end.  (* smuctpu *)