Joachim Mohr   Mathematik Musik Delphi

Die Unit jmbruch

{ "Extended integer" werden mit extended simuliert.
  extended hat 18-19 signifikante Stellen, d.h. man kann damit
  Integer darstellen, die 18-19 Dezimalstellen haben.
  Gespeichert werden diese Integer als extended.

  Int64 wären aucg möglich ... Nur dort entstehen Überlauffehler, die werden
  hier abgefangen mit "zugross". Dann wird die Zahl "unde" (Magic).


  Die Grundoperationen mit e(xttended) gekennzeichnet sind dann:
  Adde        a+b      //Muss nicht extra programmiert werden, bis auf unde(fined)
  Sube        a-b
  Multe       a*b
  Dive(a,b)   a div b  //Funktionen implementiert
  Mode(a,b)   a mod b
  ggTe(a,b)   ggT(a,b)
  hoche(a,b)   a^b
}

unit jmbruch;

interface
 uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, WinSpool, ComCtrls;
  const maxNennerMalZaehler = 1E12; //z.B. Nenner/Zähler 123456/765432 //geändert Februar 2003 vorher 1E14
        eps_fuerBruch = 1E-15;
        g_eps =1E-12; //von jmMath?????????????
        zugross = 1.0*high(Int64) + 0.5;
        undefined_e = 8642E97531;    //undefined_extended = magic
  var nPZe: integer;          //nPZe: "n=Anzahl für PZe"
      PZe: array of Integer;  //PZe:  "Primzahl extended"
//Betrifft extended  als Integer
function alsIntegergleich(const a,b: extended): boolean;
function adde(const a,b: extended): extended;
function sube(const a,b: extended): extended;
function multe(const a,b: extended): extended;
function dive(const a,b: extended): extended;  //<> a/b
function mode(const a,b: extended): extended;
function odd(const a:extended): boolean;
function ggTInt(const a,b: integer): integer; //siehe pyth Zahlentripel
function ggTe(const a,b: extended): extended;
procedure kuerzee(var a,b:Extended);
function hoche(const m,e: extended): extended;

//Allgemeine Hilfsfunktionen
function IsInteger(const x: extended; eps_Genauigkeit: extended): boolean;
  //z.B. x=2,000..0001 x=1,999..9
function RealIsIntegerToStr(x:extended): string;

//Primzahlen
//lokal function PrZe(const n:Integer): integer;    // die n. Primzahl, gezählt ab 0
function Primzahlausgabe(const n:extended): integer;  // die n. Primzahl, gezählt ab 1
function kleinsterPrimfaktor(const x: extended): extended; //2, 3 ... oder x
function groessterPrimfaktor(const x: extended): extended;
function PFZ(x0: extended): string; // Teste mit 304 250 263 527 211

//Ausgabe als Bruch
function ErmittleBruche(const q:extended;var a,b:extended; eps_Genauigkeit:Extended):boolean;
        //Die Hauptpozedur
function ReellZuBruch_(const q:extended;const alsGemZahl:boolean):string; //stets Ergebnis
function ReellZuBruch(const q:extended):string;   //stets Ergebnis, unechterBruch oder float
function ReellZuGemZahl(const q:extended):string; //Stets Ergebnis: Gem Zahl oder float
function GleichBruchfallsBruchsonstleer(r: extended): string;
function GleichBruchoderWurzelsonstleer(r: extended): string;
//Ausgabe als Wurzel oder Vielfaches von Pi
function AlsWurzeloderPi(x0:extended; wur:string):string; //evtl. ''
function AlsVielfachesVonPioderleer(x:extended):string;

         //es wird versucht x=a/b*wur(c)
         //-> x^2=z/n Nenner klein genug, dann x=1/n*wur(z*n)
function AlsBruchoderWurzel(r: extended): string;  //nie ''
function AlsBruchoderWurzelmitNaeherung(r: extended): string;


implementation

uses unitrechne, jmabbrechen, jmhilf;



function IsInteger(const x: extended; eps_Genauigkeit: extended): boolean;
begin
  result := frac(abs(x) + eps_Genauigkeit) < eps_Genauigkeit * 2;
end;

function alsIntegergleich(const a,b: extended): boolean;
begin
  result := (abs(a - b) < 0.5) //Es handelt sich um ganze Zahlen
