Bruch ermitteln

[Amateurprofi]

@jfheins
Ich habe die Prozedur Kettenbruch ausgiebig getestet.
Da die Prozedur in einem anderen Thread liegt, stelle ich sie hier noch einmal rein.

Delphi-Quellcode:

procedure Kettenbruch (var z1,z2:Int64; Ebenen:Byte);
var
   Ganzzahl, Zaehler, Nenner: Int64;
begin
   z1 := abs(z1);
   z2 := abs(z2);
   Ganzzahl:=z1 div z2;
   Zaehler:=z1-(Ganzzahl*z2);
   Nenner:=z2;
   // Falls die angegebene Tiefe erreicht ist, oder der Ausgangsbruch vollständig
   // angenähert wurde, wird der gemischte Bruch auf einen unechten X/1 Bruch
   // gerundet.
   if (Ebenen=0) or (Zaehler=0) then begin
     Zaehler:=Ganzzahl+Round(Zaehler/Nenner);
     Nenner:=1;
   end else begin
     // Rekusion mit dem Kehrwert des Bruches aus dem gem. Bruch;
     // gem. Bruch > unechter Bruch
     Kettenbruch(Nenner,Zaehler,Ebenen-1);
     Zaehler:=Zaehler+(Ganzzahl*Nenner);
   end;
   z1:=Zaehler;
   z2:=Nenner;
end;

Hauptproblem war für mich meine Sonderbedingung, dass Nenner und Zähler Byte-Werte sein müssen.
Das habe ich, so wie in der Prozedur Test1 gezeigt, zu lösen versucht.

Delphi-Quellcode:

// Zeigt für eine FTL/TL die Ergebnisse von "KettenBruch", bei Rechentiefen von 1 bis 10,
// wobei ein Abbruch erfolgt, wenn Zahler oder Nenner größer werden als 255.
PROCEDURE Test1(FTL,TL:Word);
var Depth:Integer; Z,N:Int64; S:String; Z1,N1:Byte; Solved:Boolean;
begin
   S:='FTL: '+IntToStr(FTL)+', TL: '+IntToStr(FTL)+#13;
   Solved:=False;
   Depth:=1;
   repeat
      Z:=TL;
      N:=FTL;
      KettenBruch(Z,N,Depth);
      S:=S+IntToStr(Z)+', '+IntToStr(N)+#13;
      if (Z<256) and (N<256) then begin
         Z1:=Z;
         N1:=N;
         Solved:=True;
      end else begin
         Break;
      end;
      Inc(Depth);
   until Depth=10;
   if Solved then S:=S+'Gelöst Z='+IntToStr(Z1)+' N='+IntToStr(N1)
      else S:=S+'Keine Lösung';
   ClipBoard.AsText:=S;
   ShowMessage(S);
end;

Nach einigen positiven Erfahrungen kam dann die Meldung "Keine Lösung".
Mit der Prozedur Test2 konnte ich prüfen, dass das nicht an einer falschen Abbruchbedingung in Test1 liegt, sondern daran, dass "Kettenbruch" eben keine Byte-Ergebnisse brachte.

Delphi-Quellcode:

// Zeigt für eine FTL/TL die Ergebnisse von "Kettenbruch" bei Rechentiefen von 1 bis 10
// Dient zur Überprüfung ob ein "Keine Lösung" bei Test1 an einer falschen
// Abbruchbedingung liegt.
PROCEDURE Test2(FTL,TL:Word);
var Depth:Integer; Z,N:Int64; S:String;
begin
   S:='FTL: '+IntToStr(FTL)+', TL: '+IntToStr(TL)+#13;
   Depth:=1;
   repeat
      Z:=TL;
      N:=FTL;
      KettenBruch(Z,N,Depth);
      S:=S+IntToStr(Z)+', '+IntToStr(N)+#13;
      Inc(Depth);
   until Depth=10;
   ClipBoard.AsText:=S;
   ShowMessage(S);
end;

Um in Erfahrung zu bringen, ob die Fälle, in denen keine für mich verwertbare Lösung kommt, für mich relevant sind, habe ich dann mit allen Werten FTL von 400 bis 1200 und TL von 1 bis 32767 getestet. (Prozedur Test3 am Ende des Beitrags).

