home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PI40A.ZIP / PI.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1988-02-05  |  9.5 KB  |  373 lines
  1. {$R+,S+,I+,D+,T-,F-,V+,B+,N-,L+ }
  2. { PROGRAM PI1.PAS }
  3.  
  4.  
  5. Uses
  6.   Crt,Dos,Qwik,Wndwvars,Wndw;
  7.  
  8. VAR
  9.   B,C,V,P1,S,K,N,I,J,Q,M,M1,X,R,D,
  10.   significant_digits              : INTEGER;
  11.   P,A,T                           : ARRAY[0..5000] OF INTEGER;
  12.   TI                              : STRING[20];
  13.   chr                             : Char;
  14.   Tim                             : String;
  15.  
  16. CONST
  17.   F1=5;
  18.   F2=239;
  19.   DirectVideo=True;
  20.   CheckSnow=False;
  21.   CheckBreak=True;
  22.  
  23. type
  24.   OnOrOff = (On,Off);
  25. var
  26.   start, time : real;
  27.  
  28. procedure info;
  29. Begin
  30.   SetWindowModes(ShadowRight+Zoommode);
  31.   MakeWindow(4,9,15,61,White+BlueBG,Blue+LightGrayBG,HdoubleBrdr,Window1);
  32.   TitleWindow(Top,Left,'Info for PI.exe');
  33.   AccessWindow(Window1);
  34.   Window(5,10,14,60);
  35.   writeln('Sieve of Eratosthenes');
  36.   writeln;
  37.   writeln('Modified for Turbo Pascal 4.0 by');
  38.   writeln;
  39.   writeln('                Lord Thantos Wyvern');
  40.   writeln;
  41.   writeln('With help from: Ian Samson, Kaptain Krash, Tarin Bul,');
  42.   writeln('                Glenn Lee, and others!');
  43.   Writeln;
  44.   writeln('Press enter to continue');
  45.   Readln(chr);
  46.   Window(0,0,80,25);
  47.   RemoveWindow;
  48. End;
  49.  
  50. procedure timer(O : OnOrOff);
  51.  
  52. var
  53.   recpack          : Registers;
  54.   hour,min,sec,hun : integer;
  55. begin
  56.   with recpack do
  57.   begin
  58.     ax := $2C shl 8;
  59.   end;
  60.   intr($21,Dos.Registers(recpack));                     {call interrupt}
  61.   with recpack do
  62.   begin
  63.     hour := cx shr 8;
  64.     min  := cx and $FF;
  65.     sec  := dx shr 8;
  66.     hun  := dx and $FF;
  67.   end;
  68.   if O = On then
  69.     begin
  70.       start := hour * 3600 + min * 60 + sec + hun/100;
  71.       time := 0;
  72.     end
  73.   else
  74.     begin
  75.       time := hour * 3600 + min * 60 + sec + hun/100 - start;
  76.       start := 0;
  77.     end;
  78. end;
  79.  
  80.  
  81. PROCEDURE DIVIDE(D:INTEGER);
  82. BEGIN
  83.   R := 0;
  84.   FOR J := 0 TO M DO
  85.     BEGIN
  86.       V :=  R*10+P[J];
  87.       Q := V DIV D;
  88.       R := V MOD D;
  89.       P[J] := Q;
  90.     END;
  91. END;
  92.  
  93.  
  94. PROCEDURE DIVIDEA(D:INTEGER);
  95.   BEGIN
  96.     R := 0;
  97.     FOR J := 0 TO M DO
  98.       BEGIN
  99.         V :=  R*10+A[J];
  100.         Q := V DIV D;
  101.         R := V MOD D;
  102.         A[J] := Q;
  103.       END;
  104.  END;
  105.  
  106.  
  107. PROCEDURE SUBT;
  108. BEGIN
  109.   B := 0;
  110.   FOR J := M DOWNTO 0 DO
  111.       IF T[J]>=A[J]  THEN T[J] := T[J]-A[J] ELSE
  112.         BEGIN
  113.           T[J] := 10+T[J]-A[J];
  114.           T[J-1] := T[J-1]-1;
  115.         END;
  116.   FOR J := 0 TO M DO
  117.       A[J] := T[J];
  118. END;
  119.  
  120.  
  121. PROCEDURE SUBA;
  122. BEGIN
  123.   FOR J := M DOWNTO 0 DO
  124.       IF P[J]>=A[J]  THEN P[J] := P[J]-A[J] ELSE
  125.         BEGIN
  126.           P[J] := 10+P[J]-A[J];
  127.           P[J-1] := P[J-1]-1;
  128.         END;
  129.   FOR J :=  M DOWNTO 0 DO
  130.       A[J] := P[J];
  131. END;
  132.  
  133.  
  134. PROCEDURE CLEARP;
  135. BEGIN
  136.   FOR J := 0 TO M DO
  137.   P[J] := 0;
  138. END;
  139.  
  140.  
  141. PROCEDURE ADJUST;
  142. BEGIN
  143.   P[0] := 3;
  144.   P[M] := 10;
  145.   FOR J := 1 TO M-1 DO
  146.       P[J] := 9;
  147. END;
  148.  
  149. PROCEDURE ADJUST2;
  150. BEGIN
  151.   P[0] := 0;
  152.   P[M] := 10;
  153.   FOR J := 1 TO M-1 DO
  154.       P[J] := 9;
  155. END;
  156.  
  157. PROCEDURE MULT4;
  158. BEGIN
  159.   C := 0;
  160.   FOR J := M DOWNTO 0 DO
  161.     BEGIN
  162.       P1 := 4*A[J]+C;
  163.       A[J] := P1 MOD 10;
  164.  
  165.       C := P1 DIV 10;
  166.       END;
  167. END;
  168.  
  169. PROCEDURE SAVEA;
  170. BEGIN
  171.   FOR J := 0 TO M DO
  172.       T[J] := A[J];
  173. END;
  174.  
  175. PROCEDURE TERM1;
  176. BEGIN
  177.   I := M+M+1;
  178.   A[0] := 4;
  179.   DIVIDEA(I*25);
  180.   WHILE I>3 DO
  181.     BEGIN
  182.       I := I-2;
  183.       CLEARP;
  184.       P[0] := 4;
  185.       DIVIDE(I);
  186.       SUBA;
  187.       DIVIDEA(25);
  188.     END;
  189.   CLEARP;
  190.   ADJUST;
  191.   SUBA;
  192.   DIVIDEA(5);
  193.   SAVEA;
  194. END;
  195.  
  196.  
  197. PROCEDURE TERM2;
  198. BEGIN
  199.   I := M+M+1;
  200.   A[0] := 1;
  201.   DIVIDEA(I);
  202.   DIVIDEA(239);
  203.   DIVIDEA(239);
  204.   WHILE I>3 DO
  205.     BEGIN
  206.       I := I-2;
  207.       CLEARP;
  208.       P[0] := 1;
  209.       DIVIDE(I);
  210.       SUBA;
  211.       DIVIDEA(239);
  212.       DIVIDEA(239);
  213.     END;
  214.   CLEARP;
  215.   ADJUST2;
  216.   SUBA;
  217.   DIVIDEA(239);
  218.   SUBT;
  219. END;
  220.  
  221. procedure header;
  222. begin
  223.   CLRSCR;
  224.   WRITELN('                        The Computation Of PI');
  225.   Writeln('                        --- ----------- -- --');
  226. end;
  227.  
  228. procedure mainmenu;
  229.           begin
  230.  
  231.                SetWindowModes(ShadowRight+Zoommode);
  232.                MakeWindow(5,9,11,65,White+BlueBG,Blue+LightGrayBG,DoubleBrdr,Window2);
  233.                TitleWindow(Bottom,Center,'Main Menu');
  234.                Window(10,6,64,14);
  235.                QwriteC(6,1,CRTcols,-1,'Please choose one of the following:');
  236.                GotoXY(16,3);
  237.                Writeln('1)  Information about this program');
  238.                GotoXY(16,4);
  239.                Writeln('2)  Begin the program');
  240.                GotoXY(16,5);
  241.                Read(chr);
  242.                If chr = '1' then
  243.                                  begin
  244.                                       ClrScr;
  245.                                       info;
  246.                                  end;
  247.                RemoveWindow;
  248.                Window(0,0,80,25);
  249.           End;
  250.  
  251.  
  252. {MAIN PROGRAM}
  253.  
  254. BEGIN
  255.   InitWindow(LightGray+BlueBG,True);
  256.   mainmenu;
  257.   MakeWindow(5,10,7,60,White+BlueBG,LightBlue+LightGrayBG,MhatchBrdr,Window3);
  258.   TitleWindow(Top,Center,'Input Phase!');
  259.   Window(11,6,59,13);
  260.   QwriteC(6,1,CRTcols,-1,'Input no. of decimal places you require:');
  261.   GotoXY(8,2);
  262.   Readln(significant_digits);
  263.   RemoveWindow;
  264.   Window(0,0,80,25);
  265.   m1 := significant_digits;
  266.   M := m1+4;
  267.   MakeWindow(5,10,6,60,White+BlueBG,White+RedBG,LhatchBrdr,Window5);
  268.   Window(11,6,59,6);
  269.   QWriteC(7,1,CRTcols,-1,'Working...  Working...  Working...');
  270.   Window(0,0,80,25);
  271.   FOR J := 0 TO M  DO
  272.     BEGIN
  273.       A[J] := 0;
  274.       T[J] := 0;
  275.     END;
  276.   timer(on);
  277.   TERM1;
  278.   TERM2;
  279.   MULT4;
  280.   timer(off);
  281.   RemoveWindow;
  282.   MakeWindow(4,5,15,65,White+BlueBG,LightBlue+LightGrayBG,HhatchBrdr,Window4);
  283.   TitleWindow(Top,Center,'Computation of PI');
  284.   Window(6,5,64,18);
  285.   wRITE('PI = 3.');
  286.   FOR J := 1 TO M1   DO
  287.       BEGIN
  288.            WRITE(A[J]);
  289.            IF J MOD 5 =0 THEN WRITE(' ');
  290.            IF J MOD 40=0 THEN
  291.               Begin
  292.                    Writeln;
  293.                    Write('       ');
  294.               End;
  295.       END;
  296.   WRITELN;
  297.   WRITELN;
  298.   str(TIME:6:2,Tim);
  299.   QwriteC(16,6,64,-1,'Elapsed time = '+Tim+' seconds');
  300.   writeln;
  301.   QwriteC(17,6,64,-1,'Sieve of Eratosthenes');
  302.   Window(0,0,80,25);
  303. End.
  304.  
  305.  
  306. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
  307. (*         Sieve for TURBO PASCAL V2.0 + 3.0  MS-DOS                     *)
  308. (*         Adapted for TURBO PASCAL by:                                  *)
  309. (*                Daniel E. Salo (74036,2347)                            *)
  310. (*                Date: 06/30/85                                         *)
  311. (*                                                                       *)
  312. (*         Sieve of Eratosthenes is a popular benchmark program          *)
  313. (*         based on a BYTE magazine article by Jim Gilbreath             *)
  314. (*         used for comparing relative speed of CPU and compilers.       *)
  315. (*                                                                       *)
  316. (*         Does 10 iterations of all prime numbers between 1-8191.       *)
  317. (*                                                                       *)
  318. (*         May be adapted to non MS-DOS systems by removing              *)
  319. (*         Procedure Time which does DOS calls.                          *)
  320. (*                                                                       *)
  321. (*                                                                       *)
  322. (*         IBM-PC timings    (IBM-PC, 640k, 10meg HD,DOS 2.1)            *)
  323. (*                                                                       *)
  324. (*             TURBO PASCAL v2.00B  18.23 seconds                        *)
  325. (*                          v3.01A  16.64 seconds                        *)
  326. (*                                                                       *)
  327. (*             includes approx .12 secs of housekeeping overhead         *)
  328. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
  329. END.
  330.  
  331.  
  332. {                      PROGRAM PI1.PAS
  333.                         SEPT 2, 1985
  334.  ( IMPROVED VERSION OF PI.PAS WHICH WAS SLOW AND HAD  SOME ERRORS )
  335.  
  336. THIS PROGRAM COMPUTES THE DIGITS OF PI USING THE ARCTANGENT FORMULA
  337. (1)            PI/4 = 4 ARCTAN 1/5 - ARCTAN 1/239
  338. IN CONJUNCTION WITH THE GREGORY SERIES
  339.  
  340. (2)   ARCTAN X = SUM  (-1)^N*(2N + 1)^-1*X^(2N+1)  N=0 TO  INFINITY.
  341.  
  342. SUBSTITUTING INTO (2) A FEW VALUES OF N  AND NESTING  WE HAVE,
  343.  
  344. PI/4 =  1/5[4/1 + 1/25[-4/3 + 1/25[4/5 + 1/25[-4/7 + ...].].]
  345.  
  346.     - 1/239[1/1 + 1/239^2[-1/3 + 1/239^2[1/5 + 1/239^2[-1/7 +...].].]
  347.  
  348. USING THE LONG DIVISION ALGORITHM, THIS ( NESTED ) INFINITE SERIES CAN BE
  349. USED TO CALCULATE PI TO A LARGE NUMBER OF DECIMAL PLACES IN A REASONABLE
  350. AMOUNT OF TIME. A TIME FUNCTION IS INCLUDED TO SHOW HOW SLOW THINGS
  351. GET WHEN N IS LARGE. IMPROVEMENTS CAN BE MADE BY CHANGING THE SIZE OF
  352. THE ARRAY ELEMENTS HOWEVER IT GETS A BIT TRICKY.
  353.  
  354. A LITTLE HISTORY
  355. ----------------
  356.  
  357. IN AUGUST, 1949, PROFESSOR JOHN VON NEUMANN USED THIS FORMULA TO
  358. CALCULATE PI TO OVER 2000 DECIMAL PLACES ON THE  ENIAC  COMPUTER.
  359. THE CALCULATION WAS COMPLETED OVER THE LABOR DAY WEEKEND WITH THE
  360. COMBINED EFFORTS OF FOUR ENIAC STAFF MEMBERS EACH WORKING EIGHT-HOUR
  361. SHIFTS TO ENSURE CONTINUOUS OPERATION OF THE ENIAC.
  362.  
  363. SOME YEARS AGO I REQUESTED INFORMATION ON PI FROM THE ENCYCLOPEDIA
  364. BRITANNICA RESEARCH SERVICE. I RECEIVED A REPORT GIVING THE ABOVE
  365. HISTORICAL ACCOUNT PLUS A LISTING OF THE 2000 DIGITS.
  366.  
  367. IT WAS THIS LISTING THAT ENABLED ME TO CHECK THE PROGRAM AND KEEP
  368. MY SANITY.
  369.  
  370.                         HAVE FUN
  371.                         CINO HILLIARD
  372.                         [72756,672]   }
  373.