Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBII/ECO_CALC.PAS

Pascal/Delphi Source File | 1993-03-08 | 16.6 KB | 520 lines

{
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   Unit was conceived, designed and written         ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   by Floor A.C. Naaijkens for                      ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   UltiHouse Software / The ECO Group.              ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   (C) MCMXCII by EUROCON PANATIONAL CORPORATION.   ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   All Rights Reserved for The ECO Group.           ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
}
{$O+}
{
                       f i l e    i n f o r m a t i o n

* description
supplies missing trigonometric functions for turbo pascal 5.5. also
provides hyperbolic, logarithmic, power, and root functions. all trig
functions accessibile by radians, decimal degrees, degrees-minutes-seconds
and a global degreetype.

}
unit eco_calc;

(*  eco_calc  -  supplies missing trigonometric functions for Borland Pascal 7.0
 *           also provides hyperbolic, logarithmic, power, and root functions.
 *           all trig functions accessible by radians, decimal degrees,
 *           degrees-minutes-seconds, and a global degreetype.  conversions
 *           between these are supplied.
 *
 *)

interface

type
  degreetype =  record
                  degrees, minutes, seconds : real;
                end;
const
  infinity = 9.9999999999e+37;

{  radians  }
{ sin, cos, and arctan are predefined }

function tan( radians : real ) : real;
function arcsin( invalue : real ) : real;
function arccos( invalue : real ) : real;

{  degrees, expressed as a real number  }

function degreestoradians( degrees : real ) : real;
function radianstodegrees( radians : real ) : real;
function sin_degree( degrees : real ) : real;
function cos_degree( degrees : real ) : real;
function tan_degree( degrees : real ) : real;
function arcsin_degree( degrees : real ) : real;
function arccos_degree( degrees : real ) : real;
function arctan_degree( degrees : real ) : real;

{  degrees, in degrees, minutes, and seconds, as real numbers  }

function degreepartstodegrees( degrees, minutes, seconds : real ) : real;
function degreepartstoradians( degrees, minutes, seconds : real ) : real;
procedure degreestodegreeparts( degreesin : real;
                                var degrees, minutes, seconds : real );
procedure radianstodegreeparts( radians : real;
                                var degrees, minutes, seconds : real );
function sin_degreeparts( degrees, minutes, seconds : real ) : real;
function cos_degreeparts( degrees, minutes, seconds : real ) : real;
function tan_degreeparts( degrees, minutes, seconds : real ) : real;
function arcsin_degreeparts( degrees, minutes, seconds : real ) : real;
function arccos_degreeparts( degrees, minutes, seconds : real ) : real;
function arctan_degreeparts( degrees, minutes, seconds : real ) : real;

{  degrees, expressed as degreetype ( reals in record ) }

function degreetypetodegrees( degreevar : degreetype ) : real;
function degreetypetoradians( degreevar : degreetype ) : real;
procedure degreetypetodegreeparts( degreevar : degreetype;
                                   var degrees, minutes, seconds : real );
procedure degreestodegreetype( degrees : real; var degreevar : degreetype );
procedure radianstodegreetype( radians : real; var degreevar : degreetype );
procedure degreepartstodegreetype( degrees, minutes, seconds : real;
                                   var degreevar : degreetype );
function sin_degreetype( degreevar : degreetype ) : real;
function cos_degreetype( degreevar : degreetype ) : real;
function tan_degreetype( degreevar : degreetype ) : real;
function arcsin_degreetype( degreevar : degreetype ) : real;
function arccos_degreetype( degreevar : degreetype ) : real;
function arctan_degreetype( degreevar : degreetype ) : real;

{  hyperbolic functions  }

function sinh( invalue : real ) : real;
function cosh( invalue : real ) : real;
function tanh( invalue : real ) : real;
function coth( invalue : real ) : real;
function sech( invalue : real ) : real;
function csch( invalue : real ) : real;
function arcsinh( invalue : real ) : real;
function arccosh( invalue : real ) : real;
function arctanh( invalue : real ) : real;
function arccoth( invalue : real ) : real;
function arcsech( invalue : real ) : real;
function arccsch( invalue : real ) : real;

