unit jmalg;

interface

const
    bintBasis = 10000; //= 10 Höher, dann Probleme mit rest negativ bei BintDiv
    bintBasishalb = bintBasis div 2;
    bintStellen = 4;

type polynom = array of extended;
     //Polynom p[0] + p[1]x + p[2]x^2 + p[3]x^3 + ...
     bint = array of integer; //Biginteger Index 0 = Vorzeichen
     (*Darstellung als bintBasisSystem.
     Wie Zehnersystem, nur Ziffern ={0,1,2,...,bintBasis - 1}
     bint[0] ist Vorzeichen
     bint[1] die Einer, bint[2] die Ziffer von bintBasis,
     bint[3] = die Ziffer von bintBasis^2 etc*)
     breal   = bint;             //Biginteger mit Festkomma

var jmalgStop: boolean=false;
     festkomma: integer=24; //Ein Vielfaches von 4

// Big Integers
function BintNull(var p:Bint): boolean;
function bIntToStrshow(p: Bint): string; //Für Testzwecke
function IntToBint(n: integer): Bint;
function BintToStr(p: Bint): string;
function StrToBint(s: string): bint;
function BintToInt(p: Bint): integer;
procedure Bintnormal(var p:Bint);
function BintBetragkleiner(p,q: Bint): boolean;
function Bintkleiner(p,q: Bint): boolean;
function Bintgleich(p,q: Bint): boolean;
function Bintduplikat(p: Bint): Bint;
function BintAddBetrag(p1, p2:Bint): Bint; //beide positiv oder beide negativ
function BinBetragSubtr(p1,p2: Bint): Bint;
function BintAdd(p1, p2:Bint): Bint;
function BintSubtr(p1, p2:Bint): Bint;
function BintSmult(x: integer; p: Bint; shift: integer):Bint;
function BintMult(p1, p2:Bint): Bint;
procedure BintDivmitRest(pp1, pp2:Bint; var quotient,rest: Bint);
function BintDiv(p1,p2: Bint): Bint;
function BintMod(p1,p2: Bint): Bint;
function BintHoch(p: Bint; n:integer): bint;
// Big Real = Bint mit Festkomma
function realToBreal(r: extended): Bint;
function BrealToStr(rr:Breal): string;
function StrToBreal(s: string): Breal;
function BrealAdd(r1,r2: Breal): Breal;
function BrealSubtr(r1,r2: Breal): Breal;
function BrealMult(r1,r2: Breal): Breal;
function BrealDiv(r1,r2: Breal): Breal;
function BrealHoch(r1,r2: Breal): Breal;
function BRealabs(r1: Breal): Breal;
function TermToBReal(s:string): BReal;
// -------- Ploynome ---------------
procedure polynomnormal(var p:polynom);
function polynomduplikat(p: polynom): polynom;
function PolynomSmult(x: extended; p: polynom; shift: integer):polynom;
function PolynomAdd(p1, p2:polynom): polynom;
function PolynomMult(p1, p2:polynom): polynom;
function PolynomDivisionMitRest(p1, p2:polynom; var quotient,rest: polynom): string;
procedure zerlegeInKlammern(s: string; var kl1, kl2: string);
function  strgToPolynom(s: string):polynom;
function polynomToStr(p: polynom): string;
function polynomToStrx(p: polynom): string;

implementation

uses  forms, //Application
      Sysutils, //trim
      unitlsg, //formlsg.Caption
      jminput, jmhilf, jmbruch,jmmath;

function BintNull(var p:Bint): boolean;
begin
  if length(p) = 2 then if p[1] = 0 then Begin
    result := true;
    exit;
  End;
  if length(p) <= 1 then Begin
    setlength(p,2);
    p[0] := 1;
    p[1] := 0;
    result := true;
  End else result := false;
end;

function bIntToStrshow(p: Bint): string; //Für Fehlerangabe
  var k:integer;
begin
  result := inttoStr(p[0])+ '*';
  for k := length(p) - 1  downto 1 do  result :=result + ' ' +inttoStr(p[k]);
end;


function IntToBint(n: integer): Bint;
begin
  setlength(result,1);
  if n >= 0 then result[0] := 1 else result[0] := -1;
  n := abs(n);
  repeat
    setlength(result,length(result) + 1);
    result[length(result) - 1] := n mod BintBasis;
    n:=n div bintBasis;
  until n=0;
  BintNormal(result);
end;

function BintToStr(p: Bint): string;
  var k: integer;
      s: string;
begin
  result := '';
  for k := 1 to length(p) - 1 do Begin
    s := IntToStr(abs(p[k]));
    if k < length(p) - 1 then while length(s) < BintStellen do s := '0' + s;
    result := s + result;
  End;
  if result='' then result := '0' else
    if p[0] < 0 then result := '-' + result;