end;

function adde(const a,b: extended): extended;
begin
  if (a = undefined_e) or (b = undefined_e) then result := undefined_e
    else result := a + b;
  if abs(result) > zugross then result := undefined_e;
end;

function sube(const a,b: extended): extended;
begin
  if (a = undefined_e) or (b = undefined_e) then
    result := undefined_e else result := a - b;
  if abs(result) > zugross then result := undefined_e;
end;

function multe(const a,b: extended): extended;
begin
  if (a = undefined_e) or (b = undefined_e)
    then result := undefined_e else result := a * b;
  if abs(result) > zugross then result := undefined_e;
end;

function dive(const a,b: extended): extended;
begin
  if (a = undefined_e) or (b = undefined_e) or (b = 0)
    then result := undefined_e else result := int(a/b);
end;

function mode(const a,b: extended): extended;
begin
  if (a = undefined_e) or (b = undefined_e) or (b = 0)
    then result := undefined_e else
    result := a - b*dive(a,b);
end;

function odd(const a:extended): boolean;
begin
  result := alsIntegergleich(mode(a,2),1);
end;

function ggTInt(const a,b: integer): integer;
begin
  if b = 0 then result:=a else result:=abs(ggTInt(b,a mod b));
end;

function ggTe(const a,b: extended): extended;
begin
  if (a = undefined_e) or (b = undefined_e) then result := undefined_e else
    if b = 0 then result:=a else result:=abs(ggTe(b,mode(a,b)));
end;

function hoche(const m,e: extended): extended;
begin
  if abs(m) > zugross then result := undefined_e else Begin
    if e = 0 then result := 1 else
      if odd(e) then result := m*hoche(m,e-1)  //da m^e=m*m(e-1)
        else result := hoche(m*m,dive(e,2))    //da m^e=(m*m)(e/2)
  End;
  if abs(result) > zugross then result := undefined_e;
end;


procedure suchenaechstePrimzahl;
    var groesstePZ: integer;
  function hatKeineTeiler:boolean; //Versuch, ob groesstePrimzahl wirklich PZ ist, d.h.
              //nicht durch bisherige PZ geteilt werden kann
              //Prüfung:primzahl[j] Teiler von GroesstePrimzahl?  bis
              //        primzahl[j] > Wurzel(groesstePrimzahl)  nil then Begin
    abbrechen.labbrechen.Caption := IntToStr(nPZe);
    application.ProcessMessages;
    if abbrechen.stop then exit;
  End else Begin
    abbrechen := TFormabbrechen.create(nil);
    FRechne.Enabled := false;
    abbrechen.Caption := 'Primzahlahlen werden berechnet';
    abbrechen.show;
  End;
  groesstePZ:=PZe[nPZe]; //Größte bisher gefundene PZ
  repeat
    inc(groesstePZ,2); //Eine noch groesserPZ wird gesucht, evl. PZ-Zwilling
  until hatkeineTeiler;
  inc(nPZe); //Jetzt gibt's eine PZ mehr
  if length(PZe) <= nPZe + 1 then setlength(PZe,nPZe + 500);
  PZe[nPZe] := groesstePZ; //Neue größte PZ
end;

procedure garantierePZe(const i: integer);
begin
    while nPZe < i do Begin
      if abbrechen <> nil then if abbrechen.stop then exit;
      suchenaechstePrimzahl;
    End;
end;

function PrZe(const n:Integer): integer; // die n. Primzahl, gezählt ab 0
begin
  garantierePZe(n);
  if abbrechen <> nil then if abbrechen.stop then Begin
    result := 0;
    exit;
  End;
  //Bei Abbruch n < nPrZe
  if n <= nPZe  then result := PZe[n] else result := 0;
end;

function Primzahlausgabe(const n:extended): integer;  // die n. Primzahl, gezählt ab 1
begin
  if (n < 1) or (n > high(integer)) then
    result := 0 else result := PrZe(round(n)-1);
  if abbrechen <> nil then Begin
    if abbrechen.stop then result := 0;
      abbrechen.free; //Jetzt auf jeden Fall
      abbrechen := nil;
      FRechne.Enabled := true;
      frechne.Show;
    End;
end;