{  logarithms, powers, and roots  }

{ e to the x  is  exp() }
{ natural log is  ln()  }
function log10( innumber : real ) : real;
function log( base, innumber : real ) : real;  { log of any base }
function power( innumber, exponent : real ) : real;
function root( innumber, theroot : real ) : real;


{----------------------------------------------------------------------}
implementation

const
  radiansperdegree =  0.017453292520;
  degreesperradian = 57.295779513;
  minutesperdegree =   60.0;
  secondsperdegree = 3600.0;
  secondsperminute = 60.0;
  lnof10 = 2.3025850930;

{-----------}
{  radians  }
{-----------}

{ sin, cos, and arctan are predefined }

function tan { ( radians : real ) : real };
  { note: returns infinity where appropriate }
  var
    cosineval : real;
    tangentval : real;
  begin
  cosineval := cos( radians );
  if cosineval = 0.0 then
    tan := infinity
  else
    begin
    tangentval := sin( radians ) / cosineval;
    if ( tangentval < -infinity ) or ( tangentval > infinity ) then
      tan := infinity
    else
      tan := tangentval;
    end;
  end;

function arcsin{ ( invalue : real ) : real };
  { notes: 1) exceeding input range of -1 through +1 will cause runtime error }
  {        2) only returns principal values                                   }
  {             ( -pi/2 through pi/2 radians ) ( -90 through +90 degrees )    }
  begin
  if abs( invalue ) = 1.0 then
    arcsin := pi / 2.0
  else
    arcsin := arctan( invalue / sqrt( 1 - invalue * invalue ) );
  end;

function arccos{ ( invalue : real ) : real };
  { notes: 1) exceeding input range of -1 through +1 will cause runtime error }
  {        2) only returns principal values                                   }
  {             ( 0 through pi radians ) ( 0 through +180 degrees )           }
  var
    result : real;
  begin
  if invalue = 0.0 then
    arccos := pi / 2.0
  else
    begin
    result := arctan( sqrt( 1 - invalue * invalue ) / invalue );
    if invalue < 0.0 then
      arccos := result + pi
    else
      arccos := result;
    end;
  end;

{---------------------------------------}
{  degrees, expressed as a real number  }
{---------------------------------------}

function degreestoradians{ ( degrees : real ) : real };
  begin
  degreestoradians := degrees * radiansperdegree;
  end;

function radianstodegrees{ ( radians : real ) : real };
  begin
  radianstodegrees := radians * degreesperradian;
  end;

function sin_degree{ ( degrees : real ) : real };
  begin
  sin_degree := sin( degreestoradians( degrees ) );
  end;

function cos_degree{ ( degrees : real ) : real };
  begin
  cos_degree := cos( degreestoradians( degrees ) );
  end;

function tan_degree{ ( degrees : real ) : real };
  begin
  tan_degree := tan( degreestoradians( degrees ) );
  end;

function arcsin_degree{ ( degrees : real ) : real };
  begin
  arcsin_degree := arcsin( degreestoradians( degrees ) );
  end;

function arccos_degree{ ( degrees : real ) : real };
  begin
  arccos_degree := arccos( degreestoradians( degrees ) );
  end;

function arctan_degree{ ( degrees : real ) : real };
  begin
  arctan_degree := arctan( degreestoradians( degrees ) );
  end;

{--------------------------------------------------------------}
{  degrees, in degrees, minutes, and seconds, as real numbers  }
{--------------------------------------------------------------}

function degreepartstodegrees{ ( degrees, minutes, seconds : real ) : real };
  begin
  degreepartstodegrees := degrees + ( minutes / minutesperdegree ) +
                                       ( seconds / secondsperdegree );
  end;

function degreepartstoradians{ ( degrees, minutes, seconds : real ) : real };
  begin
  degreepartstoradians := degreestoradians( degreepartstodegrees( degrees,
                                                        minutes, seconds ) );
  end;

