Turbo Toolbox/Turbo_Toolbox.iso/extra18/wita/math.pas

Pascal/Delphi Source File | 1992-01-20 | 4.7 KB | 223 lines

(* ------------------------------------------------- *)
(*                    MATH.PAS                       *)
(*        (c) 1992 W.Hermanns & DMV-Verlag           *)
(* ------------------------------------------------- *)
{$R-,S-,I-,V-}

UNIT Math;

INTERFACE

CONST
  HexBinZif = '0123456789ABCDEF';

TYPE
  Str36 = STRING[36];

VAR
  Error, Basis : BYTE;
  WiMo, Wa, Wn : REAL;


  FUNCTION Sgn(X : REAL) : ShortInt;
  FUNCTION Fakultaet(X : REAL) : REAL;
  FUNCTION Modulo(X, Y : REAL) : REAL;
  FUNCTION Sih(X : REAL) : REAL;
  FUNCTION Coh(X : REAL) : REAL;
  FUNCTION Tah(X : REAL) : REAL;
  FUNCTION Ash(X : REAL) : REAL;
  FUNCTION Ach(X : REAL) : REAL;
  FUNCTION Ath(X : REAL) : REAL;
  FUNCTION Dez(Ein : Str36) : REAL;
  FUNCTION Hexbin(Ein : LongInt) : Str36;
  FUNCTION Lint(X : REAL) : LongInt;
  FUNCTION Lg(X : REAL) : REAL;
  FUNCTION XhochY(X, Y : REAL) : REAL;
  FUNCTION Cos(X : REAL) : REAL;
  FUNCTION Sin(X : REAL) : REAL;
  FUNCTION Tan(X : REAL) : REAL;
  FUNCTION Acs(X : REAL) : REAL;
  FUNCTION Asn(X : REAL) : REAL;
  FUNCTION Atn(X : REAL) : REAL;

IMPLEMENTATION

VAR
  C : REAL; I, J : BYTE; H : Str36;

  FUNCTION Sgn(X : REAL) : ShortInt;
  BEGIN
    IF X > 0 THEN
      Sgn := 1
    ELSE IF X < 0 THEN
      Sgn := -1
    ELSE
      Sgn := 0;
  END;

  FUNCTION Fakultaet(X : REAL) : REAL;
  BEGIN
    IF (X < 33) THEN
      IF (Frac(X) = 0) AND (X >= 0) THEN BEGIN
        C := 1;
        FOR i := 1 TO Trunc(X) DO C := C*i;
        Fakultaet := C;
      END ELSE Error := 2
    ELSE Error := 3;
  END;

  FUNCTION Modulo(X, Y : REAL) : REAL;
  BEGIN
    IF (Y <> 0) AND (Frac(Y) = 0) THEN
      Modulo := X - Int(X/Y)*Y
    ELSE Error := 2;
  END;

  FUNCTION Sih(X : REAL) : REAL;
  BEGIN
    IF Abs(X) <= 88 THEN
      Sih := (Exp(X)-Exp(-X))/2
    ELSE Error:=3;
  END;

  FUNCTION Coh(X : REAL) : REAL;
  BEGIN
    IF Abs(X) <= 88 THEN
      Coh:=(Exp(X)+Exp(-X))/2
    ELSE Error:=3;
  END;

  FUNCTION Tah(X : REAL) : REAL;
  BEGIN
    IF Abs(X) <= 88 THEN
      Tah := Sih(X)/Coh(X)
    ELSE Error:=3;
  END;

  FUNCTION Ash(X : REAL) : REAL;
  BEGIN
    IF Abs(X) <= 1E18 THEN
      Ash:=Sgn(X)*Ln(Abs(X)+Sqrt(X*X+1))
    ELSE Error:=3;
  END;

  FUNCTION Ach(X : REAL) : REAL;
  BEGIN
    IF X <= 1E18 THEN
      IF X >= 1 THEN
        Ach := Ln(X+Sqrt(X*X-1))
      ELSE Error := 2
    ELSE Error := 3;
  END;

  FUNCTION Ath(X : REAL) : REAL;
  BEGIN
    IF Abs(X) < 1 THEN
      Ath := Ln((1+X)/(1-X))/2
    ELSE Error := 2
  END;

  FUNCTION Dez(Ein : Str36) : REAL;
  BEGIN
    C := 0;
    FOR i := 1 TO Length(Ein) DO BEGIN
      J := Pred(Pos(Ein[i], HexBinZif));
      C := C*(1 SHL Basis)+J;
    END;
    Dez := C;
  END;

  FUNCTION Hexbin(Ein : LongInt) : Str36;
  BEGIN
    H := '';
    FOR I := Pred((5-Basis) SHL 3) DOWNTO 0 DO BEGIN
      J := (Ein SHR (I * Basis)) AND
            Pred(1 SHL Basis);
      H := H + Copy(Hexbinzif,Succ(J),1);
      IF (I MOD 8) = 0 THEN H := H + ' ';
    END;
    Hexbin := H;
  END;

  FUNCTION Lint(X : REAL) : LongInt;
  BEGIN
    IF Abs(X) <= Maxlongint THEN
      Lint := Trunc(X)
    ELSE Error := 3;
  END;

  FUNCTION Lg(X : REAL) : REAL;
  BEGIN
    IF X > 0 THEN
      Lg := Ln(X)/Ln(10)
    ELSE Error := 2;
  END;

  FUNCTION XhochY(X, Y : REAL) : REAL;
  BEGIN
    IF X = 0 THEN BEGIN
      IF Y <= 0 THEN
        Error := 2
      ELSE XhochY := 0
    END ELSE IF X > 0 THEN
      XhochY := Exp(Y*Ln(X))
    ELSE BEGIN
      X := Abs(X);
      IF Y = Trunc(Y) THEN
        IF Odd(Trunc(Y)) THEN
          XhochY := -XhochY(X, Y)
        ELSE
          XhochY:=XhochY(X,Y)
      ELSE BEGIN
        IF (Abs(Round(1/Y)-1/Y) < 1E-8) AND
           (Odd(Round(1/Y))) THEN
          XhochY := -XhochY(X,Y)
        ELSE
          Error := 2;
      END;
    END;
  END;

  FUNCTION Cos(X : REAL) : REAL;
  BEGIN
    Cos := System.Cos(X * WiMo)
  END;

  FUNCTION Sin(X : REAL) : REAL;
  BEGIN
    Sin := System.Sin(X * WiMo)
  END;

  FUNCTION Tan(X : REAL) : REAL;
  BEGIN
    C := Cos(X);
    IF C = 0 THEN Error := 2 ELSE Tan := Sin(X)/C
  END;

  FUNCTION Acs(X : REAL) : REAL;
  BEGIN
    IF Abs(X) > 1 THEN
      Error := 2
    ELSE IF Abs(X) = 1 THEN
      C := (1-X)*Pi/2
    ELSE
      C := -ArcTan(X/Sqrt(1-X*X)) + Pi/2;
    Acs := C/WiMo
  END;

  FUNCTION Asn(X : REAL) : REAL;
  BEGIN
    Asn := Pi/2/WiMo-Acs(X);
  END;

  FUNCTION Atn(X : REAL) : REAL;
  BEGIN
    Atn := System.ArcTan(X)/WiMo;
  END;

BEGIN
  Wa := Pi/180;  Wn := Pi/200;
END.
(* ------------------------------------------------- *)
(*               Ende von MATH.PAS                   *)