dos_compilers/Borland Turbo Pascal v55/TCSCREEN.PAS
2024-07-02 06:49:04 -07:00

523 lines
14 KiB
Plaintext
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{ Copyright (c) 1989 by Borland International, Inc. }
unit TCScreen;
{ Turbo Pascal 5.5 object-oriented example screen routines.
This unit is used by TCALC.PAS.
See TCALC.DOC for an more information about this example.
}
{$S-}
interface
uses Crt, Dos, TCUtil;
const
ScreenCols = 80;
ScreenRows = 50;
MinScreenRows = 25;
ESCPress = 'Press ESC.'; { Printed in error messages }
type
Direction = (Up, Down, Left, Right);
ScreenColRange = 1..ScreenCols;
ScreenRowRange = 1..ScreenRows;
VideoTypes = (MDA, CGA, MCGA, EGA, VGA);
ScreenChar = record
Data : Char;
Attrib : Byte;
end;
ScreenArray = array[ScreenRowRange, ScreenColRange] of ScreenChar;
ScreenRow = array[ScreenColRange] of ScreenChar;
ScreenPointer = ^ScreenArray;
ScreenPos = record
Col : ScreenColRange;
Row : ScreenRowRange;
end;
Screen = object
CurrRows : ScreenRowRange;
CurrCols : ScreenColRange;
VideoType : VideoTypes;
OldCursor : Word;
InsCursor : Word;
OldMode : Word;
constructor Init;
destructor Done;
procedure ToggleMaxLinesMode;
procedure PrintError(Error : String);
procedure PrintMessage(Message : String);
procedure ClearMessage;
procedure PrintHelpLine(CommandString : String);
end;
ScreenArea = object
UpperLeft, LowerRight : ScreenPos;
Attrib : Byte;
constructor Init(InitX1 : ScreenColRange; InitY1 : ScreenRowRange;
InitX2 : ScreenColRange; InitY2 : ScreenRowRange;
InitAttrib : Byte);
procedure Scroll(Dir : Direction; Amt : Word);
procedure Clear;
procedure Erase;
end;
ColorTableType = (ColorMono, ColorBW, ColorColor);
ColorTablePtr = ^ColorTable;
ColorTable = object
TableType : ColorTableType;
BlankColor : Byte;
ValueCellColor : Byte;
TextCellColor : Byte;
FormulaCellColor : Byte;
RepeatCellColor : Byte;
ColColor : Byte;
RowColor : Byte;
InfoColor : Byte;
HighlightColor : Byte;
BlockColor : Byte;
InputColor : Byte;
InputArrowColor : Byte;
ErrorColor : Byte;
CellErrorColor : Byte;
MemoryColor : Byte;
CellDataColor : Byte;
PromptColor : Byte;
FileNameColor : Byte;
ChangedColor : Byte;
TitleColor : Byte;
ContentsColor : Byte;
KeyNameColor : Byte;
KeyDescColor : Byte;
MenuHiColor : Byte;
MenuLoColor : Byte;
MessageColor : Byte;
constructor Init;
procedure FillColorTable;
end;
const
NoCursor = $2000;
var
Colors : ColorTable;
Scr : Screen;
ScreenPtr : ScreenPointer;
procedure MoveToScreen(var Source, Dest; Len : Word);
procedure MoveFromScreen(var Source, Dest; Len : Word);
procedure ClrEOLXY(Col : ScreenColRange; Row : ScreenRowRange;
Color : Byte);
procedure WriteColor(S : String; Color : Byte);
procedure WriteXY(S : String; Col : ScreenColRange; Row : ScreenRowRange;
Color : Byte);
procedure WriteXYClr(S : String; Col : ScreenColRange; Row : ScreenRowRange;
Color : Byte);
procedure SetCursor(NewCursor : Word);
function GetCursor : Word;
implementation
const
TotalColors = 26;
WhiteOnRed = White + (Red shl 4);
WhiteOnBlue = White + (Blue shl 4);
WhiteOnCyan = White + (Cyan shl 4);
BlackOnGray = LightGray shl 4;
WhiteOnGray = White + (LightGray shl 4);
BlinkingLightRed = LightRed + Blink;
BlinkingWhite = White + Blink;
LightCyanOnBlue = LightCyan + (Blue shl 4);
YellowOnBlue = Yellow + (Blue shl 4);
type
ColorArray = array[1..TotalColors] of Byte;
const
ColorColors : ColorArray = (White, LightCyan, White, LightMagenta, White,
WhiteOnRed, WhiteOnRed, WhiteOnCyan,
WhiteOnBlue, WhiteOnCyan, White, LightCyan,
WhiteOnRed, BlinkingLightRed, LightRed,
LightGreen, Yellow, LightCyan, Yellow,
LightMagenta, Yellow, LightCyanOnBlue,
YellowOnBlue, LightCyan, White,
BlinkingLightRed);
BWColors : ColorArray = (White, White, White, White, White, BlackOnGray,
BlackOnGray, WhiteOnGray, WhiteOnGray, BlackOnGray,
White, White, White, BlinkingWhite, White, White,
White, White, White, White, White, BlackOnGray,
White, White, LightGray, BlinkingWhite);
MonoColors : ColorArray = (White, White, White, White, White, BlackOnGray,
BlackOnGray, BlackOnGray, BlackOnGray,
BlackOnGray, White, White, White, BlinkingWhite,
White, White, White, White, White, White, White,
BlackOnGray, White, White, LightGray,
BlinkingWhite);
const
InsCursorSmall = $0007;
InsCursorLarge = $000D;
var
SavedExitProc : Pointer;
procedure ClearScreen(X1, Y1, X2, Y2, Attrib : Word);
{ Clears an area of the screen }
var
Reg : Registers;
begin
if (X1 > X2) or (Y1 > Y2) then { Illegal values }
Exit;
with Reg do
begin
AX := $0600; { Clear screen through the BIOS }
BH := Attrib;
CH := Pred(Y1);
CL := Pred(X1);
DH := Pred(Y2);
DL := Pred(X2);
Intr($10, Reg);
end; { with }
end; { ClearScreen }
{$L TCMVSMEM}
procedure MoveToScreen(var Source, Dest; Len : Word); external;
{ Moves screen memory from normal RAM to screen memory - see TCMVSMEM.ASM
for source }
procedure MoveFromScreen(var Source, Dest; Len : Word); external;
{ Moves screen memory to normal RAM from screen memory - see TCMVSMEM.ASM
for source }
procedure MoveText(OldX1, OldY1, OldX2, OldY2, NewX1, NewY1 : Word);
{ Moves an area of text to a new position on the screen }
var
Counter, Len : Word;
begin
if (OldX2 < OldX1) or (OldY2 < OldY1) then
Exit;
Len := Succ(OldX2 - OldX1) shl 1;
if NewY1 < OldY1 then
begin { Move it row by row, going forwards }
for Counter := 0 to OldY2 - OldY1 do
MoveFromScreen(ScreenPtr^[OldY1 + Counter, OldX1],
ScreenPtr^[NewY1 + Counter, NewX1], Len)
end
else begin { Move it row by row, going backwards }
for Counter := OldY2 - OldY1 downto 0 do
MoveFromScreen(ScreenPtr^[OldY1 + Counter, OldX1],
ScreenPtr^[NewY1 + Counter, NewX1], Len)
end;
end; { MoveText }
procedure ScrollText(Dir : Direction; X1, Y1, X2, Y2, Amt, Attrib : Word);
{ Scrolls the screen by an amount in a direction - it does this by moving
the text to be scrolled and then clearing the area that wasn't scrolled }
begin
case Dir of
Up : begin
MoveText(X1, Y1 + Amt, X2, Y2, X1, Y1);
ClearScreen(X1, Succ(Y2 - Amt), X2, Y2, Attrib);
end;
Down : begin
MoveText(X1, Y1, X2, Y2 - Amt, X1, Succ(Y1));
ClearScreen(X1, Y1, X2, Pred(Y1 + Amt), Attrib);
end;
Left : begin
MoveText(X1 + Amt, Y1, X2, Y2, X1, Y1);
ClearScreen(Succ(X2 - Amt), Y1, X2, Y2, Attrib);
end;
Right : begin
MoveText(X1, Y1, X2 - Amt, Y2, X1 + Amt, Y1);
ClearScreen(X1, Y1, Pred(X1 + Amt), Y2, Attrib);
end;
end; { case }
end; { ScrollText }
function EGAInstalled : Boolean;
{ Tests for the presence of an EGA }
var
Reg : Registers;
begin
Reg.AX := $1200;
Reg.BX := $0010;
Reg.CX := $FFFF;
Intr($10, Reg);
EGAInstalled := Reg.CX <> $FFFF;
end; { EGAInstalled }
function PS2 : Boolean;
{ This function returns True if we are running on a PS/2 type video adapter }
var
Regs : Registers;
begin
Regs.AX := $1A00;
Intr($10, Regs);
PS2 := ((Regs.AL and $FF) = $1A) and
((Regs.BL and $FF) in [$07, $08, $0B, $0C]);
end; { PS2 }
procedure ClrEOLXY(Col : ScreenColRange; Row : ScreenRowRange; Color : Byte);
{ Clears to the end-of-line in a color at a specified position }
begin
GotoXY(Col, Row);
TextAttr := Color;
ClrEOL;
end; { ClrEOLXY }
procedure WriteColor(S : String; Color : Byte);
{ Writes a string in a color }
begin
TextAttr := Color;
Write(S);
end; { WriteColor }
procedure WriteXY(S : String; Col : ScreenColRange; Row : ScreenRowRange;
Color : Byte);
{ Writes a string in a color at a specified position }
begin
GotoXY(Col, Row);
WriteColor(S, Color);
end; { WriteXY }
procedure WriteXYClr(S : String; Col : ScreenColRange; Row : ScreenRowRange;
Color : Byte);
{ Clears to the end-of-line in a color at a specified position and then
writes a string }
begin
ClrEOLXY(Col, Row, Color);
Write(S);
end; { WriteXYClr }
procedure SetCursor(NewCursor : Word);
{ Sets the value of the scan lines of the cursor }
var
Reg : Registers;
begin
with Reg do
begin
AH := 1;
BH := 0;
CX := NewCursor;
Intr($10, Reg);
end; { with }
end; { SetCursor }
function GetCursor : Word;
{ Returns the value of the scan lines of the cursor }
var
Reg : Registers;
begin
with Reg do
begin
AH := 3;
BH := 0;
Intr($10, Reg);
GetCursor := CX;
end; { Reg }
end; { GetCursor }
constructor Screen.Init;
{ Finds what type of video adapter is being run on, and initializes various
variables based on this information }
var
Reg : Registers;
begin
OldMode := LastMode;
Reg.AH := $0F;
Intr($10, Reg); { Check for the current video mode }
if Reg.AL <> 7 then
begin
if EGAInstalled then
begin
if PS2 then
VideoType := VGA
else
VideoType := EGA;
end
else begin
if PS2 then
VideoType := MCGA
else
VideoType := CGA;
end;
ScreenPtr := Ptr($B800, 0);
if Reg.AL < 2 then
CurrCols := 40
else
CurrCols := 80;
end
else begin
VideoType := MDA;
ScreenPtr := Ptr($B000, 0);
CurrCols := 80;
end;
CurrRows := Succ(Hi(WindMax));
OldCursor := GetCursor;
if (CurrRows = MinScreenRows) and (VideoType <> CGA) then
InsCursor := InsCursorLarge
else
InsCursor := InsCursorSmall;
end; { Screen.Init }
destructor Screen.Done;
{ Restores the screen mode and cursor that existed at the start of the
program }
begin
TextMode(OldMode);
SetCursor(OldCursor);
ExitProc := SavedExitProc;
end; { Screen.Done }
procedure Screen.ToggleMaxLinesMode;
{ Toggles the display in and out of 43/50-line mode }
begin
if CurrRows = MinScreenRows then
begin
TextMode(Lo(LastMode) + Font8x8);
InsCursor := InsCursorSmall;
end
else begin
TextMode(Lo(LastMode));
InsCursor := InsCursorLarge;
end;
CurrRows := Succ(Hi(WindMax));
end; { Screen.ToggleMaxLinesMode }
procedure Screen.PrintError(Error : String);
{ Prints an error message at the bottom of the screen }
var
Ch : Word;
Buffer : ScreenRow;
begin
MoveFromScreen(ScreenPtr^[CurrRows, 1], Buffer,
SizeOf(ScreenChar) * CurrCols); { Save bottom line }
WriteXYClr(CenterStr(Error + '. ' + ESCPress, Pred(CurrCols)), 1, CurrRows,
Colors.ErrorColor);
Beep;
repeat
Ch := GetKey;
until Ch = ESC;
MoveToScreen(Buffer, ScreenPtr^[CurrRows, 1], { Restore bottom line }
SizeOf(ScreenChar) * CurrCols);
end; { Screen.PrintError }
procedure Screen.PrintMessage(Message : String);
{ Prints a message }
begin
WriteXYClr(Message + '...', 1, Pred(CurrRows), Colors.MessageColor);
end; { Screen.PrintMessage }
procedure Screen.ClearMessage;
{ Clears the last printed message }
begin
ClrEOLXY(1, Pred(CurrRows), Colors.MessageColor);
end; { Screen.ClearMessage }
procedure Screen.PrintHelpLine(CommandString : String);
{ Prints a help line at the bottom of the screen. The command string is
made up of a series of keys and descriptions separated by backslashes.
Example: 'F1\Help\F2\Save\F3\Load\Alt-X\Exit'}
var
P : Integer;
S : String[ScreenCols];
begin
CommandString := CommandString + '\';
ClrEOLXY(1, CurrRows, Colors.KeyDescColor);
while CommandString <> '' do
begin
Write(' ');
P := Pos('\', CommandString);
WriteColor(Copy(CommandString, 1, Pred(P)), Colors.KeyNameColor);
Delete(CommandString, 1, P);
P := Pos('\', CommandString);
if CommandString[1] = '\' then
S := '-'
else
S := '-' + Copy(CommandString, 1, Pred(P));
WriteColor(S, Colors.KeyDescColor);
Delete(CommandString, 1, P);
end;
end; { Screen.PrintHelpLine }
constructor ScreenArea.Init(InitX1 : ScreenColRange; InitY1 : ScreenRowRange;
InitX2 : ScreenColRange; InitY2 : ScreenRowRange;
InitAttrib : Byte);
{ Sets up a screen area }
begin
UpperLeft.Col := InitX1;
UpperLeft.Row := InitY1;
LowerRight.Col := InitX2;
LowerRight.Row := InitY2;
Attrib := InitAttrib;
end; { ScreenArea.Init }
procedure ScreenArea.Scroll(Dir : Direction; Amt : Word);
{ Scrolls a screen area an certain amount in a direction }
begin
ScrollText(Dir, UpperLeft.Col, UpperLeft.Row, LowerRight.Col,
LowerRight.Row, Amt, Attrib);
end; { ScreenArea.Scroll }
procedure ScreenArea.Clear;
{ Clears a screen area }
begin
ClearScreen(UpperLeft.Col, UpperLeft.Row, LowerRight.Col, LowerRight.Row,
Attrib);
end; { ScreenArea.Clear }
procedure ScreenArea.Erase;
{ Erases a screen area by writing over it in black }
begin
ClearScreen(UpperLeft.Col, UpperLeft.Row, LowerRight.Col, LowerRight.Row,
Black);
end; { ScreenArea.Erase }
constructor ColorTable.Init;
{ Initializes the color table by finding the video mode that is being used }
begin
case Lo(LastMode) of
BW40, BW80 : TableType := ColorBW;
CO40, CO80 : TableType := ColorColor;
Mono : TableType := ColorMono;
end; { case }
FillColorTable;
end; { ColorTable.Init }
procedure ColorTable.FillColorTable;
{ Moves the correct built-in color table to the program's color table }
var
P : Pointer;
begin
case TableType of
ColorColor : P := @ColorColors;
ColorBW : P := @BWColors;
ColorMono : P := @MonoColors;
end; { case }
Move(P^, BlankColor, TotalColors);
end; { ColorTable.FillColorTable }
{$F+}
procedure ScreenExit;
{ Clears the screen at exit }
begin
Scr.Done;
end; { ScreenExit }
{$F-}
begin
SavedExitProc := ExitProc;
ExitProc := @ScreenExit;
TextMode(LastMode);
Scr.Init;
Colors.Init;
end.