home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol131 / tstmedn.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  5.9 KB  |  229 lines
  1. PROGRAM tstmedn(0);
  2. {$e+  [extended error messages ON] }
  3. CONST
  4.   bigeven#    = MAXINT - 1;
  5.   big#        = 999.0;
  6.   Max_N     = 5000;
  7.   control_c    = false;
  8. TYPE
  9.   varrecord    = RECORD
  10.     CASE success : BOOLEAN OF
  11.                TRUE    : ( mean,
  12.                            mostfreq,
  13.                            middle,
  14.                            variance,
  15.                            stddevtn,
  16.                            stderrmn,
  17.                            skewness,
  18.                            kurtosis,
  19.                            semedian,
  20.                            seskewns,
  21.                            sekurtss : REAL;
  22.                range    : ARRAY[1..2] OF REAL);
  23.                FALSE   : ( errmsg1,
  24.                            errmsg2,
  25.                            errmsg3,
  26.                            errmsg4  : BOOLEAN );
  27.                END; { of : definition of type varrecord }
  28.   index     = 1..Max_N;
  29.   Scalar     = REAL;
  30.   real_array    = ARRAY[index] OF scalar;
  31.   list          = real_array;
  32.   str8        = STRING 8;
  33.   intarray    = ARRAY[1..55] OF INTEGER;
  34.   byte        = 0..255;
  35. VAR
  36.   parameters    : varrecord;
  37.   timestring    : str8;
  38.   answer    : char;
  39.   n,i,number    : INTEGER;
  40.   result,mean    : scalar;
  41.   A        : real_array;
  42.   randarray    : intarray;
  43.   randindex,
  44.   seed        : INTEGER;
  45.   good#        : BOOLEAN;
  46.  
  47. Procedure readq(VAR a:char);external;
  48. Procedure time(VAR t:str8 );external;
  49.  
  50. FUNCTION rndknuth(VAR randarray : intarray) : byte;
  51. {$c-,m-,f-,r-
  52. comment : fills the array "randarray" with 55 pseudo random INTEGERS in
  53.       the range 0..bigeven#. Knuth originally specified 10^9 for
  54.       bigeven# . For Pascal/Z the best number = MAXINT - 1.
  55.       Requires the following definitions globally :
  56.  CONST    bigeven#    = MAXINT - 1;
  57.  TYPE    "intarray"    = ARRAY[1..55] OF INTEGER;
  58.     "byte"        = 0..255;
  59.  VAR    "randarray"    : "intarray";
  60.        Returns the value 1 ( for reinitializing index to "randarray").
  61. }
  62. VAR
  63.     i,j,k    :  INTEGER;
  64. BEGIN
  65.  FOR i := 1 TO 55 DO
  66.   BEGIN
  67.     k := i + 31;
  68.     IF k > 55 THEN k := k - 55;
  69.     j := randarray[i] - randarray[k];
  70.     IF j < 0 THEN j := j + bigeven#;
  71.     randarray[i] := j
  72.   END;
  73.  rndknuth := 1;
  74. END; { of : FUNCTION rndknuth }
  75.  
  76. PROCEDURE initknuth(VAR randarray : intarray;seed : INTEGER);
  77. {$c-,m-,f-,r-
  78. comment : Initializes randarray.Has the same requirements as rndknuth ,
  79.       which FUNCTION  is called by initknuth,plus the input value :
  80.       "seed" : this may be a zero,one or any other positive
  81.       INTEGER value.A useful technic when you want to use a "random"
  82.       seed is to create an integer from the time of day , if you have
  83.       it available to your computer.
  84. }
  85. VAR
  86.     i,ii,j,k : INTEGER;
  87. BEGIN
  88.  randarray[55]    := seed;
  89.  j        := seed;
  90.  k        := 1;
  91.  FOR i := 1 TO 54 DO
  92.   BEGIN
  93.    ii := (21 * i) MOD 55;
  94.    randarray[ii] := k;
  95.    k := j - k;
  96.    IF k < 0 THEN k := k + bigeven#;
  97.    j := randarray[ii]
  98.   END;
  99.  i := rndknuth(randarray);
  100.  i := rndknuth(randarray);
  101.  i := rndknuth(randarray);
  102. END; { of : PROCEDURE initknuth }
  103.  
  104. FUNCTION random#r : REAL;
  105. {
  106. comment : Returns a REAL pseudo random number in the range 0.0 .. 1.0.
  107.       Requires the definitions needed by rndknuth and  initknuth
  108.       plus the following global :
  109.   VAR    randindex    : INTEGER;
  110. }
  111. BEGIN
  112.  randindex := randindex + 1;
  113.  IF randindex > 55 THEN randindex := rndknuth(randarray);
  114.  random#r  := randarray[randindex]/bigeven#;
  115. END; { of : FUNCTION random#r }
  116.  
  117. FUNCTION random#n : REAL;
  118. {
  119. comment : Returns a REAL number that is randomly selected from a normally
  120. distributed population whose mean is zero and variance (and standard dev.)
  121. is 1.0.
  122. }
  123. VAR
  124.     n    : INTEGER;
  125.     total    : REAL;
  126. BEGIN
  127.  total := -6.0;
  128.  FOR n := 1 TO 12 DO total := total + random#r;
  129.  random#n := total;
  130. END; { of : function randomn }
  131.  
  132.  
  133. procedure initseed;
  134. {$c-,m-,f- }
  135. BEGIN
  136.  timestring := '  :  :  ';
  137.  seed := 0;
  138.  time(timestring);
  139.  FOR i := 1 TO 8 DO seed := seed + ORD(timestring[i]);
  140. END;
  141.  
  142. Procedure Show;
  143. var
  144.   i: index;
  145. begin
  146.   for i:=1 to N do
  147.     begin
  148.       write(A[i]:10:4);
  149.       if i mod 6 = 0 then writeln;
  150.     end;
  151.   writeln;
  152. end;
  153.  
  154. {$iB:SELECT.PAS }
  155.  
  156. {$iB:MEDIAN.PAS }
  157.  
  158.  
  159. PROCEDURE popstats(VAR a          : list;
  160.                    n1st,nlast     : INTEGER;
  161.                    VAR parameters : varrecord); EXTERNAL;
  162.  
  163. BEGIN 
  164. {$c+,m+,f+,r+  [Turn on checks for main program : disabled by median & select]}
  165.  initseed;
  166.  initknuth(randarray,seed);
  167.  REPEAT { until control_c }
  168.   repeat
  169.     writeln;
  170.     writeln('Enter number of items in array');
  171.     writeln(' 10 <= n <= ',Max_N:5);
  172.     write('?');
  173.     readln(N);
  174.     good# := (n > 9) AND (n <= Max_N - 1);
  175.   until good#;
  176.  
  177.   writeln;
  178.   writeln('Please stand by while I set up.');
  179.   FOR i := 1 TO n DO
  180.     BEGIN
  181.       A[i] := random#n;
  182.       if (i mod 1000 = 0) then write(i);
  183.     END;
  184.   writeln;
  185.   write('random array filled : do you want to see it ?');
  186.   readq(answer);
  187.   writeln;
  188.   IF answer IN ['y','Y'] then show;
  189.   writeln;
  190.   WRITE('Press return when ready to start');
  191.   readq(answer);
  192.   writeln;
  193.   write( CHR(7), 'START @ ');
  194.   time(timestring);
  195.   write(timestring,' ');
  196.   popstats(A,1,N,parameters);
  197.   time(timestring);
  198.   writeln( CHR(7), 'DONE @ ' ,timestring);
  199.   WITH parameters DO 
  200.     BEGIN
  201.      writeln;
  202.      IF success
  203.       THEN BEGIN
  204.         writeln('range   := ',range[1]:8:4,' to',range[2]:8:4);
  205.         writeln('median             := ',middle:8:4);
  206.         writeln('S.E. of median     := ',semedian:8:4);
  207.         writeln('mode               := ',mostfreq :8:4);
  208.         writeln('mean               := ',mean :8:4);
  209.         writeln('variance           := ',variance :8:4);
  210.         writeln('standard deviation := ',stddevtn :8:4);
  211.         writeln('S.E. of the mean   := ',stderrmn :8:4);
  212.         writeln('index of skewness  := ',skewness:8:4);
  213.         writeln('S.E.  of skewness  := ',seskewns:8:4);
  214.         writeln('index of kurtosis  := ',kurtosis:8:4);
  215.         writeln('S.E.  of kurtosis  := ',sekurtss:8:4);
  216.         writeln;
  217.         END
  218.        ELSE BEGIN
  219.         writeln('SHIT!');
  220.         END;
  221.     END;
  222.   write('Print the array (Y/N)?');
  223.   readq(answer);
  224.   writeln;
  225.   If (answer='Y') or (answer='y') then Show;
  226.   readq(answer);
  227.  UNTIL control_c;
  228. END.
  229.