- Delphiartiklar, tips, forum, länksamling - 

      

START | DELPHI | LÄNKAR| GÄSTBOK 




 Forum

Grundkurs
  »Introduktion
  »Snabbguide
  »Komponenter
  »Händelser
  »Strängar
  »Räkna med Delphi   »Egna typer
  »Selektion
  »Iteration
  »Menyer
  »Funktioner
  »Arraystrukturer

Tips & Tricks
  »Nya tips
  »Blandat
  »Databaser
  »Filer
  »Forms
  »Grafik
  »Internet
  »Komponenter
  »Matematik
  »Multimedia
  »Objekt/ActiveX
  »Skrivare
  »Strängar
  »System
  »Mest lästa tips

Artiklar
  »Delphi och ADO
  »Bygga en DLL
  »Skapa en enkel rapport
  »Hantera registret
  »Enheter, units
  »Klassen TCanvas
  »Använd LookUp Controls

 Nya tips
 Lägg till tips
 Delphilänkar
 Gästbok

 

matteuttryck(sträng) till flyttal Kategori: Matematik
Inlagt: 2006-01-29
Läst: 1961
Inlagt av: Arne Bergkvist
Beskrivning
Omvandlar matteuttryck till flyttal Exempel: Matteutryck i textformat som ger ett flyttal som svar x:=1; svar:=parserx('exp(-x)*cos(2*pi*2*x)', x,fel); svar:=0,367879441171442;fel:='' om inget fel I exemplet används tre TEditt + en Tbutton i ett formulär Funktionen är mycket användbar om man vill plotta mattekurvor mm
Kod
unit Unit1; 
interface 
uses 
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
 StdCtrls,parserx; 
type 
 TForm1 = class(TForm) 
  Button1: TButton; 
  Edit1: TEdit; 
  Edit2: TEdit; 
  Edit3: TEdit; 
  procedure Button1Click(Sender: TObject); 
 private 
  { Private declarations } 
 public 
  { Public declarations } 
 end; 
 
var 
 Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
procedure TForm1.Button1Click(Sender: TObject); 
var resultat : Double; 
  xvariabel : Double; 
  mattefunktion : String; 
  fel    : String; 
begin 
xvariabel:=StrToFloat(Edit1.Text);{Exempel Edit1.Text:='5' } 
mattefunktion:=Edit2.Text;    {Exempel Edit2.Text:='((x+5.4)*(4+x))^2*sin(x/pi)/( ln(x)*2)'} 
resultat:=ParseX(xvariabel,mattefunktion,fel); {Exempel resultat:=2721,15915913286 } 
Edit3.text:=FloatToStr(resultat); 
end; 
 
end. 
 
{**Unit ParserX****************} 
 
unit PARSERX; 
interface 
uses math; 
{$IFOPT N+,E+} 
type 
 Real = Extended; 
{$ENDIF} 
 
type 
 IString = String[100]; 
 vnamn  = String[10]; 
var variabelnamn : vnamn; 
 
function ParseX(variabel : Real;S : IString; var fel : String ) : Real; 
 
{ Följande funktioner är tillgängliga 
hyberborliska funktion tanh(u) sinh(u) coth(u) cosh(u) 
Trigonometriska funktioner: 
a=sin(u), a=cos(u), a=tan(u) : -1<= a <=1,u i radianer 
a=sind(u), a=cosd(u), a=tand(u) : u i grader(degree) 
a=asin(u), a=acos(u), a=atan(u) : -1<= u <=1 , a=radianer 
a=asind(u), a=acosd(u), a=atand(u) : -1<= u <=1 , a=grader 
a=sinc(u) : a=sin(u)/u 
a=sqrt(u) : a=u^0.5  a=sqr(u) : a=u^2 
a=sgn(u) : u<0 a=-1, u=0 a=0, u>1 a=1 
a=round(u) : avrundar u till heltal 
pi 3.1415926535897932385 
a=ln(u) : naturliga log. 
a=lg(u) : 10-log. 
a=n!(u) : Fakultet 
a=e(u) eller a=exp(u): exponentfunk e^(u) 
a=h(u) : heavides stegfunktion u<0 a=0, u>=0 a=1 
a=fix(u) : a=heltalsdelen av u 
a=frac(u) : a=decimal av u 
a=abs(u) : a=absolutvärdet av u 
exempel. ((x+5.4)*(4+x))^2*sin(x/pi)/( ln(x)*2) 
Skriv inte '.12' för '0.12' 
 
} 
 
