home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
PASCAL
/
QWRIT11.ZIP
/
QWRITER.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1992-03-10
|
19KB
|
525 lines
{$A+,B-,D-,E-,F-,I+,N-,O-,R+,S-,V+}
(****************************************************************************)
(* QWRITER.PAS - Quick screen writing unit. *)
(* version 1.1 (March 10, 1992) *)
(* TP required: 6.0 *)
(* by Guy McLoughlin *)
(* Released to the public domain. *)
(****************************************************************************)
unit Qwriter; (* Unit to write Strings directly to the Video-buffer. *)
(****************************************************************************)
interface
(****************************************************************************)
const (* Set these constants according to the text-screen size *)
(* you are using. *)
Rows = 25;
Columns = 80;
ClearSize = (Rows shl 8) + Columns;
(* ReadKeyWord constants. *)
AnyKey = 0;
BackSpaceKey = 3592;
TabKey = 3849;
EnterKey = 7181;
EscapeKey = 283;
SpaceBarKey = 14624;
F1Key = 15104;
F2Key = 15360;
F3Key = 15616;
F4Key = 15872;
F5Key = 16128;
F6Key = 16384;
F7Key = 16640;
F8Key = 16896;
F9Key = 17152;
F10Key = 17408;
HomeKey = 18176;
EndKey = 20224;
PageUpKey = 18688;
PageDownKey = 20736;
UpArrowKey = 18432;
DownArrowKey = 20480;
RightArrowKey = 19712;
LeftArrowKey = 19200;
InsertKey = 20992;
DeleteKey = 21248;
(* Boolean constants. *)
On = true;
Off = false;
type (* Maximum length of display string. *)
VidString = string[Columns];
var (* Boolean use to check Video-Mode. *)
ColorMode : boolean;
NormAttr, (* Normal text-attribute variable. *)
RevAttr : word; (* Reversed text-attribute variable. *)
(****************************************************************************)
(* Unit Routines *)
(****************************************************************************)
(* Read a key-press. *)
function ReadKeyChar : char;
(* Read key and scan-code at once. *)
function ReadKeyWord : word;
(* Clear the keyboard-buffer. *)
procedure ClearKeyBuff;
(* Wait for specific key to be pressed. *)
procedure Pause(Key : word);
(* Standard PC beep. *)
procedure Beep;
(* Convert an integer-type to a string-type. *)
function Int2Str(Number : longint; Width : byte) : VidString;
(* Convert a real-type to a string-type. *)
function Real2Str(Number : real;
Width, Decimals : byte) : VidString;
(* Hide or show cursor. *)
procedure HideCursor(Switch : boolean);
(* Clear screen using a specific color attribute. *)
procedure ClearScr(Attr : byte);
(* Turn the "blink-bit" off to allow 16 different *)
(* background colors. WORKS FOR EGA+ VIDEO MODES ONLY! *)
procedure BlinkBit(Switch : boolean);
(* Procedure to write directly to the video-buffer at *)
(* Xaxis, Yaxis, using Cattr color-attribute. *)
procedure Qwrite(InString : VidString;
Xaxis, Yaxis : byte;
Cattr : word);
(* Procedure to vertically write directly to the video- *)
(* buffer at Xaxis, Yaxis, using Cattr color-attribute. *)
procedure VQwrite(InString : VidString;
Xaxis, Yaxis : byte;
Cattr : word);
(* Procedure to change video-buffer color attributes, *)
(* at Xaxis, Yaxis, using Cattr color-attribute. *)
procedure ChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);
(* Procedure to vertically change video-buffer color *)
(* attributes, at Xaxis, Yaxis, using Cattr color- *)
(* attribute. *)
procedure VChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);
(* Function to create a hi-light bar "pick-list" menu. *)
function PickIt(TopY, (* Top Y axis position. *)
BotY, (* Bottom Y axis position. *)
Xaxis, (* X axis position. *)
HiLightBarSize : byte; (* Length of hi-light bar. *)
NormalAttr, (* Normal attribute. *)
HiLightBarAttr : word) : word; (* Hi-light bar attribute. *)
(****************************************************************************)
implementation
(****************************************************************************)
var
VidAddr : word; (* Video-buffer address variable. *)
(* Set the Video-buffer address. *)
procedure SetVideoAddress;
begin
if ((Mem[$0000:$0410] and $30) <> $30) then
begin
VidAddr := $B800; (* Color video mode. *)
ColorMode := true;
NormAttr := $17; (* Lightgray text on a blue background. *)
RevAttr := $71 (* Blue text on a lightgray background. *)
end
else
begin
VidAddr := $B000; (* Monochrome video mode. *)
ColorMode := false;
NormAttr := $07; (* Lightgray text on a black background. *)
RevAttr := $70 (* Black text on a lightgray background. *)
end
end;
(* Read a key-press. *)
function ReadKeyChar : char; assembler;
asm
mov ah, 0
int 16h
end;
(* Read standard and extended key codes at once. *)
function ReadKeyWord : word; assembler;
asm
mov ah, 0
int 16h
end;
(* Clear the keyboard-buffer. *)
procedure ClearKeyBuff; assembler;
asm
@1: mov ah, 1
int 16h
jz @2
mov ah, 0
int 16h
jmp @1
@2:
end;
(* Function to indicate if a key is in the keyboard *)
(* buffer. *)
function KeyPressed : boolean; assembler;
asm
mov ah, 1
int 16h
mov ax, 0
jz @1
inc ax
@1:
end;
(* Wait for specific key to be pressed. *)
procedure Pause(Key : word);
begin
ClearKeyBuff;
if (Key = AnyKey) then
repeat until(Keypressed)
else
repeat until(ReadKeyWord = Key)
end;
(* Standard PC beep. *)
procedure Beep;
begin
write(#7)
end;
(* Convert an integer-type to a string-type. *)
function Int2Str(Number : longint; Width : byte) : VidString;
var
TempString : VidString;
begin
Str(Number:Width, TempString);
Int2Str := TempString
end;
(* Convert a real-type to a string-type. *)
function Real2Str(Number : real;
Width, Decimals : byte) : VidString;
var
TempString : VidString;
begin
Str(Number:Width:Decimals, TempString);
Real2Str := TempString
end;
(* Hide or show cursor. *)
procedure HideCursor(Switch : boolean);
begin
if (Switch = true) then
asm mov CX, 2000h end
else
if ColorMode then
asm mov CX, 0607h end
else
asm mov CX, 0C0Dh end;
asm
mov AX, 0100h
int 10h
end
end;
(* Clear screen using a specific color. *)
procedure ClearScr(Attr : byte); assembler;
asm
mov bh, Attr
xor cx, cx
mov dx, ClearSize
mov ah, 7
mov al, 25
int 10h
mov ah, 2
mov bh, 0
xor dx, dx
int 10h
end;
(* Turn the "blink-bit" off to allow 16 different *)
(* background colors. WORKS FOR EGA+ VIDEO MODES ONLY! *)
procedure BlinkBit(Switch : boolean); assembler;
asm
mov AX, 1003h
mov Bl, Switch
int 10h
end;
(* Procedure to write directly to the video-buffer at *)
(* Xaxis, Yaxis, using Cattr color-attribute. *)
procedure Qwrite(InString : VidString;
Xaxis, Yaxis : byte;
Cattr : word);
var
IsIndex : byte; (* InString position index. *)
VidOffset : word; (* Video-address offset position. *)
begin
(* If InString is empty then exit procedure. *)
if InString = '' then
exit;
(* Stop any illeagal Xaxis, Yaxis positions. *)
if Columns < (Xaxis + length(InString)) then
Xaxis := Columns - length(InString);
if Rows < Yaxis then
Yaxis := Rows;
(* Calculate the offset into the video-buffer array. *)
VidOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2);
(* Make sure string is not too long! *)
if ((length(InString) + Xaxis) > Columns) then
InString[0] := chr((Columns + 1) - Xaxis);
(* Write string to video-buffer. *)
for IsIndex := 0 to (length(InString) - 1) do
MemW[VidAddr : (VidOffset + (IsIndex * 2))] :=
(Cattr shl 8) + byte(InString[IsIndex + 1]);
end;
(* Procedure to vertically write directly to the video- *)
(* buffer at Xaxis, Yaxis, using Cattr color-attribute. *)
procedure VQwrite(InString : VidString;
Xaxis, Yaxis : byte;
Cattr : word);
var
IsIndex : byte; (* InString position index. *)
VidOffset : word; (* Video-address offset position. *)
begin
(* If InString is empty then exit procedure. *)
if InString = '' then
exit;
(* Stop any illeagal Xaxis, Yaxis positions. *)
if Columns < Xaxis then
Xaxis := Columns;
if Rows < Yaxis then
Yaxis := Rows;
(* Calculate the offset into the video-buffer array. *)
VidOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2);
(* Make sure string is not too long! *)
if ((length(InString) + Yaxis) > Rows) then
InString[0] := chr((Rows + 1) - Yaxis);
(* Write string to screen. *)
for IsIndex := 0 to (length(InString) - 1) do
MemW[VidAddr : (VidOffset + (IsIndex * Columns * 2))] :=
(Cattr shl 8) + byte(InString[IsIndex + 1]);
end;
(* Procedure to change video-buffer color attributes, *)
(* at Xaxis, Yaxis, using Cattr color-attribute. *)
procedure ChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);
var
AttrIndex,
AttrOffset : word;
begin
(* Stop any illeagal Xaxis, Yaxis positions. *)
if (Yaxis > Rows) then
Yaxis := Rows;
if (Xaxis > Columns) then
Xaxis := Columns;
(* Calculate the offset into the video-buffer array. *)
AttrOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2) + 1;
(* Make sure the number of attributes to change is not *)
(* too many. *)
if (AttrsToChange > (Columns - Xaxis)) then
AttrsToChange := (Columns - Xaxis) + 1;
(* Change color attributes in the video-buffer array. *)
for AttrIndex := 0 to (AttrsToChange - 1) do
Mem[VidAddr : (AttrOffset + (AttrIndex * 2))] := Cattr
end;
(* Procedure to vertically change video-buffer color *)
(* attributes, at Xaxis, Yaxis, using Cattr color- *)
(* attribute. *)
procedure VChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);
var
AttrIndex,
AttrOffset : word;
begin
(* Stop any illeagal Xaxis, Yaxis positions. *)
if (Yaxis > Rows) then
Yaxis := Rows;
if (Xaxis > Columns) then
Xaxis := Columns;
(* Calculate the offset into the video-buffer array. *)
AttrOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2) + 1;
(* Make sure the number of attributes to change is not *)
(* too many. *)
if (AttrsToChange > (Rows - Yaxis)) then
AttrsToChange := (Rows - Yaxis) + 1;
(* Change color attributes in the video-buffer array. *)
for AttrIndex := 0 to (AttrsToChange - 1) do
Mem[VidAddr : (AttrOffset + (AttrIndex * Columns * 2))] := Cattr
end;
(* Function to create a hi-light bar "pick-list" menu. *)
function PickIt(TopY, (* Top Y axis position. *)
BotY, (* Bottom Y axis position. *)
Xaxis, (* X axis position. *)
HiLightBarSize : byte; (* Length of hi-light bar. *)
NormalAttr, (* Normal attribute. *)
HiLightBarAttr : word) : word; (* Hi-light bar attribute. *)
var
Quit,
EscapeQuit,
MoveHiLightBar : boolean;
BarOffset : byte;
DUD : char;
begin
(* Initialize PickIt variables. *)
Quit := false;
EscapeQuit := false;
BarOffset := 0;
MoveHiLightBar := true;
(* Repeat..Until it's time to quit. *)
repeat
(* Clear key-buffer. *)
ClearKeyBuff;
(* Display / re-display the hi-light bar. *)
if MoveHiLightBar then
ChangeAttr(HiLightBarSize, Xaxis, (TopY + BarOffset), HiLightBarAttr);
(* Get User key choice. *)
case ReadKeyWord of
UpArrowKey,
LeftArrowKey : begin
(* Hide hi-light bar. *)
ChangeAttr(HiLightBarSize,
Xaxis, (TopY + BarOffset), NormalAttr);
(* Set "MoveHiLightBar" boolean. *)
MoveHiLightBar := true;
(* If hi-light bar is NOT in the starting position, then *)
(* decrement it's position by one. *)
if (BarOffset > 0) then
dec(BarOffset, 1)
(* Else, if hi-light bar IS in the starting position, *)
(* then move it to the LAST position. *)
else
BarOffset := (BotY - TopY)
end;
DownArrowKey,
RightArrowKey : begin
(* Hide hi-light bar. *)
ChangeAttr(HiLightBarSize,
Xaxis, (TopY + BarOffset), NormalAttr);
(* Set "MoveHiLightBar" boolean. *)
MoveHiLightBar := true;
(* If hi-light bar is NOT in the LAST position, then *)
(* increment it's position by one. *)
if (BarOffset < (BotY - TopY)) then
inc(BarOffset, 1)
(* Else, if hi-light bar IS in the LAST position, then *)
(* move it to the starting position. *)
else
BarOffset := 0
end;
(* <ENTER> key pressed, quit-pick loop. *)
EnterKey : Quit := true;
(* <ESC> key pressed, quit pick-loop. *)
EscapeKey : EscapeQuit := true
(* Else, discard User's key choice. *)
else
MoveHiLightBar := false
end
(* Repeat..Until it's time to quit. *)
until (Quit or EscapeQuit);
(* If the User pressed the <ESC> key, then return 0. *)
if EscapeQuit then
PickIt := 0
(* Else, return the hi-light bar position. *)
else
PickIt := BarOffset + 1
end;
BEGIN
SetVideoAddress
END.