Turbo Toolbox/Turbo_Toolbox.iso/dtx9202/aripars/arithmet.pas

Pascal/Delphi Source File | 1992-01-06 | 8KB | 295 lines

(* ------------------------------------------------------ *)
(*                      ARITHMET.PAS                      *)
(*          (c) 1991 Burkhard Wittek & DMV-Verlag         *)
(* ------------------------------------------------------ *)
PROGRAM ArithmetikParser;

CONST
  Zahlen     = ['0'..'9'];
  ZeilenEnde = 13;
  DateiEnde  = 0;
  leer       = 127;

TYPE
  KnotenTyp      = (binaerOp, unaerOp, Zahl);
  Knoten         = ^KnotenStruktur;
  KnotenStruktur = RECORD
    CASE Schritt : KnotenTyp OF
      binaerOp : (binaererOperator        : CHAR;
                  linkerSohn, rechterSohn : Knoten);
      unaerOp  : (unaererOperator         : CHAR;
                  operand                 : Knoten);
      Zahl     : (num                     : INTEGER);
  END;

VAR
  gesichertesZeichen : CHAR;

(* ------------------------------------------------------ *)
(* Eingabe-Prozeduren/Funktionen                          *)

  FUNCTION LeseZeichen : CHAR;
    (* Zeichen-Eingabe (bis Zeilen-/File-Ende) *)
  VAR
    c : CHAR;
  BEGIN
    IF gesichertesZeichen <> Chr(leer) THEN BEGIN
      LeseZeichen := gesichertesZeichen;
      gesichertesZeichen := Chr(leer);
    END ELSE IF EoLn THEN BEGIN
      LeseZeichen := Chr(ZeilenEnde);  ReadLn;
    END ELSE IF EoF THEN
      LeseZeichen := Chr(DateiEnde)
    ELSE BEGIN
      Read(c); LeseZeichen := c;
    END;
  END;

  PROCEDURE AufhebenLeseZeichen(c : CHAR);
    (* ein Zeichen zurück auf den Eingabebuffer *)
  BEGIN
    IF gesichertesZeichen = Chr(leer) THEN
      gesichertesZeichen := c
    ELSE
      WriteLn('Immer nur ein Zeichen kann gepusht werden!');
  END;

  FUNCTION naechstesZeichen : CHAR;
    (* Löschen von Blanks *)
  VAR
    c : CHAR;
  BEGIN
    REPEAT
      c := LeseZeichen
    UNTIL c <> ' ';
    naechstesZeichen := c;
  END;

  FUNCTION ZeichenzuZahl(c : CHAR) : INTEGER;
    (* Umwandlung char -> integer *)
  BEGIN
    IF NOT (c IN Zahlen) THEN BEGIN
      WriteLn(c, 'ist kein ZahlZeichen!');
      ZeichenzuZahl := 0;
    END ELSE
      ZeichenzuZahl := Ord(c) - Ord('0');
  END;

  FUNCTION EingabeZahl(c : CHAR) : INTEGER;
    (* Lesen eines Eingabezeichens *)
  VAR
    Pos : INTEGER;
  BEGIN
    Pos := 0;
    REPEAT
      Pos := 10 * Pos + ZeichenzuZahl(c);
      c := LeseZeichen;
    UNTIL NOT (c IN Zahlen);
    AufhebenLeseZeichen(c);
    EingabeZahl := Pos;
  END;

(* ------------------------------------------------------ *)
(* Prozeduren/Funktionen zur Knoten-Generierung des       *)
(* Parsing-Baumes                                         *)

  FUNCTION binaerOpKnoten(OPor      : CHAR;
                          linksund,
                          rechtsund : Knoten) : Knoten;
    (* binäre Knoten *)
  VAR
    Pos : Knoten;
  BEGIN
    IF (linksund = NIL) OR (rechtsund = NIL) THEN
      binaerOpKnoten := NIL
    ELSE BEGIN
      Pos^.Schritt := binaerOp;
      New(Pos);
      WITH Pos^ DO BEGIN
        Schritt          := binaerOp;
        binaererOperator := OPor;
        linkerSohn       := linksund;
        rechterSohn      := rechtsund;
      END;
      binaerOpKnoten := Pos;
    END;
  END;

  FUNCTION unaerOpKnoten(OPor  : CHAR;
                         OPand : Knoten) : Knoten;
    (* unäre Knoten *)
  VAR
    Pos : Knoten;
  BEGIN
    IF OPand = NIL THEN
      unaerOpKnoten := NIL
    ELSE BEGIN
      Pos^.Schritt := unaerOp;
      New(Pos);
      WITH Pos^ DO BEGIN
        Schritt         := unaerOp;
        unaererOperator := OPor;
        operand         := OPand;
      END;
      unaerOpKnoten := Pos;
    END;
  END;

  FUNCTION ZahlKnoten(i : INTEGER) : Knoten;
    (* terminale Zahlen-Knoten *)
  VAR
    Pos : Knoten;
  BEGIN
    Pos^.Schritt := Zahl;
    New(Pos);
    WITH Pos^ DO BEGIN
      Schritt := Zahl;
      Num     := i;
    END;
    ZahlKnoten := Pos;
  END;

