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:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:

unit MathParser;

(*******************************************************************************
* Description Free and powerfull recursive parser for mathematical epressions *
* Author      tyr (Martin Raifer)                                             *
* Company     asd                                                             *
* Creation    24.04.2004                                                      *
* Licence     Free (open source)                                              *
* Contact     martinrai2001 at hotmail dot com                                *
* Language    Documentation in german                                         *
*******************************************************************************)

interface

uses Classes;

  //Update 29.04.2004, Udontknow (Andreas Kreul, webmaster at xnebula dot de)
  // - Objektoriente Umsetzung der Unit Mathparser, Umwandlung von Constants
  //   von einem Array in ein Listenobjekt
  // - Korrektur in SwapConstants zwecks Unterstützung längerer Konstantennamen

  type TConstant=class(TObject)
    private
      FName:String;
      FValue:Extended;
    public
      property Name:String read FName write FName;
      property Value:Extended read FValue write FValue;
  end;

  type TConstants=class(TObject)
  private
    FItems:TList;
    function GetItems(Index: Integer): TConstant;
    procedure SetItems(Index: Integer; const Value: TConstant);
    function GetCount:integer;
    function Add:TConstant;
  public
    function IndexOf(name:String):Integer;
    procedure Delete(Index:Integer); overload;
    procedure Delete(Name:String); overload;
    procedure AddConstant(Name:String; Value:Extended);
    procedure Clear;

    property Items[Index:Integer]:TConstant read GetItems write SetItems; default;
    property Count:Integer read GetCount;

    constructor Create; virtual;
    destructor Destroy; override;
  end;

  type TMathParser=class(TObject)
    private
    {Die Funktion Parse bekommt einen String, der einen Mathematischen Term
     enthält. Als Ergebnis liefert Parse den berechneten Wert zurück.
     Im Parse sin Klammern, Strich- und Punktrechnungen, Trigonometrische Fkt-en,
     Hoch, Logaritmus und e Hoch in Kombination mit reellen Zahlen. Der String
     muss mathematisch korrekt sein, sonst wird die Funktion keinen brauchbaren
     Rückgabewert liefern. Außerdem darf der String keine Leerzeichen einthalten.
     Verwenden Sie deshalb die Funktion TrimSpace um evventuelle Leerzeichen zu
     entfernen!

     Funktionsweise:
       Die Funktion teilt den String str so lange nach mathematischen Regeln in
       kleinere Teilstrings auf, bis diese direkt mit mathematischen Funktionen
       oder StrToFloat-Umwandlungen übersetzt werden können.
     Praxisbeispiele:
       2-_xp(3,5)/(e^(7/2)) = 1 Diese Berechnung liefert das Ergebnis 1.000001
                                    und benötigt für die Berechnung 17 Aufrufe des
                                    Parsers
       (2*sin(90)-ln(1024)/ln(2))*(2*((3-(2^2))/2)) = 8 Ergebnis korrekt (= und
                                    benötigt 38 Iterationen.
       Man sieht, dass die Anzahl der Berschnungsschritte ausschließlich von der
       Komplexität der Rechenaufgabe abhängt. doppelte Komplexität ~= doppelte
       Laufzeit.
     }
      function Parse(str : string) : extended;
      {TrimSpace filtert alle Leerzeichen eines Strings heraus und löscht diese im
       Rückgabestring.}
      function TrimSpace(str : string) : string;

      {Über diese beiden Funktionen können Konstanten gemanaged werden. Mit AddConst
       können neue angelegt werden, mit SwapConstants werden alle Vorkommen einer
       Konstante im übergebenen String ersetzt.}
      function SwapConstants(str : string) : string;
    public
      Constants: TConstants;
    {Diese Funktion verwendet Parse, um einen String mathemetisch zu parsen,
     verarbeitet den String (Leerzeichenentfernung) und fängt evventuelle
     Exceptions ab. Auch werden alle vorhalndenen Konstanten eingesetzt. (siehe
     Fkt. SwapConstants) Diese Funktion sollte im Normalfall gegenüber von Parse
     verwendet werden, außer wenn man selbst auf Exeptions reagieren möchte.}

      function ParseStr(Str:String):Extended;

      constructor Create; virtual;
      destructor Destroy; override;
  end;

implementation

uses
  SysUtils, Math;

  function TMathParser.Parse(str : string) : extended;
  var a   : extended; 
      i,j : word;
    {Klammern gibt die Position der passenden abschließenden Klammer zurück} 
    function Klammern(str : string) : word; 
    var i,j : byte; 
    begin 
      Result := 0;
      j:=0; 
      for i:=1 to Length(str) do 
        case str[i] of 
          '(' : Inc(j); 
          ')' : begin 
                  Dec(j); 
                  if j=0 then 
                  begin 
                    Result := i; 
                    Exit; 
                  end; 
                end; 
        end; 
    end; 
  begin 
    {$ifdef Count_Recurses}
      Inc(count); 
    {$endif} 
    //- String '--' verhindern. aus '--' Plus machen 
    str := StringReplace(str, '--', '', [rfReplaceAll]); 
    //-Alle Klammern beseitigen! 
    if Pos('(', str) <> 0 then 
    begin 
      i:=Pos('(', str);
      i:= Klammern(Copy(str, i, high(integer)))+i-1; 
      {Wert in den Klammern berechnen} 
      a:=Parse(Copy(str, Pos('(', str)+1, i-Pos('(', str)-1)); 
      {Weiterparsen...} 
      str := Copy(str, 1, Pos('(', str)-1) + FloatToStr(a) + Copy(str, i+1, High(integer)); 
      Result := Parse(str); 
    end 
    //-Koonstanten 
    //else if processConsts then 
      //Result := const_value 
    //-Trigonometrische Funktionen 
    else if Pos('sin', str) <> 0 then 
    begin 
      i:=Pos('sin', str)+3; 
      while (str[i] in ['0'..'9',',']) or ((i=Pos('sin', str)+3)and(str[i]='-')) do 
        Inc(i); 
      {wie oben} 
      a := sin(2*Pi/360*Parse(Copy(str, Pos('sin', str)+3, i-(Pos('sin', str)+3)))); 
      str := Copy(str, 1, Pos('sin', str)-1) + FormatFloat('0.00000000########',a) + Copy(str, i, High(integer)); 
      Result := Parse(str); 
    end 
    else if Pos('cos', str) <> 0 then 
    begin 
      i:=Pos('cos', str)+3;
      while (str[i] in ['0'..'9',',']) or ((i=Pos('cos', str)+3)and(str[i]='-')) do 
        Inc(i); 
      a := cos(2*Pi/360*Parse(Copy(str, Pos('cos', str)+3, i-(Pos('cos', str)+3)))); 
      str := Copy(str, 1, Pos('cos', str)-1) + FormatFloat('0.00000000########',a) + Copy(str, i, High(integer)); 
      Result := Parse(str); 
    end 
    else if Pos('tan', str) <> 0 then 
    begin 
      i:=Pos('tan', str)+3; 
      while (str[i] in ['0'..'9',',']) or ((i=Pos('tan', str)+3)and(str[i]='-')) do 
        Inc(i); 
      a := tan(2*Pi/360*Parse(Copy(str, Pos('tan', str)+3, i-(Pos('tan', str)+3)))); 
      str := Copy(str, 1, Pos('tan', str)-1) + FormatFloat('0.00000000########',a) + Copy(str, i, High(integer)); 
      Result := Parse(str); 
    end 
    //-andere Funktionen 
    else if Pos('ln', str) <> 0 then 
    begin 
      i:=Pos('ln', str)+2; 
      while (str[i] in ['0'..'9',',']) or ((i=Pos('ln', str)+2)and(str[i]='-')) do 
        Inc(i); 
      a := Ln(Parse(Copy(str, Pos('ln', str)+2, i-(Pos('ln', str)+2)))); 
      str := Copy(str, 1, Pos('ln', str)-1) + FormatFloat('0.00000000########',a) + Copy(str, i, High(integer)); 
      Result := Parse(str);
    end 
    //Veraltert: Exponentialfunktion e hoch: wegen unkompatibilität zu Konstante 
    //e umbenannt von exp() in _xp(). 
    else if Pos('_xp', str) <> 0 then 
    begin 
      i:=Pos('_xp', str)+3; 
      while (str[i] in ['0'..'9',',']) or ((i=Pos('_xp', str)+3)and(str[i]='-')) do 
        Inc(i); 
      a := Exp(Parse(Copy(str, Pos('_xp', str)+3, i-(Pos('_xp', str)+3)))); 
      str := Copy(str, 1, Pos('_xp', str)-1) + FormatFloat('0.00000000########',a) + Copy(str, i, High(integer)); 
      Result := Parse(str); 
    end 

    //-Potenzfunktionen 
    else if Pos('^', str) <> 0 then 
    begin 
      i:=Pos('^', str)-1; 
      while str[i] in ['0'..'9',',','-'] do 
        Dec(i); 
      a := Parse(Copy(str, i+1, -i - 1 + Pos('^', str))); 
      j := i; 
      i:=Pos('^', str)+1; 
      while str[i] in ['0'..'9',',','-','^'] do 
        Inc(i);
      a := Power(a,Parse(Copy(str, Pos('^', str) + 1, -Pos('^',str) + i - 1))); 
      Result := Parse(Copy(str, 1, j)+FloatToStr(a)+Copy(str, i, high(integer))); 
    end 
    //-Punktrechnungen 
    else if Pos('*', str) <> 0 then 
    begin 
      i:=Pos('*', str)-1; 
      while str[i] in ['0'..'9',','] do 
        Dec(i); 
      a := StrToFloat(Copy(str, i+1, -i - 1 + Pos('*', str))); 
      j:=i; 
      i:=Pos('*', str)+1; 
      while (str[i] in ['0'..'9',',','*','/']) or ((str[i-1]='*')and(str[i]='-')) do 
        Inc(i); 
      a:=Parse(Copy(str, Pos('*', str) + 1, i-Pos('*',str) - 1)) * a; 
      Result := Parse(Copy(str, 1, j)+FloatToStr(a)+Copy(str, i, high(integer))); 
    end 
    else if Pos('/', str) <> 0 then 
    begin 
      i:=Pos('/', str)-1; 
      while str[i] in ['0'..'9',','] do 
        Dec(i); 
      a := StrToFloat(Copy(str, i+1, -i - 1 + Pos('/', str))); 
      j:=i;
      i:=Pos('/', str)+1; 
      while str[i] in ['0'..'9',',','/'] do 
        Inc(i); 
      a := a/Parse(Copy(str, Pos('/', str) + 1, -Pos('/',str) + i - 1)); 
      Result := Parse(Copy(str, 1, j)+FloatToStr(a)+Copy(str, i, high(integer))); 
    end 
    //-Strichrechnungen 
    else if Pos('+', str) <> 0 then 
    begin 
      i:=Pos('+', str)-1; 
      while str[i] in ['0'..'9',','] do 
        Dec(i); 
      a := StrToFloat(Copy(str, i+1, -i - 1 + Pos('+', str))); 
      j:=i; 
      i:=Pos('+', str)+1; 
      while str[i] in ['0'..'9',','] do 
        Inc(i); 
      a := StrToFloat(Copy(str, Pos('+', str) + 1, -Pos('+',str) + i - 1)) + a; 
      Result := Parse(Copy(str, 1, j)+FloatToStr(a)+Copy(str, i, high(integer))); 
    end 
    else if (Pos('-', str) <> 0) and (Pos('-',str) <> 1) then 
    begin 
      i:=Pos('-', str)-1; 
      while str[i] in ['0'..'9',','] do
        Dec(i); 
      //Sonderregelung bei negativen Zahlen: Vorzeichen allein genügt 
      if Copy(str, i+1, -i - 1 + Pos('-', str)) = '' then 
        a:=0 
      else 
        a := StrToFloat(Copy(str, i+1, -i - 1 + Pos('-', str))); 
      j:=i; 
      i:=Pos('-', str)+1; 
      while str[i] in ['0'..'9',','] do 
        Inc(i); 
      a := -StrToFloat(Copy(str, Pos('-', str) + 1, -Pos('-',str) + i - 1)) + a; 
      Result := Parse(Copy(str, 1, j)+FloatToStr(a)+Copy(str, i, high(integer))); 
    end 

    //Werte von String in Gleitkomma umwandeln 
    else 
      if str = '' then 
        Result := 0 
      else 
        Result := StrToFloat(str); 
  end; 

  function TMathParser.ParseStr(str : string) : extended;
  begin
    Result := Parse(SwapConstants(TrimSpace(str)));
  end;

  function TMathParser.TrimSpace(str : string) : string;
    function Incr(var i : integer) : integer;
    begin
      Inc(i);
      Result := i;
    end;
  var i,j:integer;
  begin
    j:=0;
    SetLength(Result, Length(str));
    if Length(str)>0 then
      for i:=1 to Length(str) do
        if str[i] <> ' ' then
          Result[Incr(j)] := str[i];
    SetLength(Result, j);
  end;

  function TMathParser.SwapConstants(str : string) : string;
  var i,j:integer;
  var Temp:TConstant;
  begin
    //vorher Konstanten umsortieren, um Fehler bei Konstanten, die einen anderen
    //Konstantennamen in ihrem mit Namen haben, zu vermeiden
    for i:=1 to Constants.Count-1 do
      for j:=0 to i-1 do
        if Pos(Constants[j].Name,Constants[i].Name)>0 then
        begin
          Temp:=Constants[i];
          Constants[i]:=Constants[j];
          Constants[j]:=Temp;
        end;


    Result := str;
    if Constants.Count > 0 then
      for i:=0 to Constants.Count-1 do
        Result := StringReplace(Result, constants[i].name, FloatToStr(constants[i].value), [rfReplaceAll, rfIgnoreCase]);
  end;

{ TConstants }

function TConstants.Add: TConstant;
begin
  Result:=TConstant.Create;
  FItems.Add(Result);
end;

procedure TConstants.AddConstant(Name: String; Value: Extended);
var Con:TConstant;
begin
  if IndexOf(Name)>-1 then
    raise Exception.Create('Konstante bereits vorhanden!');

  Con:=Add;
  Con.Name:=Name;
  Con.Value:=Value;
end;

procedure TConstants.Clear;
var i:integer;
begin
  for i:=Count-1 downto 0 do
    Delete(i);
end;

constructor TConstants.Create;
begin
  FItems:=TList.Create;
end;

procedure TConstants.Delete(Index: Integer);
begin
  TConstant(FItems[Index]).Free;
  FItems.Delete(Index);
end;

procedure TConstants.Delete(Name: String);
begin
  Delete(IndexOf(Name));
end;

destructor TConstants.Destroy;
begin
  Clear;
  FItems.Free;
  inherited;
end;

function TConstants.GetCount: integer;
begin
  Result:=FItems.Count;
end;

function TConstants.GetItems(Index: Integer): TConstant;
begin
  Result:=TConstant(FItems[Index]);
end;

function TConstants.IndexOf(name: String): Integer;
var i:integer;
begin
  Result:=-1;
  for i:=0 to Count-1 do
    if Uppercase(Self[i].Name)=Uppercase(Name) then
    begin
      Result:=i;
      exit;
    end;
end;

procedure TConstants.SetItems(Index: Integer; const Value: TConstant);
begin
  FItems[Index]:=Value;
end;

constructor TMathParser.Create;
begin
  Constants:=TConstants.Create;
  Constants.AddConstant('', 0);
  Constants.AddConstant('pi', PI);
  Constants.AddConstant('e', Exp(1));
end;

destructor TMathParser.Destroy;
begin
  Constants.Free;
  inherited;
end;

end.					

1:
2:
3:
4:

function ParseStr(str : string) : extended; 
begin 
  Result := Parse(SwapConstants(TrimSpace(str))); 
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:

  procedure DeleteConst(name : string);
  var i:integer;
  begin
    //Index der Konstante suchen
    for i:=0 to Length(constants)-1 do
      if constants[i].Name=Name then
        break;

    //Konstante gefunden?
    if constants[i].Name<>name then
     exit;

    //Aufrücken der Werte
    for i:=i+1 to Length(constants)-1 do
    begin
      constants[i-1].name:=constants[i].name;
      constants[i-1].value:=constants[i].value;
    end;

    //Verkürzen des Arrays
    SetLength(constants,Length(constants)-1);
  end;