implementation 
 
{$IFOPT N+,E+} 
const 
 MAXREAL = 9.99E4931; 
 EXPLIMIT = 11356; 
 SQRLIMIT = 1E2466; 
 MAXEXPLEN = 4; 
{$else} 
const 
 MAXREAL = 1.5E38; 
 EXPLIMIT = 88; 
 SQRLIMIT = 1E18; 
 MAXEXPLEN = 3; 
{$ENDIF} 
 
const 
 LNOF10 = 2.30258509299405; 
 LETTERS : set of Char = ['A'..'Z', 'a'..'z']; 
 PLUS = 0; 
 MINUS = 1; 
 TIMES = 2; 
 DIVIDE = 3; 
 EXPO = 4; 
 OPAREN = 6; 
 CPAREN = 7; 
 NUM = 8; 
 CELLT = 9; 
 FUNC = 10; 
 EOL = 11; 
 BAD = 12; 
 MAXFUNCNAMELEN = 15; 
 PARSERSTACKSIZE = 20; 
 MAXROWS = 10; 
 TXT = 0; 
 VALUE = 1; 
 FORMULA = 2; 
 
type 
 CellRec = record 
  Error : Boolean; 
  case Attrib : Byte of 
   TXT : (T : IString); 
   VALUE : (Value : Real); 
   FORMULA : (Fvalue : Real; 
         Formula : IString); 
 end; 
 TokenRec = record 
  State : Byte; 
  case Byte of 
   0 : (Value : Real); 
   1 : (Row : Word); 
   2 : (FuncName : String[MAXFUNCNAMELEN]); 
 end; 
 
var 
 felmed              : String; 
 Stack              : array [1..PARSERSTACKSIZE] of TokenRec; 
 CurToken             : TokenRec; 
 StackTop, TokenType       : Word; 
 MathError, TokenError, IsFormula : Boolean; 
 intext              : IString; 
 
function UpperCASE(S : String) : String; 
(* Returns a string of all upper case letters *) 
var 
 Counter : Word; 
begin 
 for Counter := 1 to Length(S) do 
  S[Counter] := UpCASE(S[Counter]); 
 UpperCASE := S; 
end; (* UpperCASE *) 
 
PROCEDURE Push(Token : TokenRec); 
(* Pushes a new Token onto the stack *) 
begin 
 if StackTop = PARSERSTACKSIZE then 
 begin 
  TokenError := True; 
 end 
 else begin 
  Inc(StackTop); 
  Stack[StackTop] := Token; 
 end; 
end; (* Push *) 
 
function IsFunc(S : String) : Boolean; 
(* Checks to see if the start of the intext string is a legal function. 
 Returns TRUE if it is, FALSE otherwise. 
*) 
var 
 Len : Word; 
begin 
 Len := Length(S); 
 if Pos(S, intext) = 1 then 
 begin 
  CurToken.FuncName := Copy(intext, 1, Len); 
  Delete(intext, 1, Len); 
  IsFunc := True; 
 end 
 else 
  IsFunc := False; 
end; (* IsFunc *) 
 
 
function FormulaStart(intext : String; Place : Word; 
           var FormLen : Word) : Boolean; 
(* Returns TRUE if the string is the start of a formula, FALSE otherwise. 
  Also returns the column, row, and length of the formula. 
*) 
begin 
 FormulaStart := False; 
 if not (intext[Place] in LETTERS) then 
  Exit; 
 if not (intext[Place]=variabelnamn) then 
  Exit; 
 FormLen := 1; 
 FormulaStart := True; 
end; (* FormulaStart *) 
 
