[comp.lang.pascal] DOSCrt Unit

davidr@hplsla.HP.COM (David M. Reed) (05/24/91)

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 }

ts@uwasa.fi (Timo Salmi) (05/25/91)

In article <6490013@hplsla.HP.COM> davidr@hplsla.HP.COM (David M. Reed) writes:
>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
:
>(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).

They all (the Wheres, sound, and delay, etc) are included (without
source code) in the /pc/ts/tspa23##.arc (##=40,50,55,60) TP units
collection available by anonymous ftp and mail server from
garbo.uwasa.fi and simtel20 archives, and their mirrors. 
Furthermore, note that the WhereX and WhereY (and many other) Crt
counterparts in my TP units do not rely on ansi.sys having been
loaded.  They are more generic, they don't need Crt, _and_ they do
not make the restrictive requirement about ansi.sys. 

...................................................................
Prof. Timo Salmi
Moderating at garbo.uwasa.fi anonymous ftp archives 128.214.12.37
School of Business Studies, University of Vaasa, SF-65101, Finland
Internet: ts@chyde.uwasa.fi Funet: gado::salmi Bitnet: salmi@finfun