end;

function StrToBint(s: string): bint; //Ohne Leerstellen
  var k:integer;
begin
  setlength(result,1);
  if char_(s,1) = '-' then Begin
    s := copyab(s,2);
    result[0] := -1;
  End else result[0] := 1;
  k:=0;
  while s > '' do Begin
    inc(k);
    setlength(result,k+1);
    result[k] := StrToInt(copy(s,length(s) - BintStellen + 1, BintStellen));
    s := copy(s,1,length(s) - BintStellen );
  End;
  BintNormal(result);
end;

function BintToInt(p: Bint): integer;
begin
  try
    result := StrToInt(BintToStr(p));
  except okp('Fehler BintToInt ' + bIntToStrshow(p)); result := 0 End;
end;

procedure uebertragVornehmen(var p:Bint);
  var k:integer;
begin
  if length(p) <= 1 then Begin // p=0
    setlength(p,2);
    p[0] := 1;
    p[1] := 0;
    exit;
  End;
  for k := 1 to length(p) - 2 do
    if p[k] >= BintBasis then Begin
    p[k+1] := p[k+1] + p[k] div BintBasis;
    p[k] := p[k] mod BintBasis;
  End;
  while p[length(p)-1] > BintBasis do Begin
    setlength(p,length(p) + 1);
    p[length(p) - 1] := p[length(p) - 2] div BintBasis;
    p[length(p) - 2] := p[length(p) - 2] mod BintBasis;
  End;
end;

procedure Bintnormal(var p:Bint);
  var k:integer;
begin
  if BintNull(p) then exit;
  uebertragVornehmen(p);
  k := length(p) - 1;
  while (k >= 2) and (p[k] = 0) do Begin
    setlength(p,length(p) - 1);
    dec(k);
  End;
  for k := 1 to length(p) - 2 do
    if p[k] < 0 then
      while p[k] < 0 do Begin
        inc(p[k],bintBasis);
        dec(p[k+1]);
      End;
  if p[length(p) - 1] < 0 then Begin
    for k := 0 to length(p) - 1 do
      p[k] := - p[k]; //der negative Wert; Jetzt p[length(p) - 1] > 0
      BintNormal(p);
  End;
end;

function BintBetragkleiner(p,q: Bint): boolean;
  var k: integer;
begin
  if length(p) < length(q) then Begin
    result := true;
    exit;
  End;
  if length(p) > length(q) then Begin
    result := false;
    exit;
  End;
  k := length(p); // = length(q)
  while k > 1 do Begin
    dec(k); //k von length(p) - 1 bis 1
    if p[k] < q[k] then BEgin
      result := true;
      exit;
    ENd;
    if p[k] > q[k] then BEgin
      result := false;
      exit;
    ENd;
  End;
  result := false;
end;

function Bintkleiner(p,q: Bint): boolean;
begin
  if p[0] < q[0] then Begin //p <0 und q > 0
    result := true;
    exit;
  End;
  if p[0] > q[0] then Begin //p > 0 und q < 0
    result := false;
    exit;
  End;
  //p und q gleiches Vorzeichen
  if p[0] > 0 then result := BintBetragkleiner(p,q) else //5 < 7
    result := BintBetragkleiner(q,p);                   //-7 < -5
end;

function Bintgleich(p,q: Bint): boolean;
  var k: integer;
begin
  BintNormal(p);
  BintNormal(q);
  if length(p) <> length(q) then Begin
    result := false;
    exit;
  End;
  for k := 0 to length(p)-1 do if p[k] <> q[k] then Begin
    result := false;
    exit;
  End;
  result := true;
end;

function Bintduplikat(p: Bint): Bint;
  var k:integer;
begin
  setlength(result,length(p));
  for k := 0 to length(p) - 1 do result[k] := p[k];
   BintNormal(result);
end;

function BintAddBetrag(p1, p2:Bint): Bint;
  var k,n1,n2: integer;
begin
  n1 := length(p1);
  n2 := length(p2);
  setlength(result,n1);
  result[0] := p1[0]; //p1 und p2 gleiches Vorzeichen
  for k := 1 to n1 - 1 do
    if k < n2 then result[k] := p1[k] + p2[k] else result[k] := p1[k];
  if n2 > n1 then Begin
    setlength(result,n2);
    for k := n1 to n2 - 1 do result[k] := p2[k];
  End;
  Bintnormal(result);
end;

function BinBetragSubtr(p1,p2: Bint): Bint; //result := |p1| - |p2| für |p1| > |p2|
  var k: integer;
      p11: bInt;