function RealIsIntegerToStr(x:extended):string;
begin
  result:=trim(floatToStrf(x,ffGeneral,4,18));
  if pos('E',result) > 0 then result := floattostr(x);
end;

function kleinsterPrimfaktor(const x: extended): extended;
   var i:integer;
begin
  for i := 0 to round(sqrt(x)) do Begin
    if alsIntegergleich(mode(x,PrZe(i)),0) then BEgin
      result := PrZe(i);
      exit;
    ENd;
  End;
  result := x; //x ist Primzahl
  if abbrechen <> nil then Begin
    abbrechen.free;
    abbrechen := nil;
    FRechne.Enabled := true;
    frechne.Show;
  End;
end;

function groessterPrimfaktor(const x: extended): extended;
   var i:integer;
begin
  i := 0;
  while PrZe(i)*PrZe(i) < x do inc(i);
  while i >= 0 do Begin
    if alsIntegergleich(mode(x,PZe[i]),0) then BEgin
      result := PrZe(i);
      exit;
    ENd;
    dec(i);
  End;
  result := x; //x ist Primzahl
    if abbrechen <> nil then Begin
    abbrechen.free;
    abbrechen := nil;
    FRechne.Enabled := true;
    frechne.Show;
  End;
end;

procedure rundeWennInteger(var x: Extended);
begin if isInteger(x, g_eps) then Begin
    if x >= 0 then x := int(x + 0.5) else
      x := -int(abs(x) + 0.5);
  End;
end;

function PFZ(x0: extended): string; // Teste mit 304 250 263 527 211
  var x,faktor: extended;
begin
  x := x0;
  RundeWennInteger(x); //sonst bei Fibonacci 144=..*3*1
  result := '';
  if abs(x) <= 1 then exit;
  if abs(x) > 1E19 then Begin //geprüft mit 10^19+1=100...001
    showmessage('Durch Rundungsfehler der Fließkommazahl ist PFZ möglicherweise nicht korrekt!');
    result := '?';
  End;
  if x < 0 then result := '-' else result := ' ';
  x := abs(x);
  repeat
    faktor := kleinsterPrimfaktor(x);
    x := x/faktor;
    if length(result) > 1 then result := result + '*';
    result := result + FloatToStr(faktor);
  until  x <= 1.5;
  Try
    result := trim(result);
    if alsIntegergleich(abs(x0),faktor) then result := result + '(PZ)'
  except result := '' End;
end;

PROCEDURE kuerzee(var a,b:Extended);
    var t:Extended;
begin
    t := ggte(a,b);
    a := dive(a,t);
    b := dive(b,t)
end;

function ErmittleBruche(const q:extended; var a,b:extended; eps_Genauigkeit:Extended):boolean;
       //=true, falls erfolgreich
    const MaxIteration=50;
    var q0,Qabs,GanzZahligerAnteilVonQ,NachkommaVonQ,am,amm,bmm,bm:extended;
       {am=a index -1 amm index -2}
        zaehl:integer;
begin //Methode: Kettenbruchentwicklung
  result := false;
  qabs := abs(q); //Es wird mit positiven Werten gerechnet
  q0 := qabs;
  a := 1;
  b := 0;
  am := 0; //altes a
  bm := 1; //altes b
  zaehl := 0;
  try //damit nach exit Finally ausgeführt wird
    repeat
      inc(zaehl);
      if zaehl>MaxIteration then exit;
      GanzZahligerAnteilVonQ:=int(q0+eps_Genauigkeit); //wg. Rundungsfeler muss z.B.  4.99.. zu 5.00.. werden
      NachkommaVonQ:=q0-GanzZahligerAnteilVonQ;        //=fraq(qabs)
      amm := am; //uraltes a
      bmm := bm; //uraltes b
      am := a;   //altes   a
      bm := b;   //altes   a
      try // möglich overflow (kommt nur vor, falls eps_Gen. zu klein)
        a := adde(GanzZahligerAnteilVonQ*am,amm); //Anfang: ak=GanzZahligerAnteilVonQ
        b := adde(GanzZahligerAnteilVonQ*bm,bmm); //        bk=1
        kuerzee(a,b);
        if NachkommaVonq < eps_Genauigkeit then exit;//endlicher Kettenbruch siehe finally
        q0 := 1/NachkommaVonq; //Jetzt ja NachkommaVonq>=eps_Genauigkeit
      Except exit End;
    until abs(qabs - a/b)=eps_Genauigkeit then result:=false else result := true;
    except result := false End;
    if q<0 then a:=-a;
  End;
