Turbo Toolbox/Turbo_Toolbox.iso/1991/02/titel/box1.pas

Pascal/Delphi Source File | 1990-11-23 | 6.9 KB | 230 lines

(* ------------------------------------------------------ *)
(*                       BOX.PAS                          *)
(*               Message und Antwort-Boxen                *)
(*   Ausgaberoutinen schreiben direkt auf den Bildschirm  *)
(*                                                        *)
(*          (c) 1990 Wolfhard Rinke & TOOLBOX             *)
(* ------------------------------------------------------ *)
PROGRAM Box;

USES Crt;                      (* nur wegen "ReadKey" ... *)

TYPE
  CrtChar  = RECORD
               ch : CHAR;
               at : BYTE;
             END;

  CrtPage  = ARRAY [1..25, 1..80] OF CrtChar;


VAR
  Screen   : CrtPage ABSOLUTE $B800:$0000;
                       (* für monochrom : $B000:$0000 *)

  TextAttr : BYTE;     (* "gültiger" als Crt.TextAttr! *)

(* ------------------------------------------------------ *)

  PROCEDURE WriteCharXY(col, row : INTEGER;
                        ch       : CHAR;
                        num      : INTEGER);
    (* Schreibt ein Zeichen "ch" an der Stelle *)
    (* "col", "row" "num"-mal in den Bildschirmspeicher. *)
  VAR
    i : INTEGER;
  BEGIN
    FOR i := 0 TO num-1 DO BEGIN
      (* Bis jetzt paßt noch niemand auf, daß ein Zeichen *)
      (* vom Bildschirm fällt! *)

      screen[row, col + i].ch := ch;
      screen[row, col + i].at := TextAttr;
           (* wenn der Parameter "attr" in den Aufruf *)
           (* übernommen wird, können wir auch bunt *)
           (* schreiben. Durch den "override" von *)
           (* Crt.TextAttr werden auch TextBackground und *)
           (* TextColor unwirksam, weil beide Prozeduren *)
           (* nur  die Crt-globale TextAttr beeinflussen. *)
    END;
  END;

