{$E+}
{$N+}
{ ┌──┬──┐  ╔══╦══╗  ╒══╤══╕  ╓──╥──╖
  │  │  │  ║  ║  ║  │  │  │  ║  ║  ║
  ├──┼──┤  ╠══╬══╣  ╞══╪══╡  ╟──╫──╢
  │  │  │  ║  ║  ║  │  │  │  ║  ║  ║
  └──┴──┘  ╚══╩══╝  ╘══╧══╛  ╙──╨──╜
%'@^~░▒▓█ ▄ ▌▐ ▀ ЄєЇїЎў°∙·√№¤■

 Стрелки:
  chr(24),' -снизу вверх
  chr(25),' -сверху вниз
  chr(26),' -слева вправо
  chr(27),' -справа влево

 (ch=#80) or  (ch=#72) or  (ch=#75) or  (ch=#77) - коды нажатий стрелок
     Down          Up          Left         Right

  Asm
    mov      AX, seg NewChar    сегмент  \
    mov      ES, AX                  =- таблицы символов
    mov      BP, offset NewChar смещение /

    mov      AH, 11h
    mov      AL, 10h
    mov      BH, 16        высота символа
    mov      BL, 0
    mov      CX, 1         количество символов
    mov      DX, ascCod    ascii - код
    Int      10h
  End;
}

Unit MyServis;

Interface

Uses Crt,Dos,MyCrt;

Type Dlina = String[22];
     Dlin  = String[40];
     Mas   = Record
               S :  array[1..40] of Char;
               T :  array[1..40] of Longint;
             End;
     Ekr   = array[1..4000] of Byte;
     St80  = String[80];
     St11  = String[11];
     St12  = String[12];

  Dan1     = ^DD ;
  DD       = Record
               SS   : String;
               SA   : array[1..80] of Byte;
               Next : Dan1;
             End;
  Dan0     = ^DDD;
  DDD      = Record
              x,y   : Byte;
              Pstr  : Dan1;
              Next  : Dan0;
             End;
 d3x3      = Array[1..3,1..3] of Real;
 d4x4      = Array[1..4,1..4] of Real;
 d5x5      = Array[1..5,1..5] of Real;
 d6x6      = Array[1..6,1..6] of Real;
 f3        = Array[1..3] of Real;
 f4        = Array[1..4] of Real;
 f5        = Array[1..5] of Real;
 f6        = Array[1..6] of Real;
 String8   = String[8];
 String2   = String[2];
 Ar16      = Array[1..16] of Byte;
 Ar14      = Array[1..14] of Byte;
 Ar8       = Array[1..8] of Byte;
Const
{  Ноты по октавам для   Sou(нота, продолжительность[1000=1сек.]);
  Db=131; Dm=262; D1=523; D2=1047; D3=2093;
  Rb=147; Rm=294; R1=587; R2=1174; R3=2348;
  Mb=165; Mm=330; M1=659; M2=1315; M3=2630;
  Fb=175; Fm=349; F1=698; F2=1396; F3=2792;
  Sb=196; Sm=392; S1=785; S2=1568; S3=3136;
  Lb=220; Lm=440; L1=880; L2=1760; L3=3520;
  Cb=247; Cm=494; C1=988; C2=1975; C3=3950;
}
  De=15;

Var  Ma      : Ekr absolute $B800:$0000;
     KeyFlag : Byte absolute $0:$417;
     Time    : Longint;
   PointWin  : Dan0;
   TPW       : Dan0;
   TPS1,TPS2 : Dan1;
{ Dark Colors:                 Light Colors:
  (Foreground & Background)    (Foreground)
  ════════════════════════     ═════════════════
  Black         0   0000       DarkGray       8   1000
  Blue          1   0001       LightBlue      9   1001
  Green         2   0010       LightGreen    10   1010
  Cyan          3   0011       LightCyan     11   1011
  Red           4   0100       LightRed      12   1100
  Magenta       5   0101       LightMagenta  13   1101
  Brown         6   0110       Yellow        14   1110
  LightGray     7   0111       White         15   1111

For flashing (blinking) text foreground, Blink = 128.}

{ Check Alt:  AltKeyPressed:=(KeyFlag and $08)     }
{   keyflag:    7 6 5 4 3 2 1 0                    }
{               │ │ │ │ │ │ │ └─ RightShift  $01   }
{               │ │ │ │ │ │ └─── LeftShift   $02   }
{               │ │ │ │ │ └───── Ctrl        $04   }
{               │ │ │ │ └─────── Alt         $08   }
{               │ │ │ └───────── ScrollLock  $10   }
{               │ │ └─────────── NumLock     $20   }
{               │ └───────────── CapsLock    $40   }
{               └─────────────── InsLock     $80   }

{ 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0              }
{  │  │  │  │  │  │ │ │ │ │ │ │ │ │ │ └─ $   1     1 }
{  │  │  │  │  │  │ │ │ │ │ │ │ │ │ └─── $   2     2 }
{  │  │  │  │  │  │ │ │ │ │ │ │ │ └───── $   4     4 }
{  │  │  │  │  │  │ │ │ │ │ │ │ └─────── $   8     8 }
{  │  │  │  │  │  │ │ │ │ │ │ └───────── $  10    16 }
{  │  │  │  │  │  │ │ │ │ │ └─────────── $  20    32 }
{  │  │  │  │  │  │ │ │ │ └───────────── $  40    64 }
{  │  │  │  │  │  │ │ │ └─────────────── $  80   128 }
{  │  │  │  │  │  │ │ └───────────────── $ 100   256 }
{  │  │  │  │  │  │ └─────────────────── $ 200   512 }
{  │  │  │  │  │  └───────────────────── $ 400  1024 }
{  │  │  │  │  └──────────────────────── $ 800  2048 }
{  │  │  │  └─────────────────────────── $1000  4096 }
{  │  │  └────────────────────────────── $2000  8192 }
{  │  └───────────────────────────────── $4000 16384 }
{  └──────────────────────────────────── $8000 32768 }
{
   ArcSin(x) = ArcTan (x/sqrt (1-sqr (x)))
   ArcCos(x) = ArcTan (sqrt (1-sqr (x)) /x)
}
Function ArcCos(as : Real) : Real;
Function ArcSin(sa : Real) : Real;

Function x_Y(x,y : Double) : Double;

Function  HD(He : String2) : Byte; {Hex To Dec}
Function  BD(Bi : String8) : Byte; {Bin To Dec}

Procedure NormChar16;  {Возвращает соотв. таблицу символов в исходное сост.}
Procedure NormChar14;
Procedure NormChar8;

Function  SqrIn(a : Real; n : Byte) : Real; {Возведение в целую степень}

Function  SetBitByte(b : Byte; NumBit : Byte; SetCount : Byte) : Byte;
Function  SetBitWord(w : Word; NumBit : Byte; SetCount : Byte) : Word;
Function  GetBitByte(b : Byte; NumBit : Byte) : Byte;{=0..1}  {NumBit=0..7 }
Function  GetBitWord(w : Word; NumBit : Byte) : Byte;{=0..1}  {NumBit=0..15}
Function               SwapByte(k : Byte) : Byte;

Function  UpReg(St : String) : String;
Function  DnReg(St : String) : String;
Function  CCR(CC : Char) : Boolean; {Check Char Rus}

Procedure W(x,y : Byte; St : St80);
Procedure WA(x,y : Byte; St : St80; Atr : Byte);
Procedure WriteAtrib(x,y,na,Atr : Byte);
Function  ReadAtrib(x,y : Byte) : Byte;

Function  GetChar(x,y : Byte) : Byte;
Function  GetString(x,y,n : Byte) : String;
Function  GetAttr(x,y : Byte) : Byte;
Procedure SetChar(x,y,c : Byte);
Procedure SetAttr(x,y,a : Byte);

Function  FilEx(FileName: String): Boolean; {проверка существования файла}
Procedure Gxy(x,y:Byte;st:String);  { B800:0000 }
Procedure XY(x,y:Byte;St:String);   { GoToXY    }
Function  DopStrok(n:Byte; s:String):String;
Procedure Sou(ss,dd : Real);
Procedure Z;
Procedure O;

Procedure C(c:byte);
Procedure F(f:byte);
Procedure CF(c,f:byte);
Procedure Beep;
Procedure Bell;

Procedure Cursor(flag:boolean);

Procedure FrameCN(xa,ya,xb,yb,ColorFrame,ColorWin : Byte; sq : String);
Procedure Frame(x1,y1,x2,y2:integer);
Procedure FrameGround(v1,v2,v3,v4,fon:byte);
Procedure FrameName(v1,v2,v3,v4,fon:byte;st:string);
Procedure GMenu(k1,k2,Kp:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7:dlina;
						  Var Result:Byte);
Procedure VMenu(k1,k2,kp:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7:dlina;
						  Var Result:Byte);
Procedure VMenuColor(k1,k2,Kp,cc,ff:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7:dlina;
						  Var Result:Byte);
Procedure GMenuColor(k1,k2,kp,cc,ff:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7:dlina;
						  Var Result:Byte);
Procedure VM(x,y:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7,
                      ss8,ss9,ss10,ss11,ss12,ss13,ss14,
                      ss15,ss16,ss17,ss18,ss19,ss20 :dlin; NP:Byte;
                                                          Var Result:Byte);
Procedure VMcf(x,y,c0,f0,cCur,fCur:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7,
                      ss8,ss9,ss10,ss11,ss12,ss13,ss14,
                      ss15,ss16,ss17,ss18,ss19,ss20 :dlin;
                      NP:Byte; Var Result:Byte);

 Procedure clr;
 Procedure beg1(aa,bb:integer;st:string);
 Procedure beg2(x,y:Integer;st:string);
 Procedure beg3(x,y:Integer;st:string);
 Procedure beg4(x,y:byte;st:string);
 Procedure beg5(x,y:byte;st:string);
 Procedure beg6(x,y:Byte;st:String);
 Procedure beg7(xx,yy:Byte;sst:String);
 Procedure beg8(a,b:Byte;St:String);
 Procedure zap(a,b:integer;st:string);
 Procedure out(clear:boolean);

 Function  Choice(UserPath : String; SizeWin,XWin,Ywin : Byte) : String;
 Procedure Key(x,y,nb : Byte; KeyStr : String; ColorS, ColorB : Byte);
 Procedure KeyOk(x,y : Byte);
 Procedure KeyCancel(x,y : Byte);
 Procedure Tim(x,y : Byte);
 Procedure TimOutDelay(x,y : Byte);

 Procedure PushW(xa,ya,xb,yb:byte);
 Procedure PopW;

 Function  GetNumFromSt(Sc : String) : LongInt;
 Function  EditStr(x,y,len : Byte; ColorS,GroundS : Byte;
                                      S0 : String; Var C0 : Char) : String;
 Function  FindStr(SubStr,S : String) : Boolean;
 Function  IntToStr(I: Longint): String;
 Function  Supplement(St : String; k,tip : Byte) : String;
     { tip = (0-center,1-left,2-Right) }  { - где будут добавляться пробелы}
 Function  CutStr(St : String; k : Byte) : String;
 Function  DosInWin(sa : String) : String;

 Function  CheckRShift     : Boolean;
 Function  CheckLShift     : Boolean;
 Function  CheckCtrl       : Boolean;
 Function  CheckAlt        : Boolean;
 Function  CheckScroll     : Boolean;
 Function  CheckNum        : Boolean;
 Function  CheckCaps       : Boolean;
 Function  CheckIns        : Boolean;

 Function  M3x3(m3 : d3x3) : Real;   {Определители матриц}
 Function  M4x4(m4 : d4x4) : Real;
 Function  M5x5(m5 : d5x5) : Real;
 Function  M6x6(m6 : d6x6) : Real;
 Procedure u3(k : d3x3; l : f3; Var f : f3; Var D30 : Real); {Решение          }
 Procedure u4(k : d4x4; l : f4; Var f : f4; Var D40 : Real); {систем           }
 Procedure u5(k : d5x5; l : f5; Var f : f5; Var D50 : Real); {уравнений        }
 Procedure u6(k : d6x6; l : f6; Var f : f6; Var D60 : Real); {D.. -определители}
 Procedure ViewWin(x1,y1,x2,y2,FrameColor,WinColor,TxtColor : Byte;
                  NameFrame,NameFile : String);

Implementation

Function SwapByte(k : Byte) : Byte;
Var kk  : Byte;
Begin
  SwapByte:=(k shl 4)+(k shr 4);
End;

Function DosInWin(sa : String) : String;
Var aa  : Word;
    ssa : String;
Begin
  ssa:=sa;
  For aa:=1 to Length(sa) do
    Case sa[aa] of
      Chr(128)..Chr(149) : ssa[aa]:=Chr(Ord(sa[aa])+64);
      Chr(150)..Chr(175) : ssa[aa]:=Chr(Ord(sa[aa])+64);
      Chr(224)..Chr(239) : ssa[aa]:=Chr(Ord(sa[aa])+16);
      Chr(240)           : ssa[aa]:=Chr(168);
      Chr(241)           : ssa[aa]:=Chr(184);
      Chr(242)           : ssa[aa]:=Chr(170);
      Chr(243)           : ssa[aa]:=Chr(186);
      Chr(244)           : ssa[aa]:=Chr(175);
      Chr(245)           : ssa[aa]:=Chr(191);
      Chr(246)           : ssa[aa]:=Chr(161);
      Chr(247)           : ssa[aa]:=Chr(162);
      Chr(248)           : ssa[aa]:=Chr(176);
      Chr(249)           : ssa[aa]:=Chr(149);
      Chr(250)           : ssa[aa]:=Chr(183);
      Chr(251)           : ssa[aa]:=Chr(95);
      Chr(252)           : ssa[aa]:=Chr(185);
      Chr(253)           : ssa[aa]:=Chr(164);
    end;
    DosInWin:=ssa;
End;

Function UpReg(St : String) : String;
Var q : Byte;
    z : String;
Begin
  z:=St;
  For q:=1 to Length(St) do z[q]:=UpCase(z[q]);
  UpReg:=z;
End;

Function DnReg(St : String) : String;
Var q : Byte;
    z : String;
Begin
  z:=St;
  For q:=1 to Length(St) do
    If z[q]=UpCase(z[q]) then
     If ((z[q]>'@') and (z[q]>'[')) or ((z[q]>'') and (z[q]<'а')) then
      If z[q]<'Р' then z[q]:=Chr(Ord(z[q])+32)
                  else z[q]:=Chr(Ord(z[q])+80);
  DnReg:=z;
End;

Function CCR(CC : Char) : Boolean; {Check Char Rus}
Begin
  CCR:=False;
  If ((CC>'') and (CC<'░')) or ((CC>'▀') and (CC<'Ё')) then CCR:=True;
End;

function IntToStr(I: Longint): String;
{ Convert any integer type to a string }
var
 S: string[11];
begin
 Str(I, S);
 IntToStr := S;
end;

Procedure XY(x,y:Byte;St:String);
Begin
  GotoXY(X,Y);
  Write(St);
End;

Procedure W(x,y : Byte; St : St80);
Var is : Byte;
Begin
  For is:=x to Length(St)+x-1 do
           Ma[2*is+(y-1)*160-1]:=Ord(St[is]);
  GoToXY(x+Length(St),y);
End;

Procedure WA(x,y : Byte; St : St80; Atr : Byte);
Var isa : Byte;
Begin
    For isa:=x to Length(St)+x-1 do
       Begin
         Ma[2*isa+(y-1)*160-1]:=Ord(St[isa]);
         Ma[2*isa+(y-1)*160]:=Atr;
       End;
    GoToXY(x+Length(St),y);
End;

Procedure WriteAtrib(x,y,na,Atr : Byte);
Var k : Byte;
Begin
    For k:=x to Na+x-1 do
       Ma[2*k+(y-1)*160]:=Atr;
End;

Function ReadAtrib(x,y : Byte) : Byte;
Begin
     ReadAtrib:=Ma[2*x+(y-1)*160];
End;

Function FilEx(FileName: String): Boolean;
{ Boolean function that returns True if the file exists;otherwise,
 it returns False. Closes the file if it exists. }
var
 F: file;
begin
 {$I-}
 Assign(F, FileName);
 FileMode := 0;  { Set file access to read only }
 Reset(F);
 Close(F);
 {$I+}
 FilEx := (IOResult = 0) and (FileName <> '');
 FileMode:=2;
end;  { FileExists }


Function DopStrok(n:Byte;s:String):String;
Var i : Byte;
Begin
If n<=Length(s) then
	Begin
	  DopStrok:=s;
	  exit;
	End;
n:=n-Length(s);
For i:=1 to (n div 2) do
	Begin
	  s:=' '+s;
	  s:=s+' ';
	End;
If Odd(n) then s:=s+' ';
DopStrok:=s;
End;

Procedure Sou(ss,dd:Real);
Begin
Sound(Round(ss));
Delay(Round(dd));
NoSound;
end;

Procedure Z;
begin
TextColor(0);
TextBackGround(7);
end;

Procedure O;
Begin
textcolor(7);
textbackground(0);
end;

Procedure C(c:byte);
begin
textcolor(c);
end;

Procedure F(f:byte);
begin
Textbackground(f);
end;

Procedure CF(c,f:byte);
begin
textcolor(c);
textbackground(f);
end;

Procedure Beep;
begin
sound(8000);
delay(9);
nosound;
end;

Procedure Cursor(flag:boolean);
const sizecursor : word = 0;
var reg : registers;
begin
   with reg do
      begin
       if flag then
           begin
            cx:=sizecursor;
           end
               else
           begin
            bh:=0;
            ah:=03;
            intr($10,reg);
            sizecursor:=cx;
            ch:=$20;
           end;
       ah:=01;
       intr($10,reg);
      end;
end;

Procedure Frame(x1,y1,x2,y2:integer);
const
a=#186;b=#187;c=#188;  { ║ ╗ ╝ }
d=#200;e=#201;f=#205;  { ╚ ╔ ═ }
var i,j : integer;
begin
 gxy(x1,y1,e);
 gxy(x1,y2,d);
 for i:=(x1+1) to (x2-1) do
 begin
 gxy(i,y1,f);
 gxy(i,y2,f);
 end;
 gxy(x2,y1,b);
 gxy(x2,y2,c);
 for i:=(y1+1) to (y2-1) do
 begin
 gxy(x1,i,a);
 gxy(x2,i,a);
 end;
end;

Procedure FrameGround(v1,v2,v3,v4,fon:byte);
var i,j : byte;
    at  : byte;
begin
at:=TextAttr;
textbackground(fon);
frame(v1,v2,v3,v4);
cursor(false);
for i:=v1+1 to v3-1 do
 for j:=v2+1 to v4-1 do Gxy(i,j,' ');
TextAttr:=At;
end;

Procedure FrameName(v1,v2,v3,v4,fon:byte;st:string);
Var qqqq : string;
begin
frameground(v1,v2,v3,v4,fon);
{Gxy(v1+round((((v3-v1)-length(st))/2)),v2,st);}
qqqq:=' '+st+' ';
If (Length(qqqq)<v3-v1-1) and (Length(st)>0) then
                Gxy(v1+((v3-v1-Length(qqqq)+1) div 2),v2,qqqq);
end;

Procedure GMenu(k1,k2,kp:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7:dlina;
						  Var Result:Byte);
Label Met;
Const
	  Kr=7;
Var m      : array[1..Kr] of string[22];
	i,t,r  : Byte;
	pp     : array[1..Kr] of Byte;
	Ch     : Char;
	Fl     : Boolean;
Begin
	Cursor(False);
	Fl:=True;
	m[1]:=ss1;
	m[2]:=ss2;
	m[3]:=ss3;
	m[4]:=ss4;
	m[5]:=ss5;
	m[6]:=ss6;
	m[7]:=ss7;
	t:=Length(m[1]);
	r:=0;
	For i:=1 to kp do
	r:=r+Length(m[i]);
	r:=Round((78-r)/kp)-1;
	Frame(1,k2-1,80,k2+1);GoToXY(14,24);
	Write('С помощью ',Chr(26),' или ',Chr(27),' укажите режим и нажмите <Enter>');
	GoToXY(Round(r/2+5),k2);
	For i:=1 to kp do
		Begin
			 If i=1 then CF(0,7) else CF(7,0);
			 pp[i]:=Wherex;
			 Write(m[i]); CF(7,0); If i=kp then r:=3; Write('':r);
		End;
	i:=1;
	While Fl=True do
	  Begin
	  Ch:=ReadKey;
	  if ch=#13 then fl:=False;
	  if (ch=#0) and KeyPressed then
		   Begin
		   Ch:=ReadKey;
		   Case Ch of
			#77 :Begin
							Beep;
							GoToXY(k1+pp[i]-1,k2);
							CF(7,0);
							Write(m[i]);
							i:=i+1;
							If i=(Kp+1) then
							   Begin
							   i:=1;
							   CF(7,0);
							   GoToXY(k1+pp[i]-1,k2);
							   CF(0,7);
							   Write(m[i]);
							   CF(7,0);
							   GoTo Met;
							   End;
							GoToXY(k1+pp[i]-1,k2);
							CF(0,7);
							Write(m[i]);
							CF(7,0);
						  End;
					 #75 : Begin
								If i=1 then GoTo Met;
								gotoxy(k1+pp[i]-1,k2);
								Beep;
								CF(7,0);
								Write(m[i]);
								i:=i-1;
								GoToXY(k1+pp[i]-1,k2);
								CF(0,7);
								Write(m[i]);
						   End
					 End;
		   Met:
		   End;
		  End;
	Result:=i;
	CF(7,0);
	Cursor(True);
End;

Procedure VMenu(k1,k2,Kp:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7:dlina;
                          Var Result:Byte);
Label Met;
Const Kr=7;
Var m     : array[1..Kr] of string[48];
    i,t   : Byte;
    Ch    : Char;
    Fl    : Boolean;
Begin
    Cursor(False);
    Fl:=True;
    m[1]:=ss1;
    m[2]:=ss2;
    m[3]:=ss3;
    m[4]:=ss4;
    m[5]:=ss5;
    m[6]:=ss6;
    m[7]:=ss7;
    t:=Length(m[1]);
    For i:=2 to Kp do If Length(m[i])>t then t:=Length(m[i]);
    Frame(k1-1,k2,k1+t,k2+kp+1);
    For i:=1 to kp do
             Begin
             If i=1 then CF(0,7) else CF(7,0);
             GoToXY(k1,k2+i);
             Write(m[i]);
             End;
    GoToXY(21,24);CF(7,0);
    Write('С помощью ',Chr(25),' или ',Chr(24),' укажите режим и нажмите <Enter>');
    CF(7,0);i:=1;
    While Fl=True do
       Begin
        Ch:=ReadKey;
        If ch=#13 then Fl:=False;
        If (ch=#0) and KeyPressed then
                     Begin
                     Ch:=ReadKey;
                     Case Ch of
                     #80 :Begin
                            Beep;
                            GoToXY(k1,k2+i);
                            CF(7,0);
                            Write(m[i]);
                            i:=i+1;
                            If i=(Kp+1) then
                               Begin
                               i:=1;
                               CF(7,0);
                               GoToXY(k1,k2+1);
                               CF(0,7);
                               Write(m[i]);
                               CF(7,0);
                               GoTo Met;
                               End;
                            GoToXY(k1,k2+i);
                            CF(0,7);
                            Write(m[i]);
                            CF(7,0);
                          End;
                     #72 : Begin
                                If i=1 then GoTo Met;
                                gotoxy(k1,k2+i);
                                Beep;
                                CF(7,0);
                                Write(m[i]);
                                i:=i-1;
                                GoToXY(k1,k2+i);
                                CF(0,7);
                                Write(m[i]);
                           End
                     End;
           Met:
           End;
          End;
    Result:=i;
    CF(7,0);
    Cursor(True);
End;

Procedure VMenuColor(k1,k2,Kp,cc,ff:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7:dlina;
						  Var Result:Byte);
Label Met;
Const Kr=7;
Var m     : array[1..Kr] of string[48];
	i,t   : Byte;
	Ch    : Char;
	Fl    : Boolean;
Begin
	Cursor(False);
	Fl:=True;
	m[1]:=ss1;
	m[2]:=ss2;
	m[3]:=ss3;
	m[4]:=ss4;
	m[5]:=ss5;
	m[6]:=ss6;
	m[7]:=ss7;
	t:=Length(m[1]);
	For i:=2 to Kp do If Length(m[i])>t then t:=Length(m[i]);
	c(cc);
	Frame(k1-1,k2,k1+t,k2+kp+1);
	For i:=1 to kp do
			 Begin
			 If i=1 then CF(cc,ff) else CF(ff,cc);
			 GoToXY(k1,k2+i);
			 Write(m[i]);
			 End;
	GoToXY(21,24);CF(ff,cc);
	Write('С помощью ',Chr(25),' или ',Chr(24),' укажите режим и нажмите <Enter>');
	CF(ff,cc);i:=1;
	While Fl=True do
	   Begin
		Ch:=ReadKey;
		If ch=#13 then Fl:=False;
		If (ch=#0) and KeyPressed then
					 Begin
					 Ch:=ReadKey;
					 Case Ch of
					 #80 :Begin
							Beep;
							GoToXY(k1,k2+i);
							CF(ff,cc);
							Write(m[i]);
							i:=i+1;
							If i=(Kp+1) then
							   Begin
							   i:=1;
							   CF(ff,cc);
							   GoToXY(k1,k2+1);
							   CF(cc,ff);
							   Write(m[i]);
							   CF(ff,cc);
							   GoTo Met;
							   End;
							GoToXY(k1,k2+i);
							CF(cc,ff);
							Write(m[i]);
							CF(ff,cc);
						  End;
					 #72 : Begin
								If i=1 then GoTo Met;
								gotoxy(k1,k2+i);
								Beep;
								CF(ff,cc);
								Write(m[i]);
								i:=i-1;
								GoToXY(k1,k2+i);
								CF(cc,ff);
								Write(m[i]);
						   End
					 End;
		   Met:
		   End;
		  End;
	Result:=i;
	CF(ff,cc);
	Cursor(True);
	O;
End;

Procedure GMenuColor(k1,k2,kp,cc,ff:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7:dlina;
						  Var Result:Byte);
Label Met;
Const
	  Kr=7;
Var     m      : array[1..Kr] of string[22];
	i,t,r  : Byte;
	pp     : array[1..Kr] of Byte;
	Ch     : Char;
	Fl     : Boolean;
Begin
	Cursor(False);
	Fl:=True;
	m[1]:=ss1;
	m[2]:=ss2;
	m[3]:=ss3;
	m[4]:=ss4;
	m[5]:=ss5;
	m[6]:=ss6;
	m[7]:=ss7;
	t:=Length(m[1]);
	r:=0;
	For i:=1 to kp do
	r:=r+Length(m[i]);
	r:=Round((78-r)/kp)-1;
	c(cc);
	FrameGround(1,k2-1,80,k2+1,ff);GoToXY(14,24);
	Write('С помощью ',Chr(26),' или ',Chr(27),' укажите режим и нажмите <Enter>');
	GoToXY(Round(r/2+5),k2);
	For i:=1 to kp do
		Begin
			 If i=1 then CF(cc,ff) else CF(ff,cc);
			 pp[i]:=Wherex;
			 Write(m[i]); CF(cc,ff); If i=kp then r:=3; Write('':r);
		End;
	i:=1;
	While Fl=True do
	  Begin
	  Ch:=ReadKey;
	  if ch=#13 then fl:=False;
	  if (ch=#0) and KeyPressed then
		   Begin
		   Ch:=ReadKey;
		   Case Ch of
			#77 :Begin
							Beep;
							GoToXY(k1+pp[i]-2,k2);
							CF(ff,cc);
							Write(m[i]);
							i:=i+1;
							If i=(Kp+1) then
							   Begin
							   i:=1;
							   CF(ff,cc);
							   GoToXY(k1+pp[i]-2,k2);
							   CF(cc,ff);
							   Write(m[i]);
							   CF(ff,cc);
							   GoTo Met;
							   End;
							GoToXY(k1+pp[i]-2,k2);
							CF(cc,ff);
							Write(m[i]);
							CF(ff,cc);
						  End;
					 #75 : Begin
								If i=1 then GoTo Met;
								gotoxy(k1+pp[i]-2,k2);
								Beep;
								CF(ff,cc);
								Write(m[i]);
								i:=i-1;
								GoToXY(k1+pp[i]-2,k2);
								CF(cc,ff);
								Write(m[i]);
						   End
					 End;
		   Met:
		   End;
		  End;
	Result:=i;
	CF(ff,cc);
	Cursor(True);
	O;
End;

Procedure VM(x,y:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7,
                      ss8,ss9,ss10,ss11,ss12,ss13,ss14,
                      ss15,ss16,ss17,ss18,ss19,ss20 :dlin;
                      NP:Byte; Var Result:Byte);
Var m            : Array[1..21] of dlin;
    t,i,k        : Byte;
    Ch           : Char;
    current_attr : Byte;
Begin
     Current_attr:=TextAttr;
     m[1]:=ss1;
     m[2]:=ss2;
     m[3]:=ss3;
     m[4]:=ss4;
     m[5]:=ss5;
     m[6]:=ss6;
     m[7]:=ss7;
     m[8]:=ss8;
     m[9]:=ss9;
     m[10]:=ss10;
     m[11]:=ss11;
     m[12]:=ss12;
     m[13]:=ss13;
     m[14]:=ss14;
     m[15]:=ss15;
     m[16]:=ss16;
     m[17]:=ss17;
     m[18]:=ss18;
     m[19]:=ss19;
     m[20]:=ss20;
     m[21]:='';
     Cursor(False);

     t:=NP;
     For i:=21 downto 1 do
        If m[i]='' then k:=i;
     For i:=1 to 20 do
            Begin
              gxy(x,y+i-1,m[i]);
            End;
              C(15);
              gxy(x,y+NP-1,m[NP]);
              C(7);
     Repeat
       Ch:=ReadKey;
       If Ch=#0 then Ch:=ReadKey;
       Case Ch of
   ' ', #80 : Begin
               C(7);
               gxy(x,y+t-1,m[t]);
               t:=t+1;
               If m[t]='' then t:=1;
              End;
        #72 : Begin
               C(7);
               gxy(x,y+t-1,m[t]);
               t:=t-1;
               If t<1 then t:=k-1;
              End;
        #27 : t:=0;
       End;
     If Ch<>#27 then
      Begin
       C(15);
       gxy(x,y+t-1,m[t]);
      End;
     Until (Ch=#13) or (Ch=#27);
     Result:=t;
     Cursor(True);
     TextAttr:=Current_attr;
End;

Procedure VMcf(x,y,c0,f0,cCur,fCur:Byte;ss1,ss2,ss3,ss4,ss5,ss6,ss7,
                      ss8,ss9,ss10,ss11,ss12,ss13,ss14,
                      ss15,ss16,ss17,ss18,ss19,ss20 :dlin;
                      NP:Byte; Var Result:Byte);
Var m            : Array[1..21] of dlin;
    t,i,k        : Byte;
    Ch           : Char;
    current_attr : Byte;
Begin
     Current_attr:=TextAttr;
     CF(c0,f0);
     m[1]:=ss1;
     m[2]:=ss2;
     m[3]:=ss3;
     m[4]:=ss4;
     m[5]:=ss5;
     m[6]:=ss6;
     m[7]:=ss7;
     m[8]:=ss8;
     m[9]:=ss9;
     m[10]:=ss10;
     m[11]:=ss11;
     m[12]:=ss12;
     m[13]:=ss13;
     m[14]:=ss14;
     m[15]:=ss15;
     m[16]:=ss16;
     m[17]:=ss17;
     m[18]:=ss18;
     m[19]:=ss19;
     m[20]:=ss20;
     m[21]:='';
     Cursor(False);

     t:=NP;
     For i:=21 downto 1 do
        If m[i]='' then k:=i;
     For i:=1 to 20 do
            Begin
              gxy(x,y+i-1,m[i]);
            End;
     CF(cCur,fCur);
     Gxy(x,y+NP-1,m[NP]);
     CF(c0,f0);
     Repeat
       Ch:=ReadKey;
       If Ch=#0 then Ch:=ReadKey;
       Case Ch of
   ' ', #80 : Begin
               CF(c0,f0);
               gxy(x,y+t-1,m[t]);
               t:=t+1;
               If m[t]='' then t:=1;
              End;
        #72 : Begin
               CF(c0,f0);
               gxy(x,y+t-1,m[t]);
               t:=t-1;
               If t<1 then t:=k-1;
              End;
        #27 : t:=0;
       End;
     If Ch<>#27 then
      Begin
       CF(cCur,fCur);
       gxy(x,y+t-1,m[t]);
      End;
     Until (Ch=#13) or (Ch=#27);
     Result:=t;
     Cursor(True);
     TextAttr:=Current_attr;
End;

Procedure clr;
 type dan=record
     x:byte;
     y:byte;
     end;
var i,j,a,b,k :integer;
	m         :array[1..2000] of dan;
	n         :dan;
 begin
 k:=0;
 for i:=1 to 80 do
  for j:=1 to 25 do
 begin
  n.x:=i;
  n.y:=j;
  k:=k+1;
  m[k]:=n;
 end;
 randomize;
  for i:=1 to 2000 do
              begin
                   a:=round(random(2000));
                   b:=round(random(2000));
                   n:=m[a];
                   m[a]:=m[b];
                   m[b]:=n;
			   end;
 cursor(False);
 for i:=1 to 2000 do
                  begin
                       {if (m[i].x<>80) and (m[i].y<>25) then}
                    begin;
                       gotoxy(m[i].x,m[i].y);write(' ');
                       delay(1);
                    end;
                  end;
 clrscr;
 cursor(True);
 end;

Procedure beg1(aa,bb:integer;st:string);
 var len,w:integer;
     s1,s2:string;
begin
 if odd(length(st)) then st:=st+' ';
 len:=length(st) div 2;
 s1:='';s2:='';
 for w:=1 to len do
                 begin
                  delay(60);
                  s1:=s1+copy(st,w,1);
                  s2:=copy(st,2*len+1-w,1)+s2;
                  gotoxy(aa+len-w,bb);write(s1);
                  gotoxy(aa+len,bb);write(s2);
                 end;
end;

 Procedure beg2(x,y:integer;st:string);
 var s1,s2,s3,s4 :string;
     l,i        :integer;
begin
 if length(st)<4 then
                 begin
                      repeat
                       st:=st+' ';
                      until length(st)>=4;
				 end;
 if odd(length(st)) then st:=st+' ';
 if length(st)/4-round(length(st)/4)<>0 then st:=st+'  ';
 l:=length(st);
 s1:='';s2:='';s3:='';s4:='';l:=l div 4;
 cursor(False);
 for i:=1 to l do
                 begin
                  delay(60);
                  s1:=s1+copy(st,i,1);
                  s2:=copy(st,2*l+1-i,1)+s2;
                  s3:=s3+copy(st,i+l*2,1);
                  s4:=copy(st,4*l+1-i,1)+s4;
                  gotoxy(x+l-i,y);   write(s1);
                  gotoxy(x+l,y);     write(s2);
                  gotoxy(x+l*3-i,y); write(s3);
                  gotoxy(x+l*3,y);   write(s4);
                 end;
cursor(True);
end;

 Procedure beg3(x,y:integer;st:string);
 var i:integer;
 begin
cursor(False);
gotoxy(x,y);
for i:=1 to length(st) do
 begin
 delay(60);
 write(st[i]);
 end;
cursor(True);
end;

 Procedure beg4(x,y:byte;st:string);
 var
    s   : string[79];
    n,i : byte;
 begin
	  s:='';n:=0;
      for i:=x+length(st)-1 downto x do
          begin
           n:=n+1;
		   s:=s+st[n];
           gotoxy(i,y);write(s);
           delay(70);
          end
 end;

Procedure beg5(x,y:byte;st:string);
var
   i,k : byte;
begin
	 beg4(x,y,st);
     delay(300);
     k:=length(st);
     for i:=1 to k do
     begin
		  delete(st,1,1);
          st:=st+' ';
          gotoxy(x,y);write(st);
          delay(70);
     end
end;

Procedure beg6(x,y:byte;st:string);
Var i,j   : Byte;
	S1,S2 : String;
Begin
	If Odd(Length(st)) then st:=st+' ';
	s1:='';s2:='';
	For i:=1 to Length(st) div 2 do
		Begin
			Delay(60);
			s1:=st[(Length(st) div 2)-i+1]+s1;
			s2:=s2+st[(Length(st) div 2)+i-1];
			GoToXY(x,y);Write(s1);
			GoToXY(x+Length(st)-i-1,y);Write(s2);
		End;
End;

Procedure beg7(xx,yy:byte;sst:string);
Var ss,ss1,ss2   : String;
	i         : Byte;
Begin
	If Odd(Length(sst)) then sst:=sst+' ';
		ss2:=Copy(sst,(Length(sst) Div 2)+1,Length(sst) Div 2);
		ss1:=Copy(sst,1,Length(sst) Div 2);
		ss:=ss2+ss1;
		Beg6(xx,yy,ss);
	cursor(False);
	For i:=Length(sst) Div 2 downto 1 do
		Begin
			GoToXY(xx+i-1,yy);
			Write(ss1);
						Delay(30);
						Write(' ');
						GoToXY((Length(sst) Div 2)-i+1+xx,yy);
						Write(ss2);
			Delay(30);
						GoToXY((Length(sst) Div 2)-i+xx,yy);
						Write(' ');
		End;
		   GoToXY(xx,yy);Write(sst);
	 cursor(True);
End;

Procedure Beg8(a,b:Byte;St:String);
Var i,n : Byte;
Begin
cursor(False);
For n:=a to a+Length(st)-1 do
Begin
 For i:=1 to 30 do
 Begin
  GotoXY(Round(Random(Length(st)+a-1-n)+n),b);
  Write(chr(Round(Random(140)+32)));
  Delay(4);
 End;
 GotoXY(n,b);Write(st[n-a+1]);
End;
cursor(True);
End;

Procedure zap(a,b:integer;
				 st:string);
var f :text;
    s:pathstr;
begin
 s:=fsearch('file.tmp','');
 assign(f,'file.tmp');
 if s='' then rewrite(f) else append(f);
 writeln(f,a);
 writeln(f,b);
 writeln(f,st);
 close(f);
end;

procedure out(clear:boolean);
 type dan2=record
		  x:integer;
		  y:integer;
		  s:string[1];
	  end;

 var f            :text;
	 n2           :dan2;
	 m            :array[1..2000] of dan2;
	 as,bs        :string[2];
	 j,a,b,na,c   :integer;
	 str          :string[79];
	 ch           : char;
  begin
   cursor(False);
   assign(f,'file.tmp');
   reset(f);
   na:=0;
   while not eof(f) do
	begin
	  readln(f,as);val(as,a,c);
	  readln(f,bs);val(bs,b,c);
	  readln(f,str);
	   for j:=1 to length(str) do
		  begin
		   na:=na+1;
		   n2.y:=b;
		   n2.x:=a+j-1;
		   as:=copy(str,j,1);
		   ch:=as[1];
		   n2.s:=ch;
		   m[na]:=n2;
		  end;
	end;
	close(f);
	erase(f);
	randomize;
	for j:=1 to na do
	   begin
		 a:=round(random(na-1))+1;
		 b:=round(random(na-1))+1;
		 n2:=m[a];
		 m[a]:=m[b];
		 m[b]:=n2;
	   end;
	 for j:=1 to na do
					begin
					  delay(10);
					  gotoxy(m[j].x,m[j].y);
					  write(m[j].s);
					end;
	  if clear then ch:=readkey;
	  if clear then begin
					 for j:=1 to na do begin
					  delay(8);
					  gotoxy(m[j].x,m[j].y);write(' ');
					 end;
					end;
	end;

Function Choice(UserPath : String; SizeWin,XWin,Ywin : Byte) : String;
     { Ctrl+Enter  -  #10       OR       Esc  -  #27 }

{Const}                 {     ..            <UP--DIR>     }
{  SizeWin = 15;}       {     namefile.ext  <SUB-DIR>     }
{  XWin    = 10;}       {         8 + 1+3+2  + 9     = 23 }
{  Ywin    =  3;}
Type
      RecFile = Record
                  NameFile  : String;
                  FlagDir   : Boolean;  { False - file    True - Directory }
                End;

Var
      CurPath     : String;
      NumPage     : Word;
      NumPos,Disk : Byte;
      q           : Byte;
      Ch          : Char;
      Mas         : Array[1..25] of RecFile;
      Rec         : SearchRec;

  Function CheckPage : Boolean;
  Var  NF  : LongInt;
       sss : String;
  Begin
     NF:=0;
     If Length(CurPath)=3 then sss:=CurPath+'*.*'
                          else sss:=CurPath+'\*.*';
     FindFirst(sss,(($01 or $02) or ($04 or $10)) or $20,Rec);
     While DosError=0 do
             Begin
                 Inc(NF);
                 FindNext(Rec);
             End;
     If NF-NumPage*SizeWin>0 then CheckPage:=True
                             else CheckPage:=False;
  End;

  Procedure UpTreeDir;
  Var tmp : Byte;
  Begin
    If Mas[NumPos].NameFile='.' then
                   CurPath:=Copy(CurPath,1,3)
                                else
    If Length(CurPath)>3 then
      Begin
         For tmp:=Length(CurPath) downto 3 do
           If CurPath[tmp]='\' then Break;
         Delete(CurPath,tmp,13);
         If Length(CurPath)=2 then CurPath:=CurPath+'\';
      End;
  End;

        Procedure ClearMas;
        Var tmp : Byte;
        Begin
           For tmp:=1 to 25 do
                   Begin
                     Mas[tmp].NameFile:='';
                     Mas[tmp].FlagDir:=False;
                   End;
        End;

  Procedure ListFile;
  Var  CurNP : Word;
       CNS   : Word;
       SS    : String;
  Begin
     CNS:=1;
     CurNP:=1;
     ClearMas;
     If Length(CurPath)=3 then ss:=CurPath+'*.*'
                          else ss:=CurPath+'\*.*';
     FindFirst(ss,(($01 or $02) or ($04 or $10)) or $20,Rec);
     While (DosError=0) and (CurNP<=NumPage) do
        Begin
           If CurNP=NumPage then
                Begin
                    Mas[CNS].NameFile:=Rec.Name;
                  If (Rec.Attr and $10)<>0 then
                    Mas[CNS].FlagDir:=True;
                End;
           Inc(CNS);
           If CNS>SizeWin then
               Begin
                  CNS:=1;
                  Inc(CurNP);
               End;
           FindNext(Rec);
        End;
       For CNS:=1 to SizeWin do
                Begin
                   GoToXY(XWin,YWin+CNS-1);
                   Write('                       ');
                End;
       NumPos:=1;
  End;

Begin
    NumPage:=1;
    Disk:=0;
   If UserPath='' then
         Begin
           GetDir(Disk,CurPath);
         end
             else
         Begin
     If CurPath[2]=':' then
           Begin
            Ch:=CurPath[1];
            If ((Ch<'c') and (Ch>'z')) or ((Ch<'C') and (Ch>'Z')) then
                 Case Ch of
                   'c'..'z' : Disk:=Ord(Ch)-96;
                   'C'..'Z' : Disk:=Ord(Ch)-64;
                 End;
           End;
      {$I-}
           ChDir(UserPath);
      {$I+}
           GetDir(Disk,CurPath);
         End;

     NumPage:=1;
     NumPos:=1;
     ClearMas;
     Repeat
        ListFile;
        TextColor(7);
        For q:=1 to SizeWin do
               Begin
               If Mas[q].NameFile='' then Break;
                If q=NumPos then TextColor(15);
                 GoToXY(XWin,YWin+q-1);
                 Write(Mas[q].NameFile);
                 GoToXY(XWin+14,YWin+q-1);
                 If Mas[q].FlagDir then
          If (Mas[q].NameFile<>'.') and (Mas[q].NameFile<>'..') then
                         Write('<SUB-DIR>')
                                             else
                         Write('<UP--DIR>');
                If q=NumPos then TextColor(7);
               End;
         Dec(q);
       Repeat
       {-------------------------------------------------------------------}
       { Здесь можно использовать функцию  CheckPage  для проверки и       }
       { отображения на экране какого-либо символа/надписи, что страниц    }
       { больше чем одна и их можно просмотреть с помощью клавиш PgDn/PgUp }
       {-------------------------------------------------------------------}
       GoToXY(Xwin,YWin+NumPos-1);
        Ch:=ReadKey;
        If Ch=#0 then Ch:=ReadKey;
           Case Ch of
             #13 : Begin
                      If Mas[NumPos].FlagDir then
                         Begin
                          If (Mas[NumPos].NameFile='..')
                             or (Mas[NumPos].NameFile='.') then UpTreeDir
                               else
                           If Length(CurPath)=3 then
                                 CurPath:=CurPath+Mas[NumPos].NameFile
                                                else
                             CurPath:=CurPath+'\'+Mas[NumPos].NameFile;
                           NumPage:=1;
                         End
                             else
                         Ch:='A';
                   End;
             #10 : Begin
                   If Mas[NumPos].NameFile='.' then
                      Begin
                       Choice:=Copy(CurPath,1,3);
                       Exit;
                      End
                               else
                      If Mas[NumPos].NameFile='..' then
                                 Begin
                                  Choice:=CurPath;
                                  Exit;
                                 End
                               else
                        If Length(CurPath)=3 then
                           Begin
                            CurPath:=CurPath+Mas[NumPos].NameFile;
                            Choice:=CurPath;
                            Exit;
                           End
                                                          else
                      CurPath:=CurPath+'\'+Mas[NumPos].NameFile;
                      Choice:=CurPath;
                      Exit;
                   End;
         #72,#80 : Begin
                      TextColor(7);
                      GoToXY(XWin,YWin+NumPos-1);
                      Write(Mas[NumPos].NameFile);
                      GoToXY(XWin+14,YWin+NumPos-1);
                      If Mas[NumPos].FlagDir then
                        If (Mas[NumPos].NameFile<>'..') and
                                  (Mas[NumPos].NameFile<>'.')
                                                 then
                                                   Write('<SUB-DIR>')
                                                 else
                                                   Write('<UP--DIR>');
               If Ch=#72 then
                   If NumPos=1 then
                       Begin
                         NumPos:=SizeWin;
                         While Mas[NumPos].NameFile='' do Dec(NumPos);
                       End
                               else Dec(NumPos)
                         else
                   If NumPos=SizeWin then NumPos:=1
                                 else            {Нельзя применить          }
                    If Mas[NumPos+1].NameFile='' {два условия в одной строке}
                              then NumPos:=1 else 
                                                   Inc(NumPos);
                      TextColor(15);
                      GoToXY(XWin,YWin+NumPos-1);
                      Write(Mas[NumPos].NameFile);
                      GoToXY(XWin+14,YWin+NumPos-1);
                      If Mas[NumPos].FlagDir then
                        If (Mas[NumPos].NameFile<>'..') and
                               (Mas[NumPos].NameFile<>'.') then
                                                   Write('<SUB-DIR>')
                                                 else
                                                   Write('<UP--DIR>');
                      TextColor(7);
                   End;
             #27 : Begin
                      Choice:='';
                      Exit;
                   End;
             #73 : Begin
                     If NumPage>1 then Dec(NumPage);
                   End;
             #81 : Begin
                     If CheckPage then Inc(NumPage);
                     NumPos:=2;
                   End;
           End;
       Until (((Ch=#27) or (Ch=#10)) or ((Ch=#13) or (Ch=#73))) or (Ch=#81);
     Until (Ch=#27) or (Ch=#10);
End;

Function GetChar(x,y : Byte) : Byte;
Begin
  GetChar:=Ma[160*(y-1)+x*2-1];
End;

Function GetAttr(x,y : Byte) : Byte;
Begin
  GetAttr:=Ma[160*(y-1)+x*2];
End;

Procedure SetChar(x,y,c : Byte);
Begin
  Ma[160*(y-1)+x*2-1]:=c;
End;

Procedure SetAttr(x,y,a : Byte);
Begin
  Ma[160*(y-1)+x*2]:=a;
End;

Procedure Gxy(x,y:Byte;st:String);
Var w   : Byte;
    sqs : String[80];
Begin
 sqs:=st;
 For w:=1 to Length(sqs) do
          Begin
               SetChar(x+w-1,y,Ord(sqs[w]));
               SetAttr(x+w-1,y,TextAttr);
          End;
End;

Procedure Key(x,y,nb : Byte; KeyStr : String; ColorS, ColorB : Byte);
Var
   s  : String;
   s1 : String;
   ii : Byte;
Begin
  If Length(KeyStr)>nb then Exit;
  s:='';
  s1:='';
  For ii:=1 to nb do
     Begin
       s:=s+' ';
       s1:=s1+'▄';
     End;
  CF(White,ColorB);
  XY(x,y,s);
  CF(LightGray,Black);
  XY(x+1,y+1,s1);
  CF(Black,LightGray);
  XY(x+nb,y,'▄');

  s:=KeyStr;
  If nb>Length(KeyStr) then
     While Length(s)<nb do
       Begin
         s:=s+' ';
         s:=' '+s;
       End;
  If nb>Length(s) then s:=s+' ';
  CF(ColorS,ColorB);
  XY(x,y,s);
End;

Procedure KeyOk(x,y : Byte);
Begin
  CF(Yellow,Green);
  XY(x,y,'      ');
  C(White);
  XY(x+3,y,'Ok');
  CF(LightGray,Black);
  XY(x+1,y+1,'▄▄▄▄▄▄▄▄');
  CF(Black,LightGray);
  XY(x+8,y,'▄');
End;

Procedure KeyCancel(x,y : Byte);
Begin
  CF(White,Green);
  XY(x,y,'        ');
  C(Yellow);
  XY(x+1,y,'Cancel');
  CF(LightGray,Black);
  XY(x+1,y+1,'▄▄▄▄▄▄▄▄');
  CF(Black,LightGray);
  XY(x+8,y,'▄');
End;

Procedure Tim(x,y : Byte);
Var H,M,S,s_ : Word;
    hc       : Char;
    Lc       : LongInt;
Begin
  hc:=Chr(GetChar(x,y));
  GetTime(h,m,s,s_);
  Lc:=s_+s*100+m*6000+h*360000-Time;
  If Lc<0 then Lc:=-Lc;
  If Lc>=De then
    Begin
     hc:=Chr(GetChar(x,y));
     Case hc of
       '-' : Gxy(x,y,'\');
       '\' : Gxy(x,y,'|');
       '|' : Gxy(x,y,'/');
       '/' : Gxy(x,y,'-');
     else
       Gxy(x,y,'-');
     End;
     Time:=s_+s*100+m*6000+h*360000;
    End;
End;

Procedure TimOutDelay(x,y : Byte);
Var
    hc       : Char;
Begin
  hc:=Chr(GetChar(x,y));
     Case hc of
       '-' : Gxy(x,y,'\');
       '\' : Gxy(x,y,'|');
       '|' : Gxy(x,y,'/');
       '/' : Gxy(x,y,'-');
     else
       Gxy(x,y,'-');
     End;
End;

Procedure PushW(xa,ya,xb,yb:byte);
Var row,col : Byte;
Begin
 New(TPW);
   If PointWin=Nil then
          Begin
           PointWin:=TPW;
           TPW^.Next:=Nil;
          End
                   else
          Begin
           TPW^.Next:=PointWin;
           PointWin:=TPW;
          End;
   TPW^.x:=xa;
   TPW^.y:=ya;

   New(TPS1);
   TPW^.Pstr:=TPS1;
  For row:=ya to yb do
   Begin
     TPS1^.SS:='';
     For col:=xa to xb do
     Begin
       TPS1^.ss:=TPS1^.ss+Chr(GetChar(col,row));
       TPS1^.sa[col]:=GetAttr(col,row);
     End;
     If row<yb then
       Begin
         TPS2:=TPS1;
         New(TPS1);
         TPS2^.Next:=TPS1
       End
                else
       TPS1^.Next:=Nil;
   End;
End;

Procedure PopW;
Var row,col : Byte;
Begin
  If PointWin=Nil then Exit;
  TPW:=PointWin;
  PointWin:=TPW^.Next;
  TPS1:=TPW^.Pstr;
  row:=TPW^.y;
  While TPS1<>Nil do
   Begin
      For col:=TPW^.x to TPW^.x+Length(TPS1^.ss)-1 do
          Begin
            SetChar(col,row,Ord(TPS1^.ss[col-TPW^.x+1]));
            SetAttr(col,row,TPS1^.sa[col]);
          End;
      TPS2:=TPS1;
      TPS1:=TPS2^.Next;
      Dispose(TPS2);
      Inc(row);
   End;
   Dispose(TPW);
End;

Function GetNumFromSt(Sc : String) : LongInt;
Var Cs         : String;
    N1s,N2s,Ks : Byte;
    ddd,iii    : Integer;
Begin
  N1s:=0;
  Ks:=0;
    While (N1s=0) and (Ks<=Length(Sc)) do
      Begin
        Inc(Ks);
        If (Sc[Ks]>='0') and (Sc[Ks]<='9') then N1s:=Ks;
      End;
    If N1s=0 then
           Begin
             GetNumFromSt:=0;
             Exit;
           End;
    N2s:=N1s;
    While (Sc[N2s]>='0') and (Sc[N2s]<='9') do
                                              Inc(N2s);
    Cs:='';
    Dec(N2s);
    For Ks:=N1s to N2s do Cs:=Cs+Sc[Ks];
    Val(Cs,ddd,iii);
    GetNumFromSt:=ddd;
End;

Function EditStr(x,y,len : Byte; ColorS,GroundS : Byte;
                                      S0 : String; Var C0 : Char) : String;
Var Ch0  : Char;
    St0  : String;
    i0,q : Byte;
    Fl   : Boolean;
Begin
  HideCursor;
  St0:=S0;
  CF(ColorS,GroundS);
  For q:=1 to len  do xy(x+q-1,y,' ');
{  CF(ColorS,GroundSelect);
  xy(x,y,St0);}
  While Length(St0)<len do St0:=St0+' ';
  i0:=1;
  Repeat
     HideCursor;
     CF(ColorS,GroundS);
     xy(x,y,St0);
     GoToXY(x+i0-1,y);
     If CheckIns then FullCursor
                 else NormCursor;
    Ch0:=ReadKey;
    If Ch0=#0 then
        Begin
          Ch0:=ReadKey;
         Case Ch0 of
          #75 : If i0>1 then Dec(i0);
          #77 : If i0<len then Inc(i0);
{Delete}  #83 : Begin
                  For q:=i0 to len-1 do St0[q]:=St0[q+1];
                  St0[len]:=' ';
                End;
{Home}    #71 : Begin
                  i0:=1;
                End;
{End}     #79 : Begin
                  q:=len;
                  While (q>1) and (St0[q]=' ') do Dec(q);
                  i0:=q;
                End;
         End;
        End
              else
        Begin
{Bkspace}  If (Ch0=#8) and (i0>1) then
             Begin
               Dec(i0);
               For q:=i0 to len-1 do St0[q]:=St0[q+1];
               St0[len]:=' ';
             End     else
           If ((Ch0<>#9) and (Ch0<>#13)) and ((Ch0<>#27) and (Ch0>#31)) then
                    Begin
                     If CheckIns then St0[i0]:=Ch0
                       else
                        Begin
                          For q:=len downto i0+1 do St0[q]:=St0[q-1];
                          St0[i0]:=Ch0;
                        End;
                      If i0<len then Inc(i0);
                    End;
        End;
  Until (((Ch0=#9) or (Ch0=#13)) or (Ch0=#15)) or (Ch0=#27);
  C0:=Ch0;
  q:=len;
  While St0[q]=' ' do Dec(q);
  St0[0]:=Chr(q);
  EditStr:=St0;
  HideCursor;
End;

Procedure FrameCN(xa,ya,xb,yb,ColorFrame,ColorWin : Byte; sq : String);
Var w,e : Byte;
    qq  : String;
    kk  : Byte;
Begin
   qq:='║';
   e:=TextAttr;
   TextColor(ColorFrame);
   TextBackGround(ColorWin);
   Gxy(xa,ya,'╔');Gxy(xb,ya,'╗');
   Gxy(xa,yb,'╚');Gxy(xb,yb,'╝');
   For w:=xa+1 to xb-1 do
              Begin
                Gxy(w,ya,'═');
                Gxy(w,yb,'═');
                qq:=qq+' ';
              End;
   qq:=qq+'║';
   For w:=ya+1 to yb-1 do
              Begin
                Gxy(xa,w,qq);
              End;
   qq:=' '+sq+' ';
   If (Length(qq)<xb-xa-1) and (Length(sq)>0) then
                Gxy(xa+((xb-xa-Length(qq)+1) div 2),ya,qq);
   TextColor(LightGray);
   TextBackGround(Black);
   If yb+1<=25 then
   Begin
     kk:=xb-xa+1;
     If xb>78 then kk:=kk-(xb-78);
     WriteAtrib(xa+2,yb+1,kk,TextAttr);
   End;
   If xb+2<=80 then
     For w:=ya+1 to yb do WriteAtrib(xb+1,w,2,TextAttr)
   else
     If xb+1<=80 then
       For w:=ya+1 to yb do WriteAtrib(xb+1,w,1,TextAttr);
   TextAttr:=e;
End;

Function FindStr(SubStr,S : String) : Boolean;
Var q : Byte;
Begin
  FindStr:=False;
  For q:=1 to Length(SubStr) do SubStr[q]:=UpCase(SubStr[q]);
  For q:=1 to Length(S) do S[q]:=UpCase(S[q]);
  q:=Pos(SubStr,S);
  If q>0 then FindStr:=True;
End;

Function  GetString(x,y,n : Byte) : String;
Var q   : Byte;
    sss : String;
Begin
  GetString:='';
  sss:='';
  If (n<1) or (n>80) then Exit;
  For q:=1 to n do
      sss:=sss+Chr(GetChar(x+q-1,y));
  GetString:=sss;
End;

Function  CheckRShift     : Boolean;
Begin
  CheckRShift:=False;
  If (KeyFlag and $01)<>0 then CheckRShift:=True;
End;

Function  CheckLShift     : Boolean;
Begin
  CheckLShift:=False;
  If (KeyFlag and $02)<>0 then CheckLShift:=True;
End;

Function  CheckCtrl       : Boolean;
Begin
  CheckCtrl:=False;
  If (KeyFlag and $04)<>0 then CheckCtrl:=True;
End;

Function  CheckAlt        : Boolean;
Begin
  CheckAlt:=False;
  If (KeyFlag and $08)<>0 then CheckAlt:=True;
End;

Function  CheckScroll : Boolean;
Begin
  CheckScroll:=False;
  If (KeyFlag and $10)<>0 then CheckScroll:=True;
End;

Function  CheckNum    : Boolean;
Begin
  CheckNum:=False;
  If (KeyFlag and $20)<>0 then CheckNum:=True;
End;

Function  CheckCaps   : Boolean;
Begin
  CheckCaps:=False;
  If (KeyFlag and $40)<>0 then CheckCaps:=True;
End;

Function  CheckIns    : Boolean;
Begin
  CheckIns:=False;
  If (KeyFlag and $80)<>0 then CheckIns:=True;
End;

Procedure Bell;
Begin
     Sound (500); Delay (30);
     Sound (300); Delay (10);
     NoSound;
End;

Function  Supplement(St : String; k,tip : Byte) : String;
{                                   tip = 0-center, 1-left, 2-Right  }
Var
   SS : String;
Begin
  SS:=St;
  Case tip of
    0 : Begin
          While Length(SS)<k-1 do SS:=' '+SS+' ';
          If Length(SS)<k then SS:=SS+' ';
        End;
    1 : While Length(SS)<k do SS:=' '+SS;
    2 : While Length(SS)<k do SS:=SS+' ';
  End;
  Supplement:=SS;
End;

Function  CutStr(St : String; k : Byte) : String;
Var i : Byte;
    s : String;
Begin
  s:='';
  If Length(St)<=k then s:=St
                   else
     For i:=1 to k do s:=s+St[i];
  CutStr:=s;
End;

Function M3x3(m3 : d3x3) : Real;
Begin
  M3x3:=m3[1,1]*(m3[2,2]*m3[3,3]-m3[3,2]*m3[2,3])
       -m3[1,2]*(m3[2,1]*m3[3,3]-m3[3,1]*m3[2,3])
       +m3[1,3]*(m3[2,1]*m3[3,2]-m3[3,1]*m3[2,2]);
End;

Function M4x4(m4 : d4x4) : Real;
Var  a     : d3x3;
     i,j   : Byte;
     S4    : Real;
Begin
  For i:=2 to 4 do
   For j:=2 to 4 do a[i-1,j-1]:=m4[i,j];
  S4:=M3x3(a);

  For i:=2 to 4 do a[i-1,1]:=m4[i,1];
  For i:=2 to 4 do
   For j:=3 to 4 do a[i-1,j-1]:=m4[i,j];
  S4:=S4-M3x3(a);

  For i:=2 to 4 do a[i-1,3]:=m4[i,4];
  For i:=2 to 4 do
   For j:=1 to 2 do a[i-1,j]:=m4[i,j];
  S4:=S4+M3x3(a);

  For i:=2 to 4 do
   For j:=1 to 3 do a[i-1,j]:=m4[i,j];
  S4:=S4-M3x3(a);
  M4x4:=S4;
End;

Function M5x5(m5 : d5x5) : Real;
Var  b     : d4x4;
     i,j   : Byte;
     S5    : Real;
Begin
  For i:=1 to 4 do
   For j:=2 to 5 do b[i,j-1]:=m5[i,j];
  S5:=M4x4(b);

  For i:=1 to 4 do b[i,1]:=m5[i,1];
  For i:=1 to 4 do
   For j:=3 to 5 do b[i,j-1]:=m5[i,j];
  S5:=S5-M4x4(b);

  For i:=1 to 4 do
   For j:=1 to 2 do b[i,j]:=m5[i,j];
  For i:=1 to 4 do
   For j:=4 to 5 do b[i,j-1]:=m5[i,j];
  S5:=S5+M4x4(b);

  For i:=1 to 4 do b[i,4]:=m5[i,5];
  For i:=1 to 4 do
   For j:=1 to 3 do b[i,j]:=m5[i,j];
  S5:=S5-M4x4(b);

  For i:=1 to 4 do
   For j:=1 to 4 do b[i,j]:=m5[i,j];
  S5:=S5+M4x4(b);
  M5x5:=S5;
End;

Function M6x6(m6 : d6x6) : Real;
Var  c     : d5x5;
     i,j   : Byte;
     S6    : Real;
Begin
  For i:=1 to 5 do
   For j:=2 to 6 do c[i,j-1]:=m6[i,j];
  S6:=M5x5(c);

  For i:=1 to 5 do c[i,1]:=m6[i,1];
  For i:=1 to 5 do
   For j:=3 to 6 do c[i,j-1]:=m6[i,j];
  S6:=S6-M5x5(c);

  For i:=1 to 5 do
   For j:=1 to 2 do c[i,j]:=m6[i,j];
  For i:=1 to 5 do
   For j:=4 to 6 do c[i,j-1]:=m6[i,j];
  S6:=S6+M5x5(c);

  For i:=1 to 5 do
   For j:=1 to 3 do c[i,j]:=m6[i,j];
  For i:=1 to 5 do
   For j:=5 to 6 do c[i,j-1]:=m6[i,j];
  S6:=S6-M5x5(c);

  For i:=1 to 5 do c[i,5]:=m6[i,6];
  For i:=1 to 5 do
   For j:=1 to 4 do c[i,j]:=m6[i,j];
  S6:=S6+M5x5(c);

  For i:=1 to 5 do
   For j:=1 to 5 do c[i,j]:=m6[i,j];
  S6:=S6-M5x5(c);
  M6x6:=S6;
End;

Procedure u3(k : d3x3; l : f3; Var f : f3; Var D30 : Real);
Var
    x   : d3x3;
    q,a : Byte;
Begin
    d30:=m3x3(k);
    For a:=1 to 3 do
    Begin
      x:=k;
      For q:=1 to 3 do x[q,a]:=l[q];
      f[a]:=m3x3(x)/d30;
    End;
End;

Procedure u4(k : d4x4; l : f4; Var f : f4; Var D40 : Real);
Var
    x   : d4x4;
    q,a : Byte;
Begin
    d40:=m4x4(k);
    For a:=1 to 4 do
    Begin
      x:=k;
      For q:=1 to 4 do x[q,a]:=l[q];
      f[a]:=m4x4(x)/d40;
    End;
End;

Procedure u5(k : d5x5; l : f5; Var f : f5; Var D50 : Real);
Var
    x   : d5x5;
    q,a : Byte;
Begin
    d50:=m5x5(k);
    For a:=1 to 5 do
    Begin
      x:=k;
      For q:=1 to 5 do x[q,a]:=l[q];
      f[a]:=m5x5(x)/d50;
    End;
End;

Procedure u6(k : d6x6; l : f6; Var f : f6; Var D60 : Real);
Var
    x   : d6x6;
    q,a : Byte;
Begin
    d60:=m6x6(k);
    For a:=1 to 6 do
    Begin
      x:=k;
      For q:=1 to 6 do x[q,a]:=l[q];
      f[a]:=m6x6(x)/d60;
    End;
End;

Function SqrIn(a : Real; n : Byte) : Real;
Var i : Byte;
   aa : real;
Begin
  If n>0 then
  Begin
    aa:=1;
    For i:=1 to n do aa:=aa*a;
    SqrIn:=aa;
  End
  else SqrIn:=1;
End;

Function SetBitByte(b : Byte; NumBit : Byte; SetCount : Byte) : Byte;
Var t : Byte;
Begin
  t:=0;
  If SetCount=1 then
  Begin
    If NumBit>0 then
      Asm
         mov   ah,b
         mov   al,1
         mov   cl,NumBit
         shl   al,cl
         or    ah,al
         mov   t,ah
      End
    else
      Asm
         mov   ah,b
         mov   al,1
         or    ah,al
         mov   t,ah
      End;
  End
    else {---===---}
  Begin
    If NumBit>0 then
      Asm
         mov   ah,b
         mov   cl,NumBit
         add   cl,1
         clc
         rcr   ah,cl
         clc
         rcl   ah,cl
         mov   t,ah
      End
    else
      Asm
         mov   ah,b
         clc
         rcr   ah,1
         clc
         rcl   ah,1
         mov   t,ah
      End;
  End;
  SetBitByte:=t;
End;

Function SetBitWord(w : Word; NumBit : Byte; SetCount : Byte) : Word;
Var t : Word;
Begin
  t:=0;
  If SetCount=1 then
  Begin
    If NumBit>0 then
      Asm
         mov   ax,w
         mov   bx,1
         mov   cl,NumBit
         shl   bx,cl
         or    ax,bx
         mov   t,ax
      End
    else
      Asm
         mov   ax,w
         mov   bx,1
         or    ax,bx
         mov   t,ax
      End;
  End
    else {---===---}
  Begin
    If NumBit>0 then
      Asm
         mov   ax,w
         mov   cl,NumBit
         add   cl,1
         clc
         rcr   ax,cl
         clc
         rcl   ax,cl
         mov   t,ax
      End
    else
      Asm
         mov   ax,w
         clc
         rcr   ax,1
         clc
         rcl   ax,1
         mov   t,ax
      End;
  End;
  SetBitWord:=t;
End;

Function  GetBitByte(b : Byte; NumBit : Byte) : Byte;
Begin
  GetBitByte:=0;
  If NumBit<8 then
    If (b and Round(SqrIn(2,NumBit)))<>0 then GetBitByte:=1;
End;

Function  GetBitWord(w : Word; NumBit : Byte) : Byte;
Begin
  GetBitWord:=0;
  If NumBit<16 then
    If (w and Round(SqrIn(2,NumBit)))<>0 then GetBitWord:=1;
End;

Procedure NormChar16;
Begin
  Asm
    mov      AH, 11h
    mov      AL, 14h
    mov      BL, 0
    Int      10h
  End;
End;

Procedure NormChar14;
Begin
  Asm
    mov      AH, 11h
    mov      AL, 11h
    mov      BL, 0
    Int      10h
  End;
End;

Procedure NormChar8;
Begin
  Asm
    mov      AH, 11h
    mov      AL, 12h
    mov      BL, 0
    Int      10h
  End;
End;

Function HD(He : String2) : Byte;
Var de : Byte;
    i  : Byte;
Begin
  De:=0;
  For i:=1 to 2 do
    Case He[i] of
      '0' : De:=De+Round(SqrIn(16,2-i))*0;
      '1' : De:=De+Round(SqrIn(16,2-i))*1;
      '2' : De:=De+Round(SqrIn(16,2-i))*2;
      '3' : De:=De+Round(SqrIn(16,2-i))*3;
      '4' : De:=De+Round(SqrIn(16,2-i))*4;
      '5' : De:=De+Round(SqrIn(16,2-i))*5;
      '6' : De:=De+Round(SqrIn(16,2-i))*6;
      '7' : De:=De+Round(SqrIn(16,2-i))*7;
      '8' : De:=De+Round(SqrIn(16,2-i))*8;
      '9' : De:=De+Round(SqrIn(16,2-i))*9;
  'A','a' : De:=De+Round(SqrIn(16,2-i))*10;
  'B','b' : De:=De+Round(SqrIn(16,2-i))*11;
  'C','c' : De:=De+Round(SqrIn(16,2-i))*12;
  'D','d' : De:=De+Round(SqrIn(16,2-i))*13;
  'E','e' : De:=De+Round(SqrIn(16,2-i))*14;
  'F','f' : De:=De+Round(SqrIn(16,2-i))*15;
    End;
  HD:=De;
End;

Function BD(Bi : String8) : Byte;
Var de : Byte;
    i  : Byte;
Begin
  For i:=1 to 8 do
    If Bi[i]='0' then de:=SetBitByte(de,8-i,0)
                 else de:=SetBitByte(de,8-i,1);
  BD:=De;
End;

Function x_Y(x,y : Double) : Double;
Var
  n : LongInt;
  k : Double;
Begin
  k:=x;
  n:=0;
  While (k>1.00000001) or (k<0.99999999) do
  Begin
    k:=sqrt(k);
    n:=n+1;
  End;
  k:=(k-1)*y+1;
  While n>0 do
  Begin
    k:=k*k;
    n:=n-1;
  End;
  x_Y:=k;
End;

Function ArcCos(as : Real) : Real;
Var
  aas : Real;
Begin
  aas:=ArcTan(sqrt(1-sqr(as))/as);
  If as<0 then ArcCos:=180+aas*180/Pi
    else
      ArcCos:=aas*180/Pi;
End;

Function ArcSin(sa : Real) : Real;
Var
  ssa : Real;
Begin
  ssa:=ArcTan(sa/sqrt(1-sqr(sa)));
  ArcSin:=ssa*180/Pi;
End;

Procedure ViewWin(x1,y1,x2,y2,FrameColor,WinColor,TxtColor : Byte;
                  NameFrame,NameFile : String);
{  Тень по краю окна: по X справа  +2 знакоместа  }
{                     по Y снизу   +1 знакоместо  }
{  x2-x1-1   - ширина окна                        }
{  y2-y1-1   - высота окна                        }
Const
    MaxBufSt     = 300;
Type
    StrBuf       = Array[1..MaxBufSt] of ^String;
Var
  Ch             : Char;
  i              : Word;
  Buf            : StrBuf;
  f              : Text;
  MaxSt,CurSt    : LongInt; {Кол-во строк в файле, Текущий номер строки для следующего чтения}
  BufP           : LongInt; {Указатель начала буффера в файле (с какой строки)}
  StInBuf        : Word;    {Указатель начальной строки экрана в буффере}
  TxtAtr,OffSet  : Byte;

  Function MaxLength : Byte;
  Var ii,jj : Byte;
  Begin
    jj:=Length(Buf[StInBuf]^);
    For ii:=StInBuf to StInBuf+y2-y1-2 do
      If MaxSt>y2-y1-1 then
      Begin
        If jj<Length(Buf[ii]^) then jj:=Length(Buf[ii]^);
      End
        else
      Begin
        If ii<=MaxSt then
          If jj<Length(Buf[ii]^) then jj:=Length(Buf[ii]^);
      End;
    MaxLength:=jj;
  End;

  Procedure SeekSt(NNst : LongInt);
  Begin
    If CurSt<>NNst then
    Begin
      If CurSt>NNst then
      Begin
        Close(f);
        Reset(f);
        CurSt:=1;
      End;

      While CurSt<NNst do
      Begin
        Readln(f);
        Inc(CurSt);
      End;
    End;
  End;                           {  |~~~~~~~~|                                   }
                                 {  | File   |                                   }
  Procedure LoadBuffer;          {  |--------+---+      BufP                     }
  Var  NNbuf : Word;             {  | Buffer |   |                               }
       STIF  : LongInt;          {  |________|___|___                            }
  Begin                          {  | Screen |   |   |  StInBuf<=>BufP+StInBuf-1 }
    STIF:=BufP+StInBuf-1;        {  |        |   |   |                           }
    If (MaxSt<MaxBufSt) or       {  |        |   |   |                           }
       (STIF<(MaxBufSt-30)) then {  |________|___|___|  StInBuf+y2-y1-2          }
    Begin                        {  |        |   |                               }
      BufP:=1;                   {  |--------+---+      BufP+MaxBufSt-1          }
      StInBuf:=STIF;             {  |________|          MaxSt                    }
    End
      else
    Begin
      If STIF>MaxSt-MaxBufSt+30 then
      Begin
        BufP:=MaxSt-MaxBufSt+1;
        StInBuf:=STIF-BufP+1;
      End
        else
      Begin
        BufP:=STIF-(MaxBufSt div 2);
        StInBuf:=STIF-BufP+1;
      End;
    End;
    NNBuf:=1;
    SeekSt(BufP);
    While (NNBuf<=MaxBufSt) and (not EOF(f)) do
    Begin
      ReadLn(f,Buf[NNbuf]^);
      Inc(NNbuf);
      Inc(CurSt);
    End;
  End;

  Procedure ShowScreen;
  Var
    j  : Byte;
  Begin
    For j:=1 to y2-y1-1 do
    Begin
      If j<=MaxSt then
        Gxy(x1+1,y1+j,Supplement(CutStr(Copy(Buf[StInBuf+j-1]^,OffSet,255),x2-x1-1),x2-x1-1,2))
      else
        Gxy(x1+1,y1+j,Supplement(CutStr(' ',x2-x1-1),x2-x1-1,2))
    End;
  End;

Begin
  OffSet:=1;
  Cursor(False);
  For i:=1 to MaxBufSt do New(Buf[i]);

  StInBuf:=1;
  BufP:=1;
  MaxSt:=0;

  Assign(f,NameFile);
  Reset(f);
  While not EOF(f) do
  Begin
    Readln(f);
    Inc(MaxSt);
  End;
  Close(f);
  Reset(f);
  CurSt:=1;

  TxtAtr:=TextAttr;
  PushW(x1,y1,x2+2,y2+1);
  FrameCN(x1,y1,x2,y2,FrameColor,WinColor,NameFrame);
  Window(x1+1,y1+1,x2-1,y2-1);
  CF(TxtColor,WinColor);

   LoadBuffer;
   ShowScreen;
  Repeat
    C(White);
    If MaxSt>=y2-y1-1 then
      Gxy(x2-4,y1,Supplement(IntToStr((BufP+StInBuf-2)*100 div (MaxSt-(y2-y1-1)))+'%',4,1))
    else
      Gxy(x2-4,y1,Supplement('100%',4,1));
     Repeat
       Tim(x1+1,y1);
     Until KeyPressed;
    C(TxtColor);
     Ch:=ReadKey;
     If Ch=#0 then Ch:=ReadKey;
          Case Ch of
{Up}        #72  : Begin
                    If StInBuf>1 then
                    Begin
                      Dec(StInBuf);
                      GoToXY(1,1);
                      InsLine;
                      Gxy(x1+1,y1+1,Supplement(CutStr(Copy(Buf[StInBuf]^,OffSet,255),x2-x1-1),x2-x1-1,2));
                    End
                      else
                    Begin
                      LoadBuffer;
                      If StInBuf>1 then
                      Begin
                        Dec(StInBuf);
                        GoToXY(1,1);
                        InsLine;
                        Gxy(x1+1,y1+1,Supplement(CutStr(Copy(Buf[StInBuf]^,OffSet,255),x2-x1-1),x2-x1-1,2));
                      End;
                    End;
                   End;
{Down}      #80  : Begin
                     If StInBuf+y2-y1-2<MaxBufSt then
                     Begin
                       If (MaxSt>y2-y1-1) and (StInBuf+y2-y1-2<MaxSt) then
                       Begin
                         Inc(StInBuf);
                         GoToXY(1,1);
                         DelLine;
                         Gxy(x1+1,y2-1,Supplement(CutStr(Copy(Buf[StInBuf+y2-y1-2]^,OffSet,255),x2-x1-1),x2-x1-1,2));
                       End;
                     End
                       else
                     Begin
                       LoadBuffer;
                       If StInBuf+y2-y1-2<MaxBufSt then
                       Begin
                         Inc(StInBuf);
                         GoToXY(1,1);
                         DelLine;
                         Gxy(x1+1,y2-1,Supplement(CutStr(Copy(Buf[StInBuf+y2-y1-2]^,OffSet,255),x2-x1-1),x2-x1-1,2));
                       End
                     End;
                   End;
{PgUp}      #73  : Begin
                    If StInBuf>=y2-y1-1 then
                    Begin
                      StInBuf:=StInBuf-(y2-y1-1)+1;
                      ShowScreen;
                    End
                      else
                    Begin
                      LoadBuffer;
                      If StInBuf>=y2-y1-1 then
                      Begin
                        StInBuf:=StInBuf-(y2-y1-1)+1;
                        ShowScreen;
                      End
                        else
                      Begin
                        StInBuf:=1;
                        ShowScreen;
                      End;
                    End;
                   End;
{PgDn}      #81  : Begin
                     If StInBuf+y2-y1-2+y2-y1-2<=MaxBufSt then
                     Begin
                       If MaxSt>y2-y1-1 then
                       Begin
                         If StInBuf+y2-y1-2+y2-y1-2<=MaxSt then
                           StInBuf:=StInBuf+y2-y1-2
                         else
                           StInBuf:=MaxSt-(y2-y1-1)+1;
                         ShowScreen;
                       End;
                     End
                       else
                     Begin
                       LoadBuffer;
                       If StInBuf+y2-y1-2+y2-y1-2<=MaxBufSt then
                       Begin
                         StInBuf:=StInBuf+y2-y1-2;
                         ShowScreen;
                       End
                         else
                       Begin
                         StInBuf:=MaxBufSt-(y2-y1-1)+1;
                         ShowScreen;
                       End;
                     End;
                   End;
{Left}      #75  : If OffSet>1 then
                   Begin
                     Dec(OffSet);
                     ShowScreen;
                   End;
{Right}     #77  : If OffSet<255 then
                   Begin
                     Inc(OffSet);
                     ShowScreen;
                   End;
{Home}      #71  : Begin
                     OffSet:=1;
                     ShowScreen;
                   End;
{End}       #79  : Begin
                     OffSet:=MaxLength-(x2-x1-1)+1;
                     ShowScreen;
                   End;
{Ctrl+PgUp} #132 : Begin
                     BufP:=1;
                     StInBuf:=1;
                     LoadBuffer;
                     ShowScreen;
                   End;
{Ctrl+PgDn} #118 : If MaxSt>y2-y1-1 then
                   Begin
                     BufP:=MaxSt-MaxBufSt+1;
                     StInBuf:=MaxBufSt-(y2-y1-1)+1;
                     LoadBuffer;
                     ShowScreen;
                   End;
          End;
  Until Ch=#27;
  Cursor(True);
  Close(f);
  PopW;
  For i:=1 to MaxBufSt do Dispose(Buf[i]);
End;

Begin
  PointWin:=Nil;
end.
{$N-}