Turbo Toolbox/Turbo_Toolbox.iso/1990/05/tricks/upn.pas

Pascal/Delphi Source File | 1990-01-15 | 15.1 KB | 430 lines

(* ------------------------------------------------------ *)
(*                      UPN.PAS                           *)
(*    (c) 1989, 1990 C.Ohr, Albin Bigalke & TOOLBOX       *)
(* ------------------------------------------------------ *)
PROGRAM UPNCalc;

{$I-,V-}

{$M 2000, 0, 100}

USES Crt, Tsr, { TOOLBOX 4`89 BZW 5`88 } Dos;

CONST
  ErsatzX   = 50;
  ErsatzY   =  3;
  HotKey    = $6600;
  MaxReal   = 1.6E38;
  MaxExp    = 88.029691931;

VAR
  Regs      : Registers;

{$F+}                               { Far-Model wegen TSR  }

TYPE
  pElement = ^Element;          { Zeiger auf Kellerelement }
  Element  = RECORD             { Kellerelemt y1 -> y2 ... }
               fig   : REAL;
               next  : pElement;
             END;
  string14 = STRING[14];
  ScrType  = ARRAY[0..3999] OF BYTE;          { Bildschirm }

CONST
  ndef   = 'Not defined!'; { Meldung, wenn Keller leer ist }
  Liste  = 1;
  Float  = 2;
  Input  = 3;
  Overfl = 8;
  MaxM   = 9;

