Convert a string to a mathematical expression and get its result (Views: 30)
Problem/Question/Abstract: How to convert a string to a mathematical expression and get its result. Answer: unit MathComponent; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, math; type TOperandtype = (ttradians, ttdegrees, ttgradients); TMathtype = (mtnil, mtoperator, mtlbracket, mtrbracket, mtoperand, mtfunction); TMathSubtype = (msnone, mstrignometric); TMathOperator = (monone, moadd, mosub, modiv, momul, mopow, momod, modivint); TMathFunction = (mfnone, mfsinh, mfcosh, mftanh, mfcosech, mfsech, mfcoth, mfsin, mfcos, mftan, mfcot, mfsec, mfcosec, mflog, mfln, mfsub, mfadd); type pmathchar = ^Tmathchar; TMathChar = record case mathtype: Tmathtype of mtoperand: (data: extended); mtoperator: (op: TMathOperator); mtfunction: (func: TMathfunction; subtype: (mstnone, msttrignometric)); end; type TMathControl = class(TComponent) private input, output, stack: array of tmathchar; fmathstring: string; ftrignometrictype: Toperandtype; fExpressionValid: boolean; procedure removespace; function isvalidchar(c: char): boolean; function getresult: extended; function checkbrackets: boolean; function calculate(operand1, operand2, operator: Tmathchar): extended; overload; function calculate(operand1, operator: Tmathchar): extended; overload; function getoperator(pos: integer; var len: integer; var amathoperator: TMathOperator): boolean; function getoperand(pos: integer; var len: integer; var value: extended): boolean; function getmathfunc(pos: integer; var len: integer; var amathfunc: TmathFunction): boolean; function processstring: boolean; procedure convertinfixtopostfix; function isdigit(c: char): boolean; function getprecedence(mop: TMathchar): integer; protected procedure loaded; override; published property MathExpression: string read fmathstring write fmathstring; property MathResult: extended read getresult; property ExpressionValid: boolean read fExpressionvalid; property Trignometrictype: Toperandtype read ftrignometrictype write ftrignometrictype; end; procedure Register; implementation function tmathcontrol.calculate(operand1, operator: Tmathchar): extended; begin result := 0; if (operator.subtype = msttrignometric) then begin if ftrignometrictype = ttdegrees then operand1.data := operand1.data * (pi / 180); if ftrignometrictype = ttgradients then operand1.data := GradToRad(operand1.data); end; case operator.func of mfsub: result := -operand1.data; mfadd: result := operand1.data; mfsin: result := sin(operand1.data); mfcos: result := cos(operand1.data); mfcot: result := 1 / tan(operand1.data); mfcosec: result := 1 / sin(operand1.data); mfsec: result := 1 / cos(operand1.data); mftan: result := tan(operand1.data); mflog: result := log10(operand1.data); mfln: result := ln(operand1.data); end; end; function tmathcontrol.getmathfunc(pos: integer; var len: integer; var amathfunc: TmathFunction): boolean; var tmp: string; i: integer; begin amathfunc := mfnone; result := false; tmp := ''; if (fmathstring[pos] = '+') then begin amathfunc := mfadd; len := 1; result := true; end; if (fmathstring[pos] = '-') then begin amathfunc := mfsub; len := 1; result := true; end; if (fmathstring[pos] = 's') then begin for i := pos to pos + 3 do tmp := tmp + fmathstring[i]; if strcomp(pchar(tmp), 'sin(') = 0 then begin amathfunc := mfsin; len := 3; result := true; end else if strcomp(pchar(tmp), 'sec(') = 0 then begin amathfunc := mfsec; len := 3; result := true; end; end; if (fmathstring[pos] = 'c') then begin for i := pos to pos + 5 do tmp := tmp + fmathstring[i]; if strlcomp(pchar(tmp), 'cos(', 4) = 0 then begin amathfunc := mfcos; len := 3; result := true; end else if strlcomp(pchar(tmp), 'cot(', 4) = 0 then begin amathfunc := mfcot; len := 3; result := true; end else if strlcomp(pchar(tmp), 'cosec(', 6) = 0 then begin amathfunc := mfcosec; len := 3; result := true; end end; if (fmathstring[pos] = 't') then begin for i := pos to pos + 3 do tmp := tmp + fmathstring[i]; if strlcomp(pchar(tmp), 'tan(', 4) = 0 then begin amathfunc := mflog; len := 3; result := true; end; end; if (fmathstring[pos] = 'l') then begin for i := pos to pos + 3 do tmp := tmp + fmathstring[i]; if strlcomp(pchar(tmp), 'log(', 4) = 0 then begin amathfunc := mflog; len := 3; result := true; end else if strlcomp(pchar(tmp), 'ln(', 3) = 0 then begin amathfunc := mfln; len := 3; result := true; end end; end; procedure tmathcontrol.loaded; begin inherited; fexpressionvalid := processstring; end; procedure tmathcontrol.removespace; var i: integer; tmp: string; begin tmp := ''; for i := 1 to length(fmathstring) do if fmathstring[i] <> ' ' then tmp := tmp + fmathstring[i]; fmathstring := tmp; end; function tmathcontrol.isvalidchar(c: char): boolean; begin result := true; if (not (isdigit(c))) and (not (c in ['(', ')', 't', 'l', 'c', 'm', 'd', 's', '*', '/', '+', '-', '^'])) then result := false; end; function tmathcontrol.checkbrackets: boolean; var i: integer; bracketchk: integer; begin result := true; bracketchk := 0; i := 1; if length(fmathstring) = 0 then result := false; while i <= length(fmathstring) do begin if fmathstring[i] = '(' then bracketchk := bracketchk + 1 else if fmathstring[i] = ')' then bracketchk := bracketchk - 1; i := i + 1; end; if bracketchk <> 0 then result := false; end; function Tmathcontrol.calculate(operand1, operand2, operator: Tmathchar): extended; begin result := 0; case operator.op of moadd: result := operand1.data + operand2.data; mosub: result := operand1.data - operand2.data; momul: result := operand1.data * operand2.data; modiv: if (operand1.data <> 0) and (operand2.data <> 0) then result := operand1.data / operand2.data else result := 0; mopow: result := power(operand1.data, operand2.data); modivint: if (operand1.data <> 0) and (operand2.data <> 0) then result := round(operand1.data) div round(operand2.data) else result := 0; momod: if (operand1.data >= 0.5) and (operand2.data >= 0.5) then result := round(operand1.data) mod round(operand2.data) else result := 0; end; end; function Tmathcontrol.getresult: extended; var i: integer; tmp1, tmp2, tmp3: tmathchar; begin fExpressionValid := processstring; if fExpressionValid = false then begin result := 0; exit; end; convertinfixtopostfix; setlength(stack, 0); for i := 0 to length(output) - 1 do begin if output[i].mathtype = mtoperand then begin setlength(stack, length(stack) + 1); stack[length(stack) - 1] := output[i]; end else if output[i].mathtype = mtoperator then begin tmp1 := stack[length(stack) - 1]; tmp2 := stack[length(stack) - 2]; setlength(stack, length(stack) - 2); tmp3.mathtype := mtoperand; tmp3.data := calculate(tmp2, tmp1, output[i]); setlength(stack, length(stack) + 1); stack[length(stack) - 1] := tmp3; end else if output[i].mathtype = mtfunction then begin tmp1 := stack[length(stack) - 1]; setlength(stack, length(stack) - 1); tmp2.mathtype := mtoperand; tmp2.data := calculate(tmp1, output[i]); setlength(stack, length(stack) + 1); stack[length(stack) - 1] := tmp2; end; end; result := stack[0].data; setlength(stack, 0); setlength(input, 0); setlength(output, 0); end; function Tmathcontrol.getoperator(pos: integer; var len: integer; var amathoperator: TMathOperator): boolean; var tmp: string; i: integer; begin tmp := ''; result := false; if fmathstring[pos] = '+' then begin amathoperator := moadd; len := 1; result := true; end else if fmathstring[pos] = '*' then begin amathoperator := momul; len := 1; result := true; end else if fmathstring[pos] = '/' then begin amathoperator := modiv; len := 1; result := true; end else if fmathstring[pos] = '-' then begin amathoperator := mosub; len := 1; result := true; end else if fmathstring[pos] = '^' then begin amathoperator := mopow; len := 1; result := true; end else if fmathstring[pos] = 'd' then begin for i := pos to pos + 2 do tmp := tmp + fmathstring[i]; if strcomp(pchar(tmp), 'div') = 0 then begin amathoperator := modivint; len := 3; result := true; end; end else if fmathstring[pos] = 'm' then begin for i := pos to pos + 2 do tmp := tmp + fmathstring[i]; if strcomp(pchar(tmp), 'mod') = 0 then begin amathoperator := momod; len := 3; result := true; end; end; end; function Tmathcontrol.getoperand(pos: integer; var len: integer; var value: extended): boolean; var i, j: integer; tmpnum: string; dotflag: boolean; begin j := 1; result := true; dotflag := false; for i := pos to length(fmathstring) - 1 do begin if isdigit(fmathstring[i]) then begin if (fmathstring[i] = '.') and (dotflag = true) then begin result := false; break; end else if (fmathstring[i] = '.') and (dotflag = false) then dotflag := true; tmpnum := tmpnum + fmathstring[i]; j := j + 1; end else break; end; if result = true then begin value := strtofloat(tmpnum); len := j - 1; end; end; function Tmathcontrol.processstring: boolean; var i: integer; mov: integer; tmpfunc: tmathfunction; tmpop: tmathoperator; numoperators: integer; numoperands: integer; begin i := 0; mov := 0; numoperators := 0; numoperands := 0; setlength(output, 0); setlength(input, 0); setlength(stack, 0); removespace; result := true; if checkbrackets = false then begin result := false; exit; end; fmathstring := '(' + fmathstring + ')'; while i <= length(fmathstring) - 1 do begin if not (isvalidchar(fmathstring[i + 1])) then begin result := false; break; end; if fmathstring[i + 1] = '(' then begin setlength(input, length(input) + 1); input[length(input) - 1].mathtype := mtlbracket; i := i + 1; end else if fmathstring[i + 1] = ')' then begin setlength(input, length(input) + 1); input[length(input) - 1].mathtype := mtrbracket; i := i + 1; end else if getoperator(i + 1, mov, tmpop) then begin if (tmpop <> moadd) and (tmpop <> mosub) then begin if i = 0 then //first character cannot be an operator begin // other than a '+' or '-'. result := false; break; end; setlength(input, length(input) + 1); input[length(input) - 1].mathtype := mtoperator; input[length(input) - 1].op := tmpop; i := i + mov; numoperators := numoperators + 1; end else if (tmpop = mosub) or (tmpop = moadd) then begin if (i = 0) or (input[length(input) - 1].mathtype = mtoperator) or (input[length(input) - 1].mathtype = mtlbracket) then begin //makes use of fact the if the first part of if expression is true then //remaining parts are not evaluated thus preventing a //exception from occuring. setlength(input, length(input) + 1); input[length(input) - 1].mathtype := mtfunction; getmathfunc(i + 1, mov, tmpfunc); input[length(input) - 1].func := tmpfunc; i := i + mov; end else begin setlength(input, length(input) + 1); numoperators := numoperators + 1; input[length(input) - 1].mathtype := mtoperator; input[length(input) - 1].op := tmpop; i := i + 1; end; end; end else if isdigit(fmathstring[i + 1]) then begin setlength(input, length(input) + 1); input[length(input) - 1].mathtype := mtoperand; if getoperand(i + 1, mov, input[length(input) - 1].data) = false then begin result := false; break; end; i := i + mov; numoperands := numoperands + 1; end else begin getmathfunc(i + 1, mov, tmpfunc); if tmpfunc <> mfnone then begin setlength(input, length(input) + 1); input[length(input) - 1].mathtype := mtfunction; input[length(input) - 1].func := tmpfunc; if tmpfunc in [mfsin, mfcos, mftan, mfcot, mfcosec, mfsec] then input[length(input) - 1].subtype := msttrignometric else input[length(input) - 1].subtype := mstnone; i := i + mov; end else begin result := false; break; end; end; end; if numoperands - numoperators <> 1 then result := false; end; function Tmathcontrol.isdigit(c: char): boolean; begin result := false; if ((integer(c) > 47) and (integer(c) < 58)) or (c = '.') then result := true; end; function Tmathcontrol.getprecedence(mop: TMathchar): integer; begin result := -1; if mop.mathtype = mtoperator then begin case mop.op of moadd: result := 1; mosub: result := 1; momul: result := 2; modiv: result := 2; modivint: result := 2; momod: result := 2; mopow: result := 3; end end else if mop.mathtype = mtfunction then result := 4; end; procedure Tmathcontrol.convertinfixtopostfix; var i, j, prec: integer; begin for i := 0 to length(input) - 1 do begin if input[i].mathtype = mtoperand then begin setlength(output, length(output) + 1); output[length(output) - 1] := input[i]; end else if input[i].mathtype = mtlbracket then begin setlength(stack, length(stack) + 1); stack[length(stack) - 1] := input[i]; end else if (input[i].mathtype = mtoperator) then begin prec := getprecedence(input[i]); j := length(stack) - 1; if j >= 0 then begin while (getprecedence(stack[j]) >= prec) and (j >= 0) do begin setlength(output, length(output) + 1); output[length(output) - 1] := stack[j]; setlength(stack, length(stack) - 1); j := j - 1; end; setlength(stack, length(stack) + 1); stack[length(stack) - 1] := input[i]; end; end else if input[i].mathtype = mtfunction then begin setlength(stack, length(stack) + 1); stack[length(stack) - 1] := input[i]; end else if input[i].mathtype = mtrbracket then begin j := length(stack) - 1; if j >= 0 then begin while (stack[j].mathtype <> mtlbracket) and (j >= 0) do begin setlength(output, length(output) + 1); output[length(output) - 1] := stack[j]; setlength(stack, length(stack) - 1); j := j - 1; end; if j >= 0 then setlength(stack, length(stack) - 1); end; end; end; end; procedure Register; begin RegisterComponents('Samples', [TMathControl]); end; end. |