Das Ergebnis:

Code:

Größte absolute Differenz=144, FTL=505, TL=32681
Größte prozentuale Differenz=33.33, FTL=401, TL=3
Keine Lösung in:
   Total: 2298539 von 26246367 Fällen (=  8.76%)
   Min:   1726 von 32767 Fällen (=  5.27%)
   Max:   5210 von 32767 Fällen (= 15.90%)
   Avg:   2870 von 32767 Fällen (=  8.76%)

Um keine Fehlinterpretationen aufkommen zu lassen:
"Keine Lösung" heißt hier nicht, dass "Kettenbruch" keine Lösung liefert, sondern dass die gelieferten Werte nicht im Byte-Bereich sind.

Da die größte gefundene Differenz höher ist, als bei meiner in #1 gezeigten Lösung, werde ich also vorerst bei meiner Lösung bleiben.
Zudem hätte ich in den Fällen "Keine Lösung" das Problem, die von "Kettenbruch" gelieferten Resultate in den Byte-Bereich zu bringen, was ja genau das ist, was meine in #1 gezeigte Lösung macht.

Übrigens:
Für die Umwandlung von Dezimalbrüche in Brüche werkelt hier https://www.delphipraxis.net/134885-rechenprogramm.html die folgende Prozedur.
Ich habe die vor langen Jahren gefunden (weiß nicht mehr wo, erinnere mich aber, dass die ursprünglich von HP kommen soll).

Delphi-Quellcode:

PROCEDURE GetFraction(V:Extended; var Numerator,Denominator:Extended);
var A,Y,D0,D1,D2,N0,N1,N2,X0,X1:Extended;
begin
   N0:=0.0;
   D0:=1.0;
   N1:=1.0;
   D1:=0.0;
   N2:=0.0;
   D2:=1.0;
   X1:=1.0;
   X0:=1.0;
   A:=Int(V);
   Y:=V-A;
   while (D0<>0) and (N0/D0<>V) do begin
      N0:=A*N1+N2;
      D0:=A*D1+D2;
      if Y=0 then break;
      A:=Int(X1/Y);
      X1:=Y;
      Y:=X0-A*Y;
      X0:=X1;
      N2:=N1;
      N1:=N0;
      D2:=D1;
      D1:=D0;
   end;
   Numerator:=N0;
   Denominator:=D0;
end;

Delphi-Quellcode:

PROCEDURE Test3(FTL1,FTL2,TL1,TL2:Word);
var
   DeltaPct,WorstDeltaPct:Double;
   Z,N:Int64;
   Depth,FTLCount,TLCount,Cases,NoSolutionCount,TotalNoSolutionCount:Integer;
   FTL,TL,WorstFTL,WorstTL,WorstDelta,Delta,WorstPctFTL,WorstPctTL:Word;
   Z1,N1:Byte;
   Solved:Boolean;
   S,S1,S2:String;
   F:TextFile;
