Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!sun-barr!lll-winken!sol.ctr.columbia.edu!zaphod.mps.ohio-state.edu!sdd.hp.com!hp-pcd!hplsla!davidr
From: davidr@hplsla.HP.COM (David M. Reed)
Newsgroups: comp.lang.pascal
Subject: DOSCrt Unit
Message-ID: <6490013@hplsla.HP.COM>
Date: 23 May 91 22:51:56 GMT
Organization: HP Lake Stevens, WA
Lines: 492

A while ago someone was requeting the equivalent of "KeyPressed" without
having to use the Unit CRT.  Below is a DOSCrt Unit which I obtained from
Borland a couple of years ago.  Unlike the standard CRT Unit (which talks
directly to the hardware), this version uses MS-DOS function calls and
ANSI to accomplish most of the same things.  I found this necessary when
I started writing programs for a variety of machines which were "MS-DOS
Compatible" but not "IBM Compatible", having various hardware differences.
This has been quite useful to me, and I hope someone else can benefit.

(NOTE: I have found inconsistencies in behaviour with WhereX and WhereY
from one version of ANSI.SYS to another.)

If anyone can supply the missing functions/procedures, I would be interested
(particularly the ones concerning Sound and Delay).

{****************************************************************************}
{                                                                            }
{         Turbo Pascal Version 4.0                                           }
{         DOSCrt Unit                                                        }
{                                                                            }
{         Copyright (c) 1988 Borland International, Inc.                     }
{                                                                            }
{****************************************************************************}

Unit DOSCrt;

Interface

Uses DOS;

CONST   { CRT modes }
        BW40      = 0;              { 40x25 B/W on Color Adapter }
        CO40      = 1;              { 40x25 Color on Color Adapter }
        BW80      = 2;              { 80x25 B/W on Color Adapter }
        CO80      = 3;              { 80x25 Color on Color Adapter }
        Mono      = 7;              { 80x25 on Monochrome Adapter }
(*
        Font8x8   = 256;            { Add-in for ROM font }
*)
        { Foreground and background color constants }
        Black        = 0;
        Blue         = 1;
        Green        = 2;
        Cyan         = 3;
        Red          = 4;
        Magenta      = 5;
        Brown        = 6;
        LightGray    = 7;

        { Foreground color constants }
        DarkGray     = 8;
        LightBlue    = 9;
        LightGreen   = 10;
        LightCyan    = 11;
        LightRed     = 12;
        LightMagenta = 13;
        Yellow       = 14;
        White        = 15;

        { Add-in for blinking }
        Blink        = 128;

        digit_offset  = 48;    { ORD ('0') }   { Added by DMR for WhereX/Y }


VAR  CheckBreak   : BOOLEAN;     { Enable Ctrl-Break }
     DirectVideo  : BOOLEAN;     { Enable direct video addressing }
(*
     CheckEOF     : BOOLEAN;     { Enable Ctrl-Z }
     CheckSnow    : BOOLEAN;     { Enable snow filtering }
*)
     LastMode     : Word;        { Current text mode }
     TextAttr     : Byte;        { Current text attribute }
     WindMin      : Word;        { Window upper left coordinates }
     WindMax      : Word;        { Window lower right coordinates }
     SystemInt23  : POINTER;     { Systems interrupt $23 }
     SaveInt1B    : POINTER;     { Save interrupt $1B }

PROCEDURE AssignCrt (VAR F : Text);       { DOS }

FUNCTION KeyPressed : BOOLEAN;            { DOS }

FUNCTION ReadKey : CHAR;                  { DOS }

PROCEDURE TextMode (Mode : Word);         { ANSI }

(*
PROCEDURE Window (X1, Y1, X2, Y2 : Byte); { BIOS (Unavailable through DOS) }
*)

PROCEDURE GotoXY (X, Y : Byte);           { ANSI }

FUNCTION WhereX : Byte;                   { ANSI }

