1:
2:

Carry:= Sum div NUMBER_BASE;
Dig:= Sum mod NUMBER_BASE;                    

1:

   1826000 it    756082 dig       20260.0 s                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:

  for p:= 0 to high(Summand) do 
    begin
    Sum:= Carry + Number[p] + Summand[p];
//  DivMod(Sum, NUMBER_BASE, Carry, Dig); ersatz   
    Carry := 0;
    IF  SUM >= NUMBER_BASE then
      begin
      dec(sum,NUMBER_BASE);      
      Carry := 1;
      end;
    Number[p]:= Sum;
  end;                    

1:
2:
3:
4:
5:

60112339269111851140389301806586681291351507449752782263142146284398312681631144
80513403906695460975689940797209307853656534423943491142030348495051500816735422
60147073619478325530666484993268957414968737533136622157990802952584506637311513

    241389 it    100000 dig    269.473066 s                    

1:
2:
3:
4:
5:

60112339269111851140389301806586681291351507449752782263142146284398312681631144
80513403906695460975689940797209307853656534423943491142030348495051500816735422
60147073619478325530666484993268957414968737533136622157990802952584506637311513

    241389 it    100000 dig    167.871914 s                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:

Zahl/Sum  123456
Kopie     123 
ich summiere dann in die Zahl 
Zahl[1]=Zahl[1]+Zahl[6]
Zahl[2]=Zahl[2]+Zahl[5]
Zahl[3]=Zahl[3]+Zahl[4]
jetzt bei der Hälfte 
Zahl[4]=Zahl[4]+Kopie[3]
Zahl[5]=Zahl[5]+Kopie[2]
Zahl[6]=Zahl[6]+Kopie[1]                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:

Startzahl: 196
Iteration   maximale Anzahl der Vergleiche auf Palindrom
         1   1
         6   2
        13   3
        16   4
        25   5
        70   8
       105  12
      1237  13
      1430  14
      3461  16
      3940  17
      9777  29
    429911  31
=
    483101 it    200000 dig 1.00391500000000E+003 s                    

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:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:

