home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / WINDOWS.ZIP / SCREEN.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1989-07-12  |  6.8 KB  |  257 lines
  1. {$f+}
  2. UNIT SCREEN;
  3.  
  4. {
  5.    "Created using Turbo Pascal, copyright (c) Borland International
  6.    1987, 1988."      Turbo Pascal 5.5
  7.  
  8.    This is a unit which will do the following:
  9.  
  10.    MONOCHROME          Returns true if monochrome monitor
  11.    PUSH_SCREEN         Store current screen in ram
  12.    POP_SCREEN          Restore screen stored in ram
  13.    CURSORON            Turn cursor off
  14.    CURSOROFF           Turn cursor on
  15.    DRAWBOX             Create and box a window given coordinates (of box)
  16.    WAITFORKEY          Wait for a any key to be pressed
  17.                        (without cursor showing)
  18.  
  19.    This unit was sparked by a program I read in "Complete Turbo
  20.    Pascal Third Edition" by Jeff Duntemann.  ISBN 0-673-38355-5.
  21.    Copyright (c) 1989 by Scott, Foresman and Company.
  22.  
  23. }
  24. INTERFACE
  25.  
  26. USES DOS,CRT;
  27.  
  28. CONST
  29.   ScreenX = 80;
  30.   ScreenY = 25;   { This could be 43 for the EGA;
  31.                     50 for the VGA;
  32.                     66 for Genuis }
  33. TYPE
  34.   wrdptr  = ^word;
  35. VAR
  36.   XSave,
  37.   YSave              : Integer;
  38.   VideoBufferSize    : Word;
  39.   SavePtr,
  40.   VideoPtr           : wrdptr;
  41.   VideoSeg           : Word;
  42.  
  43. FUNCTION  MONOCHROME : Boolean;
  44. PROCEDURE CURSORON;
  45. PROCEDURE CURSOROFF;
  46. PROCEDURE WAITFORKEY;
  47. PROCEDURE DRAWBOX(x1,y1,x2,y2:integer);
  48. PROCEDURE PUSH_SCREEN(var saveptr:wrdptr);
  49. PROCEDURE POP_SCREEN(var saveptr:wrdptr);
  50.  
  51. IMPLEMENTATION
  52.  
  53. {*********************************************************************}
  54.  
  55.   FUNCTION MONOCHROME : Boolean;
  56.   VAR
  57.      Regs : Registers;
  58.   BEGIN
  59.     INTR(17,Regs);
  60.     IF (Regs.AX AND $0030) = $30 THEN
  61.       MONOCHROME := True
  62.     ELSE
  63.       MONOCHROME := False
  64.   END;
  65.  
  66. {*********************************************************************}
  67.  
  68.   PROCEDURE CURSORON;
  69.   TYPE  adapterTYPE = (none,mda,cga,egamono,egacolor,vgamono,
  70.                        vgacolor,mcgamono,mcgacolor);
  71.   VAR points : byte;
  72.       regs   : registers;
  73.  
  74.      FUNCTION determinepoints : integer;
  75.      VAR regs:registers;
  76.  
  77.         FUNCTION QUERYATAPTERTYPE:adapterTYPE;
  78.         VAR regs: registers;
  79.             code: byte;
  80.         BEGIN
  81.           regs.ah:=$1a;
  82.           regs.al:=$00;
  83.           intr($10,regs);
  84.           IF regs.al = $1a THEN
  85.             BEGIN
  86.               CASE regs.bl OF
  87.                  $00 : QUERYATAPTERTYPE:=none;
  88.                  $01 : QUERYATAPTERTYPE:=mda;
  89.                  $02 : QUERYATAPTERTYPE:=cga;
  90.                  $04 : QUERYATAPTERTYPE:=egacolor;
  91.                  $05 : QUERYATAPTERTYPE:=egamono;
  92.                  $07 : QUERYATAPTERTYPE:=vgamono;
  93.                  $08 : QUERYATAPTERTYPE:=vgacolor;
  94.                  $0a,$0c : QUERYATAPTERTYPE :=mcgacolor;
  95.               ELSE
  96.                  QUERYATAPTERTYPE := cga;
  97.               END;
  98.             END
  99.           ELSE
  100.             BEGIN
  101.               regs.ah:=$12;
  102.               regs.bx:=$10;
  103.               intr($10,regs);
  104.               IF regs.bx <> $10 THEN
  105.                 BEGIN
  106.                   regs.ah :=$12;
  107.                   regs.bl :=$10;
  108.                   intr($10,regs);
  109.                   IF (regs.bh = 0) THEN
  110.                     QUERYATAPTERTYPE:=egacolor
  111.                   ELSE
  112.                     QUERYATAPTERTYPE:=egamono;
  113.                 END
  114.               ELSE
  115.                 BEGIN
  116.                   intr($11,regs);
  117.                   code:=(regs.al and $30) shr 4;
  118.                   CASE code OF
  119.                     1 : QUERYATAPTERTYPE := cga;
  120.                     2 : QUERYATAPTERTYPE := cga;
  121.                     3 : QUERYATAPTERTYPE := mda
  122.                   ELSE
  123.                     QUERYATAPTERTYPE:=cga;
  124.                   END;
  125.                 END;
  126.               END;
  127.             END;
  128.  
  129.      BEGIN
  130.        CASE QUERYATAPTERTYPE OF
  131.          cga    : determinepoints:=8;
  132.          mda    : determinepoints:=14;
  133.          egamono,
  134.          egacolor,
  135.          vgamono,
  136.          vgacolor,
  137.          mcgamono,
  138.          mcgacolor:BEGIN
  139.                      WITH regs DO
  140.                       BEGIN
  141.                         ah:=$11;
  142.                         al:=$30;
  143.                         bl:=0;
  144.                       END;
  145.                      intr($10,regs);
  146.                      determinepoints:=regs.cx;
  147.                    END;
  148.        END;
  149.      END;
  150.  
  151.   BEGIN
  152.     points:=determinepoints;
  153.     mem[$40:$87]:=mem[$40:$87] OR $01;
  154.     WITH regs DO
  155.       BEGIN
  156.         ax:=$0100;
  157.         ch:=points-3;
  158.         cl:=points-1;
  159.       END;
  160.     intr(16,regs);
  161.   END;
  162.  
  163.  
  164. {*********************************************************************}
  165.  
  166.   PROCEDURE CURSOROFF;
  167.   VAR Regs : Registers;
  168.   BEGIN
  169.    WITH regs DO
  170.     BEGIN
  171.       ax:=$0100;
  172.       cx:=$2000;
  173.     END;
  174.    intr(16,regs);
  175.   END;
  176.  
  177.  
  178. {*********************************************************************}
  179.  
  180.   PROCEDURE WAITFORKEY;
  181.   VAR Dummy   : Char;
  182.   BEGIN
  183.     gotoxy(1,1);
  184.     CURSOROFF;
  185.     REPEAT UNTIL KeyPressed;
  186.     Dummy := ReadKey;
  187.     IF Dummy = Chr(0) THEN
  188.        Dummy := ReadKey;
  189.     CURSORON;
  190.   END;
  191.  
  192. {*********************************************************************}
  193.  
  194.   PROCEDURE DRAWBOX(x1,y1,x2,y2:integer);
  195.   const
  196.     ULCORNER = CHR(201);
  197.     URCORNER = CHR(187);
  198.     LLCORNER = CHR(200);
  199.     LRCORNER = CHR(188);
  200.     HBAR     = CHR(205);
  201.     VBAR     = CHR(186);
  202.   VAR i:integer;
  203.   BEGIN
  204.     window(1,1,80,25);
  205.     highvideo;
  206.     gotoxy(x1,y1);
  207.     write(ulcorner);
  208.     FOR i:=x1+1 to x2-1 DO
  209.         write(hbar);
  210.     write(urcorner);
  211.     FOR i:=y1+1 to y2-1 DO
  212.         BEGIN
  213.           gotoxy(x1,i);
  214.           write(vbar);
  215.           gotoxy(x2,i);
  216.           write(vbar);
  217.         END;
  218.     gotoxy(x1,y2);
  219.     write(llcorner);
  220.     FOR i:=x1+1 to x2-1 DO
  221.        write(hbar);
  222.     write(lrcorner);
  223.     window(x1+1,y1+1,x2-1,y2-1);
  224.     ClrScr;
  225.   END;
  226.  
  227. {*********************************************************************}
  228.  
  229.   PROCEDURE PUSH_SCREEN(var saveptr:wrdptr);
  230.   VAR J:INTEGER;
  231.       VidSegment : Word;
  232.   BEGIN
  233.     XSave := WhereX;
  234.     YSave := WhereY;     { Save the underlying cursor pos. }
  235.     { Allocate memory for stored screen: }
  236.     GetMem(SavePtr,VideoBufferSize);
  237.     IF MONOCHROME THEN
  238.        VidSegment := $B000 { Get a screen buffer origin }
  239.     ELSE
  240.        VidSegment := $B800;
  241.     VideoPtr := Ptr(VidSegment,0);  { Create a pointer to the buffer }
  242.     Move(VideoPtr^,SavePtr^,VideoBufferSize); { Save screen out to the heap }
  243.   END;
  244.  
  245. {*********************************************************************}
  246.  
  247.   PROCEDURE POP_SCREEN(var saveptr:wrdptr);
  248.   BEGIN
  249.     Move(SavePtr^,VideoPtr^,VideoBufferSize);  { Bring screen back from heap }
  250.     FreeMem(SavePtr,VideoBufferSize);          { Free up the heap memory     }
  251.     GotoXY(XSave,YSave);                       { Put cursor back where it was}
  252.   END;
  253.  
  254. { initialize static variables }
  255. begin
  256.     VideoBufferSize := ScreenX*ScreenY*2;  { E.g., 25 X 80 X 2 = 4000 bytes  }
  257. END. {IMPLEMENTATION}