jclmath.pas

East make Tray Icon in delphi

function Exp(const Z: TRectComplex): TPolarComplex; overload;
function Power(const Z: TPolarComplex; const Exponent: TRectComplex): TPolarComplex; overload;
function Power(const Z: TPolarComplex; const Exponent: Float): TPolarComplex; overload;
function PowerInt(const Z: TPolarComplex; const Exponent: Integer): TPolarComplex; overload;
function Root(const Z: TPolarComplex; const K, N: Cardinal): TPolarComplex;

function Cos(const Z: TRectComplex): TRectComplex; overload;
function Sin(const Z: TRectComplex): TRectComplex; overload;
function Tan(const Z: TRectComplex): TRectComplex; overload;
function Cot(const Z: TRectComplex): TRectComplex; overload;
function Sec(const Z: TRectComplex): TRectComplex; overload;
function Csc(const Z: TRectComplex): TRectComplex; overload;

function CosH(const Z: TRectComplex): TRectComplex; overload;
function SinH(const Z: TRectComplex): TRectComplex; overload;
function TanH(const Z: TRectComplex): TRectComplex; overload;
function CotH(const Z: TRectComplex): TRectComplex; overload;
function SecH(const Z: TRectComplex): TRectComplex; overload;
function CscH(const Z: TRectComplex): TRectComplex; overload;

implementation

uses
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  Jcl8087, JclResources;

// Internal helper routines
// Linux: Get Global Offset Table (GOT) adress for Position Independent Code
// (PIC, used by shared objects)

{$IFDEF PIC}
function GetGOT: Pointer; export;
begin
  asm
        MOV Result, EBX
  end;
end;
{$ENDIF PIC}

// to be independent from JclLogic

function Min(const X, Y: Integer): Integer;
begin
  if X < Y then
    Result := X
  else
    Result := Y;
end;

// to be independent from JCLLogic

procedure SwapOrd(var X, Y: Integer);
var
  Temp: Integer;
begin
  Temp := X;
  X := Y;
  Y := Temp;
end;

function DoubleToHex(const D: Double): string;
var
  Overlay: array [1..2] of Longint absolute D;
begin
  // Look at element 2 before element 1 because of "Little Endian" order.
  Result := IntToHex(Overlay[2], 8) + IntToHex(Overlay[1], 8);
end;

function HexToDouble(const Hex: string): Double;
var
  D: Double;
  Overlay: array [1..2] of Longint absolute D;
begin
  if Length(Hex) <> 16 then
    raise EJclMathError.CreateRes(@RsUnexpectedValue);
  Overlay[1] := StrToInt('$' + Copy(Hex, 9, 8));
  Overlay[2] := StrToInt('$' + Copy(Hex, 1, 8));
  Result := D;
end;

const
  _180: Integer = 180;
  _200: Integer = 200;

// Converts degrees to radians. Expects degrees in ST(0), leaves radians in ST(0)
// ST(0) := ST(0) * PI / 180

procedure FDegToRad; assembler;
asm
        {$IFDEF PIC}
        CALL    GetGOT
        {$ENDIF PIC}
        FLDPI
        {$IFDEF PIC}
        FIDIV   [EAX][_180]
        {$ELSE}
        FIDIV   [_180]
        {$ENDIF PIC}
        FMUL
        FWAIT
end;

// Converts radians to degrees. Expects radians in ST(0), leaves degrees in ST(0)
// ST(0) := ST(0) * (180 / PI);

procedure FRadToDeg; assembler;
asm
        {$IFDEF PIC}
        CALL    GetGOT
        {$ENDIF PIC}
        FLD1
        FLDPI
        FDIV
        {$IFDEF PIC}
        FLD   [EAX][_180]
        {$ELSE}
        FLD   [_180]
        {$ENDIF PIC}
        FMUL
        FMUL
        FWAIT
end;

// Converts grads to radians. Expects grads in ST(0), leaves radians in ST(0)
// ST(0) := ST(0) * PI / 200

