calculator.pas

Yahoo Messenger for Mobile

unit calculator;

interface

uses math,sysutils;

function Calculate(CalcStr,whosaidit : String): string;

implementation

function Calculate(CalcStr,whosaidit : String): string;
var TempStr : string;
  P : Integer;
    Error : Boolean;
    Result2 : Extended;

 procedure StripBlanks(var AString : string);
  var Count : integer;
  begin
   If Length(AString)>0 Then
     for count := 0 to Length(AString) do
       begin
       if AString[count] = ' ' then Delete(AString, count, 1);
      end;
   end;


 function Compute_Formula(var P : Integer;  Strg : String; var Error : boolean) :
extended;
 var R : extended;

 (***********************************)
 
  procedure Eval(var Formula : string; var Value : extended; var BreakPoint : Integer);
  const Numbers : set of char = ['0'..'9','.'];
  var  P, I : Integer;
     Ch : char;
 
  (***********************************)

   procedure NextP;
   begin
    repeat
     P := P + 1;
     If P <= Length(Formula) then
      Ch := Formula[P]
     else
      Ch := #13;
    until (Ch <> ' ');
   end;

   (***********************************)
 
   function Expr : extended;
   var E : extended;
     Operator : char;
 
   (***********************************)

    function SmplExpr : extended;
    var S : extended;
      Operator : char;

    (***********************************)
 
     function Term : extended;
     var T : extended;
 
     (***********************************)
 
      function S_Fact : extended;

      (***********************************)
 
       function Fct : extended;
       var start : integer;
         F : extended;
 
       (***********************************)
 
        procedure Process_As_Number;
        var Code : integer;
        begin
         Start := P;
         repeat
          NextP;
         until not(Ch in Numbers);

         if Ch = '.' then
         repeat
          NextP;
         until not(Ch in Numbers);
 
         if Ch = 'E' then
          begin
           NextP;
           repeat
            NextP;
           until not(Ch in Numbers);
          end;
 
         Val(Copy(Formula, Start, P-Start), F, Code);
        end;
 
       (***********************************)

        procedure Process_As_New_Expr;
        begin
         NextP;
         F := Expr;
         if Ch = ')' then
          NextP
         else
          Breakpoint := P;
        end;
 
       (***********************************)
 
        procedure Process_As_Standard_Function;

        (***********************************)
 
         function Fact(I : integer) : extended;
         begin
          if I > 0 then
           Fact := I * Fact(I-1)
          else
           Fact := 1;
         end;
 
        (***********************************)

        begin {Process_As_Standard_Function}
         if Copy(Formula, P, 3) = 'ABS' then
          begin
           P := P + 2;
           NextP;
           F := Fct;
           f := Abs(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) = 'SIN' then
          begin
           P := P + 2;
           NextP;
           F := Fct;
           f := Sin(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, 4) = 'ATAN' then
          begin
           P := P + 3;
           NextP;
           F := Fct;
           f := ArcTan(f);
          end
         else if Copy(Formula, P, 2) = 'LN' then
          begin
           P := P + 1;
           NextP;
           Try
           F := Fct;
           f := Ln(f);
            except
           End;
          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, 4) = 'FACT' then
          begin
           P := P + 3;
           NextP;
           F := Fct;
           f := Fact(Trunc(f));
          end
         else if Copy(Formula, P, 2) = 'PI' then
          begin
           P := P + 1;
           NextP;
           F := Fct;
           f := Pi;
          end
                  else if Copy(Formula, P, 3) = 'TAN' then
          begin
           P := P + 2;
           NextP;
           F := Fct;
           f := Tan(f);
          end
                  else if Copy(Formula, P, 4) = 'ASIN' then
          begin
           P := P + 3;
           NextP;
           F := Fct;
           f := ArcSin(f);
          end
                  else if Copy(Formula, P, 4) = 'ACOS' then
          begin
           P := P + 3;
           NextP;
           F := Fct;
           f := ArcCos(f);
          end
                  else if Copy(Formula, P, 3) = 'COT' then
          begin
           P := P + 2;
           NextP;
           F := Fct;
           f := CoTan(f);
          end
                  else if Copy(Formula, P, 4) = 'SINH' then
          begin
           P := P + 3;
           NextP;
           F := Fct;
           f := SinH(f);
          end
                  else if Copy(Formula, P, 4) = 'COSH' then
          begin
           P := P + 3;
           NextP;
           F := Fct;
           f := CosH(f);
          end
                  else if Copy(Formula, P, 4) = 'TANH' then
          begin
           P := P + 3;
           NextP;
           F := Fct;
           f := TanH(f);
          end
                  else if Copy(Formula, P, 9) = 'RADTOGRAD' then
          begin
           P := P + 8;
           NextP;
           F := Fct;
           f := RadToGrad(f);
          end
                  else if Copy(Formula, P, 8) = 'RADTODEG' then
          begin
           P := P + 7;
           NextP;
           F := Fct;
           f := RadToDeg(f);
          end
                  else if Copy(Formula, P, 10) = 'RADTOCYCLE' then
          begin
           P := P + 9;
           NextP;
           F := Fct;
           f := RadToCycle(f);
          end
                  else if Copy(Formula, P, 9) = 'GRADTORAD' then
          begin
           P := P + 8;
           NextP;
           F := Fct;
           f := GradToRad(f);
          end
                  else if Copy(Formula, P, 5) = 'FLOOR' then
          begin
           P := P + 4;
           NextP;
           F := Fct;
           f := Floor(f);
          end
                  else if Copy(Formula, P, 8) = 'DEGTORAD' then
          begin
           P := P + 9;
           NextP;
           F := Fct;
           f := DegToRad(f);
          end
                  else if Copy(Formula, P, 10) = 'CYCLETORAD' then
          begin
           P := P + 9;
           NextP;
           F := Fct;
           f := CycleToRad(f);
          end
                  else if Copy(Formula, P, 4) = 'CEIL' then
          begin
           P := P + 3;
           NextP;
           F := Fct;
           f := Ceil(f);
          end
                  else
          BreakPoint := P;
        end;

       (***********************************)
 
       begin { Fct }
        if Ch in Numbers then
         Process_As_Number
        else if Ch = '(' then
         Process_As_New_Expr
        else
         Process_As_Standard_Function;
        Fct := F;
       end;

      (***********************************)
 
      begin { S_Fact }
       if Ch = '-' then
        begin
         NextP;
         S_Fact := -Fct;
        end
       else
        S_Fact := Fct;
      end;

     (***********************************)
 
     begin { Term }
      T := S_Fact;
      while Ch = '^' do
       begin
        NextP;
        try
         If T<>0 Then
             t := Exp(Ln(t) * S_Fact);
           except
          end; 
       end;
      Term := t;
     end;

    (***********************************)
 
    begin { SmplExpr }
     S := term;
     while Ch in ['*', '/'] do
      begin
       Operator := Ch;
       NextP;
       case Operator of
        '*' : S := S * Term;
        '/' : begin
                    if Term <> 0 then S := S / Term else
                         S := -1
                   end;
       end;
      end;
     SmplExpr := s;
    end;
 
   (***********************************)
 
   begin { Expr }
    E := SmplExpr;
    while Ch in ['+', '-'] do
     begin
      Operator := Ch;
      NextP;
      case Operator of
       '+' : e := e + SmplExpr;
       '-' : e := e - SmplExpr;
      end;
     end;
    Expr := E;
   end;

  (***********************************)
 
  begin { Eval }
  If Length(Formula)>0 Then
   Begin
   for I := 1 to Length(formula) do
    Formula[I] := UpCase(Formula[I]);
   if Formula[1] = '.' then
    Formula := '0' + Formula;
   if Formula[1] = '+' then
    Delete(Formula, 1, 1);
   P := 0;
   NextP;
   Value := Expr;

   if Ch = #13 then
    Error := False
   else
    Error := True;
   BreakPoint := P;
  end;
 End;

 (***********************************)

 begin { Compute_Formula }
  Eval(Strg, R, P);
  Compute_Formula := R;
 end;

begin
 TempStr := CalcStr;
 StripBlanks(TempStr);

  result2 := compute_formula(p, tempstr, error);

   if not error then
     result:=FloatToStr(Result2)
       else
    result:='There is an error! Check your equation! ';

end;

end.