{{$APPTYPE console}
program p196;
{$IFDEF FPC}
  {$MODE DELPHI}
  {$Optimization ON}
  {$Optimization RegVar}
  {$Optimization PEEPHOLE}
  {$Optimization CSE}
  {$Optimization ASMCSE}
{$Endif}

uses
  SysUtils;

const
  NUMBER_BASE = 10;
type
  TDigit = Byte;
  TSumCar = record
              s,c : byte;
            end;
  TSumCarFeld = array[0..19] of TsumCar;          
  TNumber = array of TDigit;                                // Rückwärts! Niederwertigste Stelle ist [0]
const  
  SumCarFeld : TSumCarFeld =((s:0;c:0),(s:1;c:0),(s:2;c:0),(s:3;c:0),(s:4;c:0),
                             (s:5;c:0),(s:6;c:0),(s:7;c:0),(s:8;c:0),(s:9;c:0),
                             (s:0;c:1),(s:1;c:1),(s:2;c:1),(s:3;c:1),(s:4;c:1),
                             (s:5;c:1),(s:6;c:1),(s:7;c:1),(s:8;c:1),(s:9;c:1));
var
  MaxIndex : integer;
  Cycle: Cardinal;
  
procedure NumberFromString(var Number: TNumber; Str: string);
var
  i: integer;
begin
  SetLength(Number, Length(Str));
  for i:= 0 to Length(Str) - 1 do
    Number[i]:= Ord(Str[Length(Str) - i]) - Ord('0');
end;

function NumberToString(var Number: TNumber): string;
var
  i: integer;
begin
  SetLength(Result, Length(Number));
  for i:= 0 to High(Number) do
    Result[Length(Result) - i]:= Chr(Ord('0') + Number[i]);
end;

procedure NumberAdd(var Number, Summand: TNumber);
var
  pb1,pB2 : pByte;
  p: integer;
  Carry: integer;
begin
  Carry:= 0;
  pb1 := @Number[0]; 
  pb2 := @Summand[0]; 
  for p:=  high(Summand) downto 0 do 
    begin
//  DivMod(Sum, NUMBER_BASE, Carry, Dig);    
    With SumCarFeld[Carry + pb1^ + pb2^] do
      begin
      inc(pb2);
      pb1^ := s;
      inc(pb1);        
      Carry := c;
      end;
  end;
  
  IF Carry = 1 then
    begin
    p := Length(Summand)+1;
    setlength(Summand, p);
    SetLength(Number, p);
    Number[p-1] :=1;
    end;
end;

procedure NumberReverse(var Reversed, Number: TNumber);
var
  i: integer;
begin
  SetLength(Reversed, Length(Number));
  for i:= 0 to high(Number) do
    Reversed[high(Reversed) - i]:= Number[i];
end;

function NumberCompare(var A, B: TNumber): boolean;
begin
  Result:= (high(A) = high(B)) and
    CompareMem(@A[0], @B[0], Length(A));
end;

function NumberCompareB(var A: TNumber): boolean;
var 
  i,j: integer;
begin
  i := Low(A);
  j := High(A);
  repeat
    Result:= A[i]=A[j];
    inc(i);
    dec(j);
  until Not(Result) OR (J<I); 
  IF  MaxIndex <i then
    begin
     MaxIndex := i;
     writeln(cycle:10,i:4)
     end;
end;

var
  Work, Rev: TNumber;

  Time1, Time2 : TDateTime;
  s: string;
begin
  repeat
    Write('Startzahl: ');
    ReadLn(s);
    if s='' then
      break;
    NumberFromString(Work, s);
    Cycle:= 0; // das erste ist kein cycle...
    Time1 := time;
    NumberReverse(Rev, Work);
    repeat
      NumberAdd(Work, Rev);
      NumberReverse(Rev, Work);
      inc(Cycle);
      //Keine Ausgabe !
      if Cycle AND cardinal(-1) = 0 then 
        begin
        Time2 := time;
        WriteLn(Cycle:10,' it',Length(Work):10,' dig',(Time2-Time1)*86400.0:14:1,' s');
        end;
    until NumberCompareB(REv) OR (Length(Work)>99999);
    Time2 := time;
    WriteLn('=');
    WriteLn(NumberToString(Work));
    WriteLn(Cycle:10,' it',Length(Work):10,' dig',(Time2-Time1)*86400.0,' s');

    WriteLn;
    WriteLn;
    WriteLn;
  until false;
end.
{
Startzahl: 196
         1   1
         6   2
        13   3
        16   4
        25   5
        70   8
       105  12
      1237  13
      1430  14
      3461  16
      3940  17
      9777  29
    429911  31
=
    483101 it    200000 dig 1.00391500000000E+003 s
NoteBook:
Vorher: NumberAdd
    241389 it    100000 dig 2.53229000000001E+002 s
Nachher: NumberAdd mit Pointerarithmetik
    241389 it    100000 dig 1.27149000000000E+002 s                    

1:
2:
3:
4:
5:

if checkbox1.checked then begin
  k:='';
  for i:=0 to laenge-1 do k:=chr(z[i]+48)+k;
  memo1.lines.add(inttostr(anz)+#9+k+' ('+inttostr(laenge)+')');
end;                    

1:
2:
3:
4:

k:='';
for i:=0 to laenge-1 do k:=chr(z[i]+48)+k;
if checkbox1.checked then
  memo1.lines.add(inttostr(anz)+#9+k+' ('+inttostr(laenge)+')');                    

1:
2:
3:
4:

      if Cycle >= 100000 then
        break;
statt
until NumberCompareB(REv)or (Length(Work)>99999);                    

1:
2:
3:

....086914228293595882210473480636969512153155697087

    603567 it    250000 dig 5.92248000000005E+002 s                    

1:
2:
3:

=
    241389 it    100000 dig    293.801473 s
1316113735615475349297100 ... 5799080295258450663731151                    

1:

    603567 it    250000 dig 3.23028000000001E+002 s                    

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:

procedure NumberAdd_1Feld(var Number: TNumber);
var
  pb1,pB2 : pByte;
  p: integer;
  Carry: integer;
begin
  // LenghtNum und LengthRev sind globale Variable, wie die Felder auch
  // MIst, die Übergabe hätte ich mir sparen können
  pb2 := @Number[LengthNum-1];
  pb1 := @Number[0]; 
  Move(Number[0],Rev[0],LengthRev);
  Carry:= 0;

  for p:=  LengthRev-1  downto 0 do 
    begin
    With SumCarFeld[Carry + pb1^ + pb2^] do
      begin
      dec(pb2);
      pb1^ := s;
      inc(pb1);        
      Carry := c;
      end;
  end;

  //mittlere Zahl auf sich selbst addieren
  IF ODD(LengthNum) then
    begin
    With SumCarFeld[Carry + pb1^ + pb1^] do
      begin
      pb1^ := s;
      inc(pb1);        
      Carry := c;
      end;
    end;

  pb2 := @rev[LengthRev-1];
  for p:=  LengthRev-1  downto 0 do 
    begin
    With SumCarFeld[Carry + pb1^ + pb2^] do
      begin
 //     writeln(pb1^:3,'+',pb2^:3,'+',c);      
      dec(pb2);
      pb1^ := s;
//  writeln('Num ',NumberToString  (Number));

      inc(pb1);        
      Carry := c;
      end;
  end;
  //Korrektur der Laenge
 IF Carry = 1 then
    begin
    inc(LengthNum);
    SetLength(Number, LengthNum);
    Number[LengthNum-1] :=1;
    IF NOT(ODD(LengthNum)) then
       begin
       inc(LengthRev);
       SetLength(Rev, LengthRev);
       end;
    end;
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:

procedure TForm1.Button1Click(Sender: TObject);
const zmax:integer=999;
var k:string;
    i,anz,laenge:integer;
    gefunden:boolean;
    z,e:array of byte;
    Time1, Time2, Freq: Int64;
begin
    if abbruch=false then begin abbruch:=true; exit end;
    button1.caption:='Abbruch';
    label3.caption:='';
    abbruch:=false;
    memo1.clear;
    application.processmessages;

    zmax:=strtoint(edit2.text);
    if zmax<100 then zmax:=100;

    setlength(z,zmax+2);
    setlength(e,zmax+2);
    for i:=0 to zmax do begin z[i]:=0; e[i]:=0 end;
    k:=edit1.text;
    if k='' then k:='196';
    laenge:=length(k);
    for i:=laenge downto 1 do z[laenge-i]:=ord(k[i])-48;
    anz:=0;

    QueryPerformanceFrequency(Freq);
    QueryPerformanceCounter(Time1);

    repeat
      inc(anz);
      if checkbox1.checked then begin
        k:='';
        if laenge>50 then
        begin
          for i:=0 to 25 do k:=chr(z[i]+48)+k;
          k:=' ... '+k;
          for i:=laenge-26 to laenge-1 do k:=chr(z[i]+48)+k;
        end
        else
          for i:=0 to laenge-1 do k:=chr(z[i]+48)+k;
        memo1.lines.add(inttostr(anz)+#9+k+' ('+inttostr(laenge)+')');
      end;

      for i:=0 to laenge-1 do
        e[i]:=z[i]+z[laenge-1-i];
      for i:=0 to laenge-1 do begin
        if e[i]>9 then begin
          inc(e[i+1]);
          dec(e[i],10);
        end;
      end;
      if e[laenge]>0 then inc(laenge);

      gefunden:=true;
      i:=0;
      repeat
        if e[i]<>e[laenge-1-i] then gefunden:=false;
        inc(i);
      until (not gefunden) or (i>laenge div 2);

      if gefunden then
      begin
        memo1.lines.add('Palindrom gefunden im Schritt '+inttostr(anz));
        k:='';
        for i:=0 to laenge-1 do k:=chr(e[i]+48)+k;
        memo1.lines.add(k);
      end
      else
        z:=copy(e,0,laenge);

      if anz mod 1000 = 0 then begin
        label4.caption:=inttostr(laenge);
        QueryPerformanceCounter(Time2);
        label6.caption:=inttostr(anz)+' Zyklen | '+floattostrf((Time2-Time1)/freq,ffgeneral,10,6)+' s';
        application.processmessages;
      end;
    until abbruch or gefunden or (laenge>zmax);

    label4.caption:=inttostr(laenge);
    QueryPerformanceCounter(Time2);
    label6.caption:=inttostr(anz)+' Zyklen | '+floattostrf((Time2-Time1)/freq,ffgeneral,10,6)+' s';
    if abbruch or (laenge>zmax) then
    begin
      memo1.lines.add('Folgenglied im Schritt '+inttostr(anz));
      memo1.lines.add('Länge '+inttostr(laenge));
      k:='';
      for i:=0 to 25 do k:=chr(z[i]+48)+k;
      k:=' ... '+k;
      for i:=laenge-26 to laenge-1 do k:=chr(z[i]+48)+k;
      memo1.lines.add(k);
    end;
    button1.caption:='Berechnung';
    abbruch:=true;
    setlength(z,0);
    setlength(e,0);
end;                    

1:
2:
3:
4:
5:

     48150 it     20000 dig      4.571300 s
1991208502591586282902869 ... 0206730937179519421471319

    241389 it    100000 dig    117.477378 s
1316113735615475349297100 ... 5799080295258450663731151                    

1:
2:

    241389 it    100000 dig     88.742270 s
1316113735615475349297100 ... 7990802952584506637311513                    

1:
2:
3:
4:

procedure NumberAddReversed(var Number: TNumber); 
...
    mov byte ptr [ecx], al            // speichern in number
    mov byte ptr [edx], al            // ...                    

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:

{$APPTYPE console}
program p196console;

uses
  SysUtils,
  Windows;

const zmax:integer=999;
var k:string;
    i,anz,laenge,laenge1:integer;
    gefunden:boolean;
    z,e:array of byte;
    Time1, Time2, Freq: Int64;
begin
  repeat
    write('Startzahl: ');
    readln(k);
    if k='' then k:='196';
    laenge:=length(k);
    write('maximale Laenge: ');
    readln(zmax);
    if zmax<100 then zmax:=100;
    writeln('');

    setlength(z,zmax+2);
    setlength(e,zmax+2);
    for i:=0 to zmax do begin z[i]:=0; e[i]:=0 end;
    for i:=laenge downto 1 do begin
      z[laenge-i]:=ord(k[i])-48;
      e[laenge-i]:=ord(k[i])-48;
    end;
    anz:=0;
    laenge1:=laenge-1;

    QueryPerformanceFrequency(Freq);
    QueryPerformanceCounter(Time1);

    repeat
      inc(anz);
      for i:=0 to laenge1 do inc(e[i],z[laenge1-i]);
      for i:=0 to laenge1 do begin
        if e[i]>9 then begin
          inc(e[i+1]);
          dec(e[i],10);
        end;
      end;
      if e[laenge]>0 then inc(laenge);
      laenge1:=laenge-1;

      gefunden:=true;
      i:=0;
      repeat
        if e[i]<>e[laenge1-i] then gefunden:=false;
        inc(i);
      until (not gefunden) or (i>laenge div 2);

      if gefunden then
      begin
        writeln('Palindrom im Schritt '+inttostr(anz));
        k:='';
        for i:=0 to laenge1 do k:=chr(e[i]+48)+k;
        writeln(k);
      end
      else
        z:=copy(e,0,laenge);

      if anz mod 2000 = 0 then begin
        QueryPerformanceCounter(Time2);
        writeln(anz:10,' It ',(Time2-Time1)/freq:10:6,' s');
      end;
    until gefunden or (laenge=zmax);

    QueryPerformanceCounter(Time2);
    writeln(anz:10,' It ',(Time2-Time1)/freq:10:6,' s');
    if (laenge=zmax) then
    begin
      writeln('Folgenglied im Schritt '+inttostr(anz));
      writeln('Laenge '+inttostr(laenge));
      k:='';
      for i:=0 to 25 do k:=chr(z[i]+48)+k;
      k:=' ... '+k;
      for i:=laenge-26 to laenge-1 do k:=chr(z[i]+48)+k;
      writeln(k);
    end;
    setlength(z,0);
    setlength(e,0);
    writeln('');
  until false;
end.                    

1:
2:

1316113735615475349297100 ... 7990802952584506637311513
    241389 it    100000 dig     71.290302 s                    

1:
2:

1316113735615475349297100 ... 7990802952584506637311513
    241389 it    100000 dig     75.367305 s                    

1:
2:

1316113735615475349297100 ... 7990802952584506637311513
    241389 it    100000 dig     89.618406 s                    

1:
2:

1316113735615475349297100 ... 7990802952584506637311513
    241389 it    100000 dig     52.276415 s                    

1:
2:
3:
4:
5:
6:
7:
8:
9:

FPC2.6.0
=
1316113735615475349297100 ... 7990802952584506637311513
    241389 it    100000 dig     54.138380 s

Delphi 12
=
1316113735615475349297100 ... 7990802952584506637311513
    241389 it    100000 dig     35.098787 s                    

1:
2:
3:
4:
5:

   2415600 it    999900 dig       10519.0 s
   2415800 it    999983 dig       10520.5 s
=
   2415836 it   1000000 dig  10520.815838 s
1321620866345900792403087 ... 1880303207999544559027122                    

1:
2:

1316113735615475349297100 ... 7990802952584506637311513
    241389 it    100000 dig    135.658393 s                    

1:
2:
3:
4:

  TNumber = packed record
    Length: integer;
    Digits: array[0..0] of TDigit;
  end;                    

1:
2:

    241389 it    100000 dig     67.761056 s
1316113735615475349297100 ... 7990802952584506637311513                    

1:
2:

    241389 it    100000 dig          82.5 s
13161137356154753492971008 ... 57990802952584506637311513                    

 
217:
218:
219:
220:

{ ... }
asm
        mov al, byte ptr [edx]           //wert
        mov byte ptr [ecx], al
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:

numToList x = numToList' [] x
numToList' y x =
    if x < 10
    then x : y
    else (x `mod` 10) : (numToList' y (x `div` 10))
revList x = reverse x
addList x y =
    if null x
    then (
        if null y
        then []
        else y
    )
    else (
        if null y
        then x
        else (head x + head y) : addList (tail x) (tail y)
    )
daaList x =
    if null x
    then []
    else (daaElemDigit (head x)) : (
        if null (tail x)
        then (
            if 0 == daaHeadCarry x
            then []
            else [daaHeadCarry x]
        )
        else (
            daaList (((daaHeadCarry x) + (head (tail x))) : (tail (tail x)))
        )
    )
daaElemDigit x = x `mod` 10
daaElemCarry x = x `div` 10
daaHeadDigit x = if null x then 0 else daaElemDigit (head x)
daaHeadCarry x = if null x then 0 else daaElemCarry (head x)
isPalim x = x == reverse x
getLyrchInt x = getLyrch (numToList x) 100000
getLyrch x y =
    if y == 0
    then x
    else (
        if isPalim x
        then x
        else (getLyrch (daaList (addList x (reverse x))) (y - 1))
    )                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:

[Denkansatz]

Was ihr braucht:

[*] das Programm, um die (Teil-) Summen auszurechnen
[*] ein weiteres Programm, um diese (Teil-) Summen auf ein Palindrom zu prüfen


Von verteiltem Rechnen habt ihr doch schon gehört !?
Also fehlt noch das 3. (bzw. das nach dem 1. kommende) Programm, 
wechles eine gewisse Anzahl von errechneten (Teil-) Summen dem 2. Programm zur Verfügung stellt...
[/Denkansatz]                    

1:
2:
3:
4:
5:
6:
7:

type 
  record 
      ZiffernfolgeOhneCarry : Dword;
      ZiffernfolgeMitCarry  : Dword;
      CarryOhneCarray       : word;// lieber DWword ?
      CarryMitCarray        : word;// Dword 
  end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:

2497 -> (((2*16 +4)*16+9)*16+7 ==> Feldnummer 9367
Feld[9367].ZiffernfolgeOhneCarry = $00040309 ( 0* 4096 +4*256+3*16+9 )
Feld[9367].ZiffernfolgeMitCarry =  $00040400
Feld[9367].CarryOhneCarray = 1
Feld[9367].CarryMitCarray = 1

4455 -> (((4*16 +4)*16+5)*16+5 ==> Feldnummer 17493
Feld[17493].ZiffernfolgeOhneCarry = $09090909
Feld[17493].ZiffernfolgeMitCarry =  $00000000
Feld[17493].CarryOhneCarray = 0
Feld[17493].CarryMitCarray = 1                    

1:
2:
3:
4:
5:

Eingabe:  196
Es gab einen Fehler:
    Der Wert liegt außerhalb des erwarteten Bereichs.

Gesammte Zeit: 0 ms                    

1:
2:
3:
4:
5:

Summe "2442" -> (((2*10 +4)*10+4)*10+2 ==> Feldnummer 2442
Feld[9367].ZiffernfolgeOhneCarry = $02040402 
Feld[9367].ZiffernfolgeMitCarry =  $02040403
Feld[9367].CarryOhneCarray = 0
Feld[9367].CarryMitCarray = 0                    

1:
2:
3:
4:
5:

...952584506637311513
    241389 it    100000 dig

Einzelbyte Additionen  12080757065
Einzelbyte Uebertraege  6040358167                    

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:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:

program p196;
{$IFDEF FPC}
  {$MODE DELPHI}
  {$ASMMODE INTEL}
  {$Optimization ON}
  {$Optimization RegVar}
  {$Optimization PEEPHOLE}
  {$Optimization CSE}
  {$Optimization ASMCSE}
{$Else}
  {$APPTYPE console}
{$Endif}

uses
  SysUtils;

{$IFNDEF FPC}
type
  nativeUint = LongWord;//Uint64
  PtrUint  = LongWord;
{$Endif}

const
  NUMBER_BASE = 10;
  cMaxDigit = 100000; //quadratische Laufzeit n,t->k*n,k^2*t
  cDelta = 24139;//Ausgabe alle cDelta Berechnungen

  CpuF = 3.5e9;  // CPU-Frequenz

type
  TDigit  = byte;
  tDigit2 = word;
  tpDigit =^TDigit;
  tpDigit2 =^TDigit2;
  // Rueckwaerts, niederwertigste Stelle ist [0]
  TNumber = array of TDigit;
  tSumCarry = record
                we: Word; 
//              ca:word; carry und neuer Wert separat
              end;
//ein nicht gelungener Versuch, Platz zu sparen 
//aber die Indexbestimmung wird zu langsam
//tSumCarFeld = array[0..18*32+21] of tSumCarry;
  tSumCarFeld = array[0..18*256+21] of tSumCarry;
  
var
  MaxIndex : integer;
  Cycle: Cardinal;
  AddCnt : Int64;
  cSumCarFeld : tSumCarFeld;

procedure NumberFromString(var Number: TNumber; Str: string);
var
  i: integer;
begin
  SetLength(Number, Length(Str));
  for i:= 0 to Length(Str) - 1 do
    Number[i]:= Ord(Str[Length(Str) - i]) - Ord('0');
end;

function NumberToString(var Number: TNumber): string;
var
  i,l: integer;
begin
  i := High(Number);
  If i <= 50 then
  begin
    l := i+1;
    SetLength(Result, l);
    for i:= 0 to High(Number) do
    begin
      Result[l]:= Chr(Ord('0') + Number[i]);
      dec(l);
    end;
  end
  else
  begin
    SetLength(Result, 50);
    fillchar(Result[1],50,'.');
    For l := 1 to 24 do
    Begin
      Result[l] := Chr(Ord('0') + Number[i-l+1]);
      Result[l+26] := Chr(Ord('0') + Number[24-l]);
    end;
  end;
end;

function NumAddAs(pDigit1,pDigit2 : tpDigit):NativeUInt;
//Mal sehen, ob moeglichst viele Register helfen
//Aber es dauert so nur etwa 0.25..0.32 Takte/Digit
begin
  asm
//   PUSH     ECX; PUSH     ESI;PUSH   EDI;
// Bei dermaßen vielen Stellen geht das unter.
     PUSHAD

     MOV     ESI,pDigit2
     MOV     EDI,pDigit1

     MOV     ECX,ESI
     SUB     ECX,EDI
     INC     ECX
     SAR     ECX,3
     TEST    ECX,ECX
     MOV     @result,ECX;
     JLE     @UndTschuesz
//EDI von Byte auf LongWord zeigen lassen
     SUB     ESI,3

     CMP     ECX,4
     JLE     @Reste
//     JMP     @Reste
@WeiteSchritte:
     SUB     ECX,4

     MOV     EAX,[ESI]
     BSWAP   EAX
     MOV     EBX,[ESI-4]
     BSWAP   EBX
     ADD     EAX,[EDI]
     MOV     EBP,[ESI-8]
     BSWAP   EBP
     ADD     EBX,[EDI+4]
     MOV     EDX,[ESI-12]
     BSWAP   EDX
     ADD     EBP,[EDI+8]
     ADD     EDX,[EDI+12]

     MOV     [EDI],EAX
     BSWAP   EAX
     MOV     [EDI+4],EBX
     BSWAP   EBX
     MOV     [EDI+8],EBP
     BSWAP   EBP
     MOV     [EDI+12],EDX
     BSWAP   EDX

     ADD     EDI,16

     MOV     [ESI],EAX
     MOV     [ESI-4],EBX
     MOV     [ESI-8],EBP
     MOV     [ESI-12],EDX

     SUB     ESI,16
     CMP     ECX,4

     JG      @WeiteSchritte;

@Reste:
     MOV     EAX,[EDI]
     BSWAP   EAX
     MOV     EDX,[ESI]
     ADD     EAX,EDX
     MOV     EDX,EAX
     BSWAP   EDX
     MOV     [ESI],EAX
     SUB      ESI,4
     MOV     [EDI],EDX
     ADD      EDI,4
     DEC     ECX
     JNE     @Reste;

@UndTschuesz:
     POPAD
//     POP     EDI; POP     ESI;POP     ECX
  end;
end;

function CarryCorrect(pDigit: tpDigit;cnt: integer):nativeUint;
//Das braucht ~13 Takte pro Digit :-(
//freepascal 2.6.2 div wird durch mul und shr ersetzt
var
 Carry: nativeUint;
begin
  Carry := 0;
  for  cnt := cnt Downto 0 do
  begin
    Carry := Carry+pDigit^;
    result := Carry DIV 10;
    pDigit^ := Carry-10*result;
    inc(pDigit);
    Carry := result;
  end;
end;

function CarryCorrect2(pDigit: tpDigit2;cnt: integer):nativeUint;
//Zwei Zahlen auf einmal korrigieren
var
 idx: NativeUint;
begin
  result := 0;
  //0..cnt hat cnt+1 Elemente
  dec(cnt);
  IF cnt > 0 then
    repeat
      with cSumCarFeld[pDigit^+result] do
      begin
        idx := we;
        pDigit^ := idx shr 2;
        result  := idx AND 3;
      end;
      inc(pDigit);
      dec(cnt,2);
    until cnt<0;

  IF cnt >-2 then
  begin
    // Da fehlt ein Byte
    // Zugriff via word ist nicht sauber.
    // Aber oberes Byte bleibt unangetastet
    idx := (pDigit^ AND 255 )+result;
    result := idx DIV Number_Base;
    idx := idx -result*Number_Base;// ( idx MOD Number_Base)
    pDigit^ := pDigit^ AND (255*256)+idx;
  end;
end;

procedure NumberAdd(var Number : TNumber);
// erst alles addieren und anschliessend carry
// uebertragen bringt einiges
var
  pDigit1,pDigit2 : tpDigit;
  p,
  Carry: nativeUint;
begin
  p := high(Number);
  inc(AddCnt,  (p+1) DIV 2);
  pDigit1 := @Number[0];
  pDigit2 := pDigit1;
  inc(pDigit2,p);// @Number[p];
//{ Mit Assembler
  //Wieviele Stellen mit Assemblerroutine bearbeitet
  Carry:=SizeOf(PtrUint)*NumAddAs(pDigit1,pDigit2);
  //Die Zeiger entsprechend anpassen
  inc(pDigit1,Carry);
  dec(pDigit2,Carry);
//}

  //die letzten einzelnen Stellen addieren
  Carry:= 0;
  IF PtrUint(pDigit2)>= PtrUint(pDigit1) then
    repeat
    Carry := pDigit1^+pDigit2^;
    pDigit1^ := Carry;
    pDigit2^ := Carry;
    inc(pDigit1);
    dec(pDigit2);
    until PtrUint(pDigit2) < PtrUint(pDigit1);

  IF CarryCorrect2(@Number[0],p) = 1 then
    begin
    p := Length(Number)+1;
    SetLength(Number, p);
    Number[p-1] :=1;
    end;
end;

function NumberCompare(const A: TNumber): boolean;
var
  i,j: integer;
begin
  i := Low(A);
  j := High(A);
  Repeat
    Result:= A[i]=A[j];
    inc(i);
    dec(j);
  until Not(Result) OR (J<I);

  IF  MaxIndex <i then
  begin
    MaxIndex := i;
    writeln('Erster Unterschied bei Stelle ',i:2,' und Iteration ',cycle)
  end;
end;

procedure SumCarFeldErstellen;
// Für zwei Stellen auf einmal
var
  i,j,s,c,d1,d2,idx: integer;
begin
  Fillchar(cSumCarFeld,SizeOf(cSumCarFeld),#0);
  For i := 0 to 18 do
    For j := 0 to 21 do
    begin
      idx := i*256+j;
      s := (i*Number_Base+j);
      c := s DIV sqr(Number_Base);
      s := s - c* sqr(Number_Base);
      d1 := s DIV Number_Base;
      d2 := s-d1*Number_Base;
      with cSumCarFeld[idx] do
      begin
        we := (d1*256+d2)*4+c;
      end
    end;
end;

var
  Work : TNumber;
  delta: cardinal;
  Time1, Time2 : TDateTime;
  s: string;
begin
  SumCarFeldErstellen;

  Repeat
    Write('Startzahl: ( Beenden mit 0 ) ');
    ReadLn(s);
    if s='0' then
      break;
    If s= '' then
      s := '196';
    writeln(s);
    NumberFromString(Work, s);
    Cycle:= 0; // das erste ist kein cycle...
    AddCnt := 0;
    delta := cDelta;
    Time1 := time;
    Repeat
      inc(Cycle);
      NumberAdd(Work);
      //Keine Ausgabe !
      if Length(Work) >= cMaxDigit then
        break;
      dec(delta);
      if Delta=0  then
        begin
        delta := cDelta;
        Time2 := time;
        WriteLn(Cycle:10,' it',Length(Work):10,' dig',(Time2-Time1)*86400.0:10:3,' s');
        //WriteLn(NumberToString(Work));readln;
        end;
    until NumberCompare(Work);
    Time2 := time;
    WriteLn(NumberToString(Work));
    WriteLn(Cycle:10,' Iterationen mit ',AddCnt,' Byte-Additionen ' );
    time1 := (Time2-Time1)*86400;
    IF time1 > 0 then
    begin
      WriteLn('Takte/ Addition ',(Time1*CpuF)/AddCnt:6:3);
      WriteLn(Length(Work):10,' Digits ',Time1:10:7,' s');
    end;
  until true;
end.
{# ./p196_6
Startzahl: ( Beenden mit 0 )
196
Erster Unterschied bei Stelle  1 und Iteration 1
Erster Unterschied bei Stelle  2 und Iteration 6
Erster Unterschied bei Stelle  3 und Iteration 13
Erster Unterschied bei Stelle  4 und Iteration 16
Erster Unterschied bei Stelle  5 und Iteration 25
Erster Unterschied bei Stelle  8 und Iteration 70
Erster Unterschied bei Stelle 12 und Iteration 105
Erster Unterschied bei Stelle 13 und Iteration 1237
Erster Unterschied bei Stelle 14 und Iteration 1430
Erster Unterschied bei Stelle 16 und Iteration 3461
Erster Unterschied bei Stelle 17 und Iteration 3940
Erster Unterschied bei Stelle 29 und Iteration 9777
     24139 it     10019 dig     0.152 s
     48278 it     20054 dig     0.605 s
     72417 it     30072 dig     1.360 s
     96556 it     40075 dig     2.418 s
    120695 it     50116 dig     3.780 s
    144834 it     60047 dig     5.443 s
    168973 it     70007 dig     7.407 s
    193112 it     80054 dig     9.675 s
    217251 it     90053 dig    12.239 s
131611373561547534929710..990802952584506637311513
    241389 Iterationen mit 6040318143 Byte-Additionen
Takte/ Addition  8.752
    100000 Digits 15.1040000 s
}                    

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:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:

function NumAddAs(pDigit1,pDigit2 : tpDigit):NativeUInt;
//Mal sehen, ob moeglichst viele Register helfen
//Aber es dauert so auch etwa 0.25..0.32 Takte/Digit oder war das bei 64Bit??
//4er-Gruppe Laden und umsortieren mit Bwap-> 
//mit Gegestelle addieden->dort speichern und 
//umsortieren und wieder am Original speichern

//[p1]ABCD -> DCBA -> DCBA+ [p2]VWXY = DV CW BX AY -> Speichern[p2] und  DV CW BX AY -> AY BX CW DV  speichern[p1]
begin
  asm
//   PUSH     ECX; PUSH     ESI;PUSH   EDI;
// Bei dermaszen vielen Stellen geht das unter.
     PUSHAD

     MOV     ESI,pDigit2
     MOV     EDI,pDigit1

     MOV     ECX,ESI
     SUB     ECX,EDI
     INC     ECX
     SAR     ECX,3
     TEST    ECX,ECX
     MOV     @result,ECX;
     JLE     @UndTschuesz
//EDI von Byte auf LongWord zeigen lassen
     SUB     ESI,3

     CMP     ECX,4
     JLE     @Reste

@WeiteSchritte:
     SUB     ECX,4

     MOV     EAX,[ESI]
     BSWAP   EAX
     MOV     EBX,[ESI-4]
     BSWAP   EBX
     ADD     EAX,[EDI]
     MOV     EBP,[ESI-8]
     BSWAP   EBP
     ADD     EBX,[EDI+4]
     MOV     EDX,[ESI-12]
     BSWAP   EDX
     ADD     EBP,[EDI+8]
     ADD     EDX,[EDI+12]

     MOV     [EDI],EAX
     BSWAP   EAX
     MOV     [EDI+4],EBX
     BSWAP   EBX
     MOV     [EDI+8],EBP
     BSWAP   EBP
     MOV     [EDI+12],EDX
     BSWAP   EDX

     ADD     EDI,16

     MOV     [ESI],EAX
     MOV     [ESI-4],EBX
     MOV     [ESI-8],EBP
     MOV     [ESI-12],EDX

     SUB     ESI,16
     CMP     ECX,4

     JG      @WeiteSchritte;

@Reste:
     MOV     EAX,[EDI]
     BSWAP   EAX
     MOV     EDX,[ESI]
     ADD     EAX,EDX
     MOV     EDX,EAX
     BSWAP   EDX
     MOV     [ESI],EAX
     SUB      ESI,4
     MOV     [EDI],EDX
     ADD      EDI,4
     DEC     ECX
     JNE     @Reste;

@UndTschuesz:
     POPAD
//     POP     EDI; POP     ESI;POP     ECX
  end;
end; 

function CalcCarryAs(var a:tDigit2;cnt:NativeInt):NativeInt;assembler;
//Soll die Ueberträge/Carry von 8 Digits bestimenn {Minimum 8 Byte}
//Anaolg zu BCD-Add
//http://www.azillionmonkeys.com/qed/asmexample.html
//Norbert Juffa has given me some devilishly
//clever code for performing a 64 bit BCD addition
//statt lea   edi, [eax+66666666h]
//eben Byte-weise
//MOV  EDX,EAX
//ADD  EDX,246*($01010101)// $F6F6F6F6 // OK LEA EDX,[EAX+$F6F6F6F6] ginge auch
  asm
  PUSH EDI
  PUSH ESI
  PUSH EBX
  PUSH ECX
  PUSH EBP

  MOV  EDI,a
  XOR  EAX,EAX   // Carry = 0;
  MOV  ESI,cnt
  SUB  ESI,8
// Uberhaupt etwas zu tun? Minimum 8 Byte
  JL   @WarWohlNichts

@Loop:
  ADD  EAX,[EDI] // Carry einarbeiten
  MOV  EBP ,[EDI+4]
  SUB  ESI,8
  MOV  EDX,EAX
  ADD  EDX,246*($01010101)
  SBB  EBX,EBX  // Carry merken
  XOR  EAX,EDX
  AND  EAX,$01010101
  ADD  EBX,EBX
  ADC  EBP,0    // auf folgende Zahl uebetragen
  SHL  EBX,1
  MOV  ECX,EBP
  RCR  EAX,8    // Carry reinrollen
  ADD  ECX,246*($01010101)

  XOR  EAX,($01010101)
  IMUL EAX,EAX,246
  SUB  EDX,EAX
  MOV  [EDI], EDX

  SBB  EAX,EAX  // Carry merken
  XOR  EBP,ECX
  AND  EBP,($01010100)
  ADD  EAX,EAX
  RCR  EBP,8 // Carry reinrollen
  XOR  EBP,($01010101)
  IMUL EBP,EBP,246
  SUB  ECX,EBP
  MOV  [EDI+4], ECX

  SHR  EAX,31
  ADD  EDI,8
  TEST ESI,ESI
  JGE  @Loop

@WarWohlNichts:
  POP  EBP
  POP  ECX
  POP  EBX
  POP  ESI
  POP  EDI
end;