Turbo Toolbox/Turbo_Toolbox.iso/extra18/wita/wita.pas

Pascal/Delphi Source File | 1992-01-20 | 21.0 KB | 813 lines

(* ------------------------------------------------- *)
(*                    WITA.PAS                       *)
(*        (c) 1992 W.Hermanns & DMV-Verlag           *)
(* ------------------------------------------------- *)
PROGRAM WITA;

{$R-,S-,I-,V-}
{$M $800,0,0}

USES Crt, Math, TSR;

TYPE
  Str3    = STRING[3];

CONST
  Prg     = 'Wissenschaftlicher Taschenrechner';
  Version = 'W. Hermanns, Juli 1990';
  Name    = 'WITA.FOR';
            { Dateiname der Formelsammlung }
  Palette : ARRAY[0..3] OF BYTE = (0,3,11,14);
  MaxEinL   = 128;
  MaxStapel = 47;
  MaxExp    = 88;
  MaxReal   = 1E37;
  MaxFkt    = 27;
  Fkts: ARRAY [1..MaxFkt] OF Str3=
   ('!','ABS','ACH','ACS','ASH','ASN','ATH','ATN','B',
    'COH','COS','EXP','H','INT','LG','LN','M','N','PI',
    'RND','SGN','SIH','SIN','SQR','SQT','TAH','TAN');
  Leer = 'xxx';
  Oper = ['+','-','*','/','\','^','L','R',
          'O','U','X','W'];
  Fehlermel: ARRAY [1..4] OF STRING[8]=
    ('Eingabe','Argument','Überlauf','I/O-Disk');

TYPE
  EinTyp  = STRING[MaxEinL];
  Stapelt = RECORD
       CASE INTEGER OF
         0 : (Az : BOOLEAN; Z : REAL);
         1 : (Ac : BOOLEAN; P : BYTE;
              O  : CHAR;    F : Str3);
       END;

