1:

ergebnis := Power(16, k);					

1:
2:
3:
4:
5:

MyPi:=0;
for k:=0 to 100 do
begin
  MyPi:=MyPi + 1/Power(16, k) * ( (0.5*k+1) - (0.25*k + 4) - (0.125*k+5) - (0.125*k+6) ) 
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:

program Project1;

{$APPTYPE CONSOLE}

Uses
    SysUtils,
    Math;

function series (m, id: Integer) : Extended ;forward;
procedure ihex (x: Extended; m: Integer; var chx: String);  forward;
Function expm (p, ak: Extended ): Extended ;forward;

const
NHX= 16;
eps =1e-17;
ntp= 25;

var
  tp: array [0..ntp-1] of Extended ;
  tp1 : Integer= 0;

procedure main;
var
   pid, s1, s2, s3, s4: Extended;
  id: integer;
  chx : String;
begin
  while ( True ) do begin
      WriteLn(#13#10'Pi hex digit computation: enter position (enter 0 to quit)'#13#10);
      ReadLn(id);
      if ( id < 0 ) Then break;

      if ( id >= 10000000 ) Then begin
    WriteLn('Warning: program not reliable for such a large position.'#13#10);
      end;

      s1 := series (1, id);
      s2 := series (4, id);
      s3 := series (5, id);
      s4 := series (6, id);
      pid := 4 * s1 - 2 * s2 - s3 - s4;
      pid := Frac(pid);
      if (pid < 0.0) Then pid := pid + 1.0;
      chx := '';
      ihex (pid, NHX, chx);
      WriteLn (Format(' position = %d'#13#10' fraction = %.15f '#13#10' hex digits =  %10.10s'#13#10,
        [id, pid, chx]));
  end;
end;

procedure ihex (x: Extended; m: Integer; var chx: String); 
const
  hx = '0123456789ABCDEF';
var
  i: Integer;
  y: Extended;
begin
  y := abs (x);
  for i := 0 to nhx -1 do begin
    y := 16 * Frac(y);
    chx := chx + hx[1+Trunc(y)];
  end;
end;

function series (m, id: Integer) : Extended ;
var
  k: Integer;
  ak, p, s, t: Extended;
begin

  s := 0.;

  for k := 0 to id - 1 do begin
    ak := 8 * k + m;
    p := id - k;
    t := expm (p, ak);
    s := frac(s + t / ak);
  end;

  for k := id to id + 100 do begin
    ak := 8 * k + m;
    t := power (16., (id - k)) / ak;
    if (t < eps) Then 
        break;
    s := Frac(s + t);
  end;
  Result := s;
end;

Function expm (p, ak: Extended ): Extended ;
var
  i, j: integer;
  p1, pt, r: Extended;

begin

  if (tp1 = 0) then begin
    tp1 := 1;
    tp[0] := 1.;

    for i := 1 to ntp - 1 do tp[i] := 2. * tp[i-1];
  end;

  if (ak = 1) then Begin
    Result := 0.;
    Exit;
  end;

  I := ntp - 1;
  While (tp[i] > p) do
    Dec(I);

  pt := tp[i];
  p1 := p;
  r := 1.;

  for j := 1 to i do begin
    if (p1 >= pt) then begin
      r := 16. * r;
      r := r - Trunc (r / ak) * ak;
      p1 := p1 - pt;
    end;
    pt := 0.5 * pt;
    if (pt >= 1) Then begin
      r := r * r;
      r := r - Trunc (r / ak) * ak;
    end;
  end;

  Result := r;
end;

begin
    main;
end.