home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 12 / tricks / binomial.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-09-06  |  3.4 KB  |  147 lines
  1. (* ----------------------------------------------------- *)
  2. (*                 BINOMIAL.PAS                          *)
  3. (*      (c) 1989  Alfred Kraft  &  TOOLBOX               *)
  4. (* ***************************************************** *)
  5. PROGRAM binomialverteilung;
  6.  
  7. {$N+}
  8.  
  9. USES Crt;
  10.  
  11. VAR
  12.   n, k, i  : INTEGER;
  13.   p        : REAL;
  14.   h        : EXTENDED;
  15.   wahl     : CHAR;
  16.  
  17.   FUNCTION pot(p : REAL; n : INTEGER) : EXTENDED;
  18.   VAR
  19.     prod : EXTENDED;
  20.   BEGIN
  21.     i := 1;
  22.     prod := 1;
  23.     IF n <> 0 THEN
  24.       REPEAT
  25.         prod := prod * p;
  26.         Inc(i);
  27.       UNTIL i > n;
  28.       pot := prod;
  29.   END;
  30.  
  31.   FUNCTION binkoeff(n, k : INTEGER) : EXTENDED;
  32.   VAR
  33.     max, Min, j : INTEGER;
  34.     binko       : EXTENDED;
  35.   BEGIN
  36.     IF ((n < 0) OR (k <0) OR (n < k)) THEN BEGIN
  37.       WriteLn('unzulässiger Parameter');
  38.       binkoeff := 0;
  39.       Exit;
  40.     END ELSE BEGIN
  41.       IF k < n - k THEN BEGIN
  42.         max := n - k;
  43.         Min := k;
  44.       END ELSE BEGIN
  45.         max := k;
  46.         Min := n - k;
  47.       END;
  48.       binko := 1;
  49.       j := 1;
  50.       WHILE  j <= (n - max) DO BEGIN
  51.         binko := binko * ( max + j) / j;
  52.         Inc(j);
  53.       END;
  54.         binkoeff := binko;
  55.     END;
  56.   END;
  57.  
  58.   FUNCTION binomial(n, k : INTEGER; p : REAL) : EXTENDED;
  59.   VAR
  60.     q, a, b : EXTENDED;
  61.   BEGIN
  62.     IF ((n<1) OR (k<0) OR (n<k)
  63.                        OR (p<0) OR (p>1)) THEN BEGIN
  64.       WriteLn('unzulässiger Parameter! ');
  65.       binomial := 0;
  66.     END ELSE BEGIN
  67.       IF ((p <> 0) AND (p <> 1)) THEN BEGIN
  68.         q := 1 - p;
  69.         IF n = k THEN BEGIN
  70.           a := pot(p, n);
  71.           b := 1;
  72.         END ELSE BEGIN
  73.           IF k = 0 THEN BEGIN
  74.             a := 1;
  75.             b := pot(q, n);
  76.           END ELSE BEGIN
  77.             a := pot(p, k);
  78.             b := pot(q, n - k);
  79.           END;
  80.         END;
  81.         binomial := a * b * binkoeff(n, k);
  82.       END ELSE BEGIN
  83.         IF p = 0 THEN BEGIN
  84.           IF k= 0 THEN binomial := 1
  85.                   ELSE binomial := 0;
  86.         END ELSE BEGIN
  87.           IF k = n THEN binomial := 1
  88.                    ELSE binomial := 0;
  89.         END;
  90.       END;
  91.     END;
  92.   END;
  93.  
  94.   PROCEDURE intein(VAR n : INTEGER);
  95.   VAR
  96.     Mem, posx, posy : INTEGER;
  97.     li              : LONGINT;
  98.     Zg              : BOOLEAN;
  99.   BEGIN
  100.     posx := WhereX;
  101.     posy := WhereY;
  102.     REPEAT
  103.       ClrEol;
  104. {$I-}
  105.       ReadLn(li);
  106. {$I+}
  107.       Mem := IOResult;
  108.       Zg := ((li < -MaxInt) OR (li > MaxInt));
  109.       IF ((Mem <> 0) OR Zg) THEN GotoXY(posx, posy);
  110.     UNTIL ((Mem = 0) AND (NOT Zg));
  111.     n := li;
  112.   END;
  113.  
  114.   PROCEDURE fuss;
  115.   BEGIN
  116.     Window(1, 1,80,25);
  117.     Window(1,23,80,25);
  118.     GotoXY(1, 1);
  119.     FOR i := 1 TO 80 DO Write(Chr(196));
  120.     Write('Fortsetzung : beliebige Taste...  ');
  121.     WriteLn('   Ende : Esc');
  122.     Window(1,1,80,22);
  123.   END;
  124.  
  125.   PROCEDURE bin_aus;
  126.   BEGIN
  127.     REPEAT
  128.       WriteLn('bitte n, k und p eingeben : ');
  129.       Write('n : ');  intein(n);
  130.       Write('k : ');  intein(k);
  131.       Write('p : ');  ReadLn(p);
  132.       h := binomial(n, k, p);
  133.       IF h >= 0.0001 THEN WriteLn('b(n,k,p) = ',h:10:8)
  134.                      ELSE WriteLn('b(n,k,p) = ',h);
  135.       WriteLn;
  136.       wahl := ReadKey;
  137.     UNTIL ((Ord(wahl) = 27) OR (UpCase(wahl) = 'o'));
  138.   END;
  139.  
  140. BEGIN
  141.   wahl := 'b';
  142.   ClrScr;
  143.   fuss;
  144.   bin_aus;
  145. END.
  146. (* ------------------------------------------------------ *)
  147. (*                Ende von BINOMIAL.PAS                   *)