function NextToken : Word; 
(* Gets the next Token from the Input stream *) 
var 
 NumString             : String[80]; 
 FormLen, Len, NumLen : Word; 
 koll : Integer; 
 Decimal              : Boolean; 
begin 
 if intext = '' then 
 begin 
  NextToken := EOL; 
  Exit; 
 end; 
 while (intext <> '') and (intext[1] = ' ') do 
  Delete(intext, 1, 1); 
 if intext[1] in ['0'..'9', '.'] then 
 begin 
  NumString := ''; 
  Len := 1; 
  Decimal := False; 
  while (Len <= Length(intext)) and 
     ((intext[Len] in ['0'..'9']) or 
      ((intext[Len] = '.') and (not Decimal))) do 
  begin 
   NumString := NumString + intext[Len]; 
   if intext[1] = '.' then 
    Decimal := True; 
   Inc(Len); 
  end; 
  if (Len = 2) and (intext[1] = '.') then 
  begin 
   NextToken := BAD; 
   Exit; 
  end; 
  if (Len <= Length(intext)) and (intext[Len] = 'E') then 
  begin 
   NumString := NumString + 'E'; 
   Inc(Len); 
   if intext[Len] in ['+', '-'] then 
   begin 
    NumString := NumString + intext[Len]; 
    Inc(Len); 
   end; 
   NumLen := 1; 
   while (Len <= Length(intext)) and (intext[Len] in ['0'..'9']) and 
      (NumLen <= MAXEXPLEN) do 
   begin 
    NumString := NumString + intext[Len]; 
    Inc(NumLen); 
    Inc(Len); 
   end; 
  end; 
  if NumString[1] = '.' then 
   NumString := '0' + NumString; 
  Val(NumString, CurToken.Value, koll); 
  if koll <> 0 then begin 
   MathError := True; 
   felmed:='Inget numeriskt värde'; 
  end; 
  NextToken := NUM; 
  Delete(intext, 1, Length(NumString)); 
  Exit; 
 end 
 else if intext[1] in LETTERS then 
 begin 
  if IsFunc('TANH') or 
    IsFunc('TAND') or 
    IsFunc('TAN') or 
    IsFunc('SQRT') or 
    IsFunc('SQR') or 
    IsFunc('SINH') or 
    IsFunc('SIND') or 
    IsFunc('SINC') or 
    IsFunc('SIN') or 
    IsFunc('SGN') or 
    IsFunc('ROUND') or 
    IsFunc('PI') or 
    IsFunc('LN') or 
    IsFunc('LG') or 
    IsFunc('N!') or 
    IsFunc('EXP') or 
    IsFunc('E') or 
    IsFunc('COTH') or 
    IsFunc('COSH') or 
    IsFunc('COSD') or 
    IsFunc('COS') or 
    IsFunc('H') or 
    IsFunc('FRAC') or 
    IsFunc('FIX') or 
    IsFunc('ATAND') or 
    IsFunc('ATAN') or 
    IsFunc('ASIND') or 
    IsFunc('ASIN') or 
    IsFunc('ACOSD') or 
    IsFunc('ACOS') or 
    IsFunc('ABS') then 
  begin 
   NextToken := FUNC; 
   Exit; 
  end; 
  if FormulaStart(intext, 1, FormLen) then 
  begin 
   Delete(intext, 1, FormLen); 
   IsFormula := True; 
   NextToken := CELLT; 
   Exit; 
  end 
  else begin 
   NextToken := BAD; 
   Exit; 
  end; 
 end 
 else begin 
  case intext[1] of 
   '+' : NextToken := PLUS; 
   '-' : NextToken := MINUS; 
   '*' : NextToken := TIMES; 
   '/' : NextToken := DIVIDE; 
   '^' : NextToken := EXPO; 
   '(' : NextToken := OPAREN; 
   '[' : NextToken := OPAREN; 
   '{' : NextToken := OPAREN; 
   ')' : NextToken := CPAREN; 
   ']' : NextToken := CPAREN; 
   '}' : NextToken := CPAREN; 
   else 
    NextToken := BAD; 
  end; 
  Delete(intext, 1, 1); 
  Exit; 
 end; (* case *) 