procedure FGradToRad; assembler;
asm
        {$IFDEF PIC}
        CALL    GetGOT
        {$ENDIF PIC}
        FLDPI
        {$IFDEF PIC}
        FIDIV   [EAX][_200]
        {$ELSE}
        FIDIV   [_200]
        {$ENDIF PIC}
        FMUL
        FWAIT
end;

// Converts radians to grads. Expects radians in ST(0), leaves grads in ST(0)
// ST(0) := ST(0) * (200 / PI);

procedure FRadToGrad; assembler;
asm
        {$IFDEF PIC}
        CALL    GetGOT
        {$ENDIF PIC}
        FLD1
        FLDPI
        FDIV
        {$IFDEF PIC}
        FLD   [EAX][_200]
        {$ELSE}
        FLD   [_200]
        {$ENDIF PIC}
        FMUL
        FMUL
        FWAIT
end;

procedure DomainCheck(Err: Boolean);
begin
  if Err then
    raise EJclMathError.CreateRes(@RsMathDomainError);
end;

//=== Logarithmic ============================================================

function LogBase10(X: Float): Float;

  function FLogBase10(X: Float): Float; assembler;
  asm
          FLDLG2
          FLD     X
          FYL2X
          FWAIT
  end;

begin
  DomainCheck(X <= 0.0);
  Result := FLogBase10(X);
end;

function LogBase2(X: Float): Float;

  function FLogBase2(X: Float): Float; assembler;
  asm
          FLD1
          FLD     X
          FYL2X
          FWAIT
  end;

begin
  DomainCheck(X <= 0.0);
  Result := FLogBase2(X);
end;

function LogBaseN(Base, X: Float): Float;

  function FLogBaseN(Base, X: Float): Float; assembler;
  asm
          FLD1
          FLD     X
          FYL2X
          FLD1
          FLD     Base
          FYL2X
          FDIV
          FWAIT
  end;

begin
  DomainCheck((X <= 0.0) or (Base <= 0.0) or (Base = 1.0));
  Result := FLogBaseN(Base, X);
end;

//=== Transcendental =========================================================

function ArcCos(X: Float): Float;

  function FArcCos(X: Float): Float; assembler;
  asm
          FLD     X
          FLD     ST(0)
          FMUL    ST(0), ST
          FLD1
          FSUBRP  ST(1), ST
          FSQRT
          FXCH
          FPATAN
          FWAIT
  end;

begin
  DomainCheck(Abs(X) > 1.0);
  Result := FArcCos(X);
end;

function ArcCot(X: Float): Float;
begin
  DomainCheck(X = 0);
  Result := ArcTan(1 / X);
end;

function ArcCsc(X: Float): Float;
begin
  Result := ArcSec(X / Sqrt(X * X -1));
end;

function ArcSec(X: Float): Float;

  function FArcTan(X: Float): Float; assembler;
  asm
          FLD     X
          FLD1
          FPATAN
          FWAIT
  end;

begin
  Result := FArcTan(Sqrt(X*X - 1));
end;

function ArcSin(X: Float): Float;

  function FArcSin(X: Float): Float; assembler;
  asm
          FLD     X
          FLD     ST(0)
          FMUL    ST(0), ST
          FLD1
          FSUBRP  ST(1), ST
          FSQRT
          FPATAN
          FWAIT
  end;

begin
  DomainCheck(Abs(X) > 1.0);
  Result := FArcSin(X);
end;

function ArcTan(X: Float): Float; assembler;
{$IFDEF PUREPASCAL}
begin
  Result := ArcTan2(X, 1);
end;
{$ELSE}
asm
        FLD     X
        FLD1
        FPATAN
        FWAIT
end;
{$ENDIF DEF PUREPASCAL}

function ArcTan2(Y, X: Float): Float; assembler;
asm
        FLD     Y
        FLD     X
        FPATAN
        FWAIT
end;

function Cos(X: Float): Float;

  function FCos(X: Float): Float; assembler;
  asm
          FLD     X
          FCOS
          FWAIT
  end;

begin
  DomainCheck(Abs(X) > MaxAngle);
  Result := FCos(X);
end;