VAR
  Z1     : Stapelt;
  Zmem   : ARRAY [0..9] OF REAL;
  Stapel : ARRAY [0..MaxStapel] OF Stapelt;
  Err    : INTEGER;
  Datei  : FILE OF EinTyp;
  StZeig, Xc, Yc, Wx, Wy : BYTE;
  S      : EinTyp;
  Sm     : STRING[16];
  Satz, Fkt, Lfw: Str3;
  Zm     : REAL;
  HotKey : WORD;
  SZ,Flg : BOOLEAN;
  Key    : CHAR;
  Bild   : ARRAY [0..3999] OF BYTE ABSOLUTE $BC00:0;
       { Bei Herkules- und CGA-Karte darf der Zusatz }
       { ABSOLUTE $BC00:0 nicht verwendet werden!    }

  PROCEDURE Bildsichern;
  BEGIN
    Xc := WhereX; Yc := WhereY;
    CASE Lastmode OF
      3  : Move(Mem[$B800:0], Bild, 4000);
      2,7: Move(Mem[$B000:0], Bild, 4000);
    END;
  END;  { Bildsichern }

  PROCEDURE Bildholen;
  BEGIN
    Window (1,1,80,25);
    CASE Lastmode OF
      3  : Move(Bild,Mem[$B800:0],4000);
      2,7: Move(Bild,Mem[$B000:0],4000);
    END;
    GotoXY (Xc,Yc);
  END; { Bildholen }

  PROCEDURE CWrite(S : STRING);
  VAR
    i : BYTE;
  BEGIN
    I := 0;
    REPEAT
      INC (I);
      IF S[I] = '@' THEN BEGIN
        INC (I);
        IF S[I] <> '@' THEN BEGIN
          TextColor(Palette[Ord(S[I])-48]);
          INC (I);
        END;
      END;
      IF I <= Length(S) THEN Write (S[I]);
    UNTIL I >= Length(S);
  END; { CWrite }

  PROCEDURE Taste(VAR Erw: BOOLEAN; VAR Key: CHAR);
  VAR
    AX : WORD;
  BEGIN
    INLINE ($B4/$00/$CD/$16/$08/$C0/
            $75/$02/$86/$C4/$89/$86/AX);
    Erw := (Hi(AX)=0);  Key := Chr(Lo(AX));
  END; { Taste }

  PROCEDURE Cursor(Mode: BOOLEAN);
  BEGIN
    INLINE($B4/$01/$B9/$07/$06/$8A/$86/Mode/
           $08/$C0/$75/$02/$88/$C1/$CD/$10);
  END; { Cursor }

  FUNCTION Satznr:BYTE;
  VAR
    CH : CHAR; s : Str3; i : BYTE;
  BEGIN
    s := '';
    REPEAT
      REPEAT
        Taste(SZ, CH);
      UNTIL NOT SZ;
      IF (CH = #8) AND (Length(s) > 0) THEN BEGIN
        Delete(s, Length(s), 1);
        Write (#8' '#8);
      END;
      IF CH IN ['0'..'9'] THEN BEGIN
        s := s + CH;
        Write(CH);
      END;
      Val(s, i, Err);
    UNTIL (Length(s) = 2) OR (CH = #27);
    IF CH<>#27 THEN BEGIN
      Satznr := i;  Str(i, Satz);
      IF i < 10 THEN Satz := '0' + Satz;
    END ELSE BEGIN
      Satznr := 255;
      Satz   := '';
    END;
  END; { Satznr }

  PROCEDURE Laufwerk(Nr : BYTE);
  VAR
    CH : CHAR;
  BEGIN
    lfw := #0;
    lfw := ParamStr(Nr);
    CH  := UpCase(lfw[1]);
    IF CH IN ['A'..'H'] THEN
      lfw := CH + ':'
    ELSE
      lfw := '';
  END; { Laufwerk }

  PROCEDURE Disk(Satz : BYTE; mode : CHAR);

    FUNCTION DiskOk : BOOLEAN;
    BEGIN
      IF IOResult <> 0 THEN BEGIN
        Error  := 4;
        DiskOk := FALSE;
      END ELSE DiskOk := TRUE;
    END; { DiskOk }

  BEGIN { Disk }
    IF Satz < 100 THEN BEGIN
      Assign(Datei, lfw+name);
      Reset(Datei);
      IF DiskOK THEN BEGIN
        Seek(Datei, Satz);
        IF mode = 'W' THEN
          Write(Datei, s)
        ELSE
          Read(Datei, s);
        Close(Datei);
      END;
    END;
  END; { Disk }

  PROCEDURE Rahmen;
  VAR
    i : BYTE;
  BEGIN
    Bildsichern;
    TextBackground (Palette[0]);
    Window (Wx, Wy, Wx+42, Wy+9);
    CWrite('@1╔');
    FOR i:=1 TO 41 DO Write ('═');
    Write ('╗');
    Write ('║',' ':41,'║');
    Write ('║',' ':41,'║');
    Write ('╟');
    FOR i:=1 TO 41 DO Write ('─');
    Write ('╢');
    CWrite('║ @2SQR SQT EXP () +-*/\ L R ');
    CWrite('@1x@2^@1y x@2W@1y @1F1-F10 ║');
    CWrite('║ @2H@1ex @2B@1in @2U@1nd @2X@1or ');
    CWrite('@2N@1ot @2O@1r @2LN LG M @1Crsr Del ║');
    CWrite('║ @2SIN COS TAN ASN ACS ' +
           'ATN PI RND ABS  @1Esc ║');
    CWrite('║ @2SIH COH TAH ASH ACH ATH ! ' +
           'SGN INT @1<╛ <─ ║');
    Write ('╚');
    FOR i:=1 TO 41 DO Write ('═');
    Write ('╝');
    Window (Wx+1, Wy+1, Wx+41, Wy+7);
  END; { Rahmen }

  PROCEDURE Eingabeanzeigen(s : EinTyp; z : BYTE);
  VAR
    A, I, L : BYTE;
  BEGIN
    L := Length(S);
    IF L > 40 THEN A := L-39 ELSE A := 1;
    GotoXY(1,z);  CWrite('@2');
    FOR I := A TO L DO Write(S[I]);
    ClrEol;
  END; { Eingabeanzeigen }

  PROCEDURE Statusanzeigen;
  VAR
    I : BYTE;
  BEGIN
    FOR I := 0 TO 9 DO BEGIN
      GotoXY(20+I,3);
      IF Zmem[I] <> 0 THEN
        CWrite('@1'+Chr(I+48))
      ELSE
        CWrite('@1─');
    END;
    GotoXY(2,3);
    IF Satz <> '' THEN
      CWrite('@1Term─#'+Satz)
    ELSE
      CWrite('@1────────');
    GotoXY(34,3);
    CASE Basis OF
      0 : CWrite ('@3Dez');
      1 : CWrite ('@3Bin');
      4 : CWrite ('@3Hex')
    END;
    GotoXY(38,3);
    IF WiMo = 1  THEN CWrite('Bog@2');
    IF WiMo = Wa THEN CWrite('Alt@2');
    IF WiMo = Wn THEN CWrite('Neu@2');
  END; { Statusanzeigen }

  PROCEDURE Ergebnisanzeigen;
  BEGIN
    GotoXY(1,2); ClrEol;
    IF Error > 0 THEN BEGIN
      CWrite(' @3'+Fehlermel[Error]+'fehler!@1');
      Sound(500); Delay(25); NoSound;
    END ELSE BEGIN
      IF (Abs(Zm)<=Maxlongint) AND (Basis>0) THEN
        Write (Hexbin(Trunc(Zm)):37)
      ELSE
        IF (Abs(Zm)>MaxlongInt) OR
           (Abs(Zm)<1/MaxLongInt) AND
           (Zm <> 0) THEN Write (Zm:36)
                     ELSE Write (Zm:36:9);
    END;
  END; { Ergebnisanzeigen }

  PROCEDURE Eingeben;
  VAR
    CH : CHAR; Nr : BYTE; F4Flg, F5Flg : BOOLEAN;

    PROCEDURE Baustring(VAR s : EinTyp);
    BEGIN
      IF NOT (CH IN Oper+[#8,#13,' ','(',')']) AND
              Flg AND (Error=0) THEN
        FillChar(S, MaxEinL, #0);
      Flg := FALSE;  Error := 0;
      IF CH > #26 THEN S := S+CH;
      IF CH = #8 THEN Delete (S, Length(S), 1);
    END; { Baustring }

    PROCEDURE Verschieben;
    BEGIN
      Bildholen;
      CASE CH OF
        #72: IF Wy >  1 THEN DEC(Wy);
        #75: IF Wx >  1 THEN DEC(Wx);
        #77: IF Wx < 38 THEN INC(Wx);
        #80: IF Wy < 16 THEN INC(Wy);
      END;
      Bildsichern;
      Rahmen;
    END; { Verschieben }

  BEGIN { Eingeben }
    Flg := TRUE;
    REPEAT
      F4Flg := FALSE;  F5Flg := FALSE;
      Taste(SZ, CH);
      IF NOT SZ THEN BEGIN
        Baustring(s); Satz := '';
      END ELSE BEGIN
        Flg := TRUE;
        CASE CH OF
          #59 :
            BEGIN
              IF (Basis = 0) AND Flg THEN BEGIN
                Basis := 1;  Flg := FALSE;
              END;
              IF (Basis = 1) AND Flg THEN BEGIN
                Basis := 4;  Flg := FALSE;
              END;
              IF (Basis = 4) AND Flg THEN Basis := 0;
            END;
          #60 :
            BEGIN
              IF (WiMo = 1) AND Flg THEN BEGIN
                WiMo := Wa;  Flg := FALSE;
              END;
              IF (WiMo = Wa) AND Flg THEN BEGIN
                WiMo := Wn;  Flg := FALSE;
              END;
              IF (WiMo = Wn) AND Flg THEN WiMo := 1;
            END;
        #61 :
          BEGIN
            { Ergebnis in Variable speichern }
            GotoXY(13,3);  CWrite('@3MemW#');
            REPEAT
              Taste(SZ,CH);
            UNTIL CH IN ['0'..'9'];
            Write (CH);
            Zmem[Ord(CH)-48] := Zm;
          END;
        #62 :
          BEGIN
            { Zahl in Variable speichern }
            sm := '';  F4Flg := TRUE;
            GotoXY(13,3);  CWrite('@3MemS#');
            REPEAT
              Taste(SZ,CH);
            UNTIL CH IN ['0'..'9'];
            Write (CH);
            Nr := Ord(CH)-48;
            REPEAT
              REPEAT
                Taste(SZ,CH);
              UNTIL NOT SZ;
              IF CH IN ['+'..'9','e','E'] THEN
                SM := SM+CH;
              IF CH = #8 THEN
                Delete (SM, Length(SM), 1);
              Eingabeanzeigen(sm, 2);
              Val(sm, Zmem[Nr], Err);
            UNTIL CH = #13;
            IF Err > 0 THEN Zmem[Nr] := 0;
          END;
        #63 :
          BEGIN { Term lesen }
            GotoXY(2,3);  CWrite('@3TermR#');
            Disk(Satznr, 'R');
            F5Flg := TRUE;
          END;
        #64 :
          BEGIN { Term schreiben }
            GotoXY(2,3);  CWrite('@3TermW#');
            Disk(Satznr, 'W');
          END;
        #65,#66,#67,#68 :
          BEGIN { Farbpalette ändern }
            Palette[ord(ch)-65]:=
              Succ(Palette[ord(ch)-65]) AND 15;
            Bildholen; Rahmen;
          END;
        #72,#75,#77,#80:
          BEGIN
            Verschieben; Flg := FALSE;
          END;
        #83 :
          BEGIN
            FillChar(S, MaxEinL, #0);
            Zm := 0;  Satz := '';
          END;
        END;
        CH := #0;
      END;
      Statusanzeigen;
      Ergebnisanzeigen;
      Eingabeanzeigen(s,1);
      GotoXY(13,3);  CWrite('@1──────@2');
    UNTIL (CH = #13) OR F4Flg OR F5Flg;
  END; { Eingeben }

  FUNCTION Rang(O : CHAR) : BYTE;
  BEGIN
    CASE O OF
      'O','X': Rang := 2; { OR, XOR }
      'U':     Rang := 3; { UND }
      '+','-': Rang := 4;
      '^','W': Rang := 6; { x^y, xWy }
    ELSE       Rang := 5; { *, /, \, L, R }
    END;
  END; { Rang }

  PROCEDURE Suchklammer(VAR Auf, Zu : BYTE);
  VAR
    A, I, Z : BYTE;
  BEGIN
    REPEAT
      A := 0; Z := StZeig-1;
      FOR I := 0 TO StZeig-1 DO
        IF Stapel[I].Ac AND (Stapel[I].O='(') THEN
          A := I;
      FOR I := StZeig-1 DOWNTO A+1 DO
        IF Stapel[I].Ac AND (Stapel[I].O=')') THEN
          Z := I;
      IF (Z = A+2) AND Stapel[A].Ac AND
         Stapel[Z].Ac AND (Stapel[A].O='(') AND
         (Stapel[Z].O=')') THEN BEGIN
        Stapel[A] := Stapel[Succ(A)];
        FOR I := A+1 TO StZeig-1 DO
          Stapel[I] := Stapel[I+2];
        DEC(StZeig,2);
      END;
    UNTIL (Z > A+2) OR (A = 0) AND (Z = StZeig-1);
    IF Stapel[A].Ac AND (Stapel[A].O='(') THEN
      Auf := A+1
    ELSE
      Auf := A;
    IF Stapel[Z].Ac AND (Stapel[Z].O=')') THEN
      Zu := Z-1
    ELSE
      Zu := Z;
  END; { Suchklammer }

  FUNCTION MaxRang : BYTE;
  VAR
    A, Z, I, J, K, P : BYTE;
  BEGIN
    Suchklammer(A,Z);
    J := 0;  K := 0;
    FOR I := A TO Z DO
      IF Stapel[I].Ac AND (Stapel[I].P>J) OR
         (Stapel[I].P=7) THEN BEGIN
        J := Stapel[I].P;  K := I;
      END;
    MaxRang := K;
  END; { MaxRang }

  FUNCTION TestFkt(X, Y : REAL; O : CHAR) : BOOLEAN;
  VAR
    Ok : BOOLEAN;
  BEGIN
    Ok := TRUE;
    IF (Abs(X) > MaxReal) OR (Abs(Y) > MaxReal) THEN
      Ok := FALSE;
    CASE O OF
      '+':
        IF Sgn(X)=Sgn(Y) THEN
          IF Abs(X) > MaxReal - Abs(Y) THEN
            Ok := FALSE;
      '-':
        IF Sgn(X)<>Sgn(Y) THEN
          IF Abs(X)> MaxReal + Abs(Y) THEN
            Ok := FALSE;
      '*':
        IF (Abs(X) >= 1) AND (Abs(Y) >= 1) THEN
          IF Abs(X) > MaxReal / (Abs(Y)) THEN
            Ok := FALSE;
      '/','\':
        IF (Abs(Y) < 1) AND (Abs(Y) > 0) THEN
          IF Abs(X) > MaxReal/Abs(1/Abs(Y)) THEN
            Ok := FALSE;
      '^':
        IF X <> 0 THEN
          IF Abs(Y)*Ln(Abs(X)) > MaxExp THEN
            Ok := FALSE;
      'W':
        IF (X <> 0) AND (Y <> 0) THEN
          IF Abs(1/Y)*Ln(Abs(X)) > MaxExp THEN
            Ok := FALSE;
    END;
    IF NOT Ok THEN Error := 3;
    TestFkt := Ok;
  END; { TestFkt }

  PROCEDURE Funktionswert(VAR Z : REAL);
  BEGIN
    IF Fkt = 'N'   THEN Z := NOT Lint(Z);
    IF Fkt = 'ABS' THEN Z := Abs(Z);
    IF Fkt = 'INT' THEN Z := Int(Z);
    IF Fkt = 'RND' THEN
      IF Z < 0 THEN
        Z := Int(Z-0.5)
      ELSE
        Z := Int(Z+0.5);
    IF Fkt = 'SQR' THEN Z := Sqr(Z);
    IF Fkt = 'SQT' THEN
      IF Z >= 0 THEN
        Z := Sqrt(Z)
      ELSE Error := 2;
    IF Fkt = 'LN' THEN
      IF Z > 0 THEN
        Z := Ln(Z)
      ELSE Error := 2;
    IF Fkt = 'LG'  THEN Z := Lg(Z);
    IF Fkt = 'EXP' THEN
      IF Z <= MaxExp THEN
        IF Z >= -MaxExp THEN
          Z := Exp(Z)
        ELSE
          Z := 0
      ELSE Error := 3;
    IF Fkt = 'SIN' THEN Z := Sin(Z);
    IF Fkt = 'COS' THEN Z := Cos(Z);
    IF Fkt = 'TAN' THEN Z := Tan(Z);
    IF Fkt = 'ASN' THEN Z := Asn(Z);
    IF Fkt = 'ACS' THEN Z := Acs(Z);
    IF Fkt = 'ATN' THEN Z := Atn(Z);
    IF Fkt = '!'   THEN Z := fakultaet(Z);
    IF Fkt = 'SIH' THEN Z := Sih(Z);
    IF Fkt = 'COH' THEN Z := Coh(Z);
    IF Fkt = 'TAH' THEN Z := Tah(Z);
    IF Fkt = 'ASH' THEN Z := Ash(Z);
    IF Fkt = 'ACH' THEN Z := Ach(Z);
    IF Fkt = 'ATH' THEN Z := Ath(Z);
    IF Fkt = 'SGN' THEN Z := Sgn(Z);
  END; { Funktionswert }

  PROCEDURE Stapelauswerten;
  VAR
    Z1, Z2 : Stapelt; I, J : BYTE;
  BEGIN
    REPEAT
      J := MaxRang;
      IF Stapel[J].Ac THEN
        Fkt := Stapel[J].F
      ELSE
        Fkt := Leer;
      IF (J > 0) AND (Fkt = Leer) THEN
        Z1 := Stapel[Pred(J)]
      ELSE
        Z1 := Stapel[J];
      Z2 := Stapel[Succ(J)];
      IF Fkt = Leer THEN BEGIN
        IF TestFkt(Z1.Z, Z2.Z, Stapel[J].O) THEN
          CASE (Stapel[J].O) OF
            '+': Z1.Z := Z1.Z + Z2.Z;
            '-': Z1.Z := Z1.Z - Z2.Z;
            '*': Z1.Z := Z1.Z * Z2.Z;
            '/': IF Z2.Z <> 0 THEN
                   Z1.Z := Z1.Z / Z2.Z
                 ELSE
                   Error := 2;
            '\': Z1.Z := Modulo(Z1.Z, Z2.Z);
            '^': Z1.Z := XhochY(Z1.Z, Z2.Z);
            'W': IF Z2.Z <> 0 THEN
                   Z1.Z := XhochY(Z1.Z,1/Z2.Z)
                 ELSE
                   Error := 2;
            'L': IF Z2.Z >= 0 THEN
                   Z1.Z := Lint(Z1.Z) SHL Lint(Z2.Z)
                 ELSE
                   Error := 2;
            'R': IF Z2.Z >= 0 THEN
                   Z1.Z := Lint(Z1.Z) SHR Lint(Z2.Z)
                 ELSE
                   Error := 2;
            'U': Z1.Z := Lint(Z1.Z) AND Lint(Z2.Z);
            'O': Z1.Z := Lint(Z1.Z) OR Lint(Z2.Z);
            'X': Z1.Z := Lint(Z1.Z) XOR Lint(Z2.Z);
          END;
        IF J = 0 THEN J := 1;
        FOR I := Pred(J) TO Pred(StZeig) DO
          Stapel[I] := Stapel[I+2];
        Stapel[Pred(J)].Az := FALSE;
        Stapel[Pred(J)].Z := Z1.Z;
        IF StZeig > 1 THEN
          DEC(StZeig, 2)
        ELSE
          StZeig := 0;
      END ELSE BEGIN
        Funktionswert(Z2.Z);
        IF Z1.O = #1 THEN Z2.Z := -Z2.Z;
        FOR I := J TO Pred(StZeig) DO
          Stapel[I] := Stapel[Succ(I)];
        DEC(StZeig, 1);
        IF (J = 0) OR (Fkt <> Leer) THEN BEGIN
          Stapel[J].Az := FALSE;
          Stapel[J].Z  := Z2.Z;
        END ELSE BEGIN
          Stapel[Pred(J)].Az := FALSE;
          Stapel[Pred(J)].Z  := Z2.Z;
        END;
      END;
    UNTIL (StZeig <= 1) OR (Error>0);
    IF J = 0 THEN
      Zm := Stapel[J].Z
    ELSE
      Zm := Stapel[Pred(J)].Z;
  END; { Stapelauswerten }

  PROCEDURE Stapelschreiben;
  VAR
    A, E, Vz : BYTE;
    Neg      : BOOLEAN;
    Klammer  : ShortInt;

    PROCEDURE Upstring;
    VAR
      I : BYTE;
    BEGIN
      FOR I := 1 TO Length(S) DO
        IF S[I] = ',' THEN
          S[I] := '.'
        ELSE
          S[I] := UpCase(S[I]);
    END; { Upstring }

    PROCEDURE Skipspace;
    BEGIN
      WHILE s[e] = ' ' DO INC(e);
    END; { Skipspace }

    PROCEDURE Funktion;
    VAR
      I : BYTE;
    BEGIN
      Skipspace;
      A := E;  Fkt := leer;
      WHILE (S[E] IN ['!','A'..'Z']) AND (E-A < 3) DO
        INC(E);
      IF E > A THEN BEGIN
        Fkt := Copy(S, A, E-A);
        Err := 1;
        FOR I := 1 TO MaxFkt DO
          IF Fkt = Fkts[I] THEN Err := 0;
        Error := Err;
      END;
    END; { Funktion }

    PROCEDURE Hexzahl;
    BEGIN
      A := E;  Basis := 4;
      WHILE Pos(S[E], Hexbinzif) > 0 DO INC(E);
      IF E-A > 9 THEN
        Error := 3
      ELSE BEGIN
        Err  := 0;
        Z1.Z := Dez(Copy(S, A, E-A));
      END;
    END; { Hexzahl }

    PROCEDURE Binzahl;
    BEGIN
      A := E;  Basis := 1;
      WHILE S[E] IN ['0','1'] DO INC(E);
      IF E-A > 33 THEN
        Error := 3
      ELSE BEGIN
        Err  := 0;
        Z1.Z := Dez(Copy(S, A, E-A));
      END;
      Fkt := Leer;
    END; { Binzahl }

    PROCEDURE Dezzahl;
    BEGIN
      A := E;  Basis := 0;
      WHILE S[E] IN ['0'..'9','.','E'] DO BEGIN
        INC(E);
        IF S[E] = 'E' THEN BEGIN
          INC(E);
          IF S[E] IN ['-','+'] THEN INC(E);
        END;
      END;
      IF E > A THEN
        Val(Copy(S, A, E-A), Z1.Z, Err);
    END; { Dezzahl }

    PROCEDURE Zahl;
    BEGIN
      Err := 0;
      IF (Fkt = 'M') AND
         (s[e] IN ['0'..'9']) THEN BEGIN
        Z1.Z := Zmem[Ord(s[e])-48];
        INC(e);
      END ELSE IF Fkt = 'PI' THEN
        Z1.Z := Pi
      ELSE IF Fkt = 'H' THEN
        Hexzahl
      ELSE IF Fkt = 'B' THEN
        Binzahl
      ELSE
        Dezzahl;
      IF (Err > 0) THEN Error:=1;
      IF (E < Length(S)) AND
         NOT (S[E] IN Oper+[' ',')']) THEN
        Error := 1;
    END; { Zahl }

    PROCEDURE Push;
    BEGIN
      IF StZeig < Pred(MaxStapel) THEN BEGIN
        Stapel[StZeig] := Z1;
        INC(StZeig);
      END ELSE Error := 1;
    END; { Push }

  BEGIN { Stapelschreiben }
    Upstring;
    Flg := TRUE;
    E := 1;  Klammer := 0;  Vz := 0;
    Skipspace;
    REPEAT
      IF (S[E]='-') AND
         ((vz=1) OR (Fkt<>Leer) OR (E=1)) THEN BEGIN
        INC(E);  INC(Vz);  Neg := TRUE
      END ELSE
        Neg := FALSE;
      IF (S[E] IN Oper+['(',')']) THEN BEGIN
        IF (S[E] IN Oper) THEN INC(Vz);
        IF Flg AND (S[E] IN Oper+[')']-['-']) OR
           (Vz>1) THEN
          Error := 1;
        IF NOT Flg THEN
          IF S[E] ='(' THEN Error:=1;
        Flg := S[E] IN Oper+['('];
        Z1.Ac := TRUE;
        Z1.O  := S[E];
        Z1.P  := Rang(Z1.O);
        Z1.F  := Leer;
        IF S[E] = '(' THEN BEGIN
          INC(Klammer);
          IF Neg THEN Error := 1;
        END;
        IF S[E] = ')' THEN DEC(Klammer);
        IF Klammer < 0 THEN Error := 1;
        INC(E);
      END ELSE BEGIN
        Vz := 0;
        Funktion;
        IF (Fkt = Leer) OR (Fkt = 'PI') OR
           (Fkt = 'H') OR (Fkt = 'B') OR
           (Fkt = 'M') THEN BEGIN
          IF NOT Flg THEN Error := 1;
          Zahl;
          Fkt   := leer;
          Z1.Az := FALSE;
          Flg   := FALSE;
          IF Neg THEN Z1.Z := -Z1.Z;
        END ELSE BEGIN
          IF NOT Flg THEN Error := 1
                     ELSE Flg := TRUE;
          IF Neg THEN Z1.O := #1
                 ELSE Z1.O := #0;
          Z1.F  := Fkt;
          Z1.P  := 7;
          Z1.Ac := TRUE;
        END;
      END;
      Push;
      Skipspace;
    UNTIL (E > Length(S)) OR (S[E] = #27) OR
          (Error <> 0);
    IF Flg OR (Klammer <> 0) THEN Error := 1;
  END; { Stapelschreiben }

  PROCEDURE Loeschen;
  BEGIN
    FOR StZeig := MaxStapel DOWNTO 0 DO
      WITH Stapel[StZeig] DO BEGIN
        AZ := FALSE;  Z := 0;
      END;
    Error := 0;  Z1.Z := 0;
  END; { Loeschen }

{$F+}
  PROCEDURE Start;
  BEGIN
    WiMo := Wa;  Basis := 0;  Satz := '';  Zm := 0;
    FillChar(S, MaxEinL, #0);
    Cursor(FALSE);
    Rahmen;
    CWrite('   @2' + Prg + #10#13);
    Write(' ':9, Version);
    REPEAT
      Loeschen;
      Statusanzeigen;
      Eingeben;
      Stapelschreiben;
      IF (Error = 0) THEN Stapelauswerten;
      Ergebnisanzeigen;
    UNTIL Copy(S, Length(S), 1) = #27;
    Bildholen;
    Cursor(TRUE);
  END; { Start }
{$F-}

BEGIN { Hauptprogramm }
  FOR Xc := 0 TO 9 DO Zmem[Xc] := 0;
  Wx := 35;  Wy := 2;
  Val(ParamStr(1), HotKey, Err);
  IF Err <> 0 THEN BEGIN
    WriteLn ('Hotkey-Taste drücken!');
    REPEAT
      Taste(SZ,Key);  HotKey := Ord(Key) SHL 8;
    UNTIL SZ;
  END;
  Laufwerk(1);  IF lfw = '' THEN Laufwerk(2);
  MakeResident(@Start, HotKey);
END. { Hauptprogramm }
(* ------------------------------------------------- *)
(*              Ende von WITA.PAS                    *)