{$G+,D-,E-,N+}
Unit ProgFace;
INTERFACE
const
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta= 13;
Yellow = 14;
White = 15;
Blink = 128;
type
TWindow = record
X0, Y0, Xr, Yr : Byte;
end;
var
WinAttr, WBorderAttr, WinHAttr, MnAttrK, MnAttrM,
ButtAttr, ButtLight, ButtShadow : Byte;
xt, yt : Byte;
NSav : Word;
Window : TWindow;
Function KeyPressed : Boolean;
Procedure Delay(V, W : Word);
Procedure ClrScr;
Procedure SetBorderChar(C : Char);
Function ReadKey : Char;
Procedure PutChr(C:Char; Col : Byte);
Procedure PutCursor(xx, yy : Byte);
Procedure SetButton(x, y, NLight : Byte; Text : String);
Procedure CursorOff;
Procedure CursorOn;
Procedure SetDelay(Max, Min : Word);
Procedure WriteLine(S : String; Attr : Byte);
Procedure SetAttr(Tx, BkTx : Byte; var Attr : Byte);
Procedure SaveTexBar(x1, y1, x2, y2 : Byte; P : Pointer);
Procedure RestoreTexBar(x1, y1, x2, y2 : Byte; P : Pointer);
Procedure SaveBar(xx1, yy1, xx2, yy2 : Byte);
Procedure SetWindow (X1,Y1,X2,Y2,Bord: Byte;
Header: String; Build: Boolean);
Procedure SetButtSize(l, z : Byte);
Procedure SetWindChar(Ch : Char);
Procedure ZZCursor;
Procedure NewLine;
Procedure DoMenuLine(x, y : Byte; KeyS, MenuS : String);
Procedure WriteCharXY(x, y, Attr : Byte; c : Char);
Procedure Border (X1,Y1,X2,Y2,Bord: Byte);
Procedure PutWindow(X1,Y1,X2,Y2,Bord: Byte;Header: String);
{Procedure WriteLn(S : String; z : Word);}
Procedure UndoMenu;
Procedure WindowSize(X1, Y1, X2, Y2 : Byte);
Procedure UnPackAttribute(Attr: Byte; var Text, Back: Byte);
Procedure ResetTimer;
Procedure RestoreScreen;
IMPLEMENTATION
type
MenuSave = record
x1, y1, x2, y2, Attrib: Byte;
PMS : Pointer;
end;
PTar = ^Tar;
Tar = array[1..2400] of Word;
var
i : Word;
TextSize : array[1..500] of MenuSave;
const
BorderChar : Array [0..2, 1..6] of Char =
((#32,#32,#32,#32,#32,#32),
(#218,#196,#191,#179,#192,#217),
(#201,#205,#187,#186,#200,#188));
ButtLen : Byte = 10;
ButtW : Byte = 2;
WindChar : Char = #32;
const
PMin : Word = 30000;
PMax : Word = 0;
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
Procedure SetDelay(Max, Min : Word);
begin
PMin := Min;
PMax := Max;
end;
{-=-=-=-=-=-=-=-=-=-=-=-=-=}
Procedure Delay(V, W : Word); Assembler;
asm
@1:
mov cx, Word Ptr V
mov dx, Word Ptr W
mov ah, $86
int $15
jc @1
end;
{----------------}
Procedure ResetTimer;Assembler;
asm
mov cx, 0
mov dx, 1
mov ah, $86
int $15
jnc @1
mov ah, 83h
mov al, 1
int 15h
@1:
end;
{------------------------}
Function KeyPressed : Boolean;Assembler;
asm
mov ah, $0B
int $21
end;
{------------------------}
Procedure SetBorderChar(C : Char);
var
i : Integer;
begin
for i := 1 to 6 do
BorderChar[0, i] := C;
end;
{------------------}
Procedure SetButton(x, y, NLight : Byte; Text : String);
var
i, j : Byte;
begin
if Length(Text) >= ButtLen then Text[0] := Char(ButtLen-1);
for j := 1 to ButtW do
begin
if (j = ButtW div 2) then
begin
for i := 1 to ButtLen do
begin
if i<=Length(Text) then
if i=NLight then
WriteCharXY(x+i-1, y+j-1, ButtLight, Text[i])
else
WriteCharXY(x+i-1, y+j-1, ButtAttr , Text[i])
else
if i <> ButtLen then
WriteCharXY(x+i-1, y+j-1, ButtAttr , ' ')
else
WriteCharXY(x+i-1, y+j-1, ButtShadow, '-')
end;
end
else
if j = ButtW then
begin
for i :=1 to ButtLen do
if i=1 then
WriteCharXY(x+i-1, y+j-1, ButtShadow, ' ')
else
WriteCharXY(x+i-1, y+j-1, ButtShadow, '-');
end
else
for i := 1 to ButtLen do
if i<>ButtLen then
WriteCharXY(x+i-1, y+j-1, ButtAttr , ' ')
else
WriteCharXY(x+i-1, y+j-1, ButtShadow , '-');
end;
end;
{-------------------------}
Procedure SetButtSize(l, z : Byte);
begin
ButtLen:=l;
ButtW := z;
end;
{-------------------------}
Procedure SetWindChar(Ch : Char);
begin
WindChar := Ch;
end;
{-------------------------}
Procedure ClrScr; Assembler;
asm
mov ax, 3
int $10
end;
{------------------}
Function ReadKey : Char; Assembler;
asm
mov ah, 07h
int 21h
end;
{----------------}
Procedure PutChr(C:Char; Col : Byte); Assembler;
asm
mov ah, $09
mov bh, 0
mov bl, Byte Ptr Col
mov al, Byte ptr C
mov cx, 1
int $10
end;
{----------------}
Procedure PutCursor(xx, yy : Byte);
begin
xt := xx;
yt := yy;
asm
mov ah, 2
mov dh, Byte Ptr yy
mov dl, Byte Ptr xx
dec dh
dec dl
mov bh, 0
int $10
end;
end;
{------------------}
Procedure CursorOff;Assembler;
asm
mov ah, 1
mov ch, $20
int $10
end;
{------------------}
Procedure CursorOn;Assembler;
asm
mov ah, 1
mov ch, 6
mov cl, 7
int $10
end;
{------------------}
Procedure WriteLine(S : String; Attr : Byte);
var
i : Word;
begin
with Window do
for i := 1 to Byte(S[0]) do
if (xt<=Xr) and (yt<=Yr) then
begin
if S[i]<>#32 then
PutChr(S[i], Attr)
else
PutChr(WindChar , Attr);
PutCursor(xt+1, yt);
end;
end;
{------------------------}
Procedure SetAttr(Tx, BkTx : Byte; var Attr : Byte);
begin
Attr := (Tx and $8F) or ((BkTx and 7) shl 4) or (BkTx and $80)
end;
{-----------------}
Procedure UnPackAttribute(Attr: Byte; var Text, Back: Byte);
begin
Text := Attr and $8F;
Back := (Attr shr 4) and 7
end; {UnPackAttribute}
{------------------}
Procedure SaveTexBar(x1, y1, x2, y2 : Byte; P : Pointer);
var
i, j : Byte;
Xa, Ya : Byte;
PT : PTar;
begin
PT := P;
Ya := Abs(y2-y1)+1;
Xa := Abs(x2-x1)+1;
for j := 1 to Ya do
for i := 1 to Xa do
PT^[(j-1)*Xa+i] := MemW[$B800:2*(80*(y1-2+j)+x1+i-2)];
end;
{----------------------}
Procedure RestoreTexBar(x1, y1, x2, y2 : Byte; P : Pointer);
var
i, j : Byte;
Xa, Ya : Byte;
PT : PTar;
begin
PT := P;
Ya := Abs(y2-y1)+1;
Xa := Abs(x2-x1)+1;
for j := 1 to Ya do
for i := 1 to Xa do
MemW[$B800:2*(80*(y1-2+j)+x1+i-2)] := PT^[(j-1)*Xa+i];
end;
{-------------------}
Procedure SaveBar(xx1, yy1, xx2, yy2 : Byte);
var
Size : Word;
begin
inc(NSav);
with TextSize[NSav] do
begin
x1 := xx1;
y1 := yy1;
x2 := xx2;
y2 := yy2;
Attrib := WinAttr;
Size := (Abs(x2-x1)+1)*(Abs(y2-y1)+1);
end;
GetMem(TextSize[NSav].PMS, (Size+1)*2);
if TextSize[NSav].PMS = NIL then else;
with TextSize[NSav] do
SaveTexBar(x1, y1, x2, y2, PMS);
end;
{--------------------}
Procedure DoMenuLine(x, y : Byte; KeyS, MenuS : String);
var
Size : Word;
begin
inc(NSav);
with TextSize[NSav] do
begin
x1 := x;
y1 := y;
x2 := x + Length(KeyS)+Length(MenuS) ;
y2 := y;
Size := Abs(x2-x1)+1;
end;
GetMem(TextSize[NSav].PMS, (Size+1)*2);
if TextSize[NSav].PMS = NIL then else;
with TextSize[NSav] do
SaveTexBar(x1, y1, x2, y2, PMS);
PutCursor(x, y);
WriteLine(KeyS, MnAttrK);
WriteLine(Menus, MnAttrM);
end;
{----------------------}
Procedure WriteCharXY(x, y, Attr : Byte; c : Char);
begin
PutCursor(X, Y);
PutChr(c, Attr);
end;
{-------------------------}
Procedure Border (X1,Y1,X2,Y2,Bord: Byte);
{Обводит рамкой заданную прямоугольную область экрана}
var
i : Integer;
begin
{Проверяем параметры обращения}
if not ( (X1<1) or (X2<=X1) or
(Y1<1) or (Y2<=Y1) or (Bord>2)) then
begin
WriteCharXY(X1,Y1,WBorderAttr,BorderChar[Bord,1]);
for i := 1 to X2-X1-1 do {Верхняя рамка}
WriteCharXY(X1+i,Y1,WBorderAttr,BorderChar[Bord,2]);
WriteCharXY(X2,Y1,WBorderAttr,BorderChar[Bord,3]);
for i := 1 to Y2-Y1-1 do {Боковые стороны}
begin
WriteCharXY(X1,Y1+i,WBorderAttr,BorderChar[Bord,4]);
WriteCharXY(X2,Y1+i,WBorderAttr,BorderChar[Bord,4])
end;
WriteCharXY(X1,Y2,WBorderAttr,BorderChar[Bord,5]);
for i := 1 to x2-x1-1 do {Нижняя рамка}
WriteCharXY(X1+i,Y2,WBorderAttr,BorderChar[Bord,2]);
WriteCharXY(X2,Y2,WBorderAttr,BorderChar[Bord,6])
end
end {Border};
{-------------------------}
Procedure PutWindow(X1,Y1,X2,Y2,Bord: Byte;Header: String);
var
x, y, SizeX, SizeY : Byte;
begin
Border(X1,Y1,X2,Y2,Bord);
SizeX := Abs(X2-X1)+1;
SizeY := Abs(Y2-Y1)+1;
for y := 1 to SizeY-2 do
for x := 1 to SizeX-2 do
WriteCharXY(X1+x,Y1+y, WinAttr, WindChar);
if (Length(Header) > SizeX-2) and (SizeX>4) then
begin
Header[0]:=Char(SizeX-2);
x:=Byte(Header[0]);
Header[x-2] := '.';
Header[x-1] := '.';
Header[x] := '.';
end;
If SizeX<=4 then Header[0]:=#0;
SizeX := X1+(Abs(X2-X1)-Length(Header)) div 2;
for x := 1 to Byte(Header[0]) do
WriteCharXY(SizeX+x, Y1, WinHAttr, Header[x]);
WindowSize(X1+1, Y1+1, X2-1, Y2-1);
end;
{---------------------------}
Procedure SetWindow (X1,Y1,X2,Y2,Bord: Byte;
Header: String; Build: Boolean);
{Создает окно в активной страницеи обводит его рамкой}
var
xx1,yy1,xx2,yy2,x,y,dx,dy,k: Byte;
dt: Integer;
const
N = 10;
begin
if Build and ((x2-x1>=4) or (y2-y1>=4)) then
begin
{Начальное положение левого верхнего угла окна}
x := (x2-x1) div 2;
y := (y2-y1) div 2;
{Количество промежуточных окон}
dx := ((x2-x1) div 2) div N;
dy := ((y2-y1) div 2) div N;
if dx=0 then
inc(dx);
if dy=0 then
inc(dy);
if x>1 then
begin
xx1 := x1+x-1;
xx2 := x2-x+1
end
else
begin
xx1 := x1;
xx2 := x2
end;
if y>1 then
begin
yy1 := y1+y-1;
yy2 := y2-y+1
end
else
begin
yy1 := y1;
yy2 := y2
end;
for k := 0 to N-1 do {Цикл построения}
begin
PutWindow(xx1,yy1,xx2,yy2,Bord,Header);
{Увеличиваем границы окна}
if xx1>x1 then
dec(xx1,dx);
if xx2y1 then
dec(yy1,dy);
if yy20) or (PMin <>0) then
Delay(PMax, PMin)
end;
end;
PutWindow(X1,Y1,X2,Y2,Bord,Header)
end; {SetWindow}
{-------------------}
Procedure UndoMenu;
var
Size : Word;
begin
if NSav>0 then
begin
with TextSize[NSav] do
begin
Size := Abs(x2-x1)+1;
RestoreTexBar(x1, y1, x2, y2, PMS);
end;
FreeMem(TextSize[NSav].PMS, (Size+1)*2);
dec(NSav);
with TextSize[NSav] do
begin
WindowSize(Abs(x1+1), Abs(y1+1), Abs(x2-1),Abs(y2-1));
WinAttr := Attrib;
end;
end;
end;
{-------------------}
Procedure RestoreScreen;
begin
for i := 1 to NSav do
UndoMenu;
CursorOn;
WindowSize(1, 1, 80, 25);
end;
{-------------------}
Procedure WindowSize(X1, Y1, X2, Y2 : Byte);
begin
with Window do
begin
if X1 < X2 then
begin
X0 := X1;
Xr := X2;
end
else
begin
X0 := X1;
Xr := X2;
end;
if Y1 < Y2 then
begin
Y0 := Y1;
Yr := Y2;
end
else
begin
Y0 := Y1;
Yr := Y2;
end;
end;
end;
{---------------}
{Procedure WriteLn(S : String; z : Word);
begin
WriteLine(S, WinAttr);
Write(z);
LFCR;
end;}
{--------------}
Procedure ZZCursor;
begin
With Window do
PutCursor(X0, Y0);
end;
{-----------------}
Procedure NewLine;
begin
With Window do
PutCursor(X0, Yt+1);
end;
{===========}
begin
ResetTimer;
NSav := 0;
WindowSize(1, 1, 80, 25);
end.
< -->