Turbo Toolbox/Turbo_Toolbox.iso/1989/08/praxis/upn.pas

Pascal/Delphi Source File | 1989-05-16 | 13.0 KB | 338 lines

(* ------------------------------------------------------ *)
(*                     UPN.PAS                            *)
(*             (c) 1989 C.Ohr & TOOLBOX                   *)
(* ------------------------------------------------------ *)
PROGRAM UPNCalc;
{$I-,V-}
{$M 2000, 0, 100}

USES CRT, TSR, { s. TOOLBOX 4'89 bzw. PASCAL 5'88 }  DOS;

CONST
  ErsatzX = 50;
  ErsatzY =  3;      { Defaultwerte für Bildschirmposition }
  HotKey  = $6600;                      { Hotkey : Ctrl-F9 }

VAR
  regs : Registers;

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

TYPE
  pElement = ^Element;          { Zeiger auf Kellerelement }
  Element  = RECORD             { Kellerelement 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;                                 { Fehlercodes }
  MaxM  = 9;

VAR
  EPtr   : pElement;      { Zeiger auf erstes Datenelement }
  Screen : ScrType ABSOLUTE $B800:$0000;
                                 { Bildschirmspeicher :    }
                                 { $B000:.. fuer Monochrom }
                                 { $B800:.. fuer CGA       }
  Buffer : ScrType;          { Buffer für Bildschirminhalt }
  m : ARRAY[0..MaxM] OF REAL;         { Konstantenspeicher }
  OldX, OldY,
  OldWMin,OldWMax : WORD;    { Alte Cursorposition/Fenster }
  SoftKey         : WORD;          { Scan-Code fuer Hotkey }
  XPos, YPos      : BYTE;            { Neue Cursorposition }
  ch              : CHAR;
  zahl            : string14;             { Eingabe-String }
  x, h            : 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 loeschen }
    x := 0.0;                        { x-Register loeschen }
    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);
                              { Zwei Variablen vertauschen }
  BEGIN
    h := x;  x := y;  y := h;
  END;

  PROCEDURE DrawCalc;                   { Rechner ausgeben }
  BEGIN
    TextColor(Magenta);
    TextBackGround(Black);
    Window(XPos, YPos, XPos+19, YPos+11);
    ClrScr;
    Write ('▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄');
    Write ('▌x:                ▐');
    Write ('▌y:                ▐');
    Write ('▌Z:                ▐');
    Write ('▓▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▓');
    BWrite('▒ L#n  E#x  L#og  Rp#V ▒');
    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 1.Elem. }
    EPtr := NPtr;      { Zeiger auf das 1.Elem. neu setzen }
  END;

  FUNCTION Pop : REAL;      { Holt den Inhalt des obersten }
  VAR                       { Kellerelements               }
    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);         { Fehler <nr> ausgeben }
  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)
    END;
    Delay(1000);
  END;

  PROCEDURE TestX;              { String in Zahl umwandeln }
  BEGIN
    Val(Zahl, x, error);
    IF error <> 0 THEN Err(Input);
  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);          { ... anzeigen ...                 }
    Delay(100);
    Val(ch, TempB, error);             { ...und umwandeln. }
    InputNr := TempB;
  END;

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

  PROCEDURE Execute;                          { Rechnungen }
  BEGIN
    REPEAT
      REPEAT
         ch := UpCase(ReadKey)
 { Zur Vergrößerung der Anzahl an 'Funktions'-Tasten kann  }
 { auch zw. Groß- und Kleinschreibung differenziert werden.}
      UNTIL ch <> '';            { Auf eine Eingabe warten }
      CASE ch OF            { und die jetzt unterscheiden: }
        '0'..'9',
        'E','.',
        '_'     : IF ch <> '_' THEN zahl := zahl + ch
                               ELSE zahl := zahl + '-';
 { Zur Unterscheidung mit dem normalen Minuszeichen wird   }
 { hier der Underline '_' zur Vorzeichenwahl verwendet.    }
        'A'     : BEGIN
                     WHILE EPtr <> NIL DO x := Pop;
                     x := 0.0;
                     Zahl := '';          { Alles loeschen }
                  END;
        'C'     : x := 0.0;          { x-Register loeschen }
        'D'     : x := Round(x);                  { Runden }
        'G'     : EFlag := NOT EFlag;   { Real-Darstellung }
        'H'     : x := -x;             { Vorzeichenwechsel }
        'I'     : x := Int(x);           { Integerfunktion }
        'K'     : Zahl := '';     { Eingabestring loeschen }
        'L'     : IF EPtr <> NIL THEN h := Pop
                                 ELSE Err(Liste);
                                    { y1-Register loeschen }
        '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 <--> y1 }
        '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); { x in String umwandeln }
        '+','-','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
                      CASE ch OF
                        '+': x := Pop + x;   { und rechnen }
                        '-': x := Pop - x;
                        '*': x := Pop * x;
                        '/': IF x <> 0.0 THEN x := Pop/x
                                         ELSE Err(Float);
                        'Y': BEGIN
                               x := PotenzXY(Pop, x);
                               IF error <> 0 THEN Err(Float)
                             END;
                      END;
                      IF EPtr = NIL THEN Push(x);
                      Zahl := ''; { Eingabe-String löschen }
                   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                         { Eingabe }
                     TestX;
                     IF error = 0 THEN Push(x);
                                  {  Zahl gültig -> Keller }
                     Zahl := '';  { Eingabe-String löschen }
                   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;                    { Urspr. Hauptprogramm }
  BEGIN
    Init;
    DrawCalc;                    { Taschenrechner ausgeben }
    WriteR(x, 1);
    WriteStr(ndef, 2);              { erste Werte ausgeben }
    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 Cursorposition ansteuern }
  END;

{$F-}                                    { Ende Far-Modell }

BEGIN                            { Beginn UPN-Installation }
  IF ParamCount > 1 THEN BEGIN      { Eingabe der Position }
    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;                                { s.o. }
    SoftKey := HotKey;
  END;
  MakeResident(@upn, SoftKey)
                           { Programm im Speicher behalten }
END.                       { Voila! Viel Spass mit UPN !!  }
(* ------------------------------------------------------ *)
(*                  Ende von UPN.PAS                      *)