fpc/tests/bench/pi.pp

program pi;

{$ifdef fpc}
{$mode objfpc}
{$endif fpc}

{$APPTYPE CONSOLE}

{$h+}

uses
  timer;

function ComputePi(NumDigits: Integer): string;
var
  A: array of LongInt;
  I, J, K, P, Q, X, Nines, Predigit: Integer;
  PiLength: Integer;
begin
  start;
  SetLength(A, 10*NumDigits div 3);
  SetLength(Result, NumDigits+1);
  PiLength := 1;
  for I := Low(A) to High(A) do
    A[I] := 2;
  Nines := 0;
  Predigit := 0;
  for J := 0 to NumDigits-1 do
  begin
    Q := 0;
    P := 2 * High(A) + 1;
    for I := High(A) downto Low(A) do
    begin
      X := 10*A[I] + Q*(I+1);
      A[I] := X mod P;
      Q := X div P;
      P := P - 2;
    end;
    A[Low(A)] := Q mod 10;
    Q := Q div 10;
    if Q = 9 then
      Inc(Nines)
    else if Q = 10 then
    begin
      Result[PiLength] := Chr(Predigit + 1 + Ord('0'));
      for K := 1 to Nines do
        Result[PiLength+K] := '0';
      PiLength := PiLength + Nines + 1;
      Predigit := 0;
      Nines := 0;
    end
    else
    begin
      Result[PiLength] := Chr(Predigit + Ord('0'));
      Predigit := Q;
      for K := 1 to Nines do
        Result[PiLength+K] := '9';
      PiLength := PiLength + Nines + 1;
      Nines := 0;
    end;
  end;
  Result[PiLength] := Chr(Predigit + Ord('0'));
  stop;
end;

var
  NumDigits: Integer;
  Code: Integer;
  F: TextFile;
  result : string;
begin
  if ParamCount = 0 then
    WriteLn('usage: pi #DIGITS [FILE]')
  else
  begin
    Val(ParamStr(1), NumDigits, Code);
    if Code <> 0 then
    begin
      WriteLn('Invalid # digits: ', ParamStr(1));
      Halt(1);
    end;

    if ParamCount > 1 then
    begin
      AssignFile(F, ParamStr(2));
      Rewrite(F);
      WriteLn(F, ComputePi(NumDigits));
      CloseFile(F);
    end
    else
      begin
        result:=ComputePi(NumDigits);
        WriteLn(result);
      end;
  end;
end.