{               Erster Teil von RM.PAS (Rechenmeister)               }

{====================================================================}

{                         Hilfs - Proceduren                         }

PROCEDURE gross (VAR t : zeile);

VAR i : 0..255;

BEGIN { gross }
  FOR i := 1 TO length (t) DO
    t [i] := upcase (t [i])
END;  { gross }

{====================================================================}

PROCEDURE meldung (t : zeile);

BEGIN { meldung }
  write (bildaus, t);
  IF status [print]
    THEN
      write (druckaus, t)
END;  { meldung }

{====================================================================}

PROCEDURE schreibstatus;

VAR i : flags;

BEGIN { schreibstatus }
  FOR i := argum TO gebro DO
    meldung (flagname [i]+': '+einaus [status [i]]+cr)
END;  { schreibstatus }

{====================================================================}

PROCEDURE anfangstatus;

VAR i : flags;

BEGIN { anfangstatus }
  FOR i := argum TO gebro DO
    status [i] := false;
  status [gebro] := true
END;  { anfangstatus }

{====================================================================}

PROCEDURE hilfe;

BEGIN { hilfe }
clrscr;
writeln (invon, 'Rechenzeichen in Prioritaetsfolge :', invoff);
writeln ('(k, n sind natuerliche Zahlen. a, b sind Brueche k/n)');
writeln ('n!            Fakultaet von n (1*2*..*n)');
writeln
('n/k!          Binomialkoeffizient n ueber k (n!:((n-k)!*k!))');
writeln ('a^n           a hoch n');
writeln ('a*b, a:b      Produkt, Quotient   zweier Brueche');
writeln ('a+b, a-b        Summe, Differenz  zweier Brueche');
writeln ;
writeln ('#             zeigt alle flags an');
writeln
('Flags : Printer, Fliesskomma, Bruch, Teilergebnis, Argument');
writeln
('Alle Flags werden durch ihren Anfangsbuchstaben umgeschaltet');
writeln ;
writeln (invon, 'Befehle :', invoff);
writeln ('D Formel      Die Formel wird als Arbeitsformel definiert');
writeln
('R Alt = Neu   ersetzt den Ausdruck Alt in der Formel durch Neu');
writeln ('O             setzt die Formel zurueck');
writeln ('L V von..bis          Liste der Formelwerte');
writeln ('S V von..bis          Summe der Formelwerte');
writeln ('X V von..bis        Produkt der Formelwerte');
writeln ('> Formelname  Abspeicherund der Arbeitsformel');
writeln ('< Formelname          Laden der Arbeitsformel');
writeln ('$             Inhaltsverzeichnis der Formelsammlung')
END;  { hilfe }

{====================================================================}

{                  Verwaltung der Formelsammlung                     }

PROCEDURE liesformel (fn : zeile);

VAR temp     : formel;
    gefunden : boolean;

BEGIN { liesformel }
  IF fn <> ''
    THEN
      BEGIN
        {$I-}
        reset (formelsammlung);
        {$I+}
        gefunden := false;
        IF ioresult = 0
          THEN
            WHILE NOT eof (formelsammlung) AND NOT gefunden DO
              BEGIN
                read (formelsammlung, temp);
                gefunden := temp.name = fn
              END;
        IF gefunden
          THEN
            arbeitsformel := temp;
        close (formelsammlung);
        error := NOT gefunden
      END
END;  { liesformel }

{====================================================================}

PROCEDURE schreibformel (fn : zeile);

BEGIN { schreibformel }
  IF fn <> ''
    THEN
      BEGIN
        liesformel (fn);
        IF error
          THEN
            BEGIN
              arbeitsformel.name := fn;
              {$I-}
              reset (formelsammlung);
              {$I+}
              IF ioresult <> 0
                THEN
                  rewrite (formelsammlung);
              seek (formelsammlung, filesize (formelsammlung));
              write (formelsammlung, arbeitsformel);
              close (formelsammlung)
            END;
        error := NOT error
      END