FUNCTION WhereY : Byte;                   { ANSI }

PROCEDURE ClrScr;                         { ANSI }

PROCEDURE ClrEol;                         { ANSI }

(*
PROCEDURE InsLine;                        { BIOS (Unavailable through DOS) }

PROCEDURE DelLine;                        { BIOS (Unavailable through DOS) }
*)

PROCEDURE TextColor (Color : Byte);       { ANSI }

PROCEDURE TextBackground ( Color : Byte); { ANSI }

PROCEDURE LowVideo;                       { ANSI }

PROCEDURE HighVideo;                      { ANSI }

PROCEDURE NormVideo;                      { ANSI }  { Not same function }

(*
PROCEDURE Delay (ms : Word);              { ???? (Unavailable through DOS) }

PROCEDURE Sound (Hz : Word);              { ???? (Unavailable through DOS) }

PROCEDURE NoSound;                        { ???? (Unavailable through DOS) }
*)

Implementation

CONST   ESCI = #27'[';

VAR    DOSCRT_OldExitProc : POINTER;

{ Inline Macros }

{****************************************************************************}
PROCEDURE JmpOldISR (OldISR : POINTER);

            { This procedure will jump from an ISR to the ISR vector passed }
  InLine ($5B/$58/$87/$5E/$0E/$87/$46/$10/$89/
          $EC/$5D/$07/$1F/$5F/$5E/$5A/$59/$CB);

{****************************************************************************}
FUNCTION ReadDOSEcho : CHAR;

  InLine ($B4/$01/               { MOV AH,0      ; Code for Input     }
          $CD/$21/               { INT 21        ; Call DOS           }
          $50/                   { PUSH AX       ; Save Char          }
          $B4/$02/               { MOV AH,       ; Code for Output    }
          $88/$C2/               { MOV DL,AL     ; Move Char to DL    }
          $50/                   { INT 21        ; Call DOS           }
          $58);                  { POP AX        ; Return Char in AX  }

{****************************************************************************}
FUNCTION ReadDOSNoEcho : CHAR;

  InLine ($B4/$08/               { MOV AH,08     ; Code for Input     }
          $CD/$21);              { INT 21        ; Call DOS           }

{****************************************************************************}
PROCEDURE WriteDOS (Ch : CHAR);

  InLine ($B4/$02/               { MOV AH,02     ; Code for Output    }
          $5A/                   { POP DX        ; Get Char to Write  }
          $CD/$21);              { INT 21        ; Call DOS           }

{****************************************************************************}
FUNCTION KeyReadyDOS : BOOLEAN;

  InLine ($B4/$0B/               { MOV AH,0B     ; Code for Check     }
          $CD/$21/               { INT 21        ; Call DOS           }
          $25/$01/$00);          { AND AX,01     ; Mask First Bit     }

{****************************************************************************}

{$F+}                            { Private FAR Call Procedures and Functions }