end; (* NextToken *) 
 
procedure ShIFt(State : Word); 
(* ShIFts a Token onto the stack *) 
begin 
 CurToken.State := State; 
 Push(CurToken); 
 TokenType := NextToken; 
end; (* ShIFt *) 
 
procedure Pop(var Token : TokenRec); 
(* Pops the top Token off of the stack *) 
begin 
 Token := Stack[StackTop]; 
 Dec(StackTop); 
end; (* Pop *) 
 
function Fac(nr: Real): Real; 
var n : Integer; 
const nRealMax = 33; 
   nExtENDedMax = 1754; 
   facVal: ARRAY[0..nRealMax] OF REAL = 
     (1.0,1.0,2.0,6.0,24.0,120.0,720.0,5040.0,40320.0,362880.0, 
      3628800.0,39916800.0,479001600.0,6227020800.0,87178291200.0, 
      1307674368000.0,20922789888000.0,355687428100000.0, 
      6402373705700000.0,121645100410000000.0,2432902008200000000.0, 
      51090942172000000000.0,1124000727800000000000.0, 
      25852016739000000000000.0,620448401730000000000000.0, 
      15511210043000000000000000.0,403291461120000000000000000.0, 
      10888869450000000000000000000.0,304888344610000000000000000000.0, 
      8841761993700000000000000000000.0,265252859810000000000000000000000.0, 
      8222838654100000000000000000000000.0, 
      263130836930000000000000000000000000.0, 
      8683317618800000000000000000000000000.0); 
 
var f : REAL; 
   i : WORD; 
begin 
 if ( nr > 1754.0) then begin 
  MathError:=True; 
  felmed:='Facultet för stort'; 
  fac:=0.0; 
  Exit; 
 end; 
 n:=Round(nr); 
 if n <= nRealMax then begin 
  Fac:= facVal[n]; 
  Exit; 
 end; 
 (*$IFopt N+*) 
 if n <= nExtENDedMax then begin 
  f:= facVal[nRealMax]; 
  FOR i:= nRealMax + 1 TO n DO f:= f*i; 
  Fac:= f; 
  Exit; 
 end; 
 (*$ENDIF*) 
 felmed:='Fel i fakultet'; 
 Fac:= maxReal; 
end; (* Fac *) 
 
 
function DegToRad(deg : REAL) : REAL; 
begin 
 DegToRad:=deg*pi/180.0; 
end; 
 
function RadToDeg(rad : REAL ) : REAL; 
begin 
 RadToDeg:=rad*180.0/pi; 
end; 
 
function TanDeg(deg : Real) : Real; 
begin 
 TanDeg:=Tan(DegToRad(deg)); 
end; 
 
function SinDeg(deg : Real) : Real; 
begin 
 SinDeg:=Sin(DegToRad(deg)); 
end; 
 
function CosDeg(deg : Real) : Real; 
begin 
 CosDeg:=Cos(DegToRad(deg)); 
end; 
 
function ArcCos(invalue : REAL) : REAL; 
var res : REAL; 
begin 
 if abs(invalue) > 1.0 then begin 
  felmed:='abs ACos > 1'; 
  ArcCos:=0.0; 
  Exit; 
 end; 
 if invalue = 0.0 then ArcCos:=pi/2.0 
 else begin 
  res:=Arctan(Sqrt(1-invalue*invalue)/invalue); 
  if invalue < 0.0 then ArcCos:= res+pi 
           else ArcCos:= res; 
 end; 
end;(*ArcCos*) 
 
function ArcSinDeg(invalue : REAL) : REAL; 
begin 
 if abs(invalue) > 1.0 then begin 
  felmed:='abs ASinD > 1'; 
  ArcSinDeg:=0.0; 
  Exit; 
 end; 
 if (invalue = -1.0) then ArcSinDeg:=RadToDeg(-pi/2.0) else 
 if (invalue = 1.0) then ArcSinDeg:=RadToDeg(pi/2.0) 
  else ArcSinDeg:=RadToDeg(Arctan(invalue/Sqrt(1-invalue*invalue))); 