procedure degreestodegreeparts{ ( degreesin : real;
                                  var degrees, minutes, seconds : real ) };
  begin
  degrees := int( degreesin );
  minutes := ( degreesin - degrees ) * minutesperdegree;
  seconds := frac( minutes );
  minutes := int( minutes );
  seconds := seconds * secondsperminute;
  end;

procedure radianstodegreeparts{ ( radians : real;
                                  var degrees, minutes, seconds : real ) };
  begin
  degreestodegreeparts( radianstodegrees( radians ),
                          degrees, minutes, seconds );
  end;

function sin_degreeparts{ ( degrees, minutes, seconds : real ) : real };
  begin
  sin_degreeparts := sin( degreepartstoradians( degrees, minutes, seconds ) );
  end;

function cos_degreeparts{ ( degrees, minutes, seconds : real ) : real };
  begin
  cos_degreeparts := cos( degreepartstoradians( degrees, minutes, seconds ) );
  end;

function tan_degreeparts{ ( degrees, minutes, seconds : real ) : real };
  begin
  tan_degreeparts := tan( degreepartstoradians( degrees, minutes, seconds ) );
  end;

function arcsin_degreeparts{ ( degrees, minutes, seconds : real ) : real };
  begin
  arcsin_degreeparts := arcsin( degreepartstoradians( degrees,
                                                      minutes, seconds ) );
  end;

function arccos_degreeparts{ ( degrees, minutes, seconds : real ) : real };
  begin
  arccos_degreeparts := arccos( degreepartstoradians( degrees,
                                                      minutes, seconds ) );
  end;

function arctan_degreeparts{ ( degrees, minutes, seconds : real ) : real };
  begin
  arctan_degreeparts := arctan( degreepartstoradians( degrees,
                                                      minutes, seconds ) );
  end;

{-------------------------------------------------------}
{  degrees, expressed as degreetype ( reals in record ) }
{-------------------------------------------------------}

function degreetypetodegrees{ ( degreevar : degreetype ) : real };
  begin
  degreetypetodegrees := degreepartstodegrees( degreevar.degrees,
                                       degreevar.minutes, degreevar.seconds );
  end;

function degreetypetoradians{ ( degreevar : degreetype ) : real };
  begin
  degreetypetoradians := degreestoradians( degreetypetodegrees( degreevar ) );
  end;

procedure degreetypetodegreeparts{ ( degreevar : degreetype;
                                     var degrees, minutes, seconds : real ) };
  begin
  degrees := degreevar.degrees;
  minutes := degreevar.minutes;
  seconds := degreevar.seconds;
  end;

procedure degreestodegreetype{ ( degrees : real; var degreevar : degreetype )};
  begin
  degreestodegreeparts( degrees, degreevar.degrees,
                        degreevar.minutes, degreevar.seconds );
  end;

procedure radianstodegreetype{ ( radians : real; var degreevar : degreetype )};
  begin
  degreestodegreeparts( radianstodegrees( radians ), degreevar.degrees,
                        degreevar.minutes, degreevar.seconds );
  end;

procedure degreepartstodegreetype{ ( degrees, minutes, seconds : real;
                                     var degreevar : degreetype ) };
  begin
  degreevar.degrees := degrees;
  degreevar.minutes := minutes;
  degreevar.seconds := seconds;
  end;

function sin_degreetype{ ( degreevar : degreetype ) : real };
  begin
  sin_degreetype := sin( degreetypetoradians( degreevar ) );
  end;

function cos_degreetype{ ( degreevar : degreetype ) : real };
  begin
  cos_degreetype := cos( degreetypetoradians( degreevar ) );
  end;

function tan_degreetype{ ( degreevar : degreetype ) : real };
  begin
  tan_degreetype := tan( degreetypetoradians( degreevar ) );
  end;

function arcsin_degreetype{ ( degreevar : degreetype ) : real };
  begin
  arcsin_degreetype := arcsin( degreetypetoradians( degreevar ) );
  end;

function arccos_degreetype{ ( degreevar : degreetype ) : real };
  begin
  arccos_degreetype := arccos( degreetypetoradians( degreevar ) );
  end;