end;


function reellZuBruchefallsmoeglichsonstleer(const q: extended;
          gemischteZahl: boolean; eps: extended): string;
   //liefert ganze Zahl oder Bruch oder -falls nicht möglich- leeren String
  const Hochkomma = #39;
  var a,b: extended;
begin
  try
    if ErmittleBruche(q,a,b,eps) then Begin
      if abs(a*b) > maxNennerMalZaehler then BEgin
        result := '';
        exit;
      End;
      if abs(b-1) < eps then Begin
        result := IntToStr(round(a));
        exit;
      End;
      if gemischteZahl and (abs(q) > 1) then Begin
        if q < 0 then result := '-' else result := '';
        result := result + intToStr(round(dive(abs(a),b))) + Hochkomma
                  + intToStr(round(mode(abs(a),b))) + '/' + IntToStr(round(b));
      End else result := IntToStr(round(a)) + '/' + IntToStr(round(b));;
    End  else result := '';
    {Teste mit +/- ... 1/2+1/7, 999.9999999, Pi, 15, 13579/246810}
    except result := '' End;
end;

function ReellZuBruch_(const q:extended;const alsGemZahl:boolean):string;
  //liefert ganze Zahl oder Bruch oder -falls nicht möglich- floatToStr
begin
  result := reellZuBruchefallsmoeglichsonstleer(q,alsGemZahl,eps_fuerBruch);
  if result = '' then result := FloatToStrF(q,ffGeneral,18,10);
end;

function ReellZuBruch(const q:extended):string;  //stets Ergebnis, unechterBruch oder float
begin result:=ReellZuBruch_(q,false) end;

function ReellZuGemZahl(const q:extended):string; //stets Ergebnis, Gem Zahl oder oder float
begin result:=ReellZuBruch_(q,true) end;

function GleichBruchfallsBruchsonstleer(r: extended): string;
var s: string;
begin
  s := ReellZuBruch(r); 
  if pos('/', s) > 0 then result := '=' + s else result := '';
end;

//------------------- Wurzel -------------------------
function AlsVielfachesVonPioderleer(x:extended):string;
   var z,n:extended;
begin
  result:=''; //Misserfolg
  if x > 1E9 then exit;
  try
    if ErmittleBruche(x/Pi,z,n,1E-15) then Begin
       if abs(n)<1000000 then BEgin
         if n=1 then BEgin
           if z = 1 then result := 'Pi' else
             if z = -1 then result := '-Pi' else
               result:=RealIsIntegerToStr(z)+'*Pi'
         End else
           result:=RealIsIntegerToStr(z)+'/'+RealIsIntegerToStr(n)+'*Pi'
       ENd;
    End;
  except  End;
end;

function teilweiseRadiziert(n: extended): string;
  var NrPZ: Integer;
      z,qu: extended;
begin
  NrPZ := 0;
  z := 1;
  repeat
    qu:=PrZe(NrPz)*PrZe(NrPz);
    while IsInteger(n/qu,1E-15) do Begin
      z:=z*PrZe(NrPz);
      n:=n/qu;
    End;
    inc(NrPz);
  until (NrPz>1000) or (qu>n);
  if z=1 then result := 'sqrt('+floatToStr(n)+')' else
    result := FloatToStr(z)+'*sqrt('+floatToStr(n)+')';
end;

function letzterVersuchoderleer(x: extended): string;
 //x= (a+wur(b)/c  //a,c ganz, b>0 rational => b = (c*x-a)^2
   var z,n: extended;
       a,c,sgn: integer;
       nenner,
       sqrt_z_mal_n: string;
