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