function arctan_degreetype{ ( degreevar : degreetype ) : real };
  begin
  arctan_degreetype := arctan( degreetypetoradians( degreevar ) );
  end;

{------------------------}
{  hyperbolic functions  }
{------------------------}

function sinh{ ( invalue : real ) : real };
  const
    maxvalue = 88.029691931;  { exceeds standard turbo precision }
  var
    sign : real;
  begin
  sign := 1.0;
  if invalue < 0 then
    begin
    sign := -1.0;
    invalue := -invalue;
    end;
  if invalue > maxvalue then
    sinh := infinity
  else
    sinh := ( exp( invalue ) - exp( -invalue ) ) / 2.0 * sign;
  end;

function cosh{ ( invalue : real ) : real };
  const
    maxvalue = 88.029691931;  { exceeds standard turbo precision }
  begin
  invalue := abs( invalue );
  if invalue > maxvalue then
    cosh := infinity
  else
    cosh := ( exp( invalue ) + exp( -invalue ) ) / 2.0;
  end;

function tanh{ ( invalue : real ) : real };
  begin
  tanh := sinh( invalue ) / cosh( invalue );
  end;

function coth{ ( invalue : real ) : real };
  begin
  coth := cosh( invalue ) / sinh( invalue );
  end;

function sech{ ( invalue : real ) : real };
  begin
  sech := 1.0 / cosh( invalue );
  end;

function csch{ ( invalue : real ) : real };
  begin
  csch := 1.0 / sinh( invalue );
  end;

function arcsinh{ ( invalue : real ) : real };
  var
    sign : real;
  begin
  sign := 1.0;
  if invalue < 0 then
    begin
    sign := -1.0;
    invalue := -invalue;
    end;
  arcsinh := ln( invalue + sqrt( invalue*invalue + 1 ) ) * sign;
  end;

function arccosh{ ( invalue : real ) : real };
  var
    sign : real;
  begin
  sign := 1.0;
  if invalue < 0 then
    begin
    sign := -1.0;
    invalue := -invalue;
    end;
  arccosh := ln( invalue + sqrt( invalue*invalue - 1 ) ) * sign;
  end;

function arctanh{ ( invalue : real ) : real };
  var
    sign : real;
  begin
  sign := 1.0;
  if invalue < 0 then
    begin
    sign := -1.0;
    invalue := -invalue;
    end;
  arctanh := ln( ( 1 + invalue ) / ( 1 - invalue ) ) / 2.0 * sign;
  end;

function arccoth{ ( invalue : real ) : real };
  begin
  arccoth := arctanh( 1.0 / invalue );
  end;

function arcsech{ ( invalue : real ) : real };
  begin
  arcsech := arccosh( 1.0 / invalue );
  end;

function arccsch{ ( invalue : real ) : real };
  begin
  arccsch := arcsinh( 1.0 / invalue );
  end;

{---------------------------------}
{  logarithms, powers, and roots  }
{---------------------------------}

{ e to the x  is  exp() }
{ natural log is  ln()  }

function log10{ ( innumber : real ) : real };
  begin
  log10 := ln( innumber ) / lnof10;
  end;

function log{ ( base, innumber : real ) : real };  { log of any base }
  begin
  log := ln( innumber ) / ln( base );
  end;

function power{ ( innumber, exponent : real ) : real };
  begin
  if innumber > 0.0 then
    power := exp( exponent * ln( innumber ) )
  else if innumber = 0.0 then
    power := 1.0
  else { we don'T force a runtime error, we define a function to provide
         negative logarithms! }
    if exponent=trunc(exponent) then
      power := (-2*(trunc(exponent) mod 2)+1) * exp(exponent * ln( -innumber ) )
      else power := trunc(1/(exponent-exponent));
              { now we generate a runtime error }
  end;

function root{ ( innumber, theroot : real ) : real };
  begin
  root := power( innumber, ( 1.0 / theroot ) );
  end;

end. { unit ptd_calc }