Unit FCompiler; {26.01.2012 by Heizkoerper

 Formelcompiler für die Programmiersprache (Objekt-) Pascal
 ==========================================================

 Dieser Compiler für Formeltexte ist von mir als Unit entwickelt worden.

 Diese darf in eigenen Projekten benutzt werden.

 Folgende Merkmale zeichnet diesen Compiler aus:

 * es wird prozessorunabhängiger Pseudocode erstellt,
 * es können leicht zusätzliche mathematishce Funktionen eingefügt werden,
 * ungültige Rechenvorschriften wie z.B. 1/0, ln(0) etc. können abgefangen
   werden,
 * die Unit lässt sich leicht in eigene Programme einfügen,
 * der Quelltext läßt sich leicht in eine andere Programmiersprache portieren.

 Erklärungen zum Qellcode des Formelcompilers:
 ============================================= }

Interface

// Die Konstante

Const ErgebnisFehler=1E100;

{oder ein anderer hoher Wert, welcher im Normalfall nicht auftritt,
 dient dazu, nach einer falschen Rechenvorschrift wie z.B. 1/0,
 Sqrt(-1) oder Ähnlichem entsprechend reagieren zu können.

 Somit ist es möglich, z.B. eine Funktion bei vorgegebenen y-min und
 y-max Werten auch mit Unstetigkeits- und Unendlichkeitsstellen grafisch
 darzustellen.}

Const MaxFormellaenge=100;

Type  StringMaxFormellaenge=String[MaxFormellaenge];

// In dieser Unit gibt es zum einem die

Procedure CompiliereFormel(Formel:StringMaxFormellaenge;Var Fehler:Boolean);

{mit dessen Hilfe der Formelstring Formel, welcher die Varablen x und y
 enthalten kann, übersetzt wird.

 Der Formelstring entspricht in etwa der Pascal-Syntax.

 Zum anderen läßt sich mit der}

Function f(x,y:Extended):Extended;

{der Funktionswert berechnen.

 Hinweise zum Formelstring:
 ==========================
 Es lassen sich zweidimensionale Formeln der Form y=f(x),
 dreidimensionale Formeln der Form z=f(x,y) und
 Formeln mit 2 Parametern wie z=Zahl1_Operator_Zahl2 übersetzen.

 Folgende Zeichen und Funktionen sind im Formelstring zugelassen:
 (Es wird nicht zwischen Groß- und Kleinschreibung unterschieden!)

 .         0..9      (         )
 +         -         *         /         \         ^
 x         y         Pi        e         Deg       Rad
 Abs       Sgn       Round     Rcp
 Sqr       Sqrt      Log       Ln        Exp
 Sin       Cos       Tan       Cot
 ASin      ACos      ATan      ACot

 Die Kreiskonstante Pi=3.14159... kann als Pi eingegeben werden.
 Die Eulerzahl      e =2.71828... kann als e  eingegeben werden.

 Der Buchstabe e kann auch in der wissenschaftlichen
 Zahlenschreibweise benutzt werden (z.B. 25E-1 als 2.5).

 Erklärung einzelner Funktionen:
 ===============================
 Formeln mit 1 Parameter:
 ========================
 Sqr(x)=x*x
 Sqrt(x)=Quadratwurzel aus x
 Log(x)=Logarithmus von x zur Basis 10
 Ln(x)=Logarithmus von x zur Basis e
 Sin(x)=Sinus von x
 ASin(x)=Arcus Sinus von x
 Rcp(y)=1/y
 Sgn(y)=Vorzeichen von y
 Deg(x)=x*180/Pi (Radiant wird in Degree ungerechnet)
 Rad(x)=x*Pi/180 (Degree wird in Radiant umgerechnet)

 Formeln mit 2 Parametern und einem Operator:
 ============================================
 x+y=x Plus y                     x-y=x Minus y
 x*y=x Mal y                      x/y=x Geteilt durch y
 x\y=x Mod y                      x^y=x Hoch y

 Beispiele für 2-dimensionale Funktionen der Form y=f(x):
 ========================================================
 y=Sin(Rad(x))                    y=Deg(ASin(x))
 y=(Sin(x)+1)^(Sin(x)+1)-0.75
 y=x*(Sin(1/x)+1)^(Sin(1/x)+1)
 y=x*Sin(1/x)*Cos(1/x)

 Beispiele für 3-dimensionale Funktionen der Form z=f(x,y):
 ==========================================================
 z=1/(Sqr(x)+y*y+0.25)            z=Abs(x)+Abs(y)
 z=x*Sin(1/x)*y*Sin(1/y)          z=Sqrt(Abs(Sin(x)*Sin(y)))
 z=Sin(x*y)/(x^2+0.1)             z=Sin(x+Sin(x*y))
 z=Sin(x)+Sin(5*y)                z=x*Exp(-x^2-y^2)
 z=Sin(x)/Cos(y).}