begin
  assert((length(p1)>0) and (length(p2)>0));
  p11 := BintDuplikat(p1);
  setlength(result,length(p1));
  for k := 1 to length(p1) - 1 do Begin
    if k > length(p2) -1 then result[k] := p11[k]
      else result[k] := p11[k] - p2[k];
    while result[k] < 0 do BEGIN
        result[k] := result[k] + bintBasis;
        if length(p11) < k+2 then setlength(p11,k+2);
        dec(p11[k+1]);
      END;
  End;
  BintNormal(result);
end;

function BintAdd(p1, p2:Bint): Bint;
begin
  if p1[0] = p2[0] then Begin
    result := BintAddBetrag(p1,p2);
    exit;
  End;
  if BintBetragkleiner(p2,p1) then Begin //|p2| < |p1|
    result := BinBetragSubtr(p1,p2); //|p1| - |p2|
    if p1[0] > 0 then result[0] := 1 else result[0] := -1;
  End else Begin //|p1| < |p2|
    result := BinBetragSubtr(p2,p1); //|p2| - |p1|
     if p1[0] > 0 then result[0] := -1 else result[0] := 1;
  End;
  BintNormal(result);
end;

function BintSubtr(p1, p2:Bint): Bint;
  var p22: Bint;
begin
  p22 := BintDuplikat(p2);
  p22[0] := -p22[0];
  result := BintAdd(p1,p22);
end;

function BintSmult(x: integer; p: Bint; shift: integer):Bint;
  var k:integer;
begin
  setlength(result,length(p)+shift);
  if x <0 then result[0] := - p[0] else result[0] := p[0];
  for k := 1 to shift do result[k] := 0;
  for k := 1 to length(p) - 1 do result[k + shift] := x*p[k];
  Bintnormal(result);
end;

function BintMult(p1, p2:Bint): Bint;
  var k: integer;
begin
  setlength(result,1);
  result[0] := 1;
  for k := 1 to length(p2) - 1 do
    result :=  BintAddBetrag(result,BintSmult(p2[k],p1,k-1));
  if (length(p1) > 0 ) and (length(p2) > 0) then Begin
    if (p1[0] > 0) and (p2[0] > 0) or (p1[0] < 0) and (p2[0] < 0) then
      result[0] := 1 else result[0] := -1;
  End else result[0] :=1;
  Bintnormal(result);
end;

function BintHoch(p: Bint; n:integer): bint;
  var pp: bint;
begin
  result := intToBint(1);
  pp := BintDuplikat(p);
  while n > 0 do
    if odd(n) then Begin
      result := BintMult(result,pp);
      n := n -1;
    End else Begin
      pp :=BintMult(pp,pp);
      n := n div 2
    End;
  BintNormal(result);
end;

procedure BintDivMitRest(pp1, pp2:Bint; var quotient,rest: Bint);  //hier Rest immer > 0
  var k, shift: integer;
      hoechsterKoeffizientvonp2,
      x: integer;
      p1,p2: Bint;
begin
  p1    := BintDuplikat(pp1);
  p1[0] := 1;
  p2    := BintDuplikat(pp2);
  p2[0] := 1;
  setlength(quotient,1);
  if (p1[0] > 0) and (p2[0] > 0) or (p1[0] < 0) and (p2[0] < 0) then
    quotient[0] := 1 else quotient[0] := -1;
  rest := Bintduplikat(p1);
  // Beispiel 25 12 05 : 06 02 = 4
  //        -(24 08)
  //        ----------
  //          01 04 05
  hoechsterKoeffizientvonp2 := p2[length(p2) - 1];
  shift := length(p1) - length(p2);
  for k := length(p1) - 1 downto length(p2) - 1 do Begin
    // x :=  bintBasis*rest[k+1] + rest[k] : ...für höchstend k+1 = length(rest) -1
    // x := bintBasis*rest[k+1] + rest[k] : ... für höchstens  k := length(rest) -1
    // x:= 0 sonst
    if k+2 <= length(rest) then
      x := (bintBasis*rest[k+1] + rest[k]) div hoechsterKoeffizientvonp2 else
       if k+1 <= length(rest) then x := rest[k] div hoechsterKoeffizientvonp2
         else x := 0;
    if x < 0 then
      okp('Fehler in DivMitRest');
    //rest := rest - (-x)*p2
    rest := BIntSubtr(rest,BintSmult(x,p2,shift));
    while rest[0] < 0 do Begin
      dec(x);
      rest := BintAdd(rest,BintSMult(1,p2,shift))
    End;
    quotient := BintSmult(1,quotient,1);
    if jmalgStop then exit;
    application.ProcessMessages;
    if length(quotient) < 2 then setlength(quotient,2);
    quotient[1] := x;
    dec(shift);
  End;
  Bintnormal(quotient);
  Bintnormal(rest);
  if pp1[0] < 0 then Begin
    rest[0] := -1;
    if pp2[0] > 0 then quotient[0] := -1;
  End else if pp2[0] < 0 then quotient[0] := -1;
  //quotient negativ wenn p1*p2 negativ
  //Rest negativ, wenn p1 negativ;
  //Stets a div b = q + rest <=> a = b*q + r