(* ------------------------------------------------------ *)

  PROCEDURE ClrScr(x1, y1, x2, y2 : INTEGER);
    (* Löscht einen Bildschirmausschnitt. *)
  VAR
    row, col : INTEGER;
  BEGIN
    FOR row := y1 TO y2 DO BEGIN
      WriteCharXY(x1, row, #32, x2-x1);
    END;
  END;

(* ------------------------------------------------------ *)

  PROCEDURE WriteTextXY(col, row : INTEGER; s : STRING);
    (* Schreibt einen String in den Bildschirmspeicher *)
    (* Es gibt derzeit keine Kontrolle auf korrekte Länge *)
  VAR
    i : INTEGER;
  BEGIN
    FOR i := 0 TO Length(s)-1 DO BEGIN
      WriteCharXY(col+i, row, s[i+1], 1);
    END;
  END;

(* ------------------------------------------------------ *)

  PROCEDURE Frame(x1, y1, x2, y2 : INTEGER);
    (* Zeichnet einen doppelten Rahmen um einen Bild- *)
    (* schirmausschnitt. AUch hier gibt es noch keinen *)
    (* Parameter-Check. Ich weiß: Quick and dirty... *)
  VAR
    i : INTEGER;
  BEGIN
    ClrScr(x1, y1, x2, y2);

    WriteCharXY(x1,   y1, #201, 1);          (* oben *)
    WriteCharXY(x1+1, y1, #205, x2-x1-2);
    WriteCharXY(x2-1, y1, #187, 1);

    FOR i := y1+1 TO y2-1 DO BEGIN
      WriteCharXY(x1,   i, #186, 1);         (* links *)
      WriteCharXY(x2-1, i, #186, 1);         (* rechts *)
    END;

    WriteCharXY(x1,   y2, #200, 1);          (* unten *)
    WriteCharXY(x1+1, y2, #205, x2-x1-2);
    WriteCharXY(x2-1, y2, #188, 1);
  END;

(* ------------------------------------------------------ *)

  PROCEDURE Shadow(x1, y1, x2, y2 : INTEGER);
   (* "schattiert" den Bildschirmausschnitt. Zwischen dem *)
   (* Rahmen und dem Bildschirmrand muß noch Platz für    *)
   (* den Schatten sein. Kein Check!! *)
  VAR
    i : INTEGER;
  BEGIN
    FOR i := y1+1 TO y2+1 DO BEGIN
      WriteCharXY(x2, i, #177, 1);      (* '▒' *)
    END;
    WriteCharXY(x1+1, y2+1, #177, x2-x1);
  END;

(* ------------------------------------------------------ *)

  PROCEDURE Message(head     : STRING;
                    col, row : INTEGER;
                    s        : STRING);
    (* "head" ist die Kopfzeile der Box. Wird der Leer- *)
    (* string als Parameter angegeben, erscheint keine  *)
    (* Kopfzeile. Der Kopf wird zentriert.              *)
  VAR
    i    : INTEGER;
    len  : INTEGER;
    hlen : INTEGER;
  BEGIN
    len := Length(s) + 4;
      (* Für den Rahmen und je ein Blank vorne und hinten *)

    Frame(col, row, col+len, row+2);

    IF head <> '' THEN BEGIN
      head := #32 + head + #32;
      hlen := (len - Length(Head)) DIV 2;
      WriteTextXY(col + hlen, row, head);
    END;

    WriteTextXY(col+2, row+1, s);

      (* sollte optional sein: der Schatten... *)
    Shadow(col, row, col+len, row+2);
  END;

(* ------------------------------------------------------ *)

TYPE
  EntrySet = SET OF CHAR;


  PROCEDURE Answer(col, row : INTEGER;
                   s : STRING;
                   corr : EntrySet;
                   VAR ch : CHAR);
    (* Der Prozedur kann ein Zeichensatz übergeben werden,*)
    (* der die gültige Auswahl beinhaltet.                *)
    (*                                                    *)
    (* VAR                                                *)
    (*   ans   : CHAR;                                    *)
    (*   yesno : EntrySet;                                *)
    (*                                                    *)
    (* BEGIN                                              *)
    (*    ...                                             *)
    (*   yesno := ['J', 'N'];                             *)
    (*   Answer(10, 3, 'Drücken Sie [J/N] ', yesno, ans); *)
    (*   IF ans = 'J' THEN                                *)
    (*    ...                                             *)
    (* END.                                               *)
    (*                                                    *)
    (* Das angewählte Zeichen wird nicht mehr ausgegeben. *)
  BEGIN
    Message('Answer', col, row, s);

    REPEAT
      ch := UpCase(ReadKey);
      IF ch IN corr THEN BEGIN
        (*  WriteCharXY(col+Length(s), row+1, ch, 1); *)
      END ELSE BEGIN
        Sound(200); Delay(100); NoSound;
        (* optional, Gerald!!! *)
      END;
    UNTIL ch IN corr;

  END;

(* ------------------------------------------------------ *)

  PROCEDURE Ausblick;
  BEGIN
    ClrScr(55, 5, 75, 20);
    Frame (55, 5, 75, 20);
    Shadow(55, 5, 75, 20);

    (* in allen drei Prozeduren die Parameter wegen der   *)
    (* übersichtlichkeit ... (und Unabhängigkeit!)        *)

    WriteTextXY(55+2, 5+5, 'demnächst in');
    WriteTextXY(55+2, 5+7, 'diesem');
    WriteTextXY(55+2, 5+9, 'Theater...');

  END;

(* ------------------------------------------------------ *)

VAR
  ans   : CHAR;
  yesno : EntrySet;

BEGIN
  TextAttr := 7;

  ClrScr(1, 1, 80, 25);

  Message('Ok-Box', 30, 15, 'Alles paletti!');

  Ausblick;

  Message('', 15, 20, 'Eine Message-Box ohne Header...');

  yesno := ['J', 'N'];
  Answer(10, 3, 'Drücken Sie [J/N] ...', yesno, ans);


END.
(* ------------------------------------------------------ *)
(*                   Ende von BOX.PAS                     *)