{****************************************************************************}
PROCEDURE DOSCrt_1B_23;

                                { Interrupt $1B and #23 Intermediate Handler }
Interrupt;

BEGIN
  IF CheckBreak THEN BEGIN
    InLine ($E4/$61/$8A/$E0/$0C/$80/$E6/$61/            { Clean up as the    }
            $86/$E0/$E6/$61/$B0/$20/$E6/$20);           {  BIOS would        }
    JmpOldISR (SystemInt23);

  END; { IF CheckBreak }

END; { PROC DOSCrt_1B_23 }

{****************************************************************************}
PROCEDURE DOSCrt_ExitProc;

                                                       { ExitCode for DOSCrt }
BEGIN
  ExitProc := DOSCrt_OldExitProc;
  SetIntVec ($23, SystemInt23);
  SetIntVec ($1B, SaveInt1B);

END; { PROC DOSCrt_ExitProc }

{****************************************************************************}
FUNCTION DOSCrt_NUL (VAR F : TextRec) : Integer;

                                    { Text File Device Driver Close Function }
BEGIN
  DOSCrt_NUL := 0;

END; { FUNC DOSCrt_NUL }

{****************************************************************************}
FUNCTION DOSCrt_In (VAR f : TextRec) : Integer;

                                    { Text File Device Driver Input Function }
VAR   place   : Word;
      NotDone : BOOLEAN;

BEGIN
  WITH f DO BEGIN
    place := 0;
    NotDone := TRUE;
    WHILE (NotDone) AND (place < BufSize) DO BEGIN
      BufPtr^[place] := ReadDOSEcho;
      IF (BufPtr^[place] = #13) THEN BEGIN
        Inc (place);
        BufPtr^[place] := #10;
        WriteDOS (#10);
        NotDone := FALSE;

      END; { IF BufPtr }
      Inc (place);

    END; { WHILE NotDone }
    BufPos := 0;
    BufEnd := place;

  END; { WITH f }
  DOSCrt_In := 0;

END; { FUNC DOSCrt_In }

{****************************************************************************}
FUNCTION DOSCrt_Out (VAR f : TextRec) : Integer;

                                   { Text File Device Driver Output Function }
VAR   place   : Word;

BEGIN
  WITH f DO BEGIN
    place := 0;
    WHILE (place < BufPos) DO BEGIN
      WriteDOS (BufPtr^[place] );
      Inc (place);

    END; { WHILE place }
    BufPos := 0;

  END; { WITH f }
  DOSCrt_Out := 0;

END; { FUNC DOSCrt_Out }

{****************************************************************************}
FUNCTION DOSCrt_Open (VAR f : TextRec) : Integer;

                                     { Text File Device Driver Open Function }
BEGIN
  WITH f DO BEGIN
    IF (Mode = fmInput) THEN BEGIN
      InOutFunc := @DOSCrt_In;
      FlushFunc := @DOSCrt_NUL;

    END
    ELSE BEGIN
      Mode := fmOutPut;
      InOutFunc := @DOSCrt_Out;
      FlushFunc := @DOSCrt_Out;

    END; { ELSE Mode = fmOutput }
    CloseFunc := @DOSCrt_NUL;

  END; { WITH f }
  DOSCrt_Open := 0;

END; { FUNC DOSCrt_Open }

{****************************************************************************}

{$F-}                        { END Private FAR Call Procedures and Functions }

{****************************************************************************}
PROCEDURE AssignCrt;

BEGIN
  WITH TextRec (F) DO BEGIN
    Handle := $FFFF;
    Mode := fmClosed;
    BufSize := SizeOf (Buffer);
    BufPtr := @Buffer;
    BufEnd := 0;
    BufPos := 0;
    OpenFunc := @DOSCrt_Open;
    Name [0] := #0;

  END; { WITH TextRec }

END; { PROC AssignCrt }

{****************************************************************************}
FUNCTION KeyPressed : BOOLEAN;

BEGIN
  KeyPressed := KeyReadyDOS;

END; { FUNC KeyPressed }

{****************************************************************************}
FUNCTION ReadKey : CHAR;

BEGIN
  ReadKey := ReadDOSNoEcho;

END; { FUNC ReadKey }

{****************************************************************************}
PROCEDURE TextMode;

BEGIN
  WRITE (ESCI, '=', Mode, 'h');
  LastMode := Mode;

END; { PROC TextMode }

{****************************************************************************}
PROCEDURE GotoXY (X, Y : Byte);

BEGIN
  WRITE (ESCI, Y, ';', X, 'H');

END; { PROC GotoXY }

{****************************************************************************}
FUNCTION WhereX : Byte;

VAR  tempX,
     loop  : Byte;

BEGIN 
  WRITE (ESCI, '6n');
  FOR loop := 1 TO 2 DO 
    IF (ReadKey = #0) THEN BEGIN END;
  tempX := (Byte (ReadKey) - digit_offset) * 10;
  WhereX := tempX + (Byte (ReadKey) - digit_offset);
  FOR loop := 1 TO 5 DO
    IF (ReadKey = #0) THEN BEGIN END;

END; { FUNC WhereX }

{****************************************************************************}
FUNCTION WhereY : Byte;

VAR  tempY,
     loop  : Byte;

BEGIN
  WRITE (ESCI, '6n');
  FOR loop := 1 TO 5 DO
    IF (ReadKey = #0) THEN BEGIN END;
  tempY := (Byte (ReadKey) - digit_offset) * 10;
  WhereY := tempY + (Byte (ReadKey) - digit_offset);
  FOR loop := 1 TO 2 DO
    IF (ReadKey = #0) THEN BEGIN END;

END; { FUNC WhereY }

{****************************************************************************}
PROCEDURE ClrScr;

BEGIN
  WRITE (ESCI, '2J');

END; { PROC ClrScr }

{****************************************************************************}
PROCEDURE ClrEol;

BEGIN
  WRITE (ESCI, 'K');

END; { PROC ClrEol }

{****************************************************************************}
PROCEDURE SetTextAttr;

BEGIN
  WRITE (ESCI, '0;');
  IF ( (TextAttr AND $80) = $80) THEN
    WRITE ('5;');
  IF ( (TextAttr AND $08) = $08) THEN
    WRITE ('1;');

  CASE (TextAttr AND $07) OF
    0 : WRITE ('30;');
    1 : WRITE ('34;');
    2 : WRITE ('32;');
    3 : WRITE ('36;');
    4 : WRITE ('31;');
    5 : WRITE ('35;');
    6 : WRITE ('33;');
    7 : WRITE ('37;');
    ELSE WRITE ('0;');

  END; { CASE $07 }
  CASE ( (TextAttr AND $70) Shr 4) OF
    0 : WRITE ('40;');
    1 : WRITE ('44;');
    2 : WRITE ('42;');
    3 : WRITE ('46;');
    4 : WRITE ('41;');
    5 : WRITE ('45;');
    6 : WRITE ('43;');
    7 : WRITE ('47;');
    ELSE WRITE ('0;');

  END; { CASE $70 }
  WRITE ('m');

END; { PROC SetTextAttr }

{****************************************************************************}
PROCEDURE TextColor (Color : Byte);

BEGIN
  TextAttr := (TextAttr AND $70) + (Color AND $8F);
  SetTextAttr;

END; { PROC TextColor }

{****************************************************************************}
PROCEDURE TextBackground (Color : Byte);

BEGIN
  TextAttr := (TextAttr AND $8F) + ( (Color Shl 4) AND $70);
  SetTextAttr;

END; { PROC TextBackground }

{****************************************************************************}
PROCEDURE LowVideo;

BEGIN
  TextAttr := TextAttr AND $F7;
  SetTextAttr;

END; { PROC LowVideo }

{****************************************************************************}
PROCEDURE HighVideo;

BEGIN
  TextAttr := TextAttr OR $8;
  SetTextAttr;

END; { PROC HighVideo }

{****************************************************************************}
PROCEDURE NormVideo;

BEGIN
  TextAttr := 7;
  SetTextAttr;

END; { PROC NormVideo }

{****************************************************************************}
BEGIN { Unit Initialization }
  GetIntVec ($23, SystemInt23);
  GetIntVec ($1B, SaveInt1B);
  SetIntVec ($23, @DOSCrt_1B_23);
  SetIntVec ($1B, @DOSCrt_1B_23);
  DOSCrt_OldExitProc := ExitProc;
  ExitProc := @DOSCrt_ExitProc;
  DirectVideo := FALSE;
  CheckBreak := TRUE;
  AssignCrt (input);
  AssignCrt (output);
  Reset (input);
  Rewrite (output);
  LastMode := CO80;
  TextAttr := 7;

END. { Unit DOSCrt }