VAR
  ePtr     : pElement;    { Zeiger auf ersten Datenelement }
  Screen   : ScrType ABSOLUTE $B800:$0000;
                                   { Bildschirmspeicher :  }
                                   { $B000 für Monochrom:  }
                                   { $B000 für CGA      :  }

  Buffer  : ScrType;         { Buffer für Bildschirminhalt }
  m       : ARRAY [0..MaxM] OF REAL;  { Konstantenspeicher }
  OldX, OldY,
  OldWMin, OldWMax   : WORD;
  SoftKey            : WORD;
  XPos, YPos         : BYTE;
  ch                 : CHAR;
  zahl               : string14;
  x, h               : REAL;
  temp               : REAL;
  i, error           : INTEGER;
  EFlag              : BOOLEAN; { Flag für Darstellungsart }

  PROCEDURE Init;               { Programm initialisieren  }
  BEGIN
    OldX    := WhereX;
    OldY    := WhereY;      { alte Cursorposition retten   }
    OldWMin := WindMin;
    OldWMax := WindMax;     { alte Fenster retten          }
    Zahl    := '';          { Eingabestring löschen        }
    x       := 0.0;         { x-Register löschen           }
    FOR i := 0 TO MaxM DO m[i] := 0.0;
    EPtr    := NIL;      { Keller leer => Zeiger ins Blaue }
    EFlag   := TRUE;     { Darstellung: Zehnerpotenzen     }
    Move(Screen, Buffer,
          SizeOf(Buffer))   { alten Bildschirm retten      }
  END;

  PROCEDURE BWrite(s : STRING);
                  { Schreibprozedur für den Taschenrechner }
  BEGIN
    FOR i := 1 to Length(s) DO BEGIN
      IF S[i] = '#' THEN BEGIN  { Falls dem Zeichen        }
                                { ein '#' vorgestellt ist, }
         Inc(i);                { das nächste Zeichen      }
         TextColor(White);      { heller schreiben         }
      END ELSE
       TextColor(LightGray);    { ansonsten normal         }
      Write(s[i]);
    END;
  END;

  PROCEDURE Swap(VAR x, y : REAL);
  BEGIN
    h := x;  x := y;  y := h;
  END;

  PROCEDURE DrawCalc;
  BEGIN
    TextColor(Magenta);
    TextBackGround(Black);
    Window(XPos, YPos, XPos+19, YPos+11);
    ClrScr;
    Write  ('                    ');
    Write  ('╒══════════════════╕');
    Write  ('│x:                │');
    Write  ('│y:                │');
    Write  ('│z:                │');
    Write  ('║══════════════════║');
    BWrite ('║ L#n  E#n  L#og  R#pV ║');
    BWrite ('║ #Pi  R#d  #Int  C#hS ║');
    BWrite ('║ x'+Chr(16)+'#Z En#g #Y^X  #* #/ ║');
    BWrite ('║ S#mx #Wm  #Rm   #+ #- ║');
    BWrite ('║ #Sxy #Ex #. #'+Chr(17)+'#- #C #Ac ║');
    BWrite ('║ C#ly #'+Chr(17)+'#- #Kill #Quit ║');
    Window(XPos, YPos+11, XPos+19, YPos+12);
                          { Fenster vergrößern. sonst wird }
                          { beim letzten Zeichen gescrollt }
    Write  ('╙══════════════════╜');
    Window(XPos+3, YPos+1, XPos+18, YPos+3);
    TextColor(LightMagenta);
  END;

  PROCEDURE WriteStr(s : STRING; y : BYTE);
  BEGIN
    Gotoxy(1, Y); Write(' ', s);
    ClrEoL;
  END;

  PROCEDURE WriteR(x : REAL; y : BYTE);
  BEGIN
    Gotoxy(1, Y);
    IF EFlag THEN Write(x:15)
             ELSE Write(x:15:15);
    ClrEoL;
  END;

  PROCEDURE Push(x : REAL);
  VAR
    NPtr : pElement;
  BEGIN
    New(NPtr);            { Speicherplatz bereitstellen    }
    NPtr^.fig  := x;      { x-Wert eintragen               }
    NPtr^.next := EPtr;   { Next-Zeiger auf das alte Elem. }
    EPtr       := NPtr;   { Zeiger auf das 1. Element      }
  END;

  FUNCTION Pop : REAL;    { holt den Inhalt des obersten   }
  VAR
    OPtr : pElement;
  BEGIN
    Pop         := EPtr^.fig;  { Wert auslesen             }
    OPtr        := EPtr;       { Zeiger retten             }
    EPtr        := EPtr^.next; { erstes Element ausklinken }
    Dispose(OPtr);             { ... und löschen           }
  END;

  PROCEDURE Err(nr : BYTE);
  BEGIN
    CASE nr OF
      Liste : WriteStr(#7 + 'List Error! ', 2);
      Float : WriteStr(#7 + ndef, 1);
                            { z.B. bei 1/0 oder Ln(-3) ... }
      Input : WriteStr(#7 + 'Input Error! ', 3);
      Overfl: WriteStr(#7 + 'Overflow !   ', 3)
    END;
    Delay(1000);
  END;

  PROCEDURE TestX;              { String in Zahl umwandeln }
  BEGIN
{$V-}
    Val(Zahl, x, error);
    IF error <> 0 THEN
      Err(Input)
    ELSE
      IF Abs(x) > MaxReal THEN Err(Input);
{$V+}
  END;

  FUNCTION InputNr(s : STRING) : BYTE;
                         { Nummer des m-Speichers eingeben }
  VAR
    TempB : BYTE;
  BEGIN
    WriteStr(s, 3);      { String ausgeben,                }
    REPEAT               { auf Eingabe einer Ziffer warten }
      ch := ReadKey
    UNTIL (ch >= '0') AND (ch <= '9');
    Write(ch);
    Delay(100);
    Val(ch, TempB, error);
    InputNr := TempB;    { ... und umwandeln.              }
  END;

  FUNCTION Overflow(x, y : REAL; Operand : Char) : BOOLEAN;

    FUNCTION Sign(x : REAL ) : BOOLEAN;
    BEGIN
      IF x < 0.0 THEN Sign := FALSE
                 ELSE Sign := TRUE;
    END;

  BEGIN
    CASE Operand OF
      '+': BEGIN
             IF Sign(x) = Sign(y) THEN
               IF Abs(x) > MaxReal - Abs(y) THEN
                 Overflow := TRUE
               ELSE Overflow := FALSE
             ELSE Overflow := FALSE;
           END;
      '-': BEGIN
             IF Sign(x) <> Sign(y) THEN
               IF Abs(x) > MaxReal - Abs(y) THEN
                 Overflow := TRUE
               ELSE Overflow := FALSE
             ELSE Overflow := FALSE;
           END;
      '*': BEGIN
             IF (Abs(x) >= 1.0) AND (Abs(y) >= 1.0) THEN
               IF Abs(x) > MaxReal / Abs(y) THEN
                 Overflow := TRUE
               ELSE Overflow := FALSE
             ELSE Overflow := FALSE;
           END;
      '/': BEGIN
             IF Abs(y) < 1.0 THEN
               IF Abs(x) > MaxReal / Abs(1.0 / Abs(y)) THEN
                 Overflow := TRUE
               ELSE Overflow := FALSE
             ELSE Overflow := FALSE;
           END;
      'Y': BEGIN
           IF NOT Overflow(y, Ln(Abs(x)), Char('*')) THEN
             IF Abs(y * (Ln(Abs(x)))) <= MaxExp THEN
               Overflow := FALSE
             ELSE Overflow := TRUE
           ELSE Overflow := TRUE;
         END;
    END;
  END;

  FUNCTION PotenzXY(x, y : REAL) : REAL;
  BEGIN
    error := 0;
    IF x > 0.0 THEN
      IF Not Overflow(x, y, 'Y') THEN
        PotenzXY := Exp(y * Ln(x))
      ELSE error := 8
     ELSE
       IF x = 0.0 THEN
         IF y > 0.0 THEN PotenzXY := 0.0
                    ELSE error    := 1
    ELSE                                       { Basis < 0 }
      IF Not Overflow(x, y, 'Y') THEN
        IF y = Trunc(y) THEN     { Exponent ist ganzzahlig }
          IF Odd(Trunc(y)) THEN              { gerade oder }
            PotenzXY := -Exp(y * Ln(-x))
          ELSE                               { ungerade    }
            PotenzXY :=  Exp(y * Ln(-x))
        ELSE
          IF (1/y = Round(1/y)) AND (Odd(Round(1/y))) THEN
            PotenzXY := -Exp(y * Ln(-x))     { ungerade    }
          ELSE error := 1     { sonst aber wirklich Fehler }
                   { Exponent ist der Kehrwert einer unge- }
                   { raden Zahl: eigentlich nicht de-      }
                   { finiert, die meisten TR lassen        }
                   { die Rechnung aber zu !                }
      ELSE error     := 8;
  END;

  PROCEDURE Execute;                          { Rechnungen }
  BEGIN
    REPEAT
      REPEAT
        ch      := Upcase(Readkey)
      UNTIL ch <> '';
      CASE ch OF
       '0'..'9',
       'E', '.',
       '_'       : IF ch <> '_' THEN zahl := zahl + ch
                                ELSE zahl := zahl + '-';
      { Zur Unterscheidung zum normalen Minusyeichen wird   }
      { hier der Underline '_'zur Vorzeichenwahl verwendet  }

       'A'       : BEGIN
                     WHILE EPtr <> NIL DO x := Pop;
                     x    := 0.0;
                     Zahl := '';
                   END;                { Alles löschen     }
       'C'       : x  := 0.0;          { x-Register löschen}
       'D'       : x  := Round(x);                { Runden }
       'G'       : EFlag  := NOT EFlag;{ Real-Darstellung  }
       'H'       : x  := -x;           { Vorzeichenwechsel }
       'I'       : x  := Int(x);       { Integerfunktion   }
       'K'       : Zahl := '';     { Eingabestring löschen }
       'L'       : IF EPtr <> NIL THEN h := Pop
                                  ELSE Err(Liste);
                                   { y1-Register löschen   }
       'M'       : BEGIN           { x <---> m[0..9]       }
                     SWAP(x, m[InputNr('Swap x with m')]);
                     WriteStr('M swapped!',1);
                     Delay(300);
                   END;
       'N'       : IF x > 0.0 THEN x := Ln(x)
                              ELSE Err(Float);
                                 { Natürlicher Logarithmus }
       'O'       : IF x > 0.0   THEN x := Ln(x)/Ln(10)
                                ELSE Err(Float);
                                 { Zehnerlogarithmus       }

       'P'       : Str(Pi:10:8, Zahl);                { Pi }
       'R'       : BEGIN                 { x <---> m[0..9] }
                     x := m[InputNr('Read from m')];
                     WriteStr('M read!', 1);
                     Delay(300);
                   END;
       'S'       : IF EPtr <> NIL THEN Swap(x, Eptr^.Fig)
                                  ELSE Err(Liste);
                                              { x <---> y  }
       'V'       : IF x <> 0.0 THEN x := 1/x
                               ELSE Err(Float);
                                              { Kehrwert   }
       'W'       : BEGIN                 { x  ---> m[0..9] }
                     m[InputNr('Store x in m')] := x;
                     WriteStr('M stored', 1);
                     Delay(300);
                   END;
       'X'       : x := Exp(x);             { e - Funktion }
       'Z'       : Str(x:14, Zahl);
       '+', '-',
       'Y',                   { Verknüpfungen zw. x und y1 }
       '*','/'   : IF EPtr <> NIL THEN BEGIN
                                         { Operand y1 da ? }
                     error := 0;
                     IF zahl <> '' THEN TestX; { umwandeln }
                     IF error = 0 THEN BEGIN
                       temp  := Pop;
                       CASE ch OF
                         '+': IF NOT Overflow(temp, x, '+')
                                THEN x := temp + x
                                ELSE Err(Overfl);
                         '-': IF NOT Overflow(temp, x, '-')
                                THEN x := temp - x
                                ELSE Err(Overfl);
                         '*': IF NOT Overflow(temp, x, '*')
                                THEN x := temp * x
                                ELSE Err(Overfl);
                         '/': BEGIN
                                IF x = 0.0 THEN
                                  Err(Float)
                                ELSE
                                  IF Overflow(temp, x, '/')
                                    THEN Err(Overfl)
                                    ELSE x := temp/x ;
                              END;
                        'Y' : BEGIN
                                x := PotenzXY(temp, x);
                                IF error = 8 THEN
                                  Err(Overfl)
                                ELSE
                                  IF error <> 0 THEN
                                    Err(Float);
                              END;
                       END;
                     END;
                     IF EPtr = NIL THEN Push(x);
                       Zahl   := '';
                   END ELSE
                     Err(Liste);            { sonst Fehler }
       #8        : IF Length(Zahl) > 0 THEN
                     Zahl := Copy(Zahl, 1,
                                  Pred(Length(Zahl)));
                                 { letztes Zeichen löschen }
       #13       : BEGIN
                     TestX;
                     IF error = 0 THEN Push(x);
                                   { Zahl gültig -> Keller }
                     Zahl  := '';
                   END;
      END;

      WriteR(x, 1);                       { Werte ausgeben }
      IF EPtr <> NIL THEN WriteR(EPtr^.fig, 2)
                     ELSE WriteStr(ndef, 2);
      WriteStr(Zahl, 3);
    UNTIL ch = 'Q';           { und wiederholen bis 'QUIT' }
  END;

  PROCEDURE upn;
  BEGIN
    Init;                        { Taschenrechner ausgeben }
    DrawCalc;
    WriteR(x, 1);                { erste Werte ausgeben    }
    WriteStr(ndef, 2);
    GotoXY(2, 3);
    Execute;                     { ... und los geht's      }
    Move(Buffer, Screen, SizeOF(Screen));
    Window(Succ(LO(OldWMin)), Succ(Hi(OldWMin)),
           Succ(LO(OldWMax)), Succ(Hi(OldWMax)));
                           { alten Bildschirm restaurieren }
    GotoXY(OldX, OldY);    { alte Cursorpos. ansteuern     }
  END;

BEGIN                            { Beginn UPN-Installation }
  IF ParamCount > 1 THEN BEGIN
    Val(ParamStr(1), XPos, error);
    Val(ParamStr(2), YPos, error);
    IF (XPos < 1) OR (XPos > 60) OR (YPos < 1)
                  OR (YPos > 13) OR (error <> 0) THEN BEGIN
      XPos   := ErsatzX;
      YPos   := ErsatzY;     { Default bei unvollständiger }
                             { oder unsinniger Eingabe     }
    END;
    IF ParamCount > 2 THEN BEGIN  { Eingabe des Scan-Codes }
      Val(ParamStr(3), SoftKey, error);
      IF error <> 0 THEN SoftKey := HotKey;
    END ELSE
      SoftKey := HotKey;         { oder Default einsetzen. }
  END ELSE BEGIN
    XPos    := ErsatzX;
    YPos    := ErsatzY;
    SoftKey := HotKey;                              { s.o. }
  END;
  MakeResident(@upn, SoftKey);
                           { Programm im Speicher behalten }
                           { Voila! Viel Spass mit UPN !!  }
END.
(* ------------------------------------------------------ *)
(*                  Ende von UPN.PAS                      *)