begin
  result := '';
  for c := 1 to 10 do for a := -10 to 10 do if c <> 0 then
    //z/n = (cx-a)^2 => cx - a = +- sqrt(z*n)/n => x = (a*n +- sqrt(z*n))/(c*n)
    if ErmittleBruche(sqr(c*x-a),z,n,1E-12) then
      if abs(z*n) < 1000 then Begin
      if abs(x*c*n - a*n - sqrt(z*n)) < abs(x*c*n - a*n + sqrt(z*n))
        then sgn := +1 else sgn := -1;
      if abs(x*c*n - a*n - sgn*sqrt(z*n)) > 1E-12 then exit;
      if alsIntegergleich(c*n,1) then nenner:='' else nenner := '/'+floatToStr(c*n);
      if sgn = 1 then result := '+' else result := '-';
      //result := '(' + floatToStr(a*n) + result + 'sqrt(' +floatToStr(z*n) +'))' + nenner;
      sqrt_z_mal_n := teilweiseRadiziert(z*n);
      result := '(' + floatToStr(a*n) + result + sqrt_z_mal_n +')' + nenner;
    exit;
  End;
end;

function AlsWurzeloderPi(x0:extended; wur:string):string; //evtl. ''
         //es wird versucht x=a/b*wur(c)
         //-> x^2=z/n Nenner klein genug, dann x=1/n*wur(z*n)
        var c,xq,z,n,qu:extended;
            NrPZ:integer;
    function mitWurzel(x,z,n,c:extended):string;
        var wu:string;
      begin
        kuerzee(z,n);
        if abs(c-1)<1E-15 then wu:='' else wu:='*'+wur+'('+RealIsIntegerToStr(c)+')';
        if n=1 then Begin
          if z=1 then result:=copyab(wu,2) else result:=RealIsIntegerToStr(z)+wu
        End else result:=RealIsIntegerToStr(z)+'/'+
                             RealIsIntegerToStr(n)+wu;
        if x<0 then result:='-'+result;
      end;
begin
  result:='';
  try
    xq:=x0*x0; 
  except result := ''; exit End;
  try
      if ErmittleBruche(xq,z,n,1E-15) then if abs(n)<1000000000 then Begin
         if abs(z) < g_eps then Begin
           result := '0'; //sonst lautet Primfaktorenzerlegung 0*2*2*2....
           exit;
          End;
         //x^2=z/n => x=1/n*wur(z*n);
         //z.B. 123/124*wur(2/19) hoch 2=  15 129*146 072
        c:=z*n; //x=1/n*wur(c)
      //Teilweise radizieren!
        z:=1;
        if c>1000000 then exit;
        NrPZ:=0;
        repeat
          qu:=PrZe(NrPz)*PrZe(NrPz);
          while IsInteger(c/qu,1E-15) do Begin
            z:=z*PrZe(NrPz);
            c:=c/qu;
          End;
          inc(NrPz);
        until (NrPz>1000) or (qu>c);
        result:=mitWurzel(x0,z,n,c);
      End
  finally
    if result = '' then result := AlsVielfachesVonPioderleer(x0);
    if result = '' then result := letzterVersuchoderleer(x0);
    if abbrechen <> nil then BEgin
      abbrechen.free;
      abbrechen := nil;
      FRechne.Enabled := true;
      frechne.Show;
    End;
  ENd;
end;

function AlsBruchoderWurzel(r: extended): string;
begin
  try
    if isinteger(r,g_eps) then Begin
      result := formatfloat('0',r);
      exit;
    End;
    result := reellZuBruchefallsmoeglichsonstleer(r,true,eps_fuerBruch);
    if pos('/', result) > 0 then exit;
    if result = '' then  result := AlsWurzeloderPi(r,'sqrt');
  except result := entferneSpacesNachMinus(formatfloat('0.

#',r)) End; if result ='' then result := FloatToStrF(r,ffGeneral,12,10) else result := result + '=' + FloatToStrF(r,ffGeneral,12,10); end; function GleichBruchoderWurzelsonstleer(r: extended): string; var s: string; begin s := AlsWurzeloderPi(r,'sqrt'); if (pos('/', s) > 0) or (pos('sqrt',s) > 0) then result := '=' + s else result := '' end; function AlsBruchoderWurzelmitNaeherung(r: extended): string; begin result := AlsBruchoderWurzel(r); if pos(decimalseparator,result) = 0 then if not isInteger(r,eps_fuerBruch) then result := result + ' = ' + ssd_(r,3); end; begin //initialisierung für Primzahlen setlength(PZe,2); PZe[0] := 2; PZe[1] := 3; nPze := 1; //Zählung ab 0 end.