Convert a string to a mathematical expression and get its result

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.