eval.pas

Eval for Delphi version 1.0

{*******************************************************}
{*  Eval for Delphi version 1.0                        *}
{*  Copyright (c) 1996- 1998 Giuseppe Stalteri S.G.S   *}
{*  All Rights Reserved                                *}
{*  internet mail [e-mail]                       *}
{*  http://www.elios.net/sgs                           *}
{*  You are not allowed to redistribute this           *}
{*  code or any part of it                             *}
{*******************************************************}

unit Eval;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs;


type
  TOnErrorEvent = procedure(Sender: TObject; var Value: String) of object;
  Teval = class(TComponent)
  private
    { Private declarations }
    formula:string;
    risult:string;
    resulto:real;
    decimal:integer;
    ncifre :integer;
    FOnError: TOnErrorEvent;
    function setformula(newformula:string):string;
    Function Valuta_Formula (Var p: Integer;
                         Strg : String;
                         Var Errore: Boolean) : real;
  protected
    { Protected declarations }
  public
    { Public declarations }
  constructor Create(AOwner: TComponent); virtual;
  property result:real read resulto;
  published
    { Published declarations }
  property Formul  : string read formula write setformula;
  property StResult  : string read risult write risult;
  property decimaldigit: integer read decimal write decimal default 0;
  property digit   : integer read ncifre write ncifre default 0;
  property OnError:TOnErrorEvent read FOnError write FOnError;
  end;

procedure Register;

implementation

{$ifndef REG}
{
function DelphiRunning : boolean;
var
  H1, H2, H3, H4 : Hwnd;
const
  A1 : array[0..12] of char = 'TApplication'#0;
  A2 : array[0..15] of char = 'TAlignPalette'#0;
  A3 : array[0..18] of char = 'TPropertyInspector'#0;
  A4 : array[0..11] of char = 'TAppBuilder'#0;
  T1 : array[0..6] of char = 'Delphi'#0;
begin
  H1 := FindWindow(A1, T1);
  H2 := FindWindow(A2, nil);
  H3 := FindWindow(A3, nil);
  H4 := FindWindow(A4, nil);
  Result := (H1 <> 0) and (H2 <> 0) and
            (H3 <> 0) and (H4 <> 0);
end;
     }
{$endif} {REG}






 Function Teval.Valuta_Formula (Var p: Integer;
                         Strg : String;
                         Var Errore: Boolean) : real;

 Const
 oper : Set of Char = ['+','-','*','/','^','.',','];

 Var
   r              : Real;
   i,BreakPoint   : Integer;
   Ch             : Char;
   newformula     :string;
   para,parc      : integer;

   Procedure Eval(var Formula    : string;
                  Var Valore     : Real;
                  Var BreakPoint : Integer);

     Const
       Numeri   : Set of Char = ['0'..'9','.'];

     Var
       p, i     : Integer;
       Ch       : Char;

       Procedure Nextp;

        Begin { NextP }
           p := p + 1;
           If p <= Length(Formula) then
              Ch := Formula[p]
           Else
              CH := #13;
        End;  { NextP }

       Function Expr : Real;
        Var
          E : Real;
          Operatore : Char;
        Function SmplExpr : Real;
         Var
           S : Real;
           Operatore : Char;
         Function Term : Real;
          Var
            T : Real;
          Function S_Fact : Real;

           Function Fct : Real;
            Var
              fn       : string[20];
              l,start  : Integer;
              F        : Real;
            Procedure processo_come_numero;
             Var
               codice : Integer;

             begin { processo_come_numero }
               Start := p;
               Repeat
                 NextP;
               Until Not (Ch In Numeri);
               If Ch = '.' then
                 Repeat
                   Nextp;
                 Until Not (Ch In Numeri);
               If Ch = 'E' then
                 Begin
                  NextP;
                  Repeat
                    NextP;
                  Until Not (Ch In Numeri);
               End;
                 Val(copy(Formula,Start,p-Start),F,Codice);
            End; { processo_come_numero }

            Procedure Processo_come_nuova_expr;

             Begin { Processo_come_nuova_expr }
               NextP;
               F := Expr;
               If Ch = ')' then
                  NextP
               else
                  BreakPoint := p;
             End; { Processo_come_nuova_expr }

            Procedure Processo_come_Funz_Standard;
             var
              r:real;
             Begin { Processo_come_Funz_Standard }
              If Copy(formula, p, 6)= 'ARCTAN' then begin
                p := p + 5;
                NextP;
                F := Fct;
                f := ArcTan(f);
              End Else
              If Copy(formula, p, 6)= 'ARCSIN' then begin
                p := p + 5;
                NextP;
                F := Fct;
                r := sqr(f);
                f := ArcTan(f/sqrt(1-r));
              End Else
              If Copy(formula, p, 6)= 'ARCCOS' then begin
                p := p + 5;
                NextP;
                F := Fct;
                r := sqr(f);
                f := ArcTan(sqrt(1-r)/f);
              End Else
              If Copy(formula, p, 4)= 'SQRT' then begin
                p := p + 3;
                NextP;
                F := Fct;
                f := Sqrt(f);
              End Else
              If Copy(formula, p, 3)= 'SQR' then begin
                p := p + 2;
                NextP;
                F := Fct;
                f := Sqr(f);
              End Else
              If Copy(formula, p, 3)= 'ABS' then begin
                p := p + 2;
                NextP;
                F := Fct;
                f := Abs(f);
              End Else
              If Copy(formula, p, 3)= 'EXP' then begin
                p := p + 2;
                NextP;
                F := Fct;
                f := Exp(f);
              End Else
              If Copy(formula, p, 2)= 'LN' then begin
                p := p + 1;
                NextP;
                F := Fct;
                f := Ln(f);
              End Else
              If Copy(formula, p, 3)= 'TAN' then begin
                p := p + 2;
                NextP;
                F := Fct;
                r:=sin(f);
                f := r/cos(f);
              End Else
              If Copy(formula, p, 3)= 'COS' then begin
                p := p + 2;
                NextP;
                F := Fct;
                f := Cos(f);
              End Else
              If Copy(formula,p,3) = 'SIN' then begin
                p := p + 2;
                NextP;
                F := Fct;
                f := Sin(f);
              End Else begin
                BreakPoint := p;
              End;
             End; { Processo_come_funz_standard }

             Begin { Fct }
               If (Ch In Numeri) then
                 Processo_come_numero
               else If (Ch = '(') then
                 Processo_come_nuova_expr
               else
                 Processo_come_Funz_standard;

               Fct := F;
             End; { Fct }

             Begin { S_Fact }
               If Ch = '-' then begin
                 NextP;
                 S_Fact := -Fct;
               End Else
                 S_Fact := Fct;
            End; { S_Fact }

            Begin { Term }
              T := S_fact;
              While Ch = '^' do begin
                Nextp;
                t := Exp(Ln(t)*S_fact);
              End;
              Term := t;

            End; { Term }

            Begin { SmplExpr }
              s := Term;
              While Ch In ['*','/'] do begin
                Operatore := Ch;
                NextP;
                 Case Operatore Of
                   '*'  :  s := s * term;
                   '/'  :  s := s / term;
                 End;
              End;
              smplexpr:=s;
            End; { SmplExpr }

            Begin { Expr }

              E := SmplExpr;
              While Ch In ['+','-'] do begin
                Operatore := Ch;
                NextP;
                  Case Operatore Of
                    '+'  : E := E + SmplExpr;
                    '-'  : E := E - SmplExpr;
                  End;
              End;
              expr:=E;
            End; { Expr }

            Begin { Eval }

              p := 0;
              NextP;
              Valore := Expr;
              If Ch = #13 then
                Errore := False
              Else
                Errore := True;
              BreakPoint :=p;

            End; { Eval }

            Begin { Calcola_Formula }
            newformula:='';
              For i := 1 to Length(Strg) do
                 begin
                 strg[i] := Upcase(strg[i]);
                 if strg[i]=','  then
                     strg[i]:='.';
                 if (strg[i] <> ' ')  then
                  newformula:=newformula+strg[i];
                 end;

              {End For}
                 strg:=newformula;
              If strg[1] = '.' then
                strg := '0'+strg;
              If strg[1] = '+' then
                Delete (strg,1,1);
            r:=0;
            para:=0;
            parc:=0;
            for i:=1 to (length(strg)-1) do
               begin
                if strg[i]='(' then
                   para:=para+1;
                if strg[i]=')' then
                   parc:=parc+1;
                if parc > para then
                   begin
                    errore:=true;
                    break;
                   end;
                 if (strg[i] in oper) and (strg[i+1] in oper) then
                   errore:=true;
                 if (strg[i] in oper) and (strg[i+1] =')') then
                   errore:=true;
              end;

              if strg[length(strg)]=')' then
                   parc:=parc+1;
              IF para<>parc then
                 errore:=true;

              if strg[length(strg)] in oper then
               errore:=true;
              if strg[length(strg)]='(' then
               errore:=true;

            if (not errore) and (length(strg)>0) then
                {$ifndef REG}
                {
                if not DelphiRunning then
                  MessageDlg(' UNREGISTERED EVAL - This program works only while Delphi is running',mtWarning,[mbOK],0)
                else }
               {$endif}
               Eval (strg ,r ,p);

            Valuta_formula := r;
End;


constructor TEval.Create(AOwner: TComponent);
  Begin
   inherited Create(AOwner);
   formula  :='0';
   risult   :='0';

  end;
  function Teval.setformula(newformula:string):string;
   var
    p:integer;
    errore:boolean;
    valore:real;
   begin
    formula:=newformula;
    p:=0;
    errore:=false;
    valore:=valuta_formula(p,newformula,errore);

    if errore=true then
     begin
     if Assigned(FOnError) then FOnError(Self, formula);
     formula:='errore';
     risult:='0';
     resulto:=0;
     end
     else
     begin
     resulto:=valore;
     str(valore:ncifre:decimal,risult);
     end;
   end;


procedure Register;
begin
  RegisterComponents('Samples', [Teval]);
end;

end.