Implementation

Uses SysUtils,Dialogs;

Type  Symbole=(LadeX,LadeY,LadePi,LadeE,Push,
               CNeg,CAdd,CSub,CMul,CDiv,CPot,CMod,
               CAbs,CSgn,CRound,CRcp,CSqr,CSqrt,CLog,CLn,CExp,
               CSin,CCos,CTan,CCot,CASin,CACos,CATan,CACot,CRad,CDeg,
               CEnde);

{Die maximale Länge des ausführbaren Codes, bestehend aus
 Befehlen und Konstanten kann}

Const MaxCode        =MaxFormellaenge*10; //betragen.
      MaxKlammertiefe=100;

//Der Pseudocode und die Konstanten werden im folgenden Array abgelegt:

Var   PCode:Array[0..MaxCode] Of Symbole;

{Und nun zur wichtigsten Procedure, welche in großen
 Teilen hoffentlich selbterklärend ist, dieser Unit:}

Procedure CompiliereFormel(Formel:StringMaxFormellaenge;Var Fehler:Boolean);

Type  Str1=String[1];

Const MaxLaengeBefehle=5;
   // Maximale Laenge der folgenden mathematischen Ausdrücke:
      Befehlsnamen:Array[CAbs..Pred(CEnde)] Of String[MaxLaengeBefehle]=(
       'ABS','SGN','ROUND','RCP','SQR','SQRT','LOG' ,'LN',
       'EXP','SIN','COS'  ,'TAN','COT','ASIN','ACOS','ATAN','ACOT','RAD','DEG');
      Compilerfehler:Array[0..9] Of String[55]=(
       'Der Speicherplatz im Codefeld reicht nicht aus',
       'Operator erwartet',
       '( erwartet',
       'Unbekannte Funktion',
       ') erwartet',
       'Konstante, Variable oder Funktion erwartet',
       'Fehler in Konstante',
       'Klammer-Fehler',
       'Der Formelstring ist leer',
       'Die Formel ist zu lang');

Var   ChP,Pc      :Word;
   // Formelstring- und Programmposition.
      KlammerTiefe:0..MaxKlammertiefe;
   // maximale Klammertiefe.
      Ch          :Char;
   // Aktuelles Zeichen im Formelstring.

 Procedure FehlerAusgabe(Nummer:Byte);
 Begin
  ShowMessage(Formel+' '+Compilerfehler[Nummer]+' an Stelle '+IntToStr(ChP));
  Fehler:=True;ChP:=Length(Formel)+1;Ch:='?'
 End;

 Procedure Code(Code:Symbole);
// Diese Procedure schreibt den Pseudocode in das Array PCode.
 Begin
  If Pc>=SizeOf(PCode) Then Begin FehlerAusgabe(0);Exit End;
  PCode[Pc]:=Code;Inc(Pc)
 End;

 Procedure CodeKonstante(Zahl:Extended);
// Eine Konstante aus der Formel wird gelesen und in PCode abgespeichert.
 Begin
  If Pc+SizeOf(Extended)>=SizeOf(PCode) Then Begin FehlerAusgabe(0);Exit End;
  Move(Zahl,PCode[Pc],SizeOf(Extended));Inc(Pc,SizeOf(Extended))
 End;

 Procedure ZeichenLesen;
// Ein Zeichen aus dem Formelstring wird gelesen.
 Begin
  Inc(ChP);
  If ChP>Length(Formel) Then Ch:='?' Else Ch:=Formel[ChP]
 End;

 Procedure Konstante(Vorzeichen:Str1);
