home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 11 / tricks / term.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-08-11  |  5.5 KB  |  177 lines
  1. (* ------------------------------------------------------ *)
  2. (*                      TERM.PAS                          *)
  3. (*     Berechnen von mathematischer Termen Turbo 4/5      *)
  4. (*          (C) 1989 Alexander Sunder  &  TOOLBOX         *)
  5. (* ------------------------------------------------------ *)
  6. UNIT Term;
  7.  
  8. INTERFACE
  9.  
  10. TYPE
  11.   String80 = STRING[80];
  12.  
  13. VAR
  14.   x, y, z  : REAL;
  15.  
  16.   FUNCTION Pruef(T : String80) : BOOLEAN;
  17.   FUNCTION Loes (T : String80) : REAL;
  18.  
  19. IMPLEMENTATION
  20.  
  21.   FUNCTION Pruef(T : String80) : BOOLEAN;
  22.   TYPE
  23.     TM = SET OF CHAR;
  24.   CONST
  25.     Zi : TM = ['0'..'9'];
  26.     Op : TM = ['+','-','*','/','^'];
  27.   VAR
  28.     i, Klammer               : INTEGER;
  29.     Punkt, Fehler, Verknuepf : BOOLEAN;
  30.   BEGIN
  31.     Fehler := FALSE;  Klammer := 0;  Punkt := FALSE;
  32.     Verknuepf := FALSE;  i := 1;  T[i] := UpCase(T[i]);
  33.     IF NOT(T[i] IN Zi + ['-','(','x','y','z']) THEN
  34.       Fehler := TRUE
  35.     ELSE BEGIN
  36.       IF T[i] = '(' THEN Klammer := Klammer + 1;
  37.       WHILE NOT(Fehler) AND (i < Length(T)) DO BEGIN
  38.         i := i + 1;  T[i] := UpCase(T[i]);
  39.         CASE T[i-1] OF
  40.          '0'..'9': IF NOT(T[i] IN Zi + Op) THEN
  41.                      CASE T[i] OF
  42.                        ')': Klammer := Klammer - 1;
  43.                        '.': IF NOT(Punkt) THEN
  44.                               Punkt := TRUE
  45.                             ELSE Fehler := TRUE
  46.                        ELSE Fehler := TRUE;
  47.                      END;
  48.          '+','-',
  49.          '*','/',
  50.          '^'     : BEGIN
  51.                      Punkt := FALSE;
  52.                      Verknuepf := TRUE;
  53.                      IF NOT(T[i] IN Zi+['X','Y','Z']) THEN
  54.                        IF T[i] = '(' THEN
  55.                          Klammer := Klammer + 1
  56.                        ELSE
  57.                          Fehler := TRUE;
  58.                    END;
  59.          '.'     : IF NOT(T[i] IN Zi) THEN Fehler := TRUE
  60.                                       ELSE Punkt  := TRUE;
  61.          '('     : IF NOT(T[i] IN Zi+['-','X','Y','Z']) THEN
  62.                      IF T[i] = '(' THEN Klammer := Klammer+1
  63.                                    ELSE Fehler := TRUE;
  64.          ')'     : IF NOT(T[i] IN Op) THEN
  65.                      IF T[i] = ')' THEN Klammer := Klammer-1
  66.                                    ELSE Fehler := TRUE;
  67.          'x','y',
  68.          'z'     : IF NOT(T[i] IN Zi+Op) THEN
  69.                      IF T[i] = ')' THEN Klammer := Klammer-1
  70.                                    ELSE Fehler := TRUE
  71.         END;
  72.       END;
  73.       IF NOT (Fehler) AND ((T[i] IN Op) OR
  74.              (Klammer <> 0)) THEN Fehler := TRUE;
  75.     END;
  76.     Pruef := NOT(Fehler);
  77.   END;
  78.  
  79.   PROCEDURE RechenZeichen (VAR Zeichen : CHAR;
  80.                            VAR Pos     : BYTE;
  81.                            VAR T       : STRING80);
  82.   VAR
  83.     i, Klammer : BYTE;
  84.     Prior      : 0..3;
  85.   BEGIN
  86.     Prior := 0;  Klammer := 0;
  87.     FOR i := 1 TO Length(T) DO
  88.       CASE T[i] OF
  89.         '('    : Klammer := Klammer + 1;
  90.         ')'    : Klammer := Klammer - 1;
  91.         '^'    : IF (Prior <= 1) AND (Klammer=0) THEN BEGIN
  92.                    Prior := 1; Pos := i;
  93.                  END;
  94.         '*','/': IF (Prior <= 2) AND (Klammer=0) THEN BEGIN
  95.                    Prior := 2; Pos := i;
  96.                  END;
  97.         '+','-': IF Klammer = 0 THEN BEGIN
  98.                    Prior := 3; Pos := i;
  99.                  END;
  100.       END;
  101.     IF Prior = 0 THEN BEGIN
  102.       Zeichen := #0;  Pos := 0;
  103.     END ELSE Zeichen := T[Pos];
  104.   END;
  105.  
  106.   FUNCTION Berechnung(VAR Z1, Z2 : REAL;
  107.                       VAR Operator : CHAR) : REAL;
  108.   VAR
  109.     i   : INTEGER;
  110.     Pot : REAL;
  111.   BEGIN
  112.     CASE Operator OF
  113.       '^': IF (Z1<0) AND (Frac(Z2)<>0) THEN BEGIN
  114.              WriteLn('Negative Wurzel !'); Halt(1);
  115.            END ELSE
  116.              IF Z1 = 0 THEN
  117.                Berechnung := 0
  118.              ELSE
  119.                IF (Frac(Z2) = 0) AND
  120.                   (Trunc(Z2) >= 0) THEN BEGIN
  121.                  Pot := 1.0;
  122.                  FOR i := 1 TO Trunc(Z2) DO Pot := Pot * Z1;
  123.                  Berechnung := Pot;
  124.                END ELSE
  125.                  Berechnung := Exp(Z2 * Ln(Z1));
  126.       '*': Berechnung := Z1 * Z2;
  127.       '/': IF Z2 <> 0 THEN
  128.              Berechnung := Z1/Z2
  129.            ELSE BEGIN
  130.              Write('Division durch 0 !'); Halt(1);
  131.            END;
  132.       '+': Berechnung := Z1 + Z2;
  133.       '-': Berechnung := Z1 - Z2
  134.     END;
  135.   END;
  136.  
  137.   FUNCTION Loes(T : String80) : REAL;
  138.   VAR
  139.     Z1, Z2, Zahl : REAL;
  140.     Operator     : CHAR;
  141.     Pos          : BYTE;
  142.     Code         : INTEGER;
  143.     Klammerung   : BOOLEAN;
  144.   BEGIN
  145.     REPEAT
  146.       Klammerung := FALSE;
  147.       RechenZeichen(Operator, Pos, T);
  148.       IF Pos <> 0 THEN BEGIN
  149.         Z1 := 0;
  150.         Val(Copy(T, 1, Pos-1), Z1, Code);
  151.         IF Code <> 0 THEN
  152.           Z1 := Loes(Copy(T, 1, Pos-1));
  153.         Val(Copy(T, Pos+1, Length(T)-Pos), Z2, Code);
  154.         IF Code <> 0 THEN
  155.           Z2 := Loes(Copy(T, Pos+1, Length(T)-Pos));
  156.         Loes := Berechnung(Z1, Z2, Operator)
  157.       END ELSE
  158.         IF T[1] = '(' THEN BEGIN
  159.           T := Copy(T, 2, Length(T)-2);
  160.           Klammerung := TRUE;
  161.         END;
  162.     UNTIL NOT(Klammerung);
  163.     IF Pos = 0 THEN
  164.       CASE UpCase(T[1]) OF
  165.         'x': Loes := x;
  166.         'y': Loes := y;
  167.         'Z': Loes := z;
  168.         ELSE BEGIN
  169.                Val(T, Zahl, Code);
  170.                Loes := Zahl;
  171.              END;
  172.     END;
  173.   END;
  174.  
  175. END.
  176. (* ------------------------------------------------------ *)
  177. (*                Ende von TERM.PAS                       *)