DUzun's Web
Programare, proiecte personale, divertisment

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.

​

​