// Eine Konstante aus der Formel wird gelesen und abgespeichert.
 Var Zahl                           :Extended;
     FehlerPosition1,FehlerPosition2:Integer;
 Begin
  Val(Copy(Formel,ChP,255)+'?',Zahl,FehlerPosition1);
  Val(Vorzeichen+Copy(Formel,ChP,FehlerPosition1-1),Zahl,FehlerPosition2);
  If FehlerPosition2<>0 Then Begin FehlerAusgabe(6);Exit End;
  Code(Push);CodeKonstante(Zahl);Inc(ChP,FehlerPosition1-2);ZeichenLesen;
  If Not (Ch In ['-','+','/','*','^','\',')','?']) Then FehlerAusgabe(1)
 End;

 Procedure AdditionSubtraktion;Forward;

 Procedure Term; // Die eigentliche rekursive Formelauswertung
 Var Befehlsname:String[MaxLaengeBefehle];
     i,s        :Symbole;
     Vorzeichen :Str1;
 Begin
  If Fehler Then Begin Ch:='?';Exit End;
  ZeichenLesen;
  If Ch In ['?',')'] Then Begin FehlerAusgabe(5);Exit End;
  If Ch='-' Then Begin ZeichenLesen;Vorzeichen:='-' End Else Vorzeichen:='';
  If Ch='+' Then ZeichenLesen;
  If Ch='(' Then
   Begin
    Inc(KlammerTiefe);AdditionSubtraktion;Dec(KlammerTiefe);
    If Ch<>')' Then Begin FehlerAusgabe(4);Exit End;
    ZeichenLesen
   End
            Else
   If Ch In ['0'..'9'] Then Konstante(Vorzeichen)
                       Else
    Begin
     Befehlsname:='';
     While Ch in ['A'..'Z'] Do
      Begin Befehlsname:=Befehlsname+Ch;ZeichenLesen End;
     If Befehlsname='X' Then Code(LadeX)
                        Else
      If Befehlsname='Y' Then Code(LadeY)
                         Else
       If Befehlsname='PI' Then Code(LadePi)
                           Else
        If Befehlsname='E' Then Code(LadeE)
                           Else
         Begin
          s:=LadeX;
          For i:=CAbs To Pred(CEnde) Do
           If Befehlsname=Befehlsnamen[i] Then s:=i;
          If s<>LadeX Then
           Begin
            If Ch<>'(' Then Begin FehlerAusgabe(2);Exit End;
            Dec(ChP);Term;Code(s);
           End
                      Else Begin FehlerAusgabe(3);Exit End
         End;
     If Vorzeichen='-' Then Code(CNeg)
    End
 End;

 Procedure Potenz; // 1.Rechenpriorität
 Begin
  Repeat
   Case Ch Of
    '^':Begin Term;Code(CPot) End
   End
  Until Not (Ch In ['^'])
 End;

 Procedure MultiplikationDivision; // 2.Rechenpriorität
 Begin
  Repeat
   Case Ch Of
    '*':Begin Term;Potenz;Code(CMul) End;
    '/':Begin Term;Potenz;Code(CDiv) End;
    '\':Begin Term;Potenz;Code(CMod) End
   End
  Until Not (Ch In ['*','/','\'])
 End;

 Procedure AdditionSubtraktion; // 3.Rechenpriorität}
 Begin
  If Fehler Then Begin Ch:='?';Exit End;
  Term;
  Repeat
   Case Ch Of
    '+'        :Begin Term;Potenz;MultiplikationDivision;Code(CAdd) End;
    '-'        :Begin Term;Potenz;MultiplikationDivision;Code(CSub) End;
    '('        :Begin FehlerAusgabe(1);Exit End;
    ')'        :Begin
                 If KlammerTiefe=0 Then FehlerAusgabe(7);
                 Exit
                End;
    '*','/','\':MultiplikationDivision;
    '^'        :Potenz;
    '?'        :
    Else Begin FehlerAusgabe(1);Exit End
   End
  Until (Ch='?') Or Fehler
 End;

Begin // Anfang von der Procedure CompiliereFormel.
 If Length(Formel)<1 Then Begin Chp:=1;FehlerAusgabe(8);Exit End;
 If Length(Formel)>=MaxFormellaenge Then Begin Chp:=1;FehlerAusgabe(9);Exit End;
 For ChP:=1 To Length(Formel) Do
  Begin
   Formel[ChP]:=UpCase(Formel[ChP]);
   If Formel[ChP]=',' Then Formel[ChP]:='.';
   If Formel[ChP]=' ' Then Begin FehlerAusgabe(5);Exit End
  End;
 If Formel[1]='-' Then Formel:='0'+Formel;
 Pc:=0;Fehler:=False;KlammerTiefe:=0;ChP:=0;
 AdditionSubtraktion;Code(CEnde);
// Eigentliche Übersetzung des Formelstrings.
 If KlammerTiefe<>0 Then FehlerAusgabe(7)
// Klammer- und Stackkontrolle.
End;

Function f(x,y:Extended):Extended;
 Function Sgn(x:Extended):ShortInt;
 Begin
  If x>0 Then Sgn:=1 Else Sgn:=-1;
  If x=0 Then Sgn:=0
 End;
 Function Pot(x,y:Extended):Extended;
 Begin Pot:=Exp(y*Ln(x)) End;
 Function Tan(x:Extended):Extended;
 Begin Tan:=Sin(x)/Cos(x) End;
 Function Cot(x:Extended):Extended;
 Begin Cot:=Cos(x)/Sin(x) End;
 Function ArcSin(x:Extended):Extended;
 Begin
  If Abs(x)=1 Then ArcSin:=Sgn(x)*Pi/2 Else ArcSin:=ArcTan(x/Sqrt(1-x*x))
 End;
 Function ArcCos(x:Extended):Extended;
 Begin ArcCos:=Pi/2-ArcSin(x) End;
 Function ArcCot(x:Extended):Extended;
 Begin ArcCot:=Pi/2-ArcTan(x) End;
 Function Deg(x:Extended):Extended;
 Begin Deg:=x*180/Pi End;
 Function Rad(x:Extended):Extended;
 Begin Rad:=x*Pi/180 End;
Var Stack   :Array[0..MaxKlammertiefe] Of Extended;
    Pc      :Word;               // ProgrammCounter
    Sp      :0..MaxKlammertiefe; // StackPointer
    Oc      :Symbole;            // ObjectCode
    Argument:Extended;
Begin
 Pc:=0;Sp:=0;Stack[Sp]:=0;
 Repeat
  Oc:=PCode[Pc];Inc(Pc);Argument:=Stack[Sp];
  If Argument<ErgebnisFehler Then
   Case Oc Of
    LadeX :Begin Inc(Sp);Stack[Sp]:=x End;
    LadeY :Begin Inc(Sp);Stack[Sp]:=y End;
    LadePi:Begin Inc(Sp);Stack[Sp]:=Pi End;
    LadeE :Begin Inc(Sp);Stack[Sp]:=Exp(1) End;
    Push  :Begin
            Inc(Sp);Move(PCode[Pc],Stack[Sp],SizeOf(Extended));
            Inc(Pc,SizeOf(Extended))
           End;
    CNeg  :Stack[Sp]:=-Argument;
    CAdd  :Begin Dec(Sp);Stack[Sp]:=Stack[Sp]+Argument End;
    CSub  :Begin Dec(Sp);Stack[Sp]:=Stack[Sp]-Argument End;
    CMul  :Begin Dec(Sp);Stack[Sp]:=Stack[Sp]*Argument End;
    CDiv  :Begin
            Dec(Sp);
            If Argument<>0 Then Stack[Sp]:=Stack[Sp]/Argument
                           Else Stack[Sp]:=ErgebnisFehler
           End;
    CPot  :Begin
            Dec(Sp);
            If Stack[Sp]>0 Then Stack[Sp]:=Pot(Stack[Sp],Argument)
                           Else Stack[Sp]:=ErgebnisFehler
           End;
    CMod  :Begin
            Dec(Sp);
            If Argument<>0 Then
             Stack[Sp]:=Stack[Sp]-Int(Stack[Sp]/Argument)*Argument
                           Else Stack[Sp]:=ErgebnisFehler
           End;
    CAbs  :Stack[Sp]:=Abs(Argument);
    CSgn  :Stack[Sp]:=Sgn(Argument);
    CRound:Stack[Sp]:=Round(Argument);
    CRcp  :If Argument=0 Then Stack[Sp]:=ErgebnisFehler
                         Else Stack[Sp]:=1/Argument;
    CSqr  :Stack[Sp]:=Sqr(Argument);
    CSqrt :If Argument<0 Then Stack[Sp]:=ErgebnisFehler
                         Else Stack[Sp]:=Sqrt(Argument);
    CLog  :If Argument>0 Then Stack[Sp]:=Ln(Argument)/Ln(10)
                         Else Stack[Sp]:=ErgebnisFehler;
    CLn   :If Argument>0 Then Stack[Sp]:=Ln(Argument)
                         Else Stack[Sp]:=ErgebnisFehler;
    CExp  :Stack[Sp]:=Exp(Argument);
    CSin  :Stack[Sp]:=Sin(Argument);
    CCos  :Stack[Sp]:=Cos(Argument);
    CTan  :If Cos(Argument)<>0 Then Stack[Sp]:=Tan(Argument)
                               Else Stack[Sp]:=ErgebnisFehler;
    CCot  :If Sin(Argument)<>0 Then Stack[Sp]:=Cot(Argument)
                               Else Stack[Sp]:=ErgebnisFehler;
    CASin :If Abs(Argument)>1 Then Stack[Sp]:=ErgebnisFehler
                              Else Stack[Sp]:=ArcSin(Argument);
    CACos :If Abs(Argument)>1 Then Stack[Sp]:=ErgebnisFehler
                              Else Stack[Sp]:=ArcCos(Argument);
    CATan :Stack[Sp]:=ArcTan(Argument);
    CACot :Stack[Sp]:=ArcCot(Argument);
    CRad  :Stack[Sp]:=Rad(Argument);
    CDeg  :Stack[Sp]:=Deg(Argument)
   End
                             Else
   Begin Oc:=CEnde;Stack[1]:=ErgebnisFehler End
 Until Oc>=CEnde;
 f:=Stack[1]
End;

End.