home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-387-Vol-3of3.iso
/
h
/
htmix20.zip
/
UNITS.ZIP
/
SCREEN.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-07-11
|
23KB
|
731 lines
unit Screen;
{┌──────────────────────────────────────────────────────────────────────────┐}
{│ │}
{│ File : SCREEN.PAS │}
{│ Author : Harald Thunem │}
{│ Purpose : Screen routines │}
{│ Updated : February 16 1992 │}
{│ │}
{└──────────────────────────────────────────────────────────────────────────┘}
{────────────────────────────────────────────────────────────────────────────}
interface
{────────────────────────────────────────────────────────────────────────────}
uses Dos;
const
{ Common foreground attributes }
Black = $00; DarkGray = $08;
Blue = $01; LightBlue = $09;
Green = $02; LightGreen = $0A;
Cyan = $03; LightCyan = $0B;
Red = $04; LightRed = $0C;
Magenta = $05; LightMagenta = $0D;
Brown = $06; Yellow = $0E;
LightGray = $07; White = $0F;
{ Common background attributes }
BlackBG = $00;
BlueBG = $10;
GreenBG = $20;
CyanBG = $30;
RedBG = $40;
MagentaBG = $50;
BrownBG = $60;
LightGrayBG = $70;
{ New background attributes, for use with high intensity attributes }
LightBlackBG = $80;
LightBlueBG = $90;
LightGreenBG = $A0;
LightCyanBG = $B0;
LightRedBG = $C0;
LightMagentaBG = $D0;
LightBrownBG = $E0;
LightWhiteBG = $F0;
{ Other attributes }
Blink = $80; SameAttr = -1;
{ Different border types }
NoBorder = 0; EmptyBorder = ' ';
SingleBorder = 1; SBorder = '┌─┐│┘└';
DoubleBorder = 2; DBorder = '╔═╗║╝╚';
DTopSSide = 3; DSBorder = '╒═╕│╛╘';
STopDSide = 4; SDBorder = '╓─╖║╜╙';
{ Text fonts, 25, 28 or 43/50 rows }
Font25 = 1;
Font28 = 2;
Font50 = 3;
MaxLines = 25;
type
ScrType = array[1..MaxLines*80] of word; { Array large enough to store }
PScrType = ^ScrType; { a 25 line screen image }
var
CRTRows, { Number of rows }
CRTCols, { Number of columns }
VideoMode : byte; { Video-mode }
ScrVar : PScrType; { Screen type pointer variable }
ScrFile : file of ScrType; { File in which to save screen }
{ Cursor sizes, initialized by ScrInit }
CursorInitial,
CursorOff,
CursorUnderline,
CursorHalfBlock,
CursorBlock : word;
procedure Delay(ms: word);
procedure CursorPos(var Row,Col : byte);
procedure GoToRC(Row,Col : byte);
function EosCol : byte;
function EosRow : byte;
procedure EosToRC(Row,Col : byte);
procedure GoToEos;
procedure GetCursor(var Cursor : word);
procedure SetCursor(Cursor : word);
function ReadAttr(Row,Col : byte) : byte;
function ReadChar(Row,Col : byte) : char;
procedure WriteStr(Row,Col:byte; Attr:integer; S : string);
procedure WriteEos(Attr : integer; S : string);
procedure WriteC(Row,Col:byte; Attr:integer; S : string);
procedure Attr(Row,Col,Rows,Cols,Attr : integer);
procedure FillCh(Row,Col,Rows,Cols : integer; C : char);
procedure Fill(Row,Col,Rows,Cols,Attr : integer; C : char);
procedure ScrollUp(Row,Col,Rows,Cols,BlankAttr:byte);
procedure ScrollDown(Row,Col,Rows,Cols,BlankAttr:byte);
procedure StoreToMem(Row,Col,Rows,Cols : byte; var Dest );
procedure StoreToScr(Row,Col,Rows,Cols : byte; var Source );
procedure ClrScr;
function ShadowAttr(Attr : byte) : byte;
procedure AddShadow(Row,Col,Rows,Cols : byte);
procedure Box(Row,Col,Rows,Cols,Attr,Border:byte; FillCh:char);
procedure Explode(Row,Col,Rows,Cols,Attr,Border:byte);
procedure GetFont(var CRTRows : byte);
procedure SetFont(Font : byte);
function GetVideoMode : byte;
procedure SetVideoMode(Mode : byte);
procedure SetIntens;
procedure SetBlink;
procedure SaveScreenToFile(ScrFilename: string);
function LoadScreenFromFile(ScrFilename: string): boolean;
procedure ScrInit;
{────────────────────────────────────────────────────────────────────────────}
implementation
{────────────────────────────────────────────────────────────────────────────}
var EosOfs : word; { Offset of EndOfString marker }
Regs : registers; { Register variable }
VideoSeg : word; { Video segment address }
procedure Delay(ms: word);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Same as CRT.Delay │}
{└─────────────────────────────────────────────────────────────────┘}
var cx,dx: word;
begin
cx := Trunc(ms/65.536);
dx := Trunc(65536*(ms/65.536-cx));
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $86;
Regs.CX := cx;
Regs.DX := dx;
Intr($15,Regs);
end;
procedure CursorPos(var Row,Col : byte);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Returns the cursor position in Row and Col │}
{└─────────────────────────────────────────────────────────────────┘}
begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $03;
Regs.BH := $00; { Page 0 }
Intr($10,Regs);
Row := Regs.DH;
Col := Regs.DL;
end;
procedure GoToRC(Row,Col : byte);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Moves the cursor to Row and Col │}
{│ Does not update the End-Of-String marker. Use EosToRC (below) │}
{└─────────────────────────────────────────────────────────────────┘}
begin
if Row>CRTRows then Exit;
if Col>CRTCols then Exit;
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $02;
Regs.DH := Row-1;
Regs.DL := Col-1;
Intr($10,Regs);
end;
function EosCol : byte;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Returns the column number for the End-Of-String marker │}
{└─────────────────────────────────────────────────────────────────┘}
begin
EosCol := (EosOfs mod 80);
end;
function EosRow : byte;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Returns the row number for the End-Of-String marker │}
{└─────────────────────────────────────────────────────────────────┘}
begin
EosRow := (EosOfs div 80);
end;
procedure EosToRC(Row,Col : byte);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Moves the End-Of-String marker to the current cursor position │}
{└─────────────────────────────────────────────────────────────────┘}
begin
if Row>CRTRows then Exit;
if Col>CRTCols then Exit;
EosOfs := (Row-1)*80 + (Col-1);
end;
procedure GoToEos;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Moves the cursor to the position of the End-Of-String marker │}
{└─────────────────────────────────────────────────────────────────┘}
begin
GoToRC(EosRow+1,EosCol+1);
end;
procedure GetCursor(var Cursor : word);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Returns the cursor size │}
{└─────────────────────────────────────────────────────────────────┘}
var S,E: byte;
begin
E := Mem[$0040:$0060];
S := Mem[$0040:$0061];
Cursor := (E shl 4) + S;
end;
procedure SetCursor(Cursor : word);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Sets the cursor size │}
{└─────────────────────────────────────────────────────────────────┘}
begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $01;
Regs.CH := Cursor mod 16; { Start }
Regs.CL := Cursor div 16; { End }
Intr($10,Regs);
if (Cursor = CursorOff) and (VideoMode=$07) then GoToRC(1,81);
end;
function ReadAttr(Row,Col : byte) : byte;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Returns the attribute at position Row,Col │}
{└─────────────────────────────────────────────────────────────────┘}
var Offset: word;
begin
ReadAttr := $00;
if Row>CRTRows then Exit;
if Col>CRTCols then Exit;
Offset := ((Row-1)*80 + (Col-1))*2;
ReadAttr := Mem[VideoSeg:Offset+1];
end;
function ReadChar(Row,Col : byte) : char;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Returns the character at position Row,Col │}
{└─────────────────────────────────────────────────────────────────┘}
var Offset: word;
begin
ReadChar := ' ';
if Row>CRTRows then Exit;
if Col>CRTCols then Exit;
Offset := ((Row-1)*80 + (Col-1))*2;
ReadChar := Chr(Mem[VideoSeg:Offset]);
end;
procedure WriteStr(Row,Col:byte; Attr:integer; S : string);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Writes the string S at Row,Col using attributes Attr │}
{└─────────────────────────────────────────────────────────────────┘}
var i : byte;
Offset: word;
begin
if Row>CRTRows then Exit;
if Col>CRTCols then Exit;
Offset := ((Row-1)*80 + (Col-1))*2;
if Attr = SameAttr then
for i := 1 to Length(S) do
begin
Mem[VideoSeg:Offset] := Byte(Ord(S[i]));
Inc(Offset,2);
end
else for i := 1 to Length(S) do
begin
MemW[VideoSeg:Offset] := Word((Attr shl 8) + Ord(S[i]));
Inc(Offset,2);
end;
EosOfs := Offset div 2;
end;
procedure WriteEos(Attr : integer; S : string);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Writes the string S at the End-Of-String marker using │}
{│ attributes Attr │}
{└─────────────────────────────────────────────────────────────────┘}
var i : byte;
Offset: word;
begin
Offset := EosOfs * 2;
if Attr = SameAttr then
for i := 1 to Length(S) do
begin
Mem[VideoSeg:Offset] := Byte(Ord(S[i]));
Inc(Offset,2);
end
else for i := 1 to Length(S) do
begin
MemW[VideoSeg:Offset] := Word(Attr shl 8 + Ord(S[i]));
Inc(Offset,2);
end;
EosOfs := Offset div 2;
end;
procedure WriteC(Row,Col:byte; Attr:integer; S : string);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Writes the string S centered about Col at Row │}
{└─────────────────────────────────────────────────────────────────┘}
var L: byte;
begin
L := Length(S) div 2;
WriteStr(Row,Col-L,Attr,S);
end;
procedure Attr(Row,Col,Rows,Cols,Attr : integer);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Changes the attributes in Row,Col,Rows,Cols to Attr │}
{└─────────────────────────────────────────────────────────────────┘}
var i,j : byte;
Offset: word;
begin
if Rows=0 then Exit;
if Cols=0 then Exit;
if Rows<0 then begin Row:=Row+Rows; Rows:=-Rows; end;
if Cols<0 then begin Col:=Col+Cols; Cols:=-Cols; end;
for j := Row to Row+Rows-1 do
for i := Col to Col+Cols-1 do
begin
Offset := ((j-1)*80 + (i-1))*2;
Mem[VideoSeg:Offset+1] := Attr;
end;
end;
procedure FillCh(Row,Col,Rows,Cols : integer; C : char);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Changes the characters in Row,Col,Rows,Cols to C, but leaves │}
{│ the attribute unchanged. │}
{└─────────────────────────────────────────────────────────────────┘}
var i,j : byte;
Offset: word;
begin
if Rows=0 then Exit;
if Cols=0 then Exit;
if Rows<0 then begin Row:=Row+Rows; Rows:=-Rows; end;
if Cols<0 then begin Col:=Col+Cols; Cols:=-Cols; end;
for j := Row to Row+Rows-1 do
for i := Col to Col+Cols-1 do
begin
Offset := ((j-1)*80 + (i-1))*2;
Mem[VideoSeg:Offset] := Ord(C);
end;
end;
procedure Fill(Row,Col,Rows,Cols,Attr : integer; C : char);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Fills a window with Attr and C │}
{└─────────────────────────────────────────────────────────────────┘}
var i,j : byte;
Offset: word;
begin
if Rows=0 then Exit;
if Cols=0 then Exit;
if Rows<0 then begin Row:=Row+Rows; Rows:=-Rows; end;
if Cols<0 then begin Col:=Col+Cols; Cols:=-Cols; end;
for j := Row to Row+Rows-1 do
for i := Col to Col+Cols-1 do
begin
Offset := ((j-1)*80 + (i-1))*2;
MemW[VideoSeg:Offset] := Word(Attr shl 8 + Ord(C));
end;
end;
procedure ScrollUp(Row,Col,Rows,Cols,BlankAttr:byte);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Scrolls a window up │}
{└─────────────────────────────────────────────────────────────────┘}
begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $06;
Regs.AL := $01;
Regs.BH := BlankAttr;
Regs.CH := Row-1;
Regs.CL := Col-1;
Regs.DH := Row+Rows-2;
Regs.DL := Col+Cols-2;
Intr($10,Regs);
end;
procedure ScrollDown(Row,Col,Rows,Cols,BlankAttr:byte);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Scrolls a window down │}
{└─────────────────────────────────────────────────────────────────┘}
begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $07;
Regs.AL := $01;
Regs.BH := BlankAttr;
Regs.CH := Row-1;
Regs.CL := Col-1;
Regs.DH := Row+Rows-2;
Regs.DL := Col+Cols-2;
Intr($10,Regs);
end;
procedure StoreToMem(Row,Col,Rows,Cols : byte; var Dest );
{┌─────────────────────────────────────────────────────────────────┐}
{│ Stores the background to variable Dest │}
{└─────────────────────────────────────────────────────────────────┘}
var i,j : byte;
Offs,Value,Segment,Offset: word;
begin
Segment := Seg(Dest);
Offset := Ofs(Dest);
for j := Row to Row+Rows-1 do
for i := Col to Col+Cols-1 do
begin
Offs := ((j-1)*80 + (i-1))*2;
MemW[Segment:Offset] := MemW[VideoSeg:Offs];
Inc(Offset,2);
end;
end;
procedure StoreToScr(Row,Col,Rows,Cols : byte; var Source );
{┌─────────────────────────────────────────────────────────────────┐}
{│ Draws the stored values in Source to screen │}
{└─────────────────────────────────────────────────────────────────┘}
var i,j : byte;
Offs,Value,Segment,Offset: word;
begin
Segment := Seg(Source);
Offset := Ofs(Source);
for j := Row to Row+Rows-1 do
for i := Col to Col+Cols-1 do
begin
Offs := ((j-1)*80 + (i-1))*2;
MemW[VideoSeg:Offs] := MemW[Segment:Offset];
Inc(Offset,2);
end;
end;
procedure ClrScr;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Similar to CRT.ClrScr │}
{└─────────────────────────────────────────────────────────────────┘}
begin
Fill(1,1,CRTRows,CRTCols,LightGray+BlackBG,' ');
GoToRC(1,1);
end;
function ShadowAttr(Attr : byte) : byte;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Returns the appropriate attribute for a shadow │}
{└─────────────────────────────────────────────────────────────────┘}
var Tmp: byte;
begin
Tmp := Attr AND $0F;
if Tmp > 8 then
Tmp := Tmp - 8;
ShadowAttr := Tmp;
end;
procedure AddShadow(Row,Col,Rows,Cols : byte);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Adds a shadow to a box │}
{└─────────────────────────────────────────────────────────────────┘}
var i : byte;
Tmp: byte;
begin
for i := Row+1 to Row+Rows do
begin
Tmp := ReadAttr(i,Col+Cols);
Attr(i,Col+Cols,1,1,ShadowAttr(Tmp));
Tmp := ReadAttr(i,Col+Cols+1);
Attr(i,Col+Cols+1,1,1,ShadowAttr(Tmp));
end;
for i := Col+2 to Col+Cols+1 do
begin
Tmp := ReadAttr(Row+Rows,I);
Attr(Row+Rows,i,1,1,ShadowAttr(Tmp));
end;
end;
procedure Box(Row,Col,Rows,Cols,Attr,Border:byte; FillCh:char);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Draws a box │}
{└─────────────────────────────────────────────────────────────────┘}
var i: byte;
B: string[6];
begin
if Rows=0 then Exit;
if Cols=0 then Exit;
if Rows<0 then begin Row:=Row+Rows; Rows:=-Rows; end;
if Cols<0 then begin Col:=Col+Cols; Cols:=-Cols; end;
if FillCh <> #0 then
Fill(Row,Col,Rows,Cols,Attr,FillCh);
case Border of
NoBorder : B := EmptyBorder;
SingleBorder : B := SBorder;
DoubleBorder : B := DBorder;
DTopSSide : B := DSBorder;
STopDSide : B := SDBorder;
end;
for I := 0 to Rows-1 do
begin
WriteStr(Row+I,Col,Attr,B[4]);
WriteStr(Row+I,Col+Cols-1,Attr,B[4]);
end;
for I := 0 to Cols-1 do
begin
WriteStr(Row,Col+I,Attr,B[2]);
WriteStr(Row+Rows-1,Col+I,Attr,B[2]);
end;
WriteStr(Row,Col,Attr,B[1]);
WriteStr(Row,Col+Cols-1,Attr,B[3]);
WriteStr(Row+Rows-1,Col,Attr,B[6]);
WriteStr(Row+Rows-1,Col+Cols-1,Attr,B[5]);
end;
procedure Explode(Row,Col,Rows,Cols,Attr,Border:byte);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Explodes a box │}
{└─────────────────────────────────────────────────────────────────┘}
var I,R1,R2,C1,C2 : byte;
MR,MC,DR,DC : single;
begin
DR := Rows/11;
DC := Cols/11;
MR := Row+Rows/2;
MC := Col+Cols/2;
for I := 1 to 5 do
begin
R1 := Trunc(MR-I*DR); R2 := Trunc(2*I*DR);
C1 := Trunc(MC-I*DC); C2 := Trunc(2*I*DC);
Box(R1,C1,R2,C2,Attr,Border,' ');
Delay(10);
end;
Box(Row,Col,Rows,Cols,Attr,Border,' ');
end;
procedure GetFont(var CRTRows : byte);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Gets the number of rows on the screen │}
{└─────────────────────────────────────────────────────────────────┘}
begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $11;
Regs.AL := $30;
Regs.BH := $02;
Intr($10,Regs);
CRTRows := Regs.DL+1;
end;
procedure SetFont(Font : byte);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Sets the number of rows on the screen : 25, 28 or 43/50 │}
{└─────────────────────────────────────────────────────────────────┘}
begin
case Font of
Font25: begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $00;
Regs.AL := VideoMode;
Intr($10,Regs);
CRTRows := 25;
end;
Font28: begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $11;
Regs.AL := $11;
Intr($10,Regs);
GetFont(CRTRows);
end;
Font50: begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $11;
Regs.AL := $12;
Intr($10,Regs);
GetFont(CRTRows);
end;
end;
end;
function GetVideoMode : byte;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Returns the Video Mode │}
{└─────────────────────────────────────────────────────────────────┘}
begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $0F;
Intr($10,Regs);
GetVideoMode := Regs.AL;
end;
procedure SetVideoMode(Mode : byte);
{┌─────────────────────────────────────────────────────────────────┐}
{│ Sets the Video Mode │}
{└─────────────────────────────────────────────────────────────────┘}
begin
if not Mode in [$02,$03,$07] then Exit;
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $00;
Regs.AL := Mode;
Intr($10,Regs);
end;
procedure SetIntens;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Sets mode for 16 foreground and 16 background colors │}
{└─────────────────────────────────────────────────────────────────┘}
begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $10;
Regs.AL := $03;
Regs.BL := $00;
Intr($10,Regs);
end;
procedure SetBlink;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Sets mode for 16 foreground and 8 background colors and blink │}
{└─────────────────────────────────────────────────────────────────┘}
begin
FillChar(Regs,SizeOf(Regs),0);
Regs.AH := $10;
Regs.AL := $03;
Regs.BL := $01;
Intr($10,Regs);
end;
procedure SaveScreenToFile(ScrFilename: string);
begin
GetMem(ScrVar,160*MaxLines);
StoreToMem(1,1,25,80,ScrVar^);
Assign(ScrFile,ScrFilename);
ReWrite(ScrFile);
Write(ScrFile,ScrVar^);
Close(ScrFile);
FreeMem(ScrVar,160*MaxLines);
end;
function LoadScreenFromFile(ScrFilename: string): boolean;
begin
GetMem(ScrVar,160*MaxLines);
{$I-}
Assign(ScrFile,ScrFilename);
Reset(ScrFile);
{$I+}
if IOResult=0 then
begin
Read(ScrFile,ScrVar^);
Close(ScrFile);
LoadScreenFromFile := true;
StoreToScr(1,1,25,80,ScrVar^);
end
else LoadScreenFromFile := false;
FreeMem(ScrVar,160*MaxLines);
end;
procedure ScrInit;
{┌─────────────────────────────────────────────────────────────────┐}
{│ Initializes some variables │}
{└─────────────────────────────────────────────────────────────────┘}
begin
VideoMode := GetVideoMode;
if not VideoMode in [$02,$03,$07] then
begin
WriteLn('Wrong video mode ! Halting...');
Halt(1);
end;
GetCursor(CursorInitial);
CRTCols := 80;
case VideoMode of
$02,$03 : begin
CursorUnderline := 118; { 6-7 }
CursorHalfBlock := 116; { 4-7 }
CursorBlock := 113; { 1-7 }
CursorOff := 1; { 0-1 }
VideoSeg := $B800;
end;
$07 : begin
CursorUnderline := 203; { 11-12 }
CursorHalfBlock := 198; { 6-12 }
CursorBlock := 193; { 1-12 }
CursorOff := 1; { 0- 1 }
VideoSeg := $B000;
end;
end;
GetFont(CRTRows);
end;
begin
ScrInit;
end.