END;  { schreibformel }

{====================================================================}

PROCEDURE dirformel;

VAR temp     : formel;

BEGIN { dirformel }
  {$I-}
  reset (formelsammlung);
  {$I+}
  IF ioresult = 0
    THEN
      WHILE NOT eof (formelsammlung) DO
        BEGIN
          read (formelsammlung, temp);
          meldung (temp.name + cr)
        END;
  close (formelsammlung)
END;  { dirformel }

{====================================================================}

{              Ersetze - Funktion, Text - Zahlenwandlung             }

PROCEDURE replace (alt, neu : zeile; VAR z : zeile);

BEGIN { replace }
  WHILE pos (alt, z) > 0 DO
    BEGIN
      insert (#255, z, pos (alt, z));
      delete (z, pos (alt, z), length (alt))
    END;
  WHILE pos (#255, z) > 0 DO
    BEGIN
      insert (neu, z, pos (#255, z));
      delete (z, pos (#255, z), 1)
    END
END;  { replace }

{====================================================================}

PROCEDURE machzahlen (ausdruck : zeile; trennwort : zeile;
                      VAR a, b             : real;
                      VAR fehlera, fehlerb : boolean);

CONST erlaubt : SET OF char = ['0'..'9', '-'];

VAR tp, ap, bp, lt : 0..256;
    fc             : integer;

BEGIN { machzahlen }
  tp := pos (trennwort, ausdruck);
  error := tp = 0;
  lt := length (trennwort);
  IF NOT error
    THEN
      BEGIN
        ap := tp-1;
        bp := tp + lt;
        WHILE (ausdruck [ap] IN erlaubt) AND (ap > 0) DO
          ap := pred (ap);
        WHILE (ausdruck[bp] IN erlaubt) AND (bp<=length(ausdruck)) DO
          bp := succ (bp);
        val (copy (ausdruck, ap+1, tp-ap-1), a, fc);
        fehlera := fc <> 0;
        val (copy (ausdruck, tp+lt, bp-tp-lt), b, fc);
        fehlerb := fc <> 0
      END
END;  { machzahlen }

{====================================================================}

PROCEDURE machbruch (term : zeile; VAR b : bruch; c : char;
                      VAR fehler : boolean);

VAR fehlercode : integer;
    p, q       : 0..255;
    t1, t2     : STRING [30];

BEGIN { machbruch }
  IF term <> ''
    THEN
      IF term [1] = '@'
        THEN
          term [1] := '-';
  IF term = ''
    THEN
      IF c = '!'
        THEN
          term := '-1';
  fehler := term = '';
  p := pos ('/', term);
  IF p = 0
    THEN
      IF c <> '!'
        THEN
          BEGIN
            t1 := term;
            t2 := '1'
          END
        ELSE
          BEGIN
            t1 := term;
            t2 := '-1'
          END
    ELSE
      BEGIN
        t1 := copy (term, 1, p-1);
        t2 := copy (term, p+1, length (term)-p)
      END;
  p := pos ('.', t1);
  q := pos ('.', t2);
  IF p > 0
    THEN
      BEGIN
        delete (t1, p, 1);
        p := length (t1)-p+1
      END;
  IF q > 0
    THEN
      BEGIN
        delete (t2, q, 1);
        q := length (t2)-q+1
      END;
  WHILE p <> q DO
    IF p > q
      THEN
        BEGIN
          t2 := t2+'0';
          p := pred (p)
        END
      ELSE
        BEGIN
          t1 := t1+'0';
          q := pred (q)
        END;
  WITH b DO
    BEGIN
      val (t1, zaehler, fehlercode);
      fehler := fehler OR (fehlercode <> 0);
      val (t2, nenner, fehlercode);
      fehler := fehler OR (fehlercode <> 0) OR ((nenner = 0)
                                           AND (c <> '!'));
      zaehler := int (zaehler);
      nenner := int (nenner)
    END
END;  { machbruch }

{====================================================================}

FUNCTION bruchstring (b : bruch) : zeile;

VAR tz, tn : zeile;

BEGIN { bruchstring }
  str (b.zaehler:1:0, tz);
  str (b.nenner:1:0, tn);
  IF b.nenner = 1
    THEN
      tn := ''
    ELSE
      tn := '/'+tn;
  IF tz [1] = '-'
    THEN
      tz [1] := '@';
  bruchstring := tz+tn
END;  { bruchstring }

{====================================================================}

{        Rechenoperationen und Auswertung der Eingabezeile           }

FUNCTION ggt (x, y : real) : real;

VAR t : real;

BEGIN { ggt }
  x := abs (x);
  y := abs (y);
  IF (x = 0) OR (y = 0)
    THEN
      ggt := 0
    ELSE
      BEGIN
        REPEAT
          IF y > x
            THEN
              BEGIN
                t := x;
                x := y;
                y := t
              END;
          x := x-y*(int (x/y))         { Modulo-Funktion fuer Reals }
        UNTIL x = 0;
        ggt := y
      END
END;  { ggt }

{====================================================================}

FUNCTION kgv (x, y : real) : real;

BEGIN { kgv }
  kgv := (x/ggt (x, y))*y
END;  { kgv }

{====================================================================}

PROCEDURE kuerzen (VAR b : bruch );

{ nomminiert zugleich den Bruch }

VAR temp : real;

BEGIN { kuerzen }
  IF b.nenner < 0
    THEN
      BEGIN
        b.zaehler := -b.zaehler;
        b.nenner := -b.nenner
      END;
  IF b.zaehler = 0
    THEN
      b.nenner := 1
    ELSE
      BEGIN
        temp := ggt (b.zaehler, b.nenner);
        IF temp <> 0
          THEN
            BEGIN
              b.zaehler := b.zaehler/temp;
              b.nenner := b.nenner/temp
            END
      END
END;  { kuerzen }

{====================================================================}

FUNCTION f (x : real) : real;

VAR f1 : real;

BEGIN { f }
  f1 := 1;
  WHILE x > 1 DO
    BEGIN
      f1 := f1*x;
      x := x-1
    END;
  f := f1
END;  { f }

{====================================================================}

FUNCTION ueb (x, y : real) : real;

{ Binonial-Koeffizient a ueber y }

VAR f1, y1 : real;

BEGIN { ueb }
  f1 := 1;
  y1 := 1;
  IF y > x/2
    THEN
      y := x-y;    { Ausnutzung der Symetrie }
  WHILE y > 0 DO
    BEGIN
      f1 := f1*x;
      y1 := y1*y;
      x := x-1;
      y := y-1;
      IF f1 > 1E30
        THEN
          BEGIN
            f1 := f1/y1;
            y1 := 1
          END
    END;
  ueb := int (f1/y1)
END;  { ueb }

{====================================================================}

PROCEDURE sum (b1, b2 : bruch; VAR eg : bruch);

VAR temp : real;

BEGIN { sum }
  temp := kgv (b1.nenner, b2.nenner);
  eg.nenner := temp;
  eg.zaehler := (temp/b1.nenner)*b1.zaehler+
                (temp/b2.nenner)*b2.zaehler;
  kuerzen (eg)
END;  { sum }

{====================================================================}

PROCEDURE dif (b1, b2 : bruch; VAR eg : bruch);

BEGIN { dif }
  b2.zaehler := -b2.zaehler;
  sum (b1, b2, eg)
END;  { dif }

{====================================================================}

PROCEDURE pro (b1, b2 : bruch; VAR eg : bruch);

BEGIN { pro }
  kuerzen (b1);
  kuerzen (b2);
  eg.zaehler := b1.zaehler*b2.zaehler;
  eg.nenner := b1.nenner*b2.nenner
END;  { pro }

{====================================================================}

PROCEDURE quo (b1, b2 : bruch; VAR eg : bruch);

VAR temp : real;

BEGIN { quo }
  temp := b2.zaehler;
  b2.zaehler := b2.nenner;
  b2.nenner := temp;
  IF b2.nenner <> 0
    THEN
      pro (b1, b2, eg)
    ELSE
      error := true
END;  { quo }

{====================================================================}

PROCEDURE hoch (b1, b2 : bruch; VAR eg : bruch);

VAR z, n, count : real;

BEGIN { hoch }
  z := 1;
  n := 1;
  count := b2.zaehler;
  WITH b1 DO
    WHILE count > 0 DO
      BEGIN
        z := z*zaehler;
        n := n*nenner;
        count := count-1
      END;
  eg.zaehler := z;
  eg.nenner := n
END;  { hoch }

{====================================================================}

PROCEDURE fak (b1, b2 : bruch; VAR eg : bruch);

BEGIN { fak }
  IF b2.zaehler <> -1
    THEN
      error := true
    ELSE
      IF b1.nenner = -1
        THEN
          BEGIN
            eg.zaehler := f (b1.zaehler);
            eg.nenner := 1
          END
        ELSE
          BEGIN
            eg.zaehler := ueb (b1.zaehler, b1.nenner);
            eg.nenner := 1
          END;
  kuerzen (eg)
END;  { fak }

{====================================================================}

PROCEDURE rechne (b1, b2 : bruch; rechenzeichen : char;
                  VAR ergebnis : bruch; VAR fehler : boolean);

BEGIN { rechne }
  fehler := false;
  CASE rechenzeichen OF
    '+' :  sum (b1, b2, ergebnis);
    '-' :  dif (b1, b2, ergebnis);
    '*' :  pro (b1, b2, ergebnis);
    ':' :  quo (b1, b2, ergebnis);
    '!' :  fak (b1, b2, ergebnis);
    '^' : hoch (b1, b2, ergebnis)
  END;
  kuerzen (ergebnis)
END;  { rechne }

{====================================================================}

PROCEDURE zerlege (term : zeile; VAR ergebnis : bruch;
                                 VAR fehler : boolean);

LABEL exit;

CONST bzif : SET OF char = ['@', '0'..'9', '/', '.'];

VAR t1             : zeile;
    kl, kr, rz, ip : 0..255;
    rr             : char;
    b1, b2, er     : bruch;

{--------------------------------------------------------------------}

FUNCTION min (x, y : integer) : integer;

BEGIN { min }
  IF (0 < x) AND (x < y)
    THEN
      min := x
    ELSE
      IF (0 < Y) AND (Y < X)
        THEN
          min := y
        ELSE
          IF x = 0
            THEN
              min := y
            ELSE
              min := x
END;  { min }

{--------------------------------------------------------------------}

BEGIN { zerlege }
  term := '('+term+')';
  REPEAT
    fehler := true;
    fehlermeldung := 'Eingabe-Fehler';
    kr := pos (')', term);
    kl := pos ('(', term);
    IF kr*kl = 0
      THEN
        GOTO exit;
    kl := kr-1;
    WHILE (term [kl] <> '(') AND (kl > 0) DO
      kl := pred (kl);
    t1 := copy (term, kl+1, kr-kl-1);
    delete (term, kl, kr-kl+1);
    ip := kl;
    REPEAT
      IF t1 <> ''
        THEN
          IF t1 [1] = '-'
            THEN
              t1 [1] := '@';
      rz := pos ('!', t1);
      IF rz = 0
        THEN
          rz := pos ('^', t1);
      IF rz = 0
        THEN
          rz := min (pos ('*', t1), pos (':', t1));
      IF rz = 0
        THEN
          rz := min (pos ('+', t1), pos ('-', t1));
      IF rz <> 0
        THEN
          BEGIN
            kl := rz-1;
            kr := rz+1;
            WHILE (t1 [kl] In bzif) AND (kl > 0) DO
              kl:= pred (kl);
            WHILE (t1 [kr] IN bzif) AND (kr <= length (t1)) DO
              kr := succ (kr);
            rr := t1 [rz];
            fehlermeldung := 'Bruch-Fehler';
            machbruch (copy(t1, kl+1, rz-kl-1), b1, rr, fehler);
            IF fehler
              THEN
                GOTO exit;
            machbruch (copy(t1, rz+1, kr-rz-1), b2, rr, fehler);
            IF fehler
              THEN
                GOTO exit;
            rechne (b1, b2, rr, er, fehler);
            IF fehler
              THEN
                BEGIN
                  fehlermeldung := 'Division durch Null';
                  GOTO exit
                END;
            delete (t1, kl+1, kr-kl-1);
            insert (bruchstring (er), t1, kl+1)
          END
    UNTIL rz = 0;
    machbruch (t1, er, ' ', fehler);
    IF fehler
      THEN
        GOTO exit;
    kuerzen (er);
    IF term <> ''
      THEN
        insert (bruchstring (er), term, ip);
    IF status [teile] AND (term <> '')
      THEN
        meldung ('= '+term+cr)
  UNTIL (term = '');
  ergebnis := er;
  kuerzen (ergebnis);
  exit:
END;  { zerlege }

{====================================================================}

{                     Ausgabe und Syntax-Check                       }

PROCEDURE schreibergebnis (VAR f : text; b : bruch;
                                  argument : integer);

BEGIN { schreibergebnis }
  IF NOT error
    THEN
      BEGIN
        IF status [argum]
          THEN
            write (f, argument, ') ');
        write (f, '= ');
        IF status [gebro]
          THEN
            BEGIN
              write (f, b.zaehler:1:0);
              IF b.nenner <> 1
                THEN
                  write (f, '/', b.nenner:1:0);
                writeln (f)
            END;
        IF status [float]
          THEN
            writeln (f, b.zaehler/b.nenner:60:20)
      END
    ELSE
      writeln (f, fehlermeldung, ' !')
END;  { schreibergebnis }

{====================================================================}

PROCEDURE liste (z : zeile; c : char; von, bis : integer);

VAR x      : zeile;
    i      : integer;
    is     : STRING [10];
    bs, bp : bruch;

BEGIN { liste }
  bs.zaehler := 0;
  bs.nenner := 1;
  bp.zaehler := 1;
  bp.nenner := 1;
  FOR i := von TO bis DO
    BEGIN
      x := z;
      str (i, is);
      replace (c, is, x);
      zerlege (x, erg, error);
      IF eingabe [1] = 'L'
        THEN
          BEGIN
            schreibergebnis (bildaus, erg, i);
            IF status [print]
              THEN
                schreibergebnis (druckaus, erg, i)
          END
        ELSE
          IF eingabe [1] = 'S'
            THEN
              sum (bs, erg, bs)
            ELSE
              IF eingabe [1] = 'X'
                THEN
                  pro (bp, erg, bp)
    END;
    IF eingabe [1] IN ['S', 'X']
      THEN
        BEGIN
          IF eingabe [1] = 'S'
            THEN
              erg := bs
            ELSE
              erg := bp;
          schreibergebnis (bildaus, erg, bis-von+1);
          IF status [print]
            THEN
              schreibergebnis (druckaus, erg, bis-von+1)
        END
END;  { liste }


{====================================================================}

FUNCTION syntaxok (m : zeichenvorrat; t : zeile) : boolean;

VAR i  : integer;
    ok : boolean;

BEGIN { syntaxok }
  ok := true;
  FOR i := 1 TO length (t) DO
    IF NOT (t [i] IN m)
      THEN
        BEGIN
          m := m+[t [i]];
          IF ok
            THEN
              BEGIN
                meldung ('! '+t [i]);
                ok := false
              END
            ELSE
              meldung (', '+t [i]);
        END;
  IF NOT ok
    THEN
      meldung (' undefiniert.'+cr);
  syntaxok := ok
END;  { syntaxok }