function Cot(X: Float): Float;

  function FCot(X: Float): Float; assembler;
  asm
          FLD     X
          FPTAN
          FDIVRP
          FWAIT
  end;

begin
  DomainCheck(Abs(X) > MaxAngle);
  { TODO : Cot = 1 / Tan -> Tan(X) <> 0.0 }
  Result := FCot(X);
end;

function Coversine(X: Float): Float;
begin
  Result := 1 - Sin(X);
end;

function Csc(X: Float): Float;
var
  Y: Float;
begin
  DomainCheck(Abs(X) > MaxAngle);

  Y := Sin(X);
  DomainCheck(Y = 0.0);
  Result := 1.0 / Y;
end;

function Exsecans(X: Float): Float;
begin
  Result := Sec(X) - 1;
end;

function Haversine(X: Float): Float;
begin
  Result := 0.5 * (1 - Cos(X)) ;
end;

function Sec(X: Float): Float;

  function FSec(X: Float): Float; assembler;
  asm
          FLD     X
          FCOS
          FLD1
          FDIVRP
          FWAIT
  end;

begin
  DomainCheck(Abs(X) > MaxAngle);
  { TODO : Sec = 1 / Cos -> Cos(X) <> 0! }
  Result := FSec(X);
end;

function Sin(X: Float): Float;

  function FSin(X: Float): Float; assembler;
  asm
          FLD     X
          FSIN
          FWAIT
  end;

begin
  {$IFNDEF MATH_EXT_SPECIALVALUES}
  DomainCheck(Abs(X) > MaxAngle);
  {$ENDIF ~MATH_EXT_SPECIALVALUES}
  Result := FSin(X);
end;

procedure SinCos(X: Float; var Sin, Cos: Float);

  procedure FSinCos(X: Float; var Sin, Cos: Float); assembler;
  asm
          FLD     X
          FSINCOS
          FSTP    TByte PTR [EDX]
          FSTP    TByte PTR [EAX]
          FWAIT
  end;

begin
  DomainCheck(Abs(X) > MaxAngle);
  FSinCos(X, Sin, Cos);
end;

function Tan(X: Float): Float;

  function FTan(X: Float): Float; assembler;
  asm
          FLD     X
          FPTAN
          FSTP    ST(0)
          FWAIT
  end;

begin
  DomainCheck(Abs(X) > MaxAngle);
  Result := FTan(X);
end;

function Versine(X: Float): Float;
begin
  Result := 1 - Cos(X);
end;

//=== Hyperbolic =============================================================

function ArcCosH(X: Float): Float;

  function FArcCosH(X: Float): Float; assembler;
  asm
          FLDLN2
          FLD     X
          FLD     ST(0)
          FMUL    ST(0), ST
          FLD1
          FSUBP   ST(1), ST
          FSQRT
          FADDP   ST(1), ST
          FYL2X
  end;

begin
  DomainCheck(X < 1.0);
  Result := FArcCosH(X);
end;

function ArcCotH(X: Float): Float;
begin
  DomainCheck(Abs(X) = 1.0);
  Result := 0.5 * System.Ln((X + 1.0) / (X - 1.0));
end;

function ArcCscH(X: Float): Float;
begin
  DomainCheck(X = 0);
  Result := System.Ln((Sgn(X) * Sqrt(Sqr(X) + 1.0) + 1.0) / X);
end;

function ArcSecH(X: Float): Float;
begin
  DomainCheck(Abs(X) > 1.0);
  Result := System.Ln((Sqrt(1.0 - Sqr(X)) + 1.0) / X);
end;

function ArcSinH(X: Float): Float; assembler;
asm
        FLDLN2
        FLD     X
        FLD     ST(0)
        FMUL    ST(0), ST
        FLD1
        FADDP   ST(1), ST
        FSQRT
        FADDP   ST(1), ST
        FYL2X
end;

function ArcTanH(X: Float): Float;

  function FArcTanH(X: Float): Float; assembler;
  asm
          FLDLN2
          FLD     X
          FLD     ST(0)
          FLD1
          FADDP   ST(1), ST
          FXCH
          FLD1
          FSUBRP  ST(1), ST
          FDIVP   ST(1), ST