begin
   AssignFile(F,ExtractFilePath(ParamStr(0))+'Log.txt');
   Rewrite(F);
   Writeln(F,' FTL    TL');
   Writeln(F,'---- -----');
   FTLCount:=FTL2-FTL1+1;
   TLCount:=TL2-TL1+1;
   Cases:=FTLCount*TLCount;
   TotalNoSolutionCount:=0;
   WorstDelta:=0;
   WorstDeltaPct:=0;
   for FTL:=FTL1 to FTL2 do begin
      NoSolutionCount:=0;
      for TL:=TL1 to TL2 do begin
         Solved:=False;
         Depth:=1;
         repeat
            Z:=TL;
            N:=FTL;
            KettenBruch(Z,N,Depth);
            if (Z<256) and (N<256) then begin
               Z1:=Z;
               N1:=N;
               Solved:=True;
            end else begin
               Break;
            end;
            Inc(Depth);
         until Depth=10;
         if Solved then begin
            Delta:=Abs(TL-FTL*Z1 div N1);
            if Delta>WorstDelta then begin
               WorstFTL:=FTL;
               WorstTL:=TL;
               WorstDelta:=Delta;
            end;
            DeltaPct:=Delta*100/TL;
            if DeltaPct>WorstDeltaPct then begin
               WorstDeltaPct:=DeltaPct;
               WorstPctFTL:=FTL;
               WorstPctTL:=TL;
            end;
         end else begin
            Inc(NoSolutionCount);
            Writeln(F,FTL:4,TL:6);
         end;
      end;
      Inc(TotalNoSolutionCount,NoSolutionCount);
      Writeln(F,'Keine Lösung in ',NoSolutionCount,' von ',TLCount,' Fällen');
      Writeln(F);
   end;
   Writeln(F,'Keine Lösung in ',TotalNoSolutionCount,' von ',Cases,' Fällen');
   Writeln(F);
   CloseFile(F);
   Str(WorstDeltaPct:0:2,S1);
   Str(TotalNoSolutionCount*100/Cases:0:2,S2);
   S:='Größte absolute Differenz='+IntToStr(WorstDelta)+
      ', FTL='+IntToStr(WorstFTL)+', TL='+IntToStr(WorstTL)+#13+
      'Größte prozentuale Differenz='+S1+
      ', FTL='+IntToStr(WorstPctFTL)+', TL='+IntToStr(WorstPctTL)+#13+
      'Keine Lösung in '+IntToStr(TotalNoSolutionCount)+' von '+
      IntToStr(Cases)+' Fällen (='+S2+'%)';
   ClipBoard.AsText:=S;
   ShowMessage(S);
end;

[jfheins]

Moin 😀
Auch wenn der Code etwas älter ist, freut es mich wenn ich da Denkanstöße geben konnte.

Aber eine Idee hab ich noch:
Falls du die Werte wirklich auf Bytes limitieren kannst, würde ich das einfach im voraus berechnen. Also bei Programmstart eine lookup table errechnen (alle gekürzten x/y Brüche mit x, y kleiner 256) und dann eine binäre Suche über das Verhältnis. Dann bekommst du immer das perfekte Ergebnis 😉

Die Tabelle dürfte max 392kB groß sein und sollte in jeden RAM passen...

[Amateurprofi]

Zitat von jfheins:

Moin 😀
Auch wenn der Code etwas älter ist, freut es mich wenn ich da Denkanstöße geben konnte.

Aber eine Idee hab ich noch:
Falls du die Werte wirklich auf Bytes limitieren kannst, würde ich das einfach im voraus berechnen. Also bei Programmstart eine lookup table errechnen (alle gekürzten x/y Brüche mit x, y kleiner 256) und dann eine binäre Suche über das Verhältnis. Dann bekommst du immer das perfekte Ergebnis 😉

Die Tabelle dürfte max 392kB groß sein und sollte in jeden RAM passen...

@jfheins:
Danke für den Hinweis.
Ich hab das realisiert, allerdings etwas anders als von dir (vermutlich) gedacht.
Ich hab eine Tabelle:

Delphi-Quellcode:

type
   TTLEntry=Record
      Numerator:Byte;
      Denominator:Byte;
      TL:Word;
   End;
   TTLTable=Array of TTLEntry;

Die Erstellung erfolgt so:
1) Alle unkürzbaren Brüche (GGT(Z,N)=1)) mit Z und N von 1..255, bei denen FLT*Z div N im Bereich 1..32761 ist, mit resultierender TL in die Tabelle stellen.
2) Mehrfachnennungen (gleiche TL) entfernen
3) Für alle TL von 1..32767 prüfen ob die TL in der Tabelle enthalten ist. Wenn nicht, dann vom nächstkleineren und nächstgrößeren Eintrag den besser geeigneten unter neuer TL hinzufügen.
4) Einen Dummy für TL 0 hinzufügen.
5) Tabelle nach TL aufsteigend sortieren.

Jetzt kann für jede TL im Bereich 1..32767 mit TLTable[TL].Numerator bzw. .Denominator der Zähler und Nenner geholt werden.

Die Tabelle hat während der Erstellung 262 und nach Fertigstellung 131 kB.
Die größte Abweichung zwischen TL und der aus FTL, und Zähler/Nenner resultierenden TL ist 2.28 %.

