Turbo Toolbox/Turbo_Toolbox.iso/1987/03/fkplot4.pas

Pascal/Delphi Source File | 1987-02-03 | 5.4 KB | 139 lines

{---------------------------------------------------------------------------}
{                            fkplot4.pas                                    }

{             Funktion zur Berechnung des Funktionswertes von x:            }

FUNCTION Berechnung (q2: Str; x: REAL): REAL;

VAR i, j, k: INTEGER;
    cd: INTEGER;
    f1, f2: Str;
    g1, g2, h: REAL;

BEGIN
  FOR i := Length(q2)+1 TO 255 DO q2[i]:=' ';
  REPEAT
    i:=1;
    j:=0;
    REPEAT                                  { Suchen der innersten Funktion }
      IF (q2[i] IN ['A'..'Z']) AND (NOT(q2[i] = 'E')) THEN
      BEGIN
        j := i;
        REPEAT
          j := j+1;
        UNTIL (q2[j] IN ['A'..'Z',')']) AND (NOT(q2[j] = 'E'));
        IF q2[j] = ')' THEN
        BEGIN
          IF q2[i] IN ['T'..'Z'] THEN
          BEGIN
            k := i;
            REPEAT
              k := k+1;
            UNTIL q2[k] = ',';
            f1 := Copy(q2, i+2, k-i-2);                   { erstes Argument }
            f2 := Copy(q2, k+1, j-k-1);                  { zweites Argument }
            WHILE f1[1] = ' ' DO Delete(f1, 1, 1);
            WHILE f2[1] = ' ' DO Delete(f2, 1, 1);
            IF f1 = '@' THEN g1 := x ELSE Val(f1, g1, cd);
            IF f2 = '@' THEN g2 := x ELSE Val(f2, g2, cd);
            CASE q2[i] OF                           { Berechnen der jeweils }
              'Z': h := g1+g2;                     { innersten Teilfunktion }
              'Y': h := g1-g2;
              'X': h := g1*g2;
              'W': IF g2 <> 0 THEN
                     h := g1/g2
                   ELSE
                     h := 0;                   { eigentlich:  Fehlermeldung }
              'V': IF g1 > 0 THEN
                     h := Exp(g2*Ln(g1))
                   ELSE IF (g1 = 0) AND (g2 > 0) THEN
                     h := 0
                   ELSE IF (g1 < 0) AND (g2 = Int(g2)) THEN
                     CASE Odd(Trunc(g2)) OF
                       TRUE : h := -Exp(g2*Ln(-g1));
                       FALSE: h := Exp(g2*Ln(-g1));
                     END
                   ELSE
                     h := 0;                   { eigentlich:  Fehlermeldung }
              'U': h := g1-Int(g1/g2)*g2;
              'T': h := Int(g1/g2);
            END;
          END
          ELSE
          BEGIN                                        { Falls Funktion A-S }
            f1 := Copy(q2, i+2, j-i-2);                { Argument           }
            WHILE f1[1] = ' ' DO Delete(f1, 1, 1);
            IF f1 = '@' THEN g1 := x ELSE Val(f1, g1, cd);
            CASE q2[i] OF
              'A': IF g1 = 0 THEN h := 0 ELSE h := g1/abs(g1); { Berechnung }
              'B': h := abs(g1);
              'C': IF (g1 > 0) OR (g1 = Int(g1)) THEN
                     h := Int(g1)
                   ELSE
                     h := Int(g1)-1;
              'D': IF g1 <> 0 THEN
                     h := (Exp(g1)+Exp(-g1))/(Exp(g1)-Exp(-g1))
                   ELSE
                     h := 0;                    { eigentlich: Fehlermeldung }
              'F': h := (Exp(g1)-Exp(-g1))/(Exp(g1)+Exp(-g1));
              'G': h := (Exp(g1)+Exp(-g1))/2;
              'H': h := (Exp(g1)-Exp(-g1))/2;
              'I': h := Pi/2-ArcTan(x);
              'J': h := ArcTan(x);
              'K': IF (g1 >= -1) AND (g1 <= 1) THEN
                     IF g1 = 1 THEN
                       h := 0
                     ELSE IF g1 = -1 THEN
                       h := Pi
                     ELSE
                       h := Pi/2-ArcTan(g1/Sqrt(1-g1*g1))
                   ELSE
                       h := 0;                  { eigentlich: Fehlermeldung }
              'L': IF (g1 >= -1) AND (g1 <= 1) THEN
                     IF g1 = 1 THEN
                       h := Pi/2
                     ELSE IF g1 = -1 THEN
                       h := -Pi/2
                     ELSE
                       h := ArcTan(g1/Sqrt(1-g1*g1))
                   ELSE
                     h := 0;                    { eigentlich: Fehlermeldung }
              'M': IF Sin(g1) <> 0 THEN
                     h := Cos(g1)/Sin(g1)
                   ELSE
                     h := 0;                    { eigentlich: Fehlermeldung }
              'N': IF Cos(g1) <> 0 THEN
                     h := Sin(g1)/Cos(g1)
                   ELSE
                     h := 0;                    { eigentlich: Fehlermeldung }
              'O': h := Cos(g1);
              'P': h := Sin(g1);
              'Q': IF g1 >= 0 THEN
                     h := Sqrt(g1)
                   ELSE
                     h := 0;                    { eigentlich: Fehlermeldung }
              'R': IF g1 > 0 THEN
                     h := Ln(g1)/Ln(10)
                   ELSE
                     h := 0;                    { eigentlich: Fehlermeldung }
              'S': IF g1 > 0 THEN
                     h := Ln(g1)
                   ELSE
                     h := 0;                    { eigentlich: Fehlermeldung }
            END; { of case }
          END; { of else }
          Delete(q2, i, j-i+1);
          Str(h, f1);
          Insert(f1, q2, i);
          i := 254;
        END  { of 'if q2[j]=')'' }
        ELSE
          i:=j-1;
      END;  { of 'if q2[i] in ['A'..'Z']' }
      i := i+1;
    UNTIL i >= Length(q2);
  UNTIL j = 0;            { bis der Term q2 nur noch aus einer Zahl besteht }
  Val(q2, h, cd);
  Berechnung := h;
END;