home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
PASCAL
/
MOUSE.ZIP
/
VIDEO.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1991-07-12
|
6KB
|
350 lines
Unit VIDEO;
Interface
Uses Dos,Crt;
Type
ScreenChars = Record
ch : Char;
at : Byte;
End;
screens = Record
Position : Array[1..25, 1..80] of ScreenChars;
x,y :Byte;
end;
Screentype = (Mono, Color);
var
Stype : Screentype;
VidSeg : Word;
xx : Integer;
Procedure ShowScreen (Var Source, Video; Length: Word);
Procedure Getscreen (Var Video, Source; Length: Word);
Procedure XYstring(x, y: Byte;
s: String;
fg,
bg: Byte);
Procedure ReadScr(Var S);
Procedure WriteScr(Var S);
Procedure HorStr(X, Y, Len : Byte;
fg, bg: Byte;
Ch : Char);
Procedure VerStr(X, Y, Len : Byte;
fg, bg: Byte;
Ch : Char);
Procedure Box(x1, y1, x2, y2 : Byte;
fg, bg : Byte);
Procedure Center(y : Byte;
st : String;
fg,
bg : Byte);
Procedure BoxString(y : Byte;
st : String;
fg,
bg : Byte);
Procedure FillScreen(Var sc : Screens;
s : String;
x, y : Byte;
fg, bg : Byte);
Procedure CursorOff;
Procedure CursorSmall;
Procedure CursorBig;
Implementation
Var
Regs : Registers;
Vid : Pointer;
Procedure ShowScreen(Var Source, Video;
Length: Word);
Begin
If Stype = Color Then
Inline($90/$90/$90/
$1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Video /
$8B/$8E/ Length /$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/
$72/$FB/$FA/$EC/$20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/
$EA/$5D/$1F)
Else
Begin
Length := Length * 2;
Move(Source, Video, Length);
end;
End;
Procedure GetScreen(Var Video , Source;
Length: Word);
Begin
If Stype = Color Then
Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Video /$C4/$BE/ Source /
$8B/$8E/Length /$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/
$D8/$73/$FB/$AD/$FB/$AB/$E2/$F0/$5D/$1F)
Else
begin
length := length * 2;
Move(Video, Source, Length);
end;
End;
Procedure XYstring(x, y: Byte;
s: String;
fg, bg: Byte);
Var
SA : Array[1..255] of Record
ch : Char;
at : byte;
End;
b, i : Byte;
offset : Word;
Begin
If (Length(s) = 0) Or
(x > 80) Or
(x < 1) Or
(y > 25) Or
(y < 1) Then Exit;
b := (Ord(bg) Shl 4) Or Ord(fg);
FillChar(SA, SizeOf(SA), b);
For i := 1 to Length(s) Do
Sa[i].ch := s[i];
offset := (((y-1) *80) + (x-1))*2;
Vid := Ptr (Vidseg,offset);
Showscreen(SA, Vid^, Length(s));
End;
Procedure ReadScr(Var S);
Begin
Vid := Ptr(Vidseg, 0);
Showscreen(S, Vid^, 2000);
End;
Procedure WriteScr(Var S);
Begin
Vid := Ptr(Vidseg,0);
Showscreen(S, Vid^, 2000);
End;
Procedure HorStr(x, y, Len : Byte;
fg, bg: Byte;
ch : Char);
Var
i : Byte;
Begin
For i := 1 To Len Do
Begin
XYString(x,y,ch,fg,bg);
x := x + 1;
End;
End;
Procedure VerStr(x, y, Len : Byte;
fg,bg: Byte;
ch : Char);
Var
i : Byte;
Begin
For i := 1 To Len Do
Begin
XYString(x,y,ch,fg,bg);
y := y + 1;
End;
End;
Procedure Box(x1, y1, x2, y2 : Byte;
fg, bg : Byte);
Begin
If (x1 < 1) Or
(x2 > 80) Or
(y1 < 1) Or
(y2 > 25) Or
((x2-x1) < 2) Or
((y2-y1) < 2) Then Exit;
HorStr(x1, y1, 1, fg, bg, #201);
HorStr(x2, y1, 1, fg, bg, #187);
HorStr(x1, y2, 1, fg, bg, #200);
HorStr(x2, y2, 1, fg, bg, #188);
VerStr(x1, y1+1, y2-y1-1, fg, bg, #186);
For xx:=x1+1 to x2-1 do
Begin
VerStr(xx, y1+1, y2-y1-1, fg, bg, ' ');
End;
VerStr(x2, y1+1, y2-y1-1, fg, bg, #186);
HorStr(x1+1, y1, x2-x1-1, fg, bg, #205);
HorStr(x1+1, y2, x2-x1-1, fg, bg, #205);
End;
Procedure Center(y : Byte;
st : String;
fg,
bg : Byte);
Var
x : Byte;
Begin
x := (40-(Length(st) Div 2));
XYString(x, y, st, fg, bg);
End;
Procedure BoxString(y : Byte;
st : String;
fg, bg : Byte);
Var
x1, y1, x2, y2 : Byte;
Begin
Center(y, st, fg, bg);
x1 := 40-(Length(st) Div 2) -2;
x2 := x1+Length(st)+3;
y1 := y-1;
y2 := y+1;
Box(x1, y1, x2, y2, fg, bg);
End;
Procedure FillScreen(Var sc : screens;
s : String;
x, y : Byte;
fg,bg : Byte);
Var
i, atx : Byte;
Begin
atx := fg Or (bg Shl 4);
For i := 1 To Length(s) Do
Begin
sc.position[y,x].ch := s[i];
sc.position[y,x].at := atx;
x := x+1;
If x > 80 Then
Begin
x := 1;
y := y+1;
If y>25 Then
Exit;
End;
End;
End;
Procedure CursorOff;
Begin
FillChar(Regs, sizeof(Regs),0);
With Regs Do
Begin
AH := $01;
CH := $20;
CL := $20;
End;
Intr($10, Regs);
End;
Procedure CursorSmall;
Begin
FillChar(Regs,sizeof(Regs),0);
regs. AH := $01;
Case stype of
Mono :
Begin
With Regs Do
begin
CH := 12;
CL := 13;
End;
End;
End;
Intr($10, Regs);
End;
Procedure CursorBig;
Begin
FillChar(Regs, sizeof(Regs),0);
regs.AH := 1;
regs.CH := 0;
Case stype of
Mono : regs.CL :=13;
Color : regs.CL :=7;
End;
Intr($10, Regs);
End;
Begin
FillChar(regs,sizeof(regs),0);
Regs.AH := $0F;
Intr($10,Regs);
If Regs.AL = 7 Then
Begin
Stype := Mono;
Vidseg := $b000;
End
Else
Begin
Stype := Color;
Vidseg := $B800;
End;
End.