Die Erstellung dauert ca. 10 ms.
Da bei meinem Anwendungsfall während der Zeit, in der die Tabelle benötigt wird, die FTL konstant bleibt, ist die Erstellung "on demand" deshalb unkritisch.

Zu

Zitat:

Die Tabelle dürfte max 392kB groß sein und sollte in jeden RAM passen

Mein Programm hält während der Laufzeit diverse Tabellen mit insgesamt ca. 200 MB im RAM. Die paar Bytes dieser Tabelle sind da vernachlässigbar.

Was mich interessieren würde: Wie kamst Du auf max 392kB ?

Delphi-Quellcode:

type
   TTLEntry=Record
      Numerator:Byte;
      Denominator:Byte;
      TL:Word;
   End;
   TTLTable=Array of TTLEntry;
var
   TLTable:TTLTable;

PROCEDURE CreateTLTable(FTL:Word);
FUNCTION LCD(A,B:Byte):Byte;
var C:Byte;
begin
   repeat
      C:=A mod B;
      A:=B;
      B:=C;
   until C=0;
   Result:=A;
end;
FUNCTION InitTable:Integer;
var N,D:Byte; XTL:Integer;
begin
   SetLength(TLTable,256*256);
   Result:=0;
   for N:=1 to 255 do
      for D:=1 to 255 do
         if LCD(N,D)=1 then begin
            XTL:=FTL*N div D;
            if InRange(XTL,1,$7FFF) then
               with TLTable[Result] do begin
                  Numerator:=N;
                  Denominator:=D;
                  TL:=XTL;
                  Inc(Result);
               end;
         end;
end;
PROCEDURE SortTable(Count:Integer);
var M:Word; H:TTLEntry;
PROCEDURE QSort(First,Last:Integer);
var I,J:Integer;
begin
   I:=First;
   J:=Last;
   M:=TLTable[(First+Last) shr 1].TL;
   repeat
      while TLTable[I].TL<M do Inc(I);
      while TLTable[J].TL>M do Dec(J);
      if I<=J then begin
         H:=TLTable[I];
         TLTable[I]:=TLTable[J];
         TLTable[J]:=H;
         Inc(I);
         Dec(J);
      end;
   until I>J;
   if J>First then QSort(First,J);
   if I<Last then QSort(I,Last);
end;
begin
   QSort(0,Count-1);
end;
FUNCTION MakeTableUnique(Count:Integer):Integer;
var I:Integer;
begin
   SortTable(Count);
   Result:=0;
   for I:=1 to Count-1 do
      if TLTable[I].TL<>TLTable[Result].TL then begin
         Inc(Result);
         TLTable[Result]:=TLTable[I];
      end;
   Inc(Result);
end;
FUNCTION IsBetter(const A,B:TTLEntry; TL:Word):Boolean;
begin
   Result:=Abs(TL-A.TL)<Abs(TL-B.TL);
end;
PROCEDURE CompleteTable(Count:Integer);
var I,J,L:Integer; N:Word;
begin
   L:=Count;
   I:=0;
   for N:=1 to $7FFF do begin
      while (I<L) and (TLTable[I].TL<N) do Inc(I); // I auf ersten Eintrag mit TL>=N
      if I>=L then J:=L-1  // Letzten Eintrag hinzufügen
         else if TLTable[I].TL=N then J:=-1 // Nichts hinzufügen
            else if I=0 then J:=I // Eintrag I hinzufügen
               else if IsBetter(TLTable[I],TLTable[I-1],N) then J:=I
                  else J:=I-1;
      if J>=0 then begin
         TLTable[Count]:=TLTable[J];
         TLTable[Count].TL:=N;
         Inc(Count);
      end;
   end;
   with TLTable[Count] do begin
      Numerator:=0;
      Denominator:=1;
      TL:=0;
   end;
   Inc(Count);
   SetLength(TLTable,Count);
   SortTable(Count);
end;
var Count:Integer;
begin
   Count:=InitTable;
   Count:=MakeTableUnique(Count);
   CompleteTable(Count);
end;