end;(*ArcSinDeg*) 
 
function ArcCosDeg(invalue : REAL) : REAL; 
var res : REAL; 
begin 
 if abs(invalue) > 1.0 then begin 
  felmed:='abs ACosD > 1'; 
  ArcCosDeg:=0.0; 
  Exit; 
 end; 
 if invalue = 0.0 then ArcCosDeg:=RadToDeg(pi/2.0) 
 else begin 
  res:=Arctan(Sqrt(1-invalue*invalue)/invalue); 
  if invalue < 0.0 then ArcCosDeg:=RadToDeg(res+pi) 
           else ArcCosDeg:=RadToDeg(res); 
 end; 
end;(*ArcCosDeg*) 
 
function Lg(invalue : REAL) : REAL; 
begin 
 if invalue <= 0.0 then begin 
  felmed:='Lg <= 0'; 
  Lg:=0.0; 
  Exit; 
 end; 
 Lg:=Ln(invalue)/LNOF10; 
end;(*Lg*) 
 
function ArcTanDeg(invalue : Real) : Real; 
begin 
 ArcTanDeg:=RadToDeg(ArcTan(invalue)); 
end; (* ArcTanDeg *) 
 
function CotH(invalue : Real) : Real; 
begin 
 if Tanh(invalue) <> 0 then 
  CotH:=1.0/TanH(invalue) 
 else 
  CotH:=1.0E+30; 
end; 
 
function GotoState(Production : Word) : Word; 
(* Finds the new state based on the just-completed production and the 
  top state. 
*) 
var 
 State : Word; 
begin 
 State := Stack[StackTop].State; 
 if (Production <= 3) then 
 begin 
  case State of 
   0 : GotoState := 1; 
   9 : GotoState := 19; 
   20 : GotoState := 28; 
  end; (* case *) 
 end 
 else if Production <= 6 then 
 begin 
  case State of 
   0, 9, 20 : GotoState := 2; 
   12 : GotoState := 21; 
   13 : GotoState := 22; 
  end; (* case *) 
 end 
 else if Production <= 8 then 
 begin 
  case State of 
   0, 9, 12, 13, 20 : GotoState := 3; 
   14 : GotoState := 23; 
   15 : GotoState := 24; 
   16 : GotoState := 25; 
  end; (* case *) 
 end 
 else if Production <= 10 then 
 begin 
  case State of 
   0, 9, 12..16, 20 : GotoState := 4; 
  end; (* case *) 
 end 
 else if Production <= 12 then 
 begin 
  case State of 
   0, 9, 12..16, 20 : GotoState := 6; 
   5 : GotoState := 17; 
  end; (* case *) 
 end 
 else begin 
  case State of 
   0, 5, 9, 12..16, 20 : GotoState := 8; 
  end; (* case *) 
 end; 
end; (* GotoState *) 
 
procedure Reduce(Reduction : Word; variabel : Real); 
(* Completes a reduction *) 
var 
 Token1, Token2 : TokenRec; 
 exponent : LongInt; 
