home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 2 / FFMCD02.bin / new / dev / misc / p2c / examples / e.p < prev    next >
Text File  |  1993-12-21  |  2KB  |  132 lines
  1.  
  2. $partial_eval on$
  3.  
  4. program e(input,output);
  5.  
  6. const
  7.    NDIGITS = 1007;
  8.    NPRINT = 1000;
  9.  
  10. type
  11.    digit = 0..255;
  12.    digitarray = packed array [0..NDIGITS] of digit;
  13.  
  14. var
  15.    s,x,t: ^digitarray;
  16.    xs,ts: integer;
  17.    i: integer;
  18.  
  19. procedure initinteger(var x:digitarray; n:integer);
  20. var
  21.    i: integer;
  22. begin
  23.    x[0] := n;
  24.    for i := 1 to NDIGITS do x[i] := 0;
  25. end;
  26.  
  27. procedure divide(var x:digitarray; xs,n:integer;
  28.                  var y:digitarray; var ys:integer);
  29. var
  30.    i: integer;
  31.    c: integer;
  32. begin
  33.    c := 0;
  34.    for i := xs to NDIGITS do begin
  35.       c := 10*c + x[i];
  36.       y[i] := c div n;
  37.       c := c mod n;
  38.    end;
  39.    ys := xs;
  40.    while (ys <= NDIGITS) and (y[ys] = 0) do ys := ys+1;
  41. end;
  42.  
  43. procedure add(var s,x:digitarray; xs:integer);
  44. var
  45.    i: integer;
  46.    c: integer;
  47. begin
  48.    c := 0;
  49.    for i := NDIGITS downto xs do begin
  50.       c := s[i] + x[i] + c;
  51.       if c >= 10 then begin
  52.          s[i] := c - 10;
  53.          c := 1;
  54.       end else begin
  55.          s[i] := c;
  56.          c := 0;
  57.       end;
  58.    end;
  59.    i := xs;
  60.    while c <> 0 do begin
  61.       i := i-1;
  62.       c := s[i] + c;
  63.       if c >= 10 then begin
  64.          s[i] := c - 10;
  65.          c := 1;
  66.       end else begin
  67.          s[i] := c;
  68.          c := 0;
  69.       end;
  70.    end;
  71. end;
  72.  
  73. procedure sub(var s,x:digitarray; xs:integer);
  74. var
  75.    i: integer;
  76.    c: integer;
  77. begin
  78.    c := 0;
  79.    for i := NDIGITS downto xs do begin
  80.       c := s[i] - x[i] + c;
  81.       if c < 0 then begin
  82.          s[i] := c + 10;
  83.          c := -1;
  84.       end else begin
  85.          s[i] := c;
  86.          c := 0;
  87.       end;
  88.    end;
  89.    i := xs;
  90.    while c <> 0 do begin
  91.       i := i-1;
  92.       c := s[i] + c;
  93.       if c < 0 then begin
  94.          s[i] := c + 10;
  95.          c := -1;
  96.       end else begin
  97.          s[i] := c;
  98.          c := 0;
  99.       end;
  100.    end;
  101. end;
  102.  
  103. begin
  104.    new(s); new(x);
  105.    initinteger(s^,0);
  106.    initinteger(x^,1);
  107.    xs := 0;
  108.    add(s^,x^,xs);
  109.    i := 0;
  110.    repeat
  111.       i := i+1;
  112.       divide(x^,xs,i,x^,xs);
  113.       add(s^,x^,xs);
  114.       write(#M'Series: ',100*xs/(NDIGITS+1):5:2,'%');
  115.    until xs > NDIGITS;
  116.    writeln;
  117.    writeln('':45,'e = ',s^[0]:1,'.');
  118.    i := 0;
  119.    for i := 1 to NPRINT do begin
  120.       write(s^[i]:1);
  121.       if i mod 1000 = 0 then writeln;
  122.       if i mod 100 = 0 then writeln
  123.       else if i mod 10 = 0 then write(' ');
  124.    end;
  125.    writeln;
  126.    write('Final digits: ');
  127.    for i := NPRINT+1 to NDIGITS do begin
  128.       write(s^[i]:1);
  129.    end;
  130.    writeln;
  131. end.
  132.