kleiner, vlt auch etwas uneffizienter Mathe Parser

[mr_emre_d]

Mir war fad

Erkläuterung:

Code:

o Punkt vor Strich wird beachtet
o +-*/ kann er sehr gut lösen
o Klammern () werden unterstützt
evt buggy:
o Potenzieren via ^ möglich
o Wurzel ziehen XsY  -> 9s2 --> 3

EDIT
Math Unit wird benötigt

Aufruf könnte wie "ShowMessage( SolveProblem( Edit1.Text ) )" folgen

EDIT #n
Es sind keine Fehlerbehandlungen mit eingebaut worden:
Fehler:
- doppelte Operatoren
- Klammer offen vergessen
- "4+2-" ...
So das ist mein letzter Edit heute ...
Wünsch euch allen eine gute Nacht

Code:

Delphi-Quellcode:

var
  Operators: Set of Char = ['s', '^','+', '-', '*', '/'];
  Clamp: Set of Char = [ '(', ')', #8];
  Numbers: Set of Char = [ '0'..'9' ];

function SolveProblem( Problem: String ): String;
var
  newProblem: String;
  x, t: Word;          // x = pos, solution, ...
  Solution: Single;
  function OperatorInString(Buf: String): Boolean;
  begin
    Result := True;
    if Pos('s', Buf) = 0 then
      if Pos('^', Buf) = 0 then
        if Pos('*', Buf) = 0 then
          if Pos('/', Buf) = 0 then
            if Pos('+', Buf) = 0 then
              if Pos('-', Buf) = 0 then
                Result := False;
  end;
  // x3+3 --> x = left | startpos = +
  function GetLeft(P: String; StartPos: Word): Word;
  var
    x: Word;
  begin
    x := StartPos-1;
    while (P[x] in Numbers) and (x>=1) do
      dec(x);
    if x = 0 then
      Result := 1
    else
      Result := x+1;
  end;
  // 3+3x --> x = left | startpos = +
  function GetRight(P: String; StartPos: Word): Word;
  var
    x: Word;
  begin
    x := StartPos+1;
    while (P[x] in Numbers) and (x<=Length(P)) do
      inc(x);
    Result := x;
  end;
  {leftcompo+12}
  function GetLeftComponent(P: String): Single;
  var
    x: Word;
  begin
    x := Pos( 's', LowerCase(P) );
    if x = 0 then
      x := Pos( '^', P );
    if x = 0 then
      x := Pos( '*', P );
    if x = 0 then
      x := Pos( '/', P );
    if x = 0 then
      x := Pos( '+', P );
    if x = 0 then
      x := Pos( '-', P );
    if x = 0 then
      Result := x
    else
      result := StrToFloat( Copy( P, 1, x-1 ) );
  end;
  {123+rightcompo}
  function GetRightComponent(P: String): Single;
  var
    x: Word;
  begin
    x := Pos( 's', LowerCase(P) );
    if x = 0 then
      x := Pos( '^', P );
    if x = 0 then
      x := Pos( '*', P );
    if x = 0 then
      x := Pos( '/', P );
    if x = 0 then
      x := Pos( '+', P );
    if x = 0 then
      x := Pos( '-', P );
    if x = 0 then
      Result := x
    else
      result := StrToFloat( Copy( P, x+1, Length(p) ) );
  end;
  { (1*3*5+3+2 ..) }
  function SolveThatProblems(var P: String ): Single;
  var          //  3*5*6+5*6
    Sqrt, Sqr,
    Dot, _Div,
    Plus, Minus,
    x, y: Word;
    c1, c2: Single;
    buf: String;
  begin
    Minus := 0;
    Sqr := Pos( '^', P );
    if Sqr = 0 then
      Sqrt := Pos( 's', LowerCase(P) );
    if Sqrt = 0 then
      Dot := Pos( '*', P );
    if Dot = 0 then
      _Div := Pos( '/', P );
    if _Div = 0 then
      Plus := Pos( '+', P );
    if Plus = 0 then
      Minus := Pos( '-', P );

    if (Sqr > 0) then
    begin
      x :=  GetLeft(P, Sqr);
      y := GetRight(P, Sqr);
    end else
    if (Sqrt > 0) then
    begin
      x :=  GetLeft(P, Sqrt);
      y := GetRight(P, Sqrt);
    end else
    if (Dot > 0) then
    begin
      x :=  GetLeft(P, Dot);
      y := GetRight(P, Dot);
    end else
    if (_Div > 0) then
    begin
      x :=  GetLeft(P, _Div);
      y := GetRight(P, _Div);
    end else
    if (Plus > 0) then
    begin
      x :=  GetLeft(P, Plus);
      y := GetRight(P, Plus);
    end else
    if (Minus > 0) then
    begin                 
      x :=  GetLeft(P, Minus);
      y := GetRight(P, Minus);
    end else
    begin
      Result := 0;
      Exit;
    end;
    buf := copy( P, x, y-x );
    c1 :=  GetLeftComponent( buf );
    c2 := GetRightComponent( buf );
    if Sqr > 0 then
      Result := Power( c1, c2 )
    else
    if Sqrt > 0 then
      Result := Power( c1, 1/c2 )
    else
    if Dot > 0 then
      Result := c1*c2
    else
    if _Div > 0 then
      Result := c1/c2
    else
    if Plus > 0 then
      Result := c1+c2
    else
    if Minus > 0 then
      Result := c1-c2;
    delete( P, x, y-x );
    Insert( FloatToStr(Result), P, x );
    if OperatorInString(P) then
      SolveThatProblems(P)
    else
      Result := StrToFloat(P);
  end;
  function KlammerEnde(buf: String): Word;
  var
    kAufs, kZus: Word;
    i: Integer;
  begin
    kAufs := 0;
    kZus  := 0;
    for i := 1 to Length(buf) do
    begin
      if buf[i] = '(' then
        inc(kAufs)
      else
      if buf[i] = ')' then
      begin
        inc(kZus);
        if kAufs-kZus=0 then
        begin
          Result := i;
          Exit;
        end;
      end;
    end;
  end;
begin
  x := Pos('(', Problem);
  if x > 0 then
  begin
    newProblem := Copy( Problem, x+1, KlammerEnde(Problem)-x-1 );  // ausdruck in klammern
    Delete( Problem, x, Length(NewProblem)+2 );
    Insert( SolveProblem( newProblem ), Problem, x);
    x := Pos( '(', Problem );
    if x > 0 then
      Problem := SolveProblem( Problem );  // löse werte in einer klammer auf
  end;
  if OperatorInString( Problem ) then
    SolveThatProblems( Problem );
  Result := Problem;
end;

MfG