unit CalcExpr;

interface

{DEFINE aaCLX} // set $ after { to get CLX version

uses
{$IFDEF aaCLX} QGraphics, QControls, QForms, QDialogs, QExtCtrls,
{$ELSE}        Windows, Messages, Graphics, Controls, Forms, Dialogs, ExtCtrls,
{$ENDIF}       SysUtils, Classes, Math;


type

  PTree = ^TTree;
  TTree = record
    code: Char;
    val: String;
    l, r: PTree;
  end;

  TCalcExpr = class(TComponent)
  private
    Err            : Boolean;
    Bc, poz        : Integer;
    PrevLex, Curlex: Char;
    FFormula       : String;
    Tree           : Pointer;
    FDefaultNames  : Boolean;
    procedure Init(s: String);
    function  GetTree: Pointer;
    Procedure DelTree(p: PTree);
    procedure Error(s: String);
  public
    constructor Create(o: TComponent); override;
    destructor  Destroy; override;
    function Calc: extended;
  published
    property Formula: String read FFormula write init;

  end;

const
  endl = #13#10;

implementation
(*-------------------------------------------------------------------*)
function NewNode(SVal: String = ''; WCode: Char = #0; PL: Pointer = nil; PR: Pointer = nil): PTree;
begin
  Result := AllocMem(SizeOf(TTree));
  With Result^ do begin
    l    := PL;
    r    := PR;
    Val  := SVal;
    Code := WCode;
  end;
end;
(*-------------------------------------------------------------------*)
procedure TCalcExpr.Error(s: String);
begin
  Err := True;
  raise Exception.Create(s);
end;
(*-------------------------------------------------------------------*)
constructor TCalcExpr.Create(o: TComponent);
begin
  inherited;
  Tree := nil;
  Formula := '0';
end;
(*-------------------------------------------------------------------*)
destructor TCalcExpr.Destroy;
begin
  DelTree(Tree);
  inherited;
end;
(*-------------------------------------------------------------------*)
function TCalcExpr.Calc: extended;
  function c(t: PTREE): extended;
  begin
    case t^.code of
      '+': c := c(t^.l) + c(t^.r);
      '-': if t^.r <> nil then 
           c := c(t^.l) - c(t^.r)  else 
           c := - c(t^.l);
      '*': c := c(t^.l) * c(t^.r);
      '/': c := c(t^.l) / c(t^.r);
      '#': c := StrToFloat(t^.val);
      '^': c := power(c(t^.l), c(t^.r));
      else c := 0;      
    end;
  end;
begin
  Calc := c(tree);
end;
(*-------------------------------------------------------------------*)
function TCalcExpr.GetTree: Pointer;
  {Obtine numarul din sir}
  function GetNumber: String; 
  var l, j: Integer;
  begin
    Result := '';
    try
     if FFormula = '' then FFormula := '0' else
     l := Length(FFormula);
  
     {Determinarea semnului}
     if FFormula[poz] in ['-','+'] then begin Result := FFormula[poz]; inc(poz) end;
     j := poz;
  
     {Partea intreaga}
     while (poz <= l) and (FFormula[poz] in ['0'..'9']) do inc(poz);
     if poz>j then Result := Result + Copy(FFormula, j, poz-j) else Result := '0';
     j := poz;
  
     {Mantisa}
     if(poz<=l) and (FFormula[poz] = DecimalSeparator) then begin
        inc(poz);
        if (poz>l) or not (FFormula[poz] in ['0'..'9']) then Error('Wrong number.');
        while (poz <= l) and (FFormula[poz] in ['0'..'9']) do inc(poz);
        if poz-1>j then Result := Result + Copy(FFormula, j, poz-j);      
        j := poz;
     end;
     
     {Exponentul}
     if(poz<l)and(UpCase(FFormula[poz])='E')and(FFormula[poz+1] in ['-','+']) then begin
        inc(poz, 2);
        if (poz>l) or not (FFormula[poz] in ['0'..'9']) then Error('Wrong number.');
        while (poz <= l) and (FFormula[poz] in ['0'..'9']) do inc(poz);
        if poz-2>j then Result := Result + Copy(FFormula, j, poz-j);      
     end;

    except
    end;
  end;

  {Citeste lexemul din sir}
  procedure GetLex(var code: Char; var val: String);
  begin
    val := '';
    code := #0;
    {Omitem spatiile}
    while (poz <= Length(FFormula)) and (FFormula[poz] = ' ') do inc(poz);
    if poz > Length(FFormula) then exit;

    case FFormula[poz] of
      '0'..'9':
      begin
        val := GetNumber;
        code := '#';
      end;
      else begin
        code := FFormula[poz];
        inc(poz);
        val := '';
      end;  
    end;
    PrevLex := CurLex;
    CurLex  := code;
  end;
  (*-------------------------------------------------------------------*)
  var 
  l, r: PTree;
  n, op: Char;
  neg: boolean;
  c: String;
  (*-------------------------------------------------------------------*)
  function GetSingleOp: Pointer;
  var 
    bracket: Integer;
    l, r: PTree;
  begin
    l := nil;
    try
      if n = '(' then begin
        inc(bc); 
        l := GetTree;
      end else begin
        // First operand
        if not (n in ['#']) then Error('');
          // Number
          l := NewNode(c, n)
      end;
      //Operation symbol
      GetLex(n, c);
      //Power symbol
      while n = '^' do
        begin
          GetLex(n, c);
        bracket := 0;
        if n = '(' then  
        begin   
          bracket := 1;   
          GetLex(n, c);
        end;
        if (n <> '#') then Error('');
        r := NewNode(c, n); 
        l := NewNode('','^', l, r);
        if bracket = 1 then
        begin
          GetLex(n, c);
          if n <> ')' then Error('');
        end;
        GetLex(n, c);
      end;
      Result := l;
    except
      DelTree(l);
      Result := nil;
    end;
  end;
  (*-------------------------------------------------------------------*)
  function GetOperand: Pointer;
  var op: Char;
      l, r: PTree;
  begin
    neg := false;
    GetLex(n, c);
    // Unary - or +
    if prevlex in [#0,'(',')'] then begin
       neg := n = '-';
       if n in ['+', '-'] then GetLex(n, c);
    end;   
    l := GetSingleOp;
    // 2nd operand 
    while n in ['*','/'] do
    begin
      op := n;
      GetLex(n, c);
      r := GetSingleOp;
      l := NewNode('', op, l, r);
    end;
    if neg then begin
      l := NewNode('', '-', l);
    end;
    Result := l;
  end;

  (*-------------------------------------------------------------------*)
begin
  l := nil;
  try
    l := GetOperand;
    repeat
      if n in [#0,')'] then
      begin
        if n = ')' then dec(bc);
        Result := l;
        Exit;
      end;
      if not (n in ['+','-']) then Error('');
      op := n;
      r := GetOperand;
      l := NewNode('', op, l, r);
    until false;
    Result := l;
  except
    DelTree(l);
    Result := nil;
  end;
end;

(*-------------------------------------------------------------------*)
procedure TCalcExpr.Init(s: String);
begin
  DelTree(tree);
  Err := False;
  FFormula := LowerCase(s);
  Prevlex := #0;
  Curlex := #0;
  poz := 1;
  bc := 0;
  Tree := GetTree;
  if (bc <> 0) or Err then
  begin
    ShowMessage('Error in formula.');
    DelTree(Tree);
    Tree := nil;
  end;
end;

//Tree deletion
procedure TCalcExpr.DelTree(p: PTree);
begin
  if p = nil then exit;
  DelTree(p^.l);
  DelTree(p^.r);
  FreeMem(p);
end;

(*-------------------------------------------------------------------*)

end.