end;

function BintDiv(p1,p2: Bint): Bint;
  var rest: Bint;
begin
 BintDivMitRest(p1,p2,result,rest);
end;

function BintMod(p1,p2: Bint): Bint;
  var q: Bint;
begin
 BintDivMitRest(p1,p2,q,result);
end;

procedure polynomnormal(var p:polynom);
  var k:integer;
begin
  for k := 0 to length(p) - 1 do if abs(p[k]) < 1E-12 then p[k] := 0;
  k := length(p) - 1;
  while (k > 0) and (p[k] = 0) do Begin
    setlength(p,length(p) - 1);
    dec(k);
  End;
end;

// ------------ Ende BInt --- Beginn Breal --------------------
function realToBreal(r: extended): Bint; //result = Bint/10^Festkomma
  var k: integer;
      r0: extended;
begin
  r0 := abs(r);
  result := intToBint(trunc(r0));
  result[0] := 1;
  for k := 1 to festkomma do Begin
     r0 := frac(r0)*10;
    result := BintAdd(BintMult(result,IntToBInt(10)), IntToBint(trunc(r0)));
  End;
  if r < 0 then result[0] := -1 else result[0] := 1;
end;

{procedure rundeauf(var s:string; k:integer); //k = length(s)
begin
  if k <=0 then Begin
    s := '0' + s;
    rundeauf(s,1);
  End else if s[k] = '.' then rundeauf(s,k-1) else Begin
    //Nun k >=1 und s[k] ='0' ... oder s[k]='9'
    if s[k] < '9' then inc(s[k]) else BEgin
      s[k] := '0';
      rundeauf(s,k-1);
    ENd;
  End;
end; }

procedure Endnullenweg(var s: String);
  var t:string;
begin
  if char_(s,length(s)-1) = '0' then
    if char_(s,length(s)-1) = '0' then Begin
      t := s;
      kup(t);
      while char_(t,length(t)) = '0' do kup(t);
      if length(t) < length(s) - 10 then BEgin
        s := t;
        exit; //Nur die letzte Zifer war <>0
      ENd;
    End;
  if char_(s,length(s)-1) = '9' then
    if char_(s,length(s)-1) = '9' then Begin
      t := s;
      kup(t);
      while char_(t,length(t)) = '9' do kup(t);
      if char_(t,length(t)) in ['.',','] then BEgin
        kup(t);
        s := BrealToStr(BrealAdd(StrToBreal(t),RealToBreal(1)));
        exit;
      End;
  End;
  while s[length(s)] = '0' do kup(s);
end;


function BrealToStr(rr:Breal): string;
  var rrr:Breal;
      //c: char;
Begin
  if jmalgstop then Begin
    result := 'Abbruch!';
    exit;
  End;
  if length(rr) = 0 then Begin
    result := '0';
    exit;
  End;
  rrr := BIntduplikat(rr);
  rrr[0] := 1;
  result := BintToStr(rrr);
  while length(result) <= Festkomma do result := '0' + result;
  result := copy(result,1,length(result) - festkomma)+ Decimalseparator + copyab(result,length(result) - festkomma + 1);
  Endnullenweg(result);
  if result[length(result)] in ['.',','] then kup(result);
  if rr[0] < 0 then result := '-' + result;
end;

function StrToBreal(s: string): Breal;
  var k: integer;
      nachkomma: string;
begin
  k := pos('.',s);
  if k =0 then k :=pos(',',s);
  if k = 0 then nachkomma := '' else Begin
    nachkomma := copyab(s,k+1);
    s := copy(s,1,k-1);
  End;
  result := StrToBint(s);
  result[0] := 1;
  result := BintMult(result,Binthoch(intToBint(10),Festkomma));
  for k := 1 to length(nachkomma) do
  result := BintAdd(result,BintMult(IntToBint(StrToInt(nachkomma[k])),Binthoch(intToBint(10),Festkomma-k)));
  if pos('-',s) > 0 then result[0] := -1;
end;

function BrealAdd(r1,r2: Breal): Breal;
  begin result := BintAdd(r1,r2) End;
function BrealSubtr(r1,r2: Breal): Breal;
  begin result := BintSubtr(r1,r2) end;

Procedure Divisiondurch10hochFestkommaMitRunden(var p:Bint);
   var k, n:integer;