(* ------------------------------------------------------ *)
(* Prozeduren/Funktionen zum arithmetischen Parser        *)

  FUNCTION Term   : Knoten;  FORWARD;
  FUNCTION Faktor : Knoten;  FORWARD;

  FUNCTION Ausdruck : Knoten;
    (* Ausdruck = ein Term bzw.
       ein Term '+' / '-' ein Ausdruck) *)
  VAR
    c   : CHAR;
    Pos : Knoten;
  BEGIN
    Pos := Term;
    Ausdruck := Pos;
    IF Pos <> NIL THEN BEGIN
      c := naechstesZeichen;
      IF (c = '+') OR (c = '-') THEN
        Ausdruck := binaerOpKnoten(c, Pos, Ausdruck)
      ELSE IF c <> Chr(ZeilenEnde) THEN
        AufhebenLeseZeichen(c);
    END;
  END;

  FUNCTION Term;
    (* Term = ein Faktor bzw.
       ein Faktor '*' / '/' ein Term)  *)
  VAR
    c   : CHAR;
    Pos : Knoten;
  BEGIN
    Pos  := Faktor;
    Term := Pos;
    IF Pos <> NIL THEN BEGIN
      c := naechstesZeichen;
      IF (c = '*') OR (c = '/') THEN
        Term := binaerOpKnoten(c, Pos, Term)
      ELSE AufhebenLeseZeichen(c);
    END;
  END;

  FUNCTION Faktor;
    (* Faktor = eine Zahl bzw. ein
       Minus ('-') gefolgt von einem Faktor
       bzw. ein geklammerter Ausdruck  *)
  VAR
    c : CHAR;
  BEGIN
    c := naechstesZeichen;
    IF c IN Zahlen THEN
      Faktor := ZahlKnoten(EingabeZahl(c))
    ELSE IF c = '-' THEN
      Faktor := unaerOpKnoten(c, Faktor)
    ELSE IF c = '(' THEN BEGIN
      Faktor := Ausdruck;
      IF naechstesZeichen <> ')' THEN
        Writeln('Schließende Klammer wurde erwartet');
    END ELSE BEGIN
      WriteLn('Kein wohlgeformter Ausdruck');
      Faktor := NIL;
    END;
  END;

(* ------------------------------------------------------ *)
(* Prozeduren/Funktionen zum Zeichnen des Parsing-Baums   *)

  PROCEDURE Baum(Pos : Knoten; Tiefe : INTEGER);
  BEGIN
    WITH Pos^ DO
      CASE Schritt OF
        binaerOp : BEGIN
                     Baum(linkerSohn, Tiefe+3);
                     WriteLn(' ' : Tiefe, binaererOperator);
                     Baum(rechterSohn, Tiefe+3);
                   END;
        unaerOp  : BEGIN
                     WriteLn(' ' : Tiefe, unaererOperator);
                     Baum(operand, Tiefe+3);
                   END;
        Zahl     : WriteLn(' ' : Tiefe, num);
      END;
  END;

  PROCEDURE ZeichneBaum(Pos : Knoten);
  BEGIN
    Baum(Pos, 3);
  END;

(* ------------------------------------------------------ *)
(* Funktion zur Berechnung des geparsten                  *)
(* semantischen Baums                                     *)

  FUNCTION Evaluation(n : Knoten) : REAL;
  VAR
    op1, op2 : REAL;
  BEGIN
    WITH n^ DO
      CASE Schritt OF
        binaerOp : BEGIN
                     op1 := Evaluation(linkerSohn);
                     op2 := Evaluation(rechterSohn);
                     CASE binaererOperator OF
                       '+' : Evaluation := op1 + op2;
                       '-' : Evaluation := op1 - op2;
                       '*' : Evaluation := op1 * op2;
                       '/' : Evaluation := op1 / op2;
                     END;
                   END;
        unaerOp  : Evaluation := -Evaluation(operand);
        Zahl     : Evaluation := num;
      END;
  END;

  PROCEDURE ProgrammLauf;
    (* Hauptprozedur des Programmlaufs *)
  VAR
    Pos : Knoten;
    c   : CHAR;
  BEGIN
    REPEAT
      Write('> ');
      Pos := Ausdruck;
      IF Pos <> NIL THEN BEGIN
        Writeln;
        ZeichneBaum(Pos);
        WriteLn;  WriteLn(Evaluation(Pos):0:2);
      END;
    UNTIL FALSE;
  END;

BEGIN
  WriteLn;
  WriteLn('CIS München - Pascal-Arithmetik-Parsing- ',
          'und Berechnungs-Programm');
  WriteLn;
  WriteLn('Eingabe ist: Ein arithmetischer Ausdruck ',
          'plus < RETURN >');
  WriteLn('Ausgabe ist: Ein Parsing-Baum des Ausdrucks ',
          'plus Ergebnis.');
  ProgrammLauf;
END.
(* ------------------------------------------------------ *)
(*                 Ende von ARITHMET.PAS                  *)