home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1987 / 08 / calc / mathfunc.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1987-05-22  |  9.6 KB  |  335 lines
  1. (****************************************************************************)
  2. (*                             MATHFUNC.PAS                                 *)
  3. (*                              Version 1.1                                 *)
  4. (* Formulierung einiger nuetzlicher mathematischer Funktionen und           *)
  5. (* Konstanten. Dabei werden folgende Standardfunktionen vorausgesetzt:      *)
  6. (* Sin(x), Cos(x), Exp(x), ArcTan(x), Ln(x), Sqrt(x), Sqr(x)                *)
  7. (*                                                                          *)
  8. (* Modifikationen gegenueber der in PASCAL 3/87 veroeffentlichten Version:  *)
  9. (*  Fehlerkorrektur: x_hoch_y, arcosh                                       *)
  10. (*  Verbesserungen : sinh, cosh, tanh                                       *)
  11. (*  Erweiterungen  : Fehlerbehandlung in Verbindung mit der Fehlerprozedur  *)
  12. (*                   'CalcError' des math. Ausdruckauswerters in PASCAL     *)
  13. (*                   6/87, "CALC - ein mathematischer Compiler".            *)
  14. (****************************************************************************)
  15.  
  16. (* folgende Konstanten je nach Compiler in globalen Vereinbarungsteil ueber-
  17.    nehmen !                                                                 *)
  18.  
  19. CONST Wurzel_2 = 1.414213562;
  20.       Pi       = 3.141592654;
  21.       E        = 2.718281829;
  22.       Pi_Halbe = 1.570796327;                            (* Pi_Halbe = Pi/2 *)
  23.  
  24. (****************************************************************************)
  25. (* groessten, gemeinsamen Teiler von 'n1' und 'n2' ermitteln:               *)
  26.  
  27. FUNCTION ggT (n1, n2: INTEGER): INTEGER;
  28.  
  29. BEGIN
  30.   n1 := ABS(n1);    (* Berechnung erfolgt nach dem Euklid'schen Algorithmus *)
  31.   n2 := ABS(n2);
  32.   IF (n1 <> 0) AND (n2 <> 0) THEN                          (* ggT(0,0) := 0 *)
  33.     IF n2 <> 0 THEN                   (* Teilung durch Null ist unzulaessig *)
  34.       REPEAT
  35.         n1 := (n1 MOD n2);
  36.         IF n1 > 0 THEN
  37.           n2 := (n2 MOD n1);
  38.       UNTIL (n1 = 0) OR (n2 = 0);
  39.   ggT := n1 + n2;
  40. END;
  41.  
  42. (****************************************************************************)
  43. (* kleinstes, gemeinsames Vielfaches von 'n1' und 'n2' ermitteln:           *)
  44.  
  45. FUNCTION kgV (n1, n2: INTEGER): INTEGER;
  46.  
  47. VAR n: INTEGER;
  48.  
  49. BEGIN
  50.   n := ggT(n1, n2);
  51.   IF n <> 0 THEN
  52.     kgV := (n1 DIV ggT(n1, n2)) * n2   (* kgv(n1,n2) := n1 * n2 / ggT(n1,n2 *)
  53.   ELSE
  54.     kgV := 0
  55. END;
  56.  
  57. (****************************************************************************)
  58. (* Bogenmass nach Altgrad umrechnen:                                        *)
  59.  
  60. FUNCTION AltGrad (x: REAL): REAL;
  61.  
  62. CONST k_180_durch_Pi = 57.29577951;            (* k_180_durch_pi = 180 / Pi *)
  63.  
  64. BEGIN
  65.   AltGrad := x * k_180_durch_Pi;
  66. END;
  67.  
  68. (****************************************************************************)
  69. (* Altgrad nach Bogenmass umrechnen:                                        *)
  70.  
  71. FUNCTION Radiant (alpha: REAL): REAL;
  72.  
  73. CONST Pi_durch_180 = 0.017453292;                (* Pi_durch_180 = Pi / 180 *)
  74.  
  75. BEGIN
  76.   Radiant := alpha * Pi_durch_180;
  77. END;
  78.  
  79. (****************************************************************************)
  80. (* is' klar !?                                                              *)
  81.  
  82. FUNCTION Fakultaet (n: INTEGER): REAL;
  83.  
  84. CONST fak_00 = 1.000000000E00;                              (* fak_00 =  0! *)
  85.       fak_08 = 4.032000000E04;                              (* fak_08 =  8! *)
  86.       fak_16 = 2.092278989E13;                              (* fak_16 = 16! *)
  87.       fak_24 = 6.204484016E23;                              (* fak_24 = 24! *)
  88.       fak_32 = 2.631308368E35;                              (* fak_32 = 32! *)
  89.  
  90. VAR i, d: INTEGER;
  91.     r   : REAL;
  92.  
  93. BEGIN
  94.   IF n < 0 THEN                        (* n! ist fuer n < 0 nicht definiert *)
  95.     CalcError(3, 'Fakultaet(x)')
  96.   ELSE
  97.     BEGIN
  98.       d := (n DIV 8);
  99.       CASE d OF             (* dieser kleine Trick dient zur Beschleunigung *)
  100.         0 : r := 1.00;
  101.         1 : r := fak_08;
  102.         2 : r := fak_16;
  103.         3 : r := fak_24;
  104.         4 : r := fak_32;
  105.       END;
  106.       IF (d * 8 < n) THEN
  107.         FOR i := d * 8 + 1 TO n DO  r := r * i;
  108.       Fakultaet := r;
  109.     END;
  110. END;
  111.  
  112. (****************************************************************************)
  113.  
  114. FUNCTION Kehrwert (x: REAL): REAL;
  115.  
  116. BEGIN
  117.   IF x <> 0 THEN
  118.     Kehrwert := 1 / x
  119.   ELSE
  120.     CalcError(3, 'in Kehrwert(x): x = 0')
  121. END;
  122.  
  123. (****************************************************************************)
  124. (* Logarithmus von 'x' zur Basis 'b':                                       *)
  125.  
  126. FUNCTION Logarithmus (x, b: REAL): REAL;
  127.  
  128. BEGIN
  129.   IF (x > 0.0) AND (b <> 1.0) AND (b > 0.0) THEN
  130.     Logarithmus := Ln(x) / Ln(b)
  131.   ELSE
  132.     CalcError(3, 'Logarithmus(x,b): x <= 0 oder b <= 0 oder b = 1')
  133. END;
  134.  
  135. (****************************************************************************)
  136. (* Zehner-Logarithmus von 'x':                                              *)
  137.  
  138. FUNCTION lg (x: REAL): REAL;
  139.  
  140. CONST rez_ln_10 = 0.434294481;                    (* rez_ln_10 = 1 / ln(10) *)
  141.  
  142. BEGIN
  143.   IF x > 0.0 THEN
  144.     lg := Ln(x) * rez_ln_10
  145.   ELSE
  146.     CalcError(3, 'lg(x): x <= 0')
  147. END;
  148.  
  149. (****************************************************************************)
  150. (* Zweier-Logarithmus von 'x':                                              *)
  151.  
  152. FUNCTION ld (x: REAL): REAL;
  153.  
  154. CONST rez_ln_2 = 1.442695041;                       (* rez_ln_2 = 1 / ln(2) *)
  155.  
  156. BEGIN
  157.   IF x > 0.0 THEN
  158.     ld := Ln(x) * rez_ln_2
  159.   ELSE
  160.     CalcError(3, 'ld(x): x <= 0')
  161. END;
  162.  
  163. (****************************************************************************)
  164. (* Berechnung von 'x hoch y':                                               *)
  165.  
  166. FUNCTION x_hoch_y (x, y: REAL): REAL;
  167.  
  168. VAR ganz_y: INTEGER;
  169.  
  170. BEGIN
  171.   IF (x <> 0.0) OR (y <> 0.0) THEN
  172.     IF x > 0.0 THEN
  173.       x_hoch_y := Exp(y * Ln(x))
  174.     ELSE
  175.       BEGIN
  176.         ganz_y := Trunc(y);
  177.         IF ABS(y) > ABS(ganz_y) THEN
  178.           CalcError(3, 'x_hoch_y(x,y): nur ganzzahlige Exponenten zulaessig')
  179.         ELSE
  180.           IF x <> 0.0 THEN
  181.             IF (ganz_y MOD 2) = 0 THEN
  182.               x_hoch_y :=  Exp(Ln(ABS(x)) * y)
  183.             ELSE
  184.               x_hoch_y := -Exp(Ln(ABS(x)) * y)       (* ungerader Exponent *)
  185.           ELSE
  186.             x_hoch_y := 0
  187.       END
  188.   ELSE
  189.     CalcError(3, 'x_hoch_y(x,y): x = 0 und y = 0')
  190. END;
  191.  
  192. (****************************************************************************)
  193.  
  194. (* Sinus hyp.:                                                              *)
  195.  
  196. FUNCTION sinh (x: REAL): REAL;
  197.  
  198. BEGIN
  199.   x := Exp(x);
  200.   sinh := 0.5 * (x-1/x);
  201. END;
  202.  
  203. (* Cosinus hyp.:                                                            *)
  204.  
  205. FUNCTION cosh (x: REAL): REAL;
  206.  
  207. BEGIN
  208.   x := Exp(x);
  209.   cosh := 0.5 * (x+1/x);
  210. END;
  211.  
  212. (* Tangens hyp.:                                                            *)
  213.  
  214. FUNCTION tanh (x: REAL): REAL;
  215.  
  216. BEGIN
  217.   tanh := 1-2/(1+Exp(2*x));
  218. END;
  219.  
  220. (* Cotangens hyp.:                                                          *)
  221.  
  222. FUNCTION coth (x: REAL): REAL;
  223.  
  224. BEGIN
  225.   coth := 1 / tanh(x)
  226. END;
  227.  
  228. (****************************************************************************)
  229.  
  230. (* Umkehrfunktion zu sinh(x):                                               *)
  231.  
  232. FUNCTION arsinh (x: REAL): REAL;
  233.  
  234. BEGIN
  235.   arsinh := Ln(x + Sqrt(Sqr(x) + 1));
  236. END;
  237.  
  238. (* Umkehrfunktion zu cosh(x):                                               *)
  239.  
  240. FUNCTION arcosh (x: REAL): REAL;
  241.  
  242. BEGIN
  243.   IF x < 1.0 THEN
  244.     CalcError(3, 'arcosh(x): x < 1')
  245.   ELSE
  246.     arcosh := Ln(x + Sqrt(Sqr(x) - 1));
  247. END;
  248.  
  249. (* Umkehrfunktion zu tanh(x):                                               *)
  250.  
  251. FUNCTION artanh (x: REAL): REAL;
  252.  
  253. BEGIN
  254.   IF ABS(x) < 1.0 THEN
  255.     artanh := 0.5 * Ln((1 + x) / (1 - x))
  256.   ELSE
  257.     CalcError(3, 'artanh(x): x <= -1 oder x >= 1')
  258. END;
  259.  
  260. (* Umkehrfunktion zu coth(x):                                               *)
  261.  
  262. FUNCTION arcoth (x: REAL): REAL;
  263.  
  264. BEGIN
  265.   IF ABS(x) > 1.0 THEN
  266.     arcoth := 0.5 * Ln((x + 1) / (x - 1))
  267.   ELSE
  268.     CalcError(3, 'arcoth(x): -1 <= x <= 1')
  269. END;
  270.  
  271. (****************************************************************************)
  272.  
  273. (* Tangens von 'x':                                                         *)
  274.  
  275. FUNCTION tan (x: REAL): REAL;
  276.  
  277. BEGIN
  278.   IF Cos(x) <> 0 THEN
  279.     tan := Sin(x) * Kehrwert(Cos(x))
  280.   ELSE
  281.     CalcError(3, 'tan(x): x = (Pi/2)')
  282. END;
  283.  
  284. (* Cotangens von 'x':                                                       *)
  285.  
  286. FUNCTION cot (x: REAL): REAL;
  287.  
  288. VAR tmp: REAL;
  289.  
  290. BEGIN
  291.   tmp := Int(x/Pi_Halbe);
  292.   IF tmp * Pi_Halbe <> x THEN
  293.     cot := Kehrwert(tan(x))
  294.   ELSE
  295.     CalcError(3, 'cot(x): x = Vielfaches von Pi/2')
  296. END;
  297.  
  298. (****************************************************************************)
  299.  
  300. (* Umkehrfunktion zu sin(x):                                                *)
  301.  
  302. FUNCTION arcsin (x: REAL): REAL;
  303.  
  304. BEGIN
  305.   IF ABS(x) > 1.0 THEN
  306.     CalcError(3, 'arcsin(x): x < -1 oder x > 1')
  307.   ELSE
  308.     IF ABS(x) < 1.0 THEN
  309.       arcsin := ArcTan(x / Sqrt(1 - Sqr(x)))
  310.     ELSE
  311.       arcsin := x * Pi_Halbe
  312. END;
  313.  
  314. (* Umkehrfunktion zu cos(x):                                                *)
  315.  
  316. FUNCTION arccos (x: REAL): REAL;
  317.  
  318. BEGIN
  319.   IF ABS(x) > 1.0 THEN
  320.     CalcError(3, 'arccos(x): x < -1 oder x > 1')
  321.   ELSE
  322.     arccos := Pi_Halbe - arcsin(x);
  323. END;
  324.  
  325. (* Umkehrfunktion zu cot(x):                                                *)
  326.  
  327. FUNCTION arccot (x: REAL): REAL;
  328.  
  329. BEGIN
  330.   arccot := Pi_Halbe - ArcTan(x);
  331. END;
  332.  
  333. (****************************************************************************)
  334. (*                        Ende von MATHFUNC.PAS                             *)
  335.