begin 
 case Reduction of 
  1 : begin (* a+b *) 
   Pop(Token1); 
   Pop(Token2); 
   Pop(Token2); 
   CurToken.Value := Token1.Value + Token2.Value; 
  end; 
  2 : begin (* a-b *) 
   Pop(Token1); 
   Pop(Token2); 
   Pop(Token2); 
   CurToken.Value := Token2.Value - Token1.Value; 
  end; 
  4 : begin (* a*b *) 
   Pop(Token1); 
   Pop(Token2); 
   Pop(Token2); 
   CurToken.Value := Token1.Value * Token2.Value; 
  end; 
  5 : begin (* a/b *) 
   Pop(Token1); 
   Pop(Token2); 
   Pop(Token2); 
   if Token1.Value = 0 then begin 
    MathError := True; 
    felmed:='Division med 0'; 
   end else 
    CurToken.Value := Token2.Value / Token1.Value; 
  end; 
  7 : begin (*a^b*) 
   Pop(Token1); 
   Pop(Token2); 
   Pop(Token2); 
   if Token2.Value = 0 then 
    CurToken.Value := 0; 
   if Token2.Value < 0 then begin 
    exponent:=Round(token1.value); 
    if ( exponent <> token1.value ) then begin 
     MathError := True; 
     felmed:='ex -3^-1.5 går inte'; 
    end; 
    if (Token1.Value * Ln(-Token2.Value) < -EXPLIMIT) or 
      (Token1.Value * Ln(-Token2.Value) > EXPLIMIT) then begin 
     MathError := True; 
     felmed:='abs(tal) för stort'; 
    end; 
    if Not MathError then 
     CurToken.Value:=IntPower(Token2.Value,exponent) 
    else 
     curtoken.Value:=0; 
   end; 
   if Token2.Value > 0 then begin 
    if (Token1.Value * Ln(Token2.Value) < -EXPLIMIT) or 
       (Token1.Value * Ln(Token2.Value) > EXPLIMIT) then begin 
     MathError := True; 
     felmed:='abs(tal) för stort'; 
     CurToken.Value:=0; 
    end else CurToken.Value := Exp(Token1.Value * Ln(Token2.Value)); 
    end; 
  end; 
  9 : begin 
   Pop(Token1); 
   Pop(Token2); 
   CurToken.Value := -Token1.Value; 
  end; 
  11 : begin 
   Pop(Token1); 
   Pop(Token2); 
   Pop(Token2); 
   CurToken.Value := 0; 
   end; 
  13 : begin  (* a=x *) 
   Pop(CurToken); 
   CurToken.Value := variabel; 
  end; 
  14 : begin 
   Pop(Token1); 
   Pop(CurToken); 
   Pop(Token1); 
  end; 
  16 : begin 
   Pop(Token1); 
   Pop(CurToken); 
   Pop(Token1); 
   Pop(Token1); 
   if Token1.FuncName = 'ABS' then 
    CurToken.Value := Abs(CurToken.Value) 
   else if Token1.FuncName = 'FRAC' then 
    CurToken.Value := FRAC(CurToken.Value) 
   else if Token1.FuncName = 'ATAN' then 
    CurToken.Value := ArcTan(CurToken.Value) 
   else if Token1.FuncName = 'SINH' then 
     CurToken.Value := SinH(CurToken.Value) 
   else if Token1.FuncName = 'COSH' then 
     CurToken.Value := CosH(CurToken.Value) 
   else if Token1.FuncName = 'TANH' then 
     CurToken.Value := TanH(CurToken.Value) 
   else if Token1.FuncName = 'COTH' then 
     CurToken.Value := CotH(CurToken.Value) 
   else if Token1.FuncName = 'COS' then 
    CurToken.Value := Cos(CurToken.Value) 
   else if (Token1.FuncName = 'E') or (Token1.FuncName = 'EXP') then 
   begin 
    if (CurToken.Value < -EXPLIMIT) or (CurToken.Value > EXPLIMIT) then begin 
     MathError := True; 
     felmed:='E(tal) för stort'; 
    end else 
     CurToken.Value := Exp(CurToken.Value); 
   end 
   else if Token1.FuncName = 'LN' then 
   begin 
    if CurToken.Value <= 0 then begin 
     MathError := True; 
     felmed:='neg. tal Ln'; 
    end else 
     CurToken.Value := Ln(CurToken.Value); 
   end 
   else if Token1.FuncName = 'H' then 
   begin 
    if CurToken.Value <= 0 then 
     CurToken.Value := 0.0 
    else 
     CurToken.Value := 1.0; 
   end 
   else if Token1.FuncName = 'ROUND' then 
   begin 
    if (CurToken.Value < -1E9) or (CurToken.Value > 1E9) then begin 
     MathError := True; 
     felmed:='Round(tal) för stort'; 
    end else 
     CurToken.Value := Round(CurToken.Value); 
   end 
   else if Token1.FuncName = 'PI' then 
    CurToken.Value := pi * Curtoken.Value 
   else if Token1.FuncName = 'TAN' then 
    CurToken.Value := Tan(CurToken.Value) 
   else if Token1.FuncName = 'TAND' then 
    CurToken.Value := TanDeg(CurToken.Value) 
   else if Token1.FuncName = 'COSD' then 
    CurToken.Value := CosDeg(CurToken.Value) 
   else if Token1.FuncName = 'SIND' then 
    CurToken.Value := Sindeg(CurToken.Value) 
   else if Token1.FuncName = 'SINC' then begin 
    if ( CurToken.Value <> 0.0 ) then 
      CurToken.Value := Sin(CurToken.Value)/CurToken.Value 
      else CurToken.Value:=0.0; 
    end 
   else if Token1.FuncName = 'N!' then 
    CurToken.Value := Fac(CurToken.Value) 
   else if Token1.FuncName = 'ASIN' then 
    CurToken.Value := ArcSin(CurToken.Value) 
   else if Token1.FuncName = 'ACOS' then 
    CurToken.Value := ArcCos(CurToken.Value) 
   else if Token1.FuncName = 'ATAND' then 
    CurToken.Value := ArcTanDeg(CurToken.Value) 
   else if Token1.FuncName = 'ASIND' then 
    CurToken.Value := ArcSinDeg(CurToken.Value) 
   else if Token1.FuncName = 'ACOSD' then 
    CurToken.Value := ArcCosDeg(CurToken.Value) 
   else if Token1.FuncName = 'LG' then 
    CurToken.Value := Lg(CurToken.Value) 
   else if Token1.FuncName = 'SIN' then 
    CurToken.Value := Sin(CurToken.Value) 
   else if Token1.FuncName = 'SGN' then 
   begin 
    if CurToken.Value < 0 then CurToken.Value:=-1.0; 
    if CurToken.Value = 0 then CurToken.Value:=0.0; 
    if CurToken.Value > 0 then CurToken.Value:=1.0; 
   end 
   else if Token1.FuncName = 'SQRT' then 
   begin 
    if CurToken.Value < 0 then begin 
     MathError := True; 
     felmed:='sqrt( < 0 )'; 
    end else 
     CurToken.Value := Sqrt(CurToken.Value); 
   end 
   else if Token1.FuncName = 'SQR' then 
   begin 
    if (CurToken.Value < -SQRLIMIT) or (CurToken.Value > SQRLIMIT) then begin 
     MathError := True; 
     felmed:='Sqr(Abs(tal)) för stort'; 
    end else 
     CurToken.Value := Sqr(CurToken.Value); 
   end 
   else if Token1.FuncName = 'FIX' then 
   begin 
    if (CurToken.Value < -1E9) or (CurToken.Value > 1E9) then begin 
     MathError := True; 
     felmed:='fix(abs(tal)) för stort'; 
    end else 
     CurToken.Value := Trunc(CurToken.Value); 
   end; 
  end; 
  3, 6, 8, 10, 12, 15 : Pop(CurToken); 
 end; (* case *) 
 CurToken.State := GotoState(Reduction); 
 Push(CurToken); 
