home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 02 / titel / box.mod < prev    next >
Encoding:
Modula Implementation  |  1990-11-23  |  4.5 KB  |  172 lines
  1. (* ------------------------------------------------------ *)
  2. (*                       BOX.MOD                          *)
  3. (*               Message und Antwort-Boxen                *)
  4. (*   Ausgaberoutinen schreiben direkt auf den Bildschirm  *)
  5. (*                                                        *)
  6. (*          (c) 1991 Wolfhard Rinke & TOOLBOX             *)
  7. (* ------------------------------------------------------ *)
  8. IMPLEMENTATION MODULE Box;
  9.  
  10. FROM Strings  IMPORT Length, CompareStr;
  11. FROM Terminal IMPORT Read;
  12. FROM SYSTEM   IMPORT BYTE, ADDRESS, SEG, OFS;
  13.  
  14. TYPE
  15.   CrtChar  = RECORD
  16.                ch : CHAR;
  17.                at : BYTE;
  18.              END;
  19.  
  20.   CrtPage  = ARRAY [1..25], [1..80] OF CrtChar;
  21.  
  22. VAR
  23.   Screen   : POINTER TO CrtPage;
  24.               (* "Standard":  Screen[0B800H:0] : CrtPage; *)
  25.               (*              für monochrom : $B000:$0000 *)
  26.  
  27.   CrtAddr  : ADDRESS;
  28.   
  29. (* ------------------------------------------------------ *)
  30.  
  31.   PROCEDURE WriteCharXY(col, row : CARDINAL;
  32.                         ch       : CHAR;
  33.                         num      : CARDINAL);
  34.   VAR
  35.     i : CARDINAL;
  36.   BEGIN
  37.     FOR i := 0 TO num-1 DO
  38.       IF (i + row) <= 80 THEN
  39.         Screen^[row, col+i].ch := ch;
  40.         Screen^[row, col+i].at := TextAttr;
  41.       END;
  42.     END;
  43.   END WriteCharXY;
  44.  
  45. (* ------------------------------------------------------ *)
  46.  
  47.   PROCEDURE ClrScr(x1, y1, x2, y2 : CARDINAL);
  48.   VAR
  49.     row : CARDINAL;
  50.   BEGIN
  51.     FOR row := y1 TO y2 DO
  52.       WriteCharXY(x1, row, 40C, x2-x1);
  53.     END;
  54.   END ClrScr;
  55.  
  56. (* ------------------------------------------------------ *)
  57.  
  58.   PROCEDURE WriteTextXY(col, row : CARDINAL;
  59.                         s        : ARRAY OF CHAR);
  60.   VAR
  61.     i : CARDINAL;
  62.   BEGIN
  63.     FOR i := 0 TO Length(s)-1 DO
  64.       WriteCharXY(col+i, row, s[i], 1);
  65.                             (*  ^ Turbo Pascal !!! *)
  66.     END;
  67.   END WriteTextXY;
  68.  
  69. (* ------------------------------------------------------ *)
  70.  
  71.   PROCEDURE Frame(x1, y1, x2, y2 : CARDINAL);
  72.   VAR
  73.     i : CARDINAL;
  74.   BEGIN
  75.     ClrScr(x1, y1, x2, y2);
  76.     WriteCharXY(x1,   y1, 311C, 1);             (* oben   *)
  77.     WriteCharXY(x1+1, y1, 315C, x2-x1-2);
  78.     WriteCharXY(x2-1, y1, 273C, 1);
  79.  
  80.     FOR i := y1+1 TO y2-1 DO
  81.       WriteCharXY(x1,   i, 272C, 1);            (* links  *)
  82.       WriteCharXY(x2-1, i, 272C, 1);            (* rechts *)
  83.     END;
  84.  
  85.     WriteCharXY(x1,   y2, 310C, 1);             (* unten  *)
  86.     WriteCharXY(x1+1, y2, 315C, x2-x1-2);
  87.     WriteCharXY(x2-1, y2, 274C, 1);
  88.   END Frame;
  89.  
  90. (* ------------------------------------------------------ *)
  91.  
  92.   PROCEDURE Shadow(x1, y1, x2, y2 : CARDINAL);
  93.   VAR
  94.     i : CARDINAL;
  95.   BEGIN
  96.     FOR i := y1+1 TO y2+1 DO
  97.       WriteCharXY(x2, i, 261C, 1);                 (* '▒' *)
  98.     END;
  99.     WriteCharXY(x1+1, y2+1, 261C, x2-x1);
  100.   END Shadow;
  101.  
  102. (* ------------------------------------------------------ *)
  103.  
  104.   PROCEDURE Message(head     : ARRAY OF CHAR;
  105.                     col, row : CARDINAL;
  106.                     s        : ARRAY OF CHAR);
  107.   VAR
  108.     i    : CARDINAL;
  109.     len  : CARDINAL;
  110.     hlen : CARDINAL;
  111.   BEGIN
  112.     len := Length(s) + 4;
  113.  
  114.       (* Für den Rahmen und je ein Blank vorne und hinten *)
  115.  
  116.     Frame(col, row, col+len, row+2);
  117.  
  118.     IF CompareStr(head, '') <> 0 THEN
  119.       (* oder: IF head[0] <> 0C THEN ... *)
  120.  
  121.       hlen := (len-Length(head)) DIV 2;
  122.       WriteTextXY(col+hlen, row, head);
  123.     END;
  124.  
  125.     WriteTextXY(col+2, row+1, s);
  126.  
  127.                  (* sollte optional sein: der Schatten... *)
  128.     Shadow(col, row, col+len, row+2);
  129.   END Message;
  130.  
  131. (* ------------------------------------------------------ *)
  132.  
  133.   PROCEDURE ReadKey() : CHAR;
  134.   VAR
  135.     ch : CHAR;
  136.   BEGIN
  137.     Read(ch);
  138.     RETURN ch;
  139.   END ReadKey;
  140.  
  141. (* ------------------------------------------------------ *)
  142.  
  143.   PROCEDURE Answer(col, row : CARDINAL;
  144.                    s        : ARRAY OF CHAR;
  145.                    corr     : EntrySet;
  146.                    VAR ch   : CHAR);
  147.   BEGIN
  148.     Message(' Answer ', col, row, s);
  149.  
  150.     REPEAT
  151.       ch := CAP(ReadKey());
  152.       IF ch IN corr THEN
  153.         (*  WriteCharXY(col+Length(s), row+1, ch, 1); *)
  154.       ELSE
  155.         (* optional:
  156.         Sound(200);
  157.         Delay(100);
  158.         NoSound;
  159.         *)
  160.       END;
  161.     UNTIL ch IN corr;
  162.   END Answer;
  163.  
  164. BEGIN
  165.   CrtAddr.SEG := 0B800H;           (* $B000 für monochrom *)
  166.   CrtAddr.OFS := 00000H;
  167.   Screen      := CrtAddr;
  168. END Box.
  169. (* ------------------------------------------------------ *)
  170. (*                  Ende von BOX.MOD                      *)
  171.  
  172.