(* MENU_FMS использует: KEYS_FMS *)
(* OKHO_FMS *)
(* STAK_FMS *)
(* TYPE_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O-,R+,S+,V+,X-}
{$M 16384,0,655360}
unit MENU_FMS;
INTERFACE
uses DOS, CRT, KEYS_FMS, OKHO_FMS, STAK_FMS, TYPE_FMS;
TYPE
pMenuRec = ^MenuRec;
Uncodul = array [1..32] of integer;
Resc = record XH,YH,XK,YK : integer end;
MenuRec = record Kall : integer; { Всего элементов меню }
Kscr : integer; { Сколько элементов на экране }
Curs : integer; { Начальная установка курсора }
Surs : integer;
Base : integer;
Rend : boolean;
OnScr : integer;
Codul : uncodul;
Teke : integer;
pCurs : integer;
pSurs : integer;
pBase : integer;
pOnScr : integer;
Mafi : Resc; { Главное рабочее поле }
Sufi : Resc; { Вспомогательное рабочее поле }
Cufi : Resc; { Место нахождения курсора }
Grad : Resc; { "Градусник" + }
CoMa : Byte; { Окраска главного поля }
CoSu : Byte; { Окраска вспом. поля }
CoCu : Byte; { Окраска курсора }
MeDel : boolean; { Управление KillElem_Edi }
Pindx : pointer; { Для индексного файла }
NuPan : LongInt; { Номер панели in MG.EXE }
NaPan : String; { Фильтр или наименование меню }
end;
TypeCodeElem = function (O : pMenuRec; N : integer) : integer;
TypeBornElem = procedure(O : pMenuRec; H,K : integer);
TypeKillElem = procedure(O : pMenuRec; B,H,K : integer);
TypeBornCurs = procedure(O : pMenuRec; Base,Curs,Surs : integer);
TypeElseBody = procedure(O : pMenuRec);
TypeBody = procedure(O : pMenuRec);
procedure AddrCurs(O : pMenuRec; E : integer);
procedure MenuInit(O : pMenuRec; fKall : integer);
procedure MenuRun(O : pMenuRec; CodeElem : TypeCodeElem;
BornElem : TypeBornElem;
KillElem : TypeKillElem;
BornCurs : TypeBornCurs;
MenuBody : TypeBody);
procedure MenuOrd(O : pMenuRec; CodeElem : TypeCodeElem;
BornElem : TypeBornElem;
KillElem : TypeKillElem);
procedure MenuDone(O : pMenuRec);
procedure RectElem (O : pMenuRec; var R : Resc; H : integer);
procedure KillCurs (O : pMenuRec);
function CodeElem_All(O : pMenuRec; N : integer) : integer;
procedure KillElem_Emp(O : pMenuRec; B,H,K : integer);
procedure KillElem_All(O : pMenuRec; B,H,K : integer);
procedure BornCurs_Emp(O : pMenuRec; Base,Curs,Surs : integer);
procedure BornCurs_All(O : pMenuRec; Base,Curs,Surs : integer);
procedure MenuBody_Pnl(O : pMenuRec; ElseBody : TypeElseBody);
procedure MenuBody_All(O : pMenuRec; ElseBody : TypeElseBody);
procedure MenuBody_Vir(O : pMenuRec; ElseBody : TypeElseBody);
procedure MenuBody_Gor(O : pMenuRec; ElseBody : TypeElseBody);
procedure RescFul(var R : Resc; A,B,C,D : integer);
procedure RescInc(var R : Resc; A,B,C,D : integer);
procedure RescExt(var R : Resc; Dx, Dy : integer);
procedure RescAdd(var R : Resc; Xa, Ya : integer);
procedure RescCut(var R,M : Resc);
function RescOKK(var R : Resc) : boolean;
function RescLeg(var R,M : Resc) : boolean;
procedure RescUni(var R,Q : Resc);
procedure RescWin(var R : Resc; A : integer);
procedure RescWit(var R : Resc; C : integer);
procedure RescPAM(var R : Resc; A : integer; var P : Todul);
procedure COEXYY(X,YH,YK : integer);
procedure COEXXY(XH,XK,Y : integer);
procedure SimpMenu(var M : MenuRec);
VAR Glob_Menu : MenuRec;
CONST aGlob : pMenuRec = addr(Glob_Menu);
Size_Menu : integer = SizeOf( MenuRec );
{ Обслуживание процессов }
TYPE tServ = record WOS : boolean;
POS : byte;
CKO : integer;
LCH : char;
LAT : byte;
RSC : Resc end;
VAR Serv : tServ;
procedure CentServ(Y,A : integer; S : String);
procedure InitServ(S : String);
procedure BornServ(S1,S2 : String);
procedure PrepServ(FC : char; FA : integer; LC : char;
LA,CK : integer);
procedure SimpServ(TIT,FNA : String; Ko : integer);
procedure MarkServ(N : LongInt);
procedure DoneServ;
procedure Bye_Serv(S : String);
IMPLEMENTATION
TYPE UTB = array [0..65534] of byte;
UTP = array [1..16383] of pointer;
UniElem = record X,Y : integer; N : String end;
ptrUniElem = ^UniElem;
UniP = array [1..16383] of ptrUniElem;
procedure RescFul(var R : Resc; A,B,C,D : integer);
begin with R do begin
XH:=A;
YH:=B;
XK:=C;
YK:=D
end end;
procedure RescInc(var R : Resc; A,B,C,D : integer);
begin with R do begin
Inc(XH,A);
Inc(YH,B);
Inc(XK,C);
Inc(YK,D)
end end;
procedure RescExt(var R : Resc; Dx,Dy : integer);
begin RescInc(R,-Dx,-Dy,+Dx,+Dy) end;
procedure RescAdd(var R : Resc; Xa,Ya : integer);
begin RescInc(R,Xa,Ya,Xa,Ya) end;
procedure RescCut(var R,M : Resc);
procedure E(var A : integer; H,K : integer);
begin if A < H then A:=H
else if K < A then A:=K
end;
begin E(R.XH,M.XH,M.XK);
E(R.YH,M.YH,M.YK);
E(R.XK,M.XH,M.XK);
E(R.YK,M.YH,M.YK) end;
function RescLeg(var R,M : Resc) : boolean;
function E(A,H,K : integer) : boolean;
begin E:=(H <= A) and (A <= K)
end;
begin RescLeg:=E(R.XH,M.XH,M.XK) and
E(R.YH,M.YH,M.YK) and
E(R.XK,M.XH,M.XK) and
E(R.YK,M.YH,M.YK) and
(R.XH <= R.XK) and
(R.YH <= R.YK) end;
procedure RescUni(var R,Q : Resc);
begin if Q.XH < R.XH then R.XH:=Q.XH;
if Q.YH < R.YH then R.YH:=Q.YH;
if Q.XK > R.XK then R.XK:=Q.XK;
if Q.YK > R.YK then R.YK:=Q.YK end;
function RescOKK(var R : Resc) : boolean;
begin with R do
RescOKK:=(1 <= XH) and (XH <= XK) and (XK <= 80) and
(1 <= YH) and (YH <= YK) and (YK <= 25) end;
procedure RescWin(var R : Resc; A : integer);
begin if RescOKK(R) then
with R do EmpWin(XH,YH,XK,YK,A) end;
procedure RescWit(var R : Resc; C : integer);
var I : integer;
begin RescWin(R,C);
with R do begin
for I:=YH+1 to YK+1 do begin
SCR[I,XK+1].att:=$07;
SCR[I,XK+2].att:=$07;
end;
for I:=XH+2 to XK do SCR[YK+1,I].att:=$07;
end end;
procedure RescPAM(var R : Resc; A : integer; var P : Todul);
var I : integer;
begin with R do begin
for I:=XH+1 to XK-1 do begin
ISC(I,YH,P[1,2],A);
ISC(I,YK,P[1,2],A);
end;
for I:=YH+1 to YK-1 do begin
ISC(XH,I ,P[2,1],A);
ISC(XK,I ,P[2,1],A)
end;
ISC(XH,YH,P[1,1],A); ISC(XK,YH,P[1,5],A);
ISC(XH,YK,P[5,1],A); ISC(XK,YK,P[5,5],A)
end end;
procedure COEXYY(X,YH,YK : integer);
var I : integer;
A : char;
begin A:=SCR[YH,X].txt;
if A = Podul[1,2] then A:=Podul[1,3]
else if A = Wodul[1,2] then A:='С';
SCR[YH,X].txt:=A;
for I:=YH+1 to YK-1 do SCR[I,X].txt:=Podul[2,1];
A:=SCR[YK,X].txt;
if A = Podul[1,2] then A:=Podul[5,3]
else if A = Wodul[1,2] then A:='П';
SCR[YK,X].txt:=A end;
procedure COEXXY(XH,XK,Y : integer);
var I : integer;
begin SCR[Y,XH].txt:='З';
for I:=XH+1 to XK-1 do SCR[Y, I].txt:=Podul[1,2];
SCR[Y,XK].txt:='¶' end;
procedure SimpMenu(var M : MenuRec);
begin with M do begin
RescFul(Sufi, 1,1, 0, 0);
Cufi:=Sufi;
Grad:=Sufi;
Curs:=1;
Surs:=1;
MeDel:=true
end end;
procedure AddrCurs(O : pMenuRec; E : integer);
begin with O^ do begin
Base:=0;
Curs:=E;
if Curs < 1 then Curs:= 1;
if Kall < Curs then Curs:=Kall;
if Curs <= Kscr then Base:=0
else if Kall-Kscr < Curs then Base:=Kall-Kscr
else Base:=Curs-Kscr div 2;
Curs :=Curs-Base;
end end;
procedure MenuInit(O : pMenuRec; fKall : integer);
begin with O^ do begin
Kall:=fKall;
Kscr:=Mafi.YK-Mafi.YH+1;
AddrCurs(O,Curs);
Surs :=1;
pOnScr:=0;
pBase :=0;
pCurs :=0;
pSurs :=0
end end;
procedure MenuDone(O : pMenuRec);
begin end;
procedure KillElem_Emp(O : pMenuRec; B,H,K : integer); begin end;
procedure KillElem_All(O : pMenuRec; B,H,K : integer);
var R : Resc;
J : integer;
begin for J:=H to K do begin
RectElem(O,R,J);
RescWin(R,O^.CoMa)
end end;
procedure KillCurs(O : pMenuRec);
var I : integer;
begin with O^ do begin
with Cufi do
for I:=XH to XK do SCR[YH,I].att:=CoMa;
if RescOKK(Sufi) then RescWin(Sufi,CoSu)
end end;
procedure BornCurs_Emp(O : pMenuRec; Base,Curs,Surs : integer);
begin RectElem(O,O^.Cufi,Curs) end;
procedure BornCurs_All(O : pMenuRec; Base,Curs,Surs : integer);
var I : integer;
begin with O^ do begin
RectElem(O,Cufi,Curs);
with Cufi do
for I:=XH to XK do SCR[YH,I].att:=CoCu
end end;
procedure RectElem(O : pMenuRec; var R : Resc; H : integer);
begin with O^ do begin
R:=Mafi;
Inc(R.YH,H-1);
R.YK:=R.YH
end end;
procedure BornGrad(O : pMenuRec);
const CUP = chr( 30);
CDN = chr( 31);
CTT = chr(177);
CSC = chr(254);
var S : EltSCR;
I,N : integer;
procedure TP(Y,A : integer; C : char); { Нанесение на экран }
begin S:=SCR[Y,O^.Grad.XH];
if S.att = A then
if S.txt = C then Exit;
S.att:=A;
S.txt:=C;
SCR[Y,O^.Grad.XH]:=S
end;
begin with O^ do begin
if not RescOKK(Grad) then Exit;
N:=Kall-Kscr;
if N <= 0 then Exit;
with Grad do begin
I:=YK-1-YH;
if I < 3 then Exit;
if Base = 0 then N:=1
else N:=(LongInt(Base)*(I-2)) div N + 2;
I:=(CoMa shl 4) or (Coma shr 4);
I:=I and $7F;
N:=YH+N;
TP(YH,I,CUP);
TP(N ,I,CSC);
TP(YK,I,CDN);
for I:=YH+1 to YK-1 do
if I <> N then TP(I,Coma,CTT)
end
end end;
procedure Replace(var F,T : Resc);
var I,J,SX,SY : integer;
W : boolean;
begin W:=(T.YH <= F.YH) and (F.YH <= T.YK);
SX:=2*(F.XK-F.XH)+2;
SY:= F.YK-F.YH;
for I:=0 to SY do begin
if W then J:= I
else J:=SY-I;
Move(SCR[F.YH+J,F.XH],SCR[T.YH+J,T.XH],SX)
end end;
procedure ReplElem(O : pMenuRec; pBS,FH,FK,BS,TH,TK : integer);
var I,K,M : integer;
W : boolean;
A,FC,FU,FN,TC,TU,TN : ReSc;
procedure Lor(var R : Resc; H,K : integer);
begin if TH < FH then RectElem(O,R,H+I-1)
else RectElem(O,R,K-I+1)
end;
procedure Unire(var C,U,N : Resc);
begin U:=C;
if A.XH < U.XH then U.XH:=A.XH;
if A.YH < U.YH then U.YH:=A.YH;
if A.XK > U.XK then U.XK:=A.XK;
if A.YK > U.YK then U.YK:=A.YK;
N.XH:=U.XH-C.XH;
N.YH:=U.YH-C.YH;
N.XK:=U.XK-C.XK;
N.YK:=U.YK-C.YK
end;
function Liker : boolean;
begin Liker:= (FN.XH = TN.XH) and
(FN.YH = TN.YH) and
(FN.XK = TN.XK) and
(FN.YK = TN.YK) and
((FN.XH = 0 ) and
(FN.XK = 0 ) or
(FN.YH = 0 ) and
(FN.YK = 0 ))
end;
begin K:=FK-FH+1;
I:=0;
while I < K do begin
I:=I+1;
Lor(FC,FH,FK);
Lor(TC,TH,TK);
W:=true;
while W and (I < K) do begin
I:=I+1;
Lor(A,FH,FK); Unire(FC,FU,FN);
Lor(A,TH,TK); Unire(TC,TU,TN);
W:=Liker;
if W then begin
FC:=FU;
TC:=TU
end else I:=I-1
end;
Replace(FC,TC);
end end;
function CodeElem_All(O : pMenuRec; N : integer) : integer;
begin CodeElem_All:=N end;
procedure EmptMenu(O : pMenuRec);
begin end;
procedure MenuBody_Vir(O : pMenuRec; ElseBody : TypeElseBody);
begin with O^ do begin
Cufi.XK:=Cufi.XH-1; { блокировать KillCurs }
Teke:=Gey;
case Teke of
UP : if 0 < Base then Base:=Base-1;
DOWN : if Base < Kall-Kscr then Base:=Base+1;
PgUp : if 0 < Base then Base:=Base-(Kscr-1);
PgDn : if Base < Kall-Kscr then Base:=Base+(Kscr-1);
ENDD : if Kscr < Kall then Base:=Kall-Kscr;
HOME : Base:=0;
ESC,F10 : Rend:=true;
ELSE ElseBody(O);
end
end end;
procedure MenuBody_Pnl(O : pMenuRec; ElseBody : TypeElseBody);
begin
with O^ do begin
Teke:=Gey777;
case Teke of
UP : Curs:=Curs-1;
DOWN : Curs:=Curs+1;
PgUp : if 0 < Base then Base:=Base-(Kscr-1)
else Curs:=1;
PgDn : if Base+Kscr < Kall then Base:=Base+(Kscr-1)
else Curs:=Kscr;
ENDD : begin Curs:=Kscr; Base:=Kall-Kscr end;
HOME : begin Curs:= 1; Base:=0 end;
else ElseBody(O)
end
end end;
procedure MenuBody_All(O : pMenuRec; ElseBody : TypeElseBody);
begin
with O^ do begin
Teke:=Gey;
IF Kall <= Kscr
THEN case Teke of
UP : if OnScr = 0 then Curs:=0
else Curs:=(Curs+OnScr-2) mod OnScr + 1;
DOWN : if OnScr = 0 then Curs:=0
else Curs:= Curs mod OnScr + 1;
PgDn,ENDD : Curs:=OnScr;
PgUp,HOME : Curs:= 1;
else ElseBody(O)
end
ELSE case Teke of
UP : Curs:=Curs-1;
DOWN : Curs:=Curs+1;
PgUp : if 0 < Base then Base:=Base-(Kscr-1)
else Curs:=1;
PgDn : if Base+Kscr < Kall then Base:=Base+(Kscr-1)
else Curs:=Kscr;
ENDD : begin Curs:=Kscr; Base:=Kall-Kscr end;
HOME : begin Curs:= 1; Base:=0 end;
else ElseBody(O)
end
end end;
procedure MenuBody_Gor(O : pMenuRec; ElseBody : TypeElseBody);
begin
with O^ do begin
Teke:=Gey;
case Teke of
LEFT : if OnScr = 0 then Curs:=0
else Curs:=(Curs+OnScr-2) mod OnScr + 1;
RIGHT : if OnScr = 0 then Curs:=0
else Curs:= Curs mod OnScr + 1;
ENDD : Curs:=OnScr;
HOME : Curs:= 1;
else ElseBody(O)
end
end end;
procedure MenuRun(O : pMenuRec; CodeElem : TypeCodeElem;
BornElem : TypeBornElem;
KillElem : TypeKillElem;
BornCurs : TypeBornCurs;
MenuBody : TypeBody);
var H,I,J,L,M,I0,J0 : integer;
function Facommo(P,N : integer) : integer;
var K,L : integer;
begin with O^ do begin
K:=pOnScr-P;
L:= OnScr-N;
if K < L then L:=K;
N:=Base+N;
for K:=0 to L do
if Codul[P+K] <> CodeElem(O,N+K) then begin
Facommo:=K;
Exit
end;
Facommo:=L+1
end;
end;
function Normal(OS : integer; var H,K : integer) : boolean;
begin Normal:=false;
if K < H then Exit;
if OS < H then Exit;
if K < 1 then Exit;
if H < 1 then H:=1;
if OS < K then K:=OS;
if K < H then Exit;
Normal:=true
end;
procedure Killer(H,K : integer);
begin with O^ do
if Normal( pOnScr, H,K)
then KillElem(O,pBase, H,K)
end;
procedure Borner(H,K : integer);
begin with O^ do
if Normal(OnScr,H,K)
then BornElem(O ,H,K)
end;
begin
with O^ do begin
Rend:=false;
repeat
if Kscr < Kall then OnScr:=Kscr { Чистильщик }
else OnScr:=Kall;
if Curs < 1 then begin Curs:= 1; Base:=Base-1 end;
if OnScr < Curs then begin Curs:=OnScr; Base:=Base+1 end;
if Base < 0 then Base:=0;
if Kall-OnScr < Base then Base:=Kall-OnScr;
H:=Facommo(1,1); { Дирижер }
if (pCurs <> Curs) or
(pSurs <> Surs) or
(pOnScr <> H) or
( OnScr <> H) then begin
if pCurs <> 0 then KillCurs(O);
M:=0;
I0:=OnScr+1;
I:=H;
while I < OnScr-M do begin
I:=I+1;
J:=H;
while J < pOnScr-M do begin
J:=J+1;
L:=Facommo(J,I);
if M < L then begin
M:=L;
I0:=I;
J0:=J
end
end
end;
if 0 < M then
if J0 <> I0 then ReplElem(O,pBase,J0,J0+M-1, { Move to }
Base,I0,I0+M-1);
Killer(H +1, I0 -1);
Borner(H +1, I0 -1);
Killer(I0+M,pOnScr);
Borner(I0+M, OnScr);
for I:=1 to OnScr do
Codul[I]:=CodeElem(O,Base+I);
if Curs <> 0 then BornCurs(O,Base,Curs,Surs)
else EmptMenu(O)
end;
pCurs :=Curs;
pSurs :=Surs;
pBase :=Base;
pOnScr:=OnScr;
BornGrad(O);
MenuBODY(O);
until Rend;
end end;
{ MenuOrd : Реорганизовать меню на экране без входа в опрос }
procedure MenuBody_Exi(O : pMenuRec);
begin O^.Rend:=true end;
procedure MenuOrd(O : pMenuRec; CodeElem : TypeCodeElem;
BornElem : TypeBornElem;
KillElem : TypeKillElem);
begin O^.pCurs:=0; { Блокировать KillCurs }
MenuRun (O,CodeElem ,
BornElem ,
KillElem ,
BornCurs_Emp,
MenuBody_Exi) end;
{ ****Serv - Окно процесса }
procedure CentServ(Y,A : integer; S : String);
begin with Serv do begin
if WOS then Exit;
OnScrCYA(RSC.YH+Y,A,S);
POS:=40 { ??? }
end end;
procedure InitServ(S : String);
var I : integer;
begin with Serv do begin
if WOS then Exit;
RescFul(RSC,20,8,60,14);
with RSC do begin
PUSH(SCR[YH],(YK-YH+2)*SizeOf(LinSCR));
RescWit(RSC,SVpam);
RescExt(RSC,-1,0);
RescPAM(RSC,SVpam,Wodul);
RescExt(RSC,+1,0);
CentServ(0,SVpam,' '+S+' ')
end
end end;
procedure PrepServ(FC : char; FA : integer; LC : char; LA,CK : integer);
var I,B : integer;
begin with Serv do begin
if WOS then Exit;
LCH:=LC;
LAT:=LA;
B:=(RSC.XH+RSC.XK) div 2 - 17;
for I:=1 to 32 do ISC(B+I,RSC.YH+4,FC,FA);
CKO:=CK;
POS:=0;
end end;
procedure BornServ(S1,S2 : String);
begin Serv.WOS:=false;
InitServ(S1);
CentServ(2,SVpen,S2) end;
procedure SimpServ(TIT,FNA : String; Ko : integer);
begin Serv.WOS:=false;
InitServ(TIT);
CentServ(2,SVpen,FNA);
PrepServ('±',SVpam,' ',$07,Ko) end;
procedure MarkServ(N : LongInt);
var I,B : integer;
begin with Serv do begin
if WOS then Exit;
N:=N shl 5;
N:=N div CKO;
B:=(RSC.XH+RSC.XK) div 2 - 17;
for I:=POS+1 to N do
if B+I <= 80 then ISC(B+I,RSC.YH+4,LCH,LAT);
POS:=N
end end;
procedure DoneServ;
begin with Serv do
if not WOS then POP(SCR[RSC.YH]) end;
procedure Bye_Serv(S : String);
begin CentServ(4,SVpam,S);
CentServ(5,SVpen,'Нажмите любую клавишу...');
with Serv.RSC do Goto_Scurs(XH+32,YH+5);
PressAnyKey;
DoneServ end;
end.
|