end; (* Reduce *) 
 
function ParseX(variabel : Real;S : IString; var fel : String ) : Real; 
var 
 FirstToken : TokenRec; 
 Accepted  : Boolean; 
 i : Word; 
begin 
 Accepted := False; 
 TokenError := False; 
 MathError := False; 
 IsFormula := False; 
 felmed:=''; 
 fel:=''; 
 intext := UpperCASE(S); 
 S:=intext; 
 i:=1; 
 while ( i <= Length(intext) ) DO begin (* om PI lägg till PI(1) *) 
  if ( intext[i] = 'P' ) AND ( intext[i+1] = 'I' ) then begin 
   if (intext[i+2] <> '(') OR ( Length(intext) = (i+1) ) then 
    insert('(1)',intext,i+2); 
  end; 
  i:=i+1; 
 end; 
 i:=1; 
 while ( i <= Length(intext) ) DO begin (* om komma ändra till punkt*) 
  if ( intext[i] = ',' ) then intext[i]:='.'; 
  i:=i+1; 
 end; 
 StackTop := 0; 
 FirstToken.State := 0; 
 FirstToken.Value := 0; 
 Push(FirstToken); 
 TokenType := NextToken; 
 repeat case Stack[StackTop].State of 
   0, 9, 12..16, 20 : begin 
    if TokenType = NUM then 
     ShIFt(10) 
    else if TokenType = CELLT then 
     ShIFt(7) 
    else if TokenType = FUNC then 
     ShIFt(11) 
    else if TokenType = MINUS then 
     ShIFt(5) 
    else if TokenType = OPAREN then 
     ShIFt(9) 
    else 
     TokenError := True; 
   end; 
   1 : begin 
    if TokenType = EOL then 
     Accepted := True 
    else if TokenType = PLUS then 
     ShIFt(12) 
    else if TokenType = MINUS then 
     ShIFt(13) 
    else 
     TokenError := True; 
   end; 
   2 : begin 
    if TokenType = TIMES then 
     ShIFt(14) 
    else if TokenType = DIVIDE then 
     ShIFt(15) 
    else 
     Reduce(3,variabel); 
   end; 
   3 : Reduce(6,variabel); 
   4 : begin 
    if TokenType = EXPO then 
     ShIFt(16) 
    else 
     Reduce(8,variabel); 
   end; 
   5 : begin 
    if TokenType = NUM then 
     ShIFt(10) 
    else if TokenType = CELLT then 
     ShIFt(7) 
    else if TokenType = FUNC then 
     ShIFt(11) 
    else if TokenType = OPAREN then 
     ShIFt(9) 
    else 
     TokenError := True; 
   end; 
   6 : Reduce(10,variabel); 
   7 : Reduce(13,variabel); 
   8 : Reduce(12,variabel); 
   10 : Reduce(15,variabel); 
   11 : begin 
    if TokenType = OPAREN then 
     ShIFt(20) 
     else 
     TokenError := True; 
   end; 
   17 : Reduce(9,variabel); 
   18 : begin 
    if TokenType = CELLT then 
     ShIFt(26) 
    else 
     TokenError := True; 
   end; 
   19 : begin 
    if TokenType = PLUS then 
     ShIFt(12) 
    else if TokenType = MINUS then 
     ShIFt(13) 
    else if TokenType = CPAREN then 
     ShIFt(27) 
    else 
     TokenError := True; 
   end; 
   21 : begin 
    if TokenType = TIMES then 
     ShIFt(14) 
    else if TokenType = DIVIDE then 
     ShIFt(15) 
    else 
     Reduce(1,variabel); 
   end; 
   22 : begin 
    if TokenType = TIMES then 
     ShIFt(14) 
    else if TokenType = DIVIDE then 
     ShIFt(15) 
    else 
     Reduce(2,variabel); 
   end; 
   23 : Reduce(4,variabel); 
   24 : Reduce(5,variabel); 
   25 : Reduce(7,variabel); 
   26 : Reduce(11,variabel); 
   27 : Reduce(14,variabel); 
   28 : begin 
    if TokenType = PLUS then 
     ShIFt(12) 
    else if TokenType = MINUS then 
     ShIFt(13) 
    else if TokenType = CPAREN then 
     ShIFt(29) 
    else 
     TokenError := True; 
   end; 
   29 : Reduce(16,variabel); 
  end; (* case *) 
 until Accepted or TokenError; 
 if TokenError then 
 begin 
  fel:='Felskrivet'; 
  ParseX := 0; 
  Exit; 
 end; 
 if MathError then 
 begin 
  fel:=felmed; 
  ParseX := 0; 
  Exit; 
 end; 
 fel:=felmed; 
 ParseX := Stack[StackTop].Value; 
end; (* ParseX *) 
 
begin 
 variabelnamn:='X'; 
end.

 
 
© Copyright 2005 - Staffan Berg
- Alla rättigheter förbehålles -