begin
  n := festkomma div 4; //p[1] := p[1+n] p[2] := p[2+n]
  if n < length(p) then if p[n] >= bintBasishalb then Begin
    if length(p) < n then setlength(p,length(p) + 1);
    try inc(p[n+1]);
    except okp('Fehler in Divisiondurch10hochFestkommaMitRunden:' + BrealToStr(p)) End;
  End;
  for k := 1 to length(p) - 1 - n do p[k] := p[k + n];
  if n <=length(p) then setlength(p,length(p) - n) else setlength(p,1);
  uebertragVornehmen(p);
end;

function BrealMult(r1,r2: Breal): Breal;
begin
  result := BintMult(r1,r2);
  Divisiondurch10hochFestkommaMitRunden(result);
  //result := BintDiv(BintMult(r1,r2),BintHoch(intToBint(10),Festkomma)); //Ohne Runden!!
  //ktest(bIntToStrshow(test) + #13 + bIntToStrshow(result));
end;

procedure Mult10hochFestkommaplusbintStellen(var p:BInt);
  var k,n:integer;
begin
  n := (festkomma div 4) + 1; //p[1] := p[1+n] p[2] := p[2+n]
  setlength(p,length(p) + n);
  for k := length(p) - 1 downto 1 + n do p[k] := p[k-n];
  for k := 1 to n do p[k] := 0;
end;

Procedure DivisiondurchIntStellenMitRunden(var p:Bint);
var k:integer;
begin
  //n := 1; //p[1] := p[1+n] p[2] := p[2+n]
  if p[1] >= bintBasishalb then inc(p[2]);
  for k := 1 to length(p) - 2 do p[k] := p[k + 1];
  if length(p) >=1 then setlength(p,length(p) - 1) else setlength(p,1);
  uebertragVornehmen(p);
end;

function BrealDiv(r1,r2: Breal): Breal;
begin
  result := BintDuplikat(r1);
  Mult10hochFestkommaplusbintStellen(result);
  result := BintDiv(result,r2);
  DivisiondurchIntStellenMitRunden(result);
  //result := BintDiv(BintMult(r1,BintHoch(intToBint(10),festkomma)),r2);
end;

function BrealHoch(r1,r2: Breal): Breal;
  var pp: breal;
      n: integer;
begin
  n := StrToInt(BrealToStr(r2));
  result := realToBReal(1);
  if n < 0 then Begin
    r2 := BrealSubtr(IntToBint(0),r2); // r2 := -2;
    result := BrealHoch(r1,r2);      // result := r1^(-r);
    r1 := IntToBint(1);
    Mult10hochFestkommaplusbintStellen(r1);
    result := BrealDiv(r1,result);//Rekursiv
    DivisiondurchIntStellenMitRunden(result);
    exit;
  End;
  pp := BintDuplikat(r1);
  while n > 0 do
    if odd(n) then Begin
      result := BRealMult(result,pp);
      n := n -1;
    End else Begin
      pp :=BRealMult(pp,pp);
      n := n div 2
    End;
end;

function BRealabs(r1: Breal): Breal;
begin
  result := Bintduplikat(r1);
  result[0] := 1;
end;

function BrealSqrt(a: Breal): breal;
  var x: Breal;
begin
  x := RealToBreal(1);
  if a[0] < 0 then Begin
    result := x;
    okp('Fehler Sqrt von '+BrealToStr(a));
    exit;
  End;
  repeat
    result := x;
    if jmalgStop then Begin result := RealToBreal(0); exit End;
    application.ProcessMessages;
    formlsg.Caption := 'Rechenblatt rechnet eine Quadratwurzel';
    //x := (x+a/x)/2
    x := BrealDiv(BrealAdd(x,BrealDiv(a,x)),RealToBreal(2));
  until BIntGleich(x,result);
end;



function istVariableDatenblatt(const s:string):boolean;
//z.B.  Parametersatz =' x=-5/7  x0=4,74 alpha=30.9 ';
begin
  result := pos(' ' + s + '=',Parametersatz) > 0;
end;

function wertderVariablenDatenblatt(const s:string):Breal;
  var k,j: integer;
begin
  k := pos(' ' + s + '=',Parametersatz);
  while (k <= length(Parametersatz)) and (Parametersatz[k]<>'=') do inc(k); //"=" muss vorhanden sein!
  j := k + 1;
  while (j <= length(Parametersatz)) and (Parametersatz[j]<>' ') do inc(j); //Leerstelle muss vorhanden sein!
  result := StrToBreal(copy(Parametersatz,k+1,j - k - 1));
end;

function wertderVariablenOderDefaultDatenblatt(const s, default:string):Breal;
begin
   if not istVariableDatenblatt(s) then Begin
     Parametersatz := '  ' + s + '=' + BrealToStr(TermToBreal(default)) +
       '  ' + Parametersatz + ' '; //Am Anfang nur ein Buchstabe!
     okp('Neuen Parameter gesetzt:'+s+'='+default);
   End;
   result := wertderVariablenDatenblatt(s);
