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