Turbo Toolbox/Turbo_Toolbox.iso/1990/12/tricks/mathe0.mod

Modula Implementation | 1990-09-12 | 5.0 KB | 226 lines

(* ------------------------------------------------------ *)
(*                     MATHE0.MOD                         *)
(*    erweitertes Mathe-Bibilotheks-Modul für Modula-2    *)
(*          (c) 1990  Jürgen Walter & TOOLBOX             *)
(* ------------------------------------------------------ *)
IMPLEMENTATION MODULE Mathe0;

FROM MathLib0 IMPORT sqrt, arctan, exp,
                     ln, real, entier;

CONST
  pi = 3.14159;

  PROCEDURE fraction(x : REAL) : REAL;
  VAR
    Rueck         : REAL;
    i, Vorzeichen : INTEGER;
    Test          : BOOLEAN;
  BEGIN
    Vorzeichen := sgn(x);
    x := ABS(x);
    IF real(entier(x)) > x THEN   (* Nachkommaanteil > .5 *)
      Rueck := x - real(entier(x - 0.5));
    ELSE
      Rueck := x - real(entier(x));
    END;
    IF Vorzeichen = -1 THEN
      Rueck := -1.0 * Rueck;
    END;
    RETURN Rueck;
  END fraction;

  PROCEDURE sgn(x : REAL) : INTEGER;
  VAR
    Rueck : INTEGER;
  BEGIN
    IF x > 0.0 THEN
      Rueck := 1;
    ELSIF x < 0.0 THEN
      Rueck := -1;
    ELSE
      Rueck := 0;
    END;
    RETURN Rueck;
  END sgn;

  PROCEDURE power(x, n : REAL) : REAL;
  (* Die Prozedur "power" fängt als einzige einen Fehler  *)
  (* bei der Übergabe der Parameter ab, ist x = 0 oder    *)
  (* x < 0 und der Nachkommaanteil eine gebrochene Zahl,  *)
  (* so wird eine Null zurückgegeben.                     *)
  VAR
    Rueck, nn : REAL;
    i         : CARDINAL;
    Test      : BOOLEAN;
  BEGIN
                (* Vorzeichen wird als positiv angenommen *)
    Test := TRUE;
    nn   := ABS(fraction(n));
    IF n = 0.0 THEN
                        (* Potenz ist 0 => Potenzwert = 1 *)
      Rueck := 1.0;
      RETURN Rueck;
    END;
        (* soll das Programm bei einem Fehler aussteigen, *)
        (* dann diese IF-Anweisung entfernen ...          *)
    IF ((nn > 0.0) AND (x < 0.0)) OR (x = 0.0) THEN
      Rueck := 0.0;
      RETURN Rueck;
    END;
    IF x < 0.0 THEN
      x := ABS(x); (* Vorzeichen wird als negativ erkannt *)
      Test := FALSE;
    END;
    IF n >= 1.0 THEN             (* Berechnung der Potenz *)
      Rueck := exp(n * ln(x));
    ELSIF nn > 0.0 THEN
      Rueck := exp(n * ln(x));
    ELSE                         (* Berechnung der Wurzel *)
      Rueck := exp(ln(x) / (1.0 / n));
    END;
    IF Test = FALSE THEN
      IF fraction(n / 2.0) # 0.0 THEN
        Rueck := -Rueck;
      ELSE
        Rueck := Rueck;
      END;
    END;
    RETURN Rueck;
  END power;

  PROCEDURE fact(x : REAL) : REAL;
  VAR
    Rueck, r : REAL;
    j, k     : INTEGER;
  BEGIN
    Rueck := 1.0;
    k     := entier(x);
    IF x = 0.0 THEN
      RETURN 1.0;
    END;
    FOR j := 1 TO k DO
      r     := real(j);
      Rueck := Rueck * r;
    END;
    RETURN Rueck;
  END fact;

  PROCEDURE Bi(n, r : REAL) : REAL;
  VAR
    NMinusR, Rueck : REAL;
  BEGIN
    NMinusR := n - r;
    Rueck   := fact(n) / (fact(r) * fact(NMinusR));
    RETURN Rueck;
  END Bi;

  PROCEDURE arccos(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := (pi / 2.0) - arcsin(x);
    RETURN Rueck;
  END arccos;

  PROCEDURE arcsin(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := (pi / 2.0) - arccos(x);
    RETURN Rueck;
  END arcsin;

  PROCEDURE arccot(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := arctan(1.0 / x);
    RETURN Rueck;
  END arccot;

  PROCEDURE sinh(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := 0.5 * (exp(x) - exp(-x));
    RETURN Rueck;
  END sinh;

  PROCEDURE cosh(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := 0.5 * (exp(x) + exp(-x));
    RETURN Rueck;
  END cosh;

  PROCEDURE tanh(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := (exp(x) - exp(-x)) / (exp(x) + exp(-x));
    RETURN Rueck;
  END tanh;

  PROCEDURE coth(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := 1.0 / tanh(x);
    RETURN Rueck;
  END coth;

  PROCEDURE arsinh(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := ln(x + sqrt(power(x, 2.0) + 1.0));
    RETURN Rueck;
  END arsinh;

  PROCEDURE arcosh(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := ln(x + sqrt(power(x, 2.0) - 1.0));
    RETURN Rueck;
  END arcosh;

  PROCEDURE artanh(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := 0.5 * ln((1.0 + x) / (1.0 -x));
    RETURN Rueck;
  END artanh;

  PROCEDURE arcoth(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := 0.5 * ln((x + 1.0) / (x - 1.0));
    RETURN Rueck;
  END arcoth;

  PROCEDURE log(x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := ln(x) / ln(10.0);
    RETURN Rueck;
  END log;

  PROCEDURE logb(b, x : REAL) : REAL;
  VAR
    Rueck : REAL;
  BEGIN
    Rueck := ln(x) / ln(b);
    RETURN Rueck;
  END logb;

BEGIN
END Mathe0.
(* ------------------------------------------------------ *)
(*                 Ende von MATHE0.MOD                    *)