end;

function BrealFakInt(n: Integer): Breal;
  var k:integer;
begin
  result := RealToBreal(1);
  for k := 2 to n do  Begin
    result := BrealMult(realToBReal(k),result);
  End;
end;

function BrealToInt(r: Breal): integer;
begin
  try
    result := Round(StrToInt(BrealToStr(r)));
  except
    okp('Fehler bei Parameter ' + BrealToStr(r));
    result := 0
  End;
end;

function BrealFakBReal(a: Breal): Breal;
begin
  result := BrealFakInt(BrealToInt(a));
end;

function BrealnueInt(const n,k: integer): Breal; // n über k
  var i:integer;
begin
  result := RealToBreal(1);
  for i := 1 to k do Begin
    if jmalgStop then exit;
    application.ProcessMessages;
    result := BrealDiv(BrealMult(result,realToBreal(n-i+1)),realToBReal(i));
  End;
end;

function BrealnueBreal(k: Breal): Breal;   //n über k
  var n:integer;
begin
   n := BrealToInt(wertderVariablenOderDefaultDatenblatt('n','49'));
   result := BrealNueInt(n,BrealToInt(k));
end;

function BrealBinInt(const n,k: integer; p: Breal): Breal; // n über k * p^k *(1 - p)^k
begin
  result := BrealMult(BrealMult(
    BrealnueInt(n,k),Brealhoch(p,RealToBreal(k))),BrealHoch(BRealSubtr(RealToBreal(1),p),RealToBreal(n-k)));
end;

function BrealBinBreal(k: Breal): Breal;   //n über k
  var n:integer;
      p: Breal;
begin
   n := BrealToInt(wertderVariablenOderDefaultDatenblatt('n','49'));
   p := wertderVariablenOderDefaultDatenblatt('p','1/6');
   result := BrealBinInt(n,BrealToInt(k),p);
end;

function BrealSummeBin0(const n, x: integer; p: Breal): Breal;
var m: integer;
begin
  result := RealToBreal(0);
  for m := 0 to x do Begin
    if jmalgStop then Begin result := RealToBreal(0); exit End;
    application.ProcessMessages;
    formlsg.Caption := 'Rechenblatt rechnet eine Summe';
    result := BrealAdd(result,BrealBinInt(n, m, p));
  End;
end;

function BrealSummeBin(x: Breal): Breal;
begin
    result := BrealSummeBin0(
                BrealToInt(wertderVariablenOderDefaultDatenblatt('n','50')),
                BrealToInt(x), wertderVariablenOderDefaultDatenblatt('p','1/6'))
end;

function TermToBReal(s:string): BReal;
 function TTR(s:string): Breal; //TTR = Abkürzung
      //——— Hilfsfunktionen ————————————————————
      var u2,v2, u3,v3, u4, v4, u6, v6: string; //für Funktionen wie "ln",  "sin", "sqrt"
   function pos0(c:char;s:string):integer;
     //pos0 findet das Zeichen "+","-" ... nicht innerhalb von Klammern
      var k,z:integer; //z:=Anzahl der Klammern
   begin
     z:=0;
     for k:=length(s) downto 1 do Begin
       if s[k]='(' then inc(z);
       if s[k]=')' then dec(z);
       if (z=0) and (s[k]=c) then BEgin
        result:=k; //Treffer
        exit;
      ENd;
    End;
    result:=0; //nichts gefunden
  end;

   function anfang(s:string;c:char):string;
   begin
     anfang:=copy(s,1,pos0(c,s)-1);
   end;

   function copyab(const s:string; const i:integer):string;
     begin result:=copy(s,i,length(s)-i+1) end;

   function ende(s:string; c:char):string;
   begin
     ende:=copyab(s,pos0(c,s)+1)
   end;
   Procedure MalzeichenSetzten(var s:string);
    //macht aus 2x = 2*x , aus 2(a+b) = 2*(a+b), aus (a+b)c = (a+b)*c,
    // aus (a+b)(a-b) =(a+b)*(a-b), aus 2sin(x) = 2*sin(x) u.s.e.
     var k: integer;
   begin
     for k := 1 to length(s) - 1 do
       if (s[k] in ['0'..'9',')']) and (s[k+1] in ['a'..'z','A'..'Z','(']) then Begin
       s := copy(s,1,k) + '*' + copyab(s,k+1);
       MalzeichenSetzten(s); //rekursiv
       exit; //length(s) ist größer geworden
    End;
end;
 begin
  result := realToBreal(0);
  if jmalgStop then exit;
  application.ProcessMessages;
  s := trim(s);
  if s[1]='-' then s:='0'+s; //zB. s='-7/3x+14' -> s='0-7/3x+14'
  if s = '' then exit;
  MalzeichenSetzten(s);
  u2:=copy(s,1,2);  //zum Beispiel u2 = 'ln'
  v2:=copyab(s,3);
  u3:=copy(s,1,3);  //zum Beispiel u3 = 'sin'
  v3:=copyab(s,4);
  u4:=copy(s,1,4);  //zum Beispiel u4 = 'sqrt'
  v4:=copyab(s,5);
  u6:=copy(s,1,6);  //zum Beispiel u4 = 'arctan'
  v6:=copyab(s,7);
  //Zuerst ganzrationale Funktion
  if pos0('+',s)>0  then result:=BrealAdd(TTR(anfang(s,'+')),TTR(ende(s,'+'))) else
  if pos0('-',s)>0  then result:=BrealSubtr(TTR(anfang(s,'-')),TTR(ende(s,'-'))) else
  if pos0('*',s)>0 then  result:=BrealMult(TTR(anfang(s,'*')),TTR(ende(s,'*'))) else
  if pos0('/',s)>0 then  result:=Brealdiv(TTR(anfang(s,'/')),TTR(ende(s,'/'))) else
  if pos0('^',s)>0 then  result:=BrealHoch(TTR(anfang(s,'^')),TTR(ende(s,'^'))) else
  //Jetzt die Funktionen
  if u3='abs' then result := BRealAbs(TTR(v3)) else
  if u3='fak' then result := BrealFakBReal(TTR(v3)) else
  if u3='nue' then result := BrealnueBReal(TTR(v3)) else
  if u3='Bin' then result := BrealBinBreal(TTR(v3)) else
  if u3='BiS' then result := BrealSummeBin(TTR(v3)) else
  if u4='sqrt' then result:=BrealSqrt(TTR(v4)) else //Nur Dummy
  //Jetzt die Klammern
  if (s>'') and (s[1]='(') then Begin //Am Anfang und Ende eine Klammer
    s:=copy(s,2,length(s)-2);
    result:=TTR(s)
  End else
        if istVariableDatenblatt(s) then result := wertderVariablenDatenblatt(s) else
    BEgin      try result:=strToBreal(s); except okp('Syntaxf. in '+s); exit end;
    ENd
end;
begin
  result := TTR(s);
end;

// -------------- Polynome -------------

function polynomduplikat(p: polynom): polynom;
  var k:integer;
begin
  setlength(result,length(p));
  for k := 0 to length(p) - 1 do result[k] := p[k];
end;

function PolynomSmult(x: extended; p: polynom; shift:integer):polynom;
  var k:integer;
begin
  setlength(result,length(p)+shift);
  for k := 0 to shift - 1 do result[k] := 0;
  for k := 0 to length(p) - 1 do
    result[k + shift] := x*p[k];
end;

function PolynomAdd(p1, p2:polynom): polynom;
  var k,n1,n2: integer;
begin
  n1 := length(p1);
  n2 := length(p2);
  setlength(result,n1);
  for k := 0 to n1 - 1 do
    if k < n2 then result[k] := p1[k] + p2[k] else result[k] := p1[k];
  if n2 > n1 then Begin
    setlength(result,n2);
    for k := n1 to n2 - 1 do result[k] := p2[k];
  End;
  polynomnormal(result);
end;

function PolynomMult(p1, p2:polynom): polynom;
  var k: integer;
begin
  setlength(result,0);
  for k := 0 to length(p2) - 1 do Begin
    result := PolynomAdd(result,PolynomSmult(p2[k],p1,k));
  End;
  polynomnormal(result);
end;



function PolynomDivisionMitRest(p1, p2:polynom; var quotient,rest: polynom): string;
  var k, shift: integer;
      hoechsterKoeffizientvonp2,
      x: extended;
begin
  result := '';
  setlength(quotient,0);
  rest := polynomduplikat(p1);
  hoechsterKoeffizientvonp2 := p2[length(p2) - 1];
  shift := length(p1) - length(p2);
  for k := length(p1) - 1 downto length(p2) - 1 do Begin
    if length(rest) < k + 1 then x := 0 else x:= rest[k]/hoechsterKoeffizientvonp2;
    quotient := PolynomSmult(1,quotient,1);
    quotient[0] := x;
    //rest := rest + (-x)*p2
    if abs(x) > 1E-12 then
      result := result + '-(' + polynomtostrx(PolynomSmult(x,p2,shift)) + ')' +#13#10
                       + '----------------------'#13#10;
    rest := PolynomAdd(rest,PolynomSmult(-x,p2,shift));
    if abs(x) > 1E-12 then result := result + polynomtostrx(rest) + #13#10;
    //okp(polynomtostrx(SmultPolynom(-x,p2,shift)) + #13+polynomtostrx(rest));
    dec(shift);
  End;
  polynomnormal(quotient);
  polynomnormal(rest);
end;


procedure zerlegeInKlammern(s: string; var kl1, kl2: string);
  var n: integer;
begin
  kl1 := '';
  kl2 := '';
  n := pos('(',s);
  if n = 0 then exit;
  s := copyab(s,n+1);
  kl1 := s;
  n := pos(')',kl1);
  if n = 0 then exit;
  kl1 := trim(copy(kl1,1,n-1));
  s:= copyab(s,n+1); //s = Klammer2
  n := pos('(',s);
  if n = 0 then exit;
  s := copyab(s,n+1);
  kl2 := s;
  n := pos(')',kl2);
  if n = 0 then exit;
  kl2 := trim(copy(kl2,1,n-1));
end;



function polynomToStr(p: polynom): string;
  var k:integer;
begin
  result := '(';
  for k := length(p) - 1 downto 0 do Begin
    result := result + ReellZuBruch(p[k]);
    if k <>0 then result := result + ' ';
  End;
  result := result + ')';
end;

function floatToStrMitVorz(x:extended): string;
begin
  if x = 0 then result :='' else Begin
    if abs(x) <> 1 then result := ReellZuBruch(x) else if
    x = -1 then result := '-';
    if x > 0 then result := '+' + result;
  End;
end;

function koeff_xhochnmitVorz(x: extended; n: integer): string;
begin
  result := '';
  if x = 0 then exit;
  Case n of 0: result := '';
            1: result := 'x';
       else result := 'x^' + intToStr(n);
  End;
  result := floatToStrMitVorz(x) + result;
  if (length(result) = 1) and (n=0) then result := result + '1';
end;

function polynomToStrx(p: polynom): string;
  var k:integer;
begin
  result := '';
  for k := length(p) - 1 downto 0 do result := result + koeff_xhochnmitVorz(p[k],k);
  if length(result)> 0 then if result[1] = '+' then result := copyab(result,2);
  if result = '' then result := '0';
end;

function ohneMalZeichen(const s: string): string;
  var k: integer;
begin
  result := s;
  if pos('*',s) =0 then exit;
  result := '';
  for k := 1 to length(s) do
    if s[k] <>'*' then result := result + s[k];
end;

function strgToPolynomMitX(s: string):polynom; //z.B. 1/2x^2+5/3x+7)
  var n,k,zahlAnfang,Zahllaenge,grad: integer;
      vorzahl: string;
begin
  s := ohneMalZeichen(s); //brutal
  n := pos('x',s);
  if n = 0 then Begin //Grad = 0
    setlength(result,1);
    result[0] := TermToRealTolerant(s);
    exit;
  End;
  vorzahl := copy(s,1,n-1);
  if (vorzahl = '') or (vorzahl='+') then vorzahl := '1';
  if vorzahl = '-' then vorzahl := '-1';
  if char_(s,n+1) = '^' then Begin
    zahlAnfang := n+2;
    Zahllaenge := 0;
    while char_(s,zahlAnfang+Zahllaenge) in ['0'..'9'] do inc(zahllaenge);
    grad := round(TermToRealTolerant(copy(s,zahlAnfang,zahllaenge)));
    setlength(result,grad+1);
    for k := 0 to grad do result[k] := 0;
    result[grad] := TermToRealTolerant(vorzahl);
    result := polynomadd(result,strgToPolynomMitX(copyab(s,zahlanfang+zahllaenge))); //rekursiv
  End else Begin
    grad := 1; //ohne "^"
    setlength(result,grad+1);
    if char_(s,n-1) in ['0'..'9'] then
      result[grad] := TermToRealTolerant(copy(s,1,n-1)) else
         result[grad] := 1;
    result := polynomadd(result,strgToPolynomMitX(copyab(s,n+1)));
  End;
end;

function strgToPolynom(s: string):polynom;
  var  k: integer;
       r: extended;
begin
  if pos('x',s) > 0 then Begin
    result := strgToPolynommitx(s);
    exit;
  End;
  s := s + magics;
  k := 1;
  setlength(result,0);
  r := rr_(s,1);
  while r < magicr do Begin
    setlength(result, k);
    result[k-1] := r;
    inc(k);
    r := rr_(s,k);
  End;
  //Reihenfolge umkehren
  for k := 0 to (length(result)-1) div 2 do
    tausche(result[k],result[length(result)-1 - k]);
end;

{procedure test;
  var s1,s2: string;
      r1,r2,rr: Breal;
begin
  festkomma := 40;
  s1 := '1';
  s2 := '2';
  r1 := strToBreal(s1);
  r2 := strToBreal(s2);
  r1 := realToBreal(1);

  rr := BrealMult(r1,r2);
  ktest(BrealToStr(rr));
end;


begin

test}

end.