(* MAIN_FMS использует: DESK_FMS *)
(* D_UNIT *)
(* EDIS_FMS *)
(* EXIT_FMS *)
(* FACE_FMS *)
(* INFO_FMS *)
(* KEYS_FMS *)
(* LAYS_FMS *)
(* LOAD_FMS *)
(* MENU_FMS *)
(* OKHO_FMS *)
(* OPEN_FMS *)
(* OVER_FMS *)
(* SELE_FMS *)
(* STAK_FMS *)
(* TEST_FMS *)
(* TYPE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O+,R+,S+,V+,X-}
{$M 16384,0,65536}
Unit MAIN_FMS;
INTERFACE
uses CRT, DOS, TYPE_FMS, STAK_FMS, OKHO_FMS, KEYS_FMS, OVER_FMS,
SELE_FMS, EDIS_FMS, MENU_FMS, LOAD_FMS, LAYS_FMS,
TEST_FMS, INFO_FMS, DESK_FMS, OPEN_FMS, UNIF_FMS,
FACE_FMS, EXIT_FMS, D_Unit;
procedure MAIN_MGE;
IMPLEMENTATION
function CodeElem_Edi(O : pMenuRec; N : integer) : integer;
var H,K,I : integer;
W,V : boolean;
begin H:=0; { DOMAP[K] = К-во 1-ц в FIMAP[1..K-1] }
K:=COMAP;
repeat
I:=(H + K) div 2;
V:=(DOMAP[I] < N);
W:=V and (N <= DOMAP[I+1]);
if not W then begin
if V then H:=I+1
else K:=I;
I:=(H + K) div 2
end;
until W;
N:=N-DOMAP[I];
I:=16*I-1;
repeat
I:=I+1;
if TSTMAP(I) then Dec(N)
until N = 0;
CodeElem_Edi:=I end;
procedure IniLinWRK(O : pMenuRec);
var I : integer;
begin with O^.Mafi do begin
LinWRK:=SCR[YH];
for I:=XH to XK do ICH(I,' ',O^.CoMa)
end;
ICH(78,'|',CPsys);
ICH(79,' ',CPsys);
ICH(80,' ',CPsys) end;
{ FIS_Elt : F - Номер поля; D - Номер строки в поле }
{ Res = заполненный селектор строки FIS }
procedure FIS_Elt(F,D : integer);
var I,J : integer;
H : pHead;
function DD(V : integer) : boolean;
begin Dec(D);
if D = 0 then begin
FIS[1]:=I;
FIS[2]:=V;
DD:=true
end else DD:=false
end;
begin FillChar(FIS,4,0); { FIS:=0 }
LoadField(F);
H:=MEAD^.BDS[F].DTL;
if H <> NIL then
for I:=1 to H^.HSF do
with H^.BDS[I] do
IF DTL^.KND = 4
THEN begin for J:=1 to DTL^.HSF do
if DD(J) then Exit end
ELSE begin if DD(0) then Exit end end;
{ AddrElt : F - Номер поля; D - Номер строки в поле }
{ Res = - корневой pНеad строки }
procedure AddrElt(var HH : pHead; var NN : integer; F,D : integer);
begin FIS_Elt(F,D);
NN:=FIS[1];
if NN = 0 then HH:=MEAD else begin
HH:=MEAD^.BDS[F].DTL;
if FIS[2] <> 0 then begin
HH:=HH^.BDS[NN].DTL;
NN:=FIS[2]
end
end end;
procedure QuExten(H : pHead; N,L : integer);
var I : integer;
begin if H^.KND <> 4 then Exit;
for I:=L-N+1 to L-N+H^.HSF do
if not TSTMAP(I) then begin
ICH(80,PPC,CPppc);
Exit
end end;
procedure Out_Elem(O : pMenuRec; F,N,L,Y : integer);
var I,X,J,C : integer;
H : pHead;
B : boolean;
R,Q : Alfa;
begin Inc(Y,O^.Mafi.YH-1);
X:=O^.Mafi.XH-1;
IniLinWRK(O);
AddrElt(H,J,F,N);
QuExten(H,J,L );
if J = 0 then
with MEAD^.BDS[F] do begin
if OKP < 1 then J:=O^.CoMa
else J:=OKP;
if 127 < J then J:=O^.Coma;
In_LinWRK(X,AlfaName(CTP),J);
SCR[Y]:=LinWRK;
Exit
end;
if J = 1 then { Заголовок поля }
if (H^.KND = 2) or (H^.BK_POS = 1) then
with MEAD^.BDS[F] do begin
Q:=AlfaName(CTP);
B:=false;
if Modes[Defi] then begin
R:=AlfaName(TIT);
B:=(X+Length(Q)+Length(R) <= CR_TOX)
end;
if B then Q:=Q+R
else Q:=Copy(Q+Csps(4),1,4)+':';
if (0 < OKP) and (OKP <= 255) then C:=OKP
else C:=O^.CoMa;
In_LinWRK(X,Q+' ',C)
end;
CBEPTKA(H,J); { SELE_FMS }
LineOn(Y);
Pos79(Y,Lask(H,J,MKP)) end;
procedure BornElem_Edi(O : pMenuRec; H,K : integer);
var I,J,L,E : integer;
begin CX:=0;
L:=0;
with O^ do begin
E:=-Base;
with Mafi do begin
if 0 < Base then OnScrXYA(78,YH-1,CMpam,'-')
else OnScrXYA(78,YH-1,CMpam,'С');
if Base+Kscr < Kall then OnScrXYA(78,YK+1,CMpam,'-')
else OnScrXYA(78,YK+1,CMpam,'П')
end
end;
for I:=1 to MEAD^.HSF do
for J:=1 to MEAD^.BDS[I].CR_FRX do begin
L:=L+1;
if TSTMAP(L) then begin
Inc(E);
if H <= E then Out_Elem(O,I,J,L,E);
if K <= E then Exit;
end
end end;
procedure KillElem_Edi(O : pMenuRec; B,H,K : integer);
var J : integer;
begin if not O^.MeDel then begin
O^.MeDel:=true;
Exit
end;
IniLinWRK(O);
for J:=H to K do SCR[O^.Mafi.YH-1+J]:=LinWRK end;
procedure Key_Filling;
var S,R : String;
G,C : String[63];
H : pHead;
N,E : integer;
begin if Fin_Str(S,CKEY) then begin
if CKEY = '' then Exit;
S:=S+'.'; { abs(FITEK) -> <наворот>.<лог.номер> }
if Fin_Str(R,S) then;
Val_Int(R,N,E);
G:=BORN_HABOPOT(N)+'.'+S;
G[0]:=Pred(G[0]); { Префикс пути }
while Fin_Str(S,CKEY) do begin
C:=S;
S:=G+S; { Путь }
if Fin_Str(R,CKEY) then { R = Значение было }
if Pth_Audi(S) = 0 then begin
S:=G+C;
if Pth_Load(S,false,H,N) then
if Lask( H,N,COF) then begin
UnoStr(S,H,N,false); { Новое значение }
if S <> '' then
if S <> R then INKEYSER(G+C)
end
end
end
end end;
procedure BornCurs_Edi(O : pMenuRec; Base,Curs,Surs : integer);
var I,J,E,Y : integer;
begin with O^ do begin
E:=Base+Curs;
Y:=Mafi.YH-1+Curs;
WherElt(E , I,J);
AddrElt(Hmain, Nmain,I,J);
MayUP :=(FirstWork < E);
MayDOWN :=(E < Kall-mLastWork);
MayEnter:=MayDOWN or (SCR[Y,80].txt <> ' ')
end;
for I:=0 to 15 do { Init DESK }
with MESSAGE^.DSK[I] do begin
if 10 <= Length(BKP) then BKP[0]:=chr(9);
BKP[10]:=UNC
end;
if Type_Field(abs(FITEK)) = 1 then begin
Edi_Genera(Y);
Exit
end;
CKEY:=''; { Ключевые поля }
Edi_String(Y);
GrandCorr:=GrandCorr or (not FirstCorr);
if not FirstCorr then Corrections; { SELE_FMS }
Key_Filling end;
(* ????
function KOMMEHTA(E : integer) : boolean;
var F,N : integer;
begin WherElt(E,F,N);
KOMMEHTA:=(MEAD^.BDS[F].DTL = NIL) end;
function KOM_CH(O : pMenuRec) : integer;
var F,N : integer;
begin with O^ do WherElt(Base+OnScr,F,N);
N:=F;
while MEAD^.BDS[F].DTL = NIL do F:=F-1;
KOM_CH:=N-F end;
*)
procedure ForwCurs(O : pMenuRec);
var F,N,L : integer;
begin with O^ do begin
L:=Base+Curs+1;
WherElt(L,F,N);
while MEAD^.BDS[F].DTL = NIL do begin
L:=L+1;
F:=F+1
end;
Curs:=L-Base;
if OnScr <= Curs then begin
Curs:= OnScr;
Base:=L-OnScr
end;
HOPMA(O) { DESK_FMS }
end end;
procedure BackCurs(O : pMenuRec);
var F,N,L : integer;
begin with O^ do begin
L:=Base+Curs-1;
WherElt(L,F,N);
while MEAD^.BDS[F].DTL = NIL do begin
L:=L-1;
F:=F-1;
end;
Curs:=L-Base;
if Curs < 1 then begin
Curs:= 1;
Base:=L-1
end;
HOPMA(O) { DESK_FMS }
end end;
procedure Exe_PgUp(O : pMenuRec);
var F,N : integer;
begin with O^ do
if Base = 0 then Curs:=FirstWork else begin
WherElt(Base+2,F,N);
N:=F;
while MEAD^.BDS[F].DTL = NIL do F:=F+1;
F:=F-N+2;
if F = Curs then Base:=Base-(Kscr-1)
else Curs:=F;
if Curs = FirstWork then Base:=0;
if Base < 0 then Base:=0
end;
SearCurs(O) end;
procedure Exe_PgDn(O : pMenuRec);
var F,N : integer;
begin with O^ do
if Base = Kall-OnScr then Curs:=Kall-mLastWork-Base else begin
WherElt(Base+OnScr-1,F,N);
N:=F;
while MEAD^.BDS[F].DTL = NIL do F:=F-1;
F:=OnScr-N+F-1;
if F = Curs then Base:=Base+(Kscr-1)
else Curs:=F;
if Curs = Kall-mLastWork then Base:=Kall-OnScr;
if Kall-OnScr < Base then Base:=Kall-OnScr
end;
SearCurs(O) end;
function Y_OnScr(I : integer; var Y : integer) : boolean;
begin with Glob_Menu do
with Mafi do begin
Y:=YH-1+Curs+I-Nmain;
Y_OnScr:=(YH <= Y) and (Y <= YK)
end end;
function N_Codul(I : integer; var N : integer) : boolean;
begin with Glob_Menu do begin
N:=Curs+I-Nmain;
N_Codul:=(1 <= N) and (N <= Kscr)
end end;
procedure Inc_String(O : pMenuRec);
var I,K,L : integer;
begin if SCR[WhereY,80].txt = ' ' then Exit;
L:=O^.Codul[O^.Curs]+1;
for K:=Nmain+1 to Hmain^.HSF do
if TSTMAP(L) then L:=L+1 else begin
ONEMAP(L);
for I:=K downto Nmain+2 do { Replace }
CopyFore(Hmain,I-1,I);
if Nmain+1 <= K-1 then KillBody(Hmain,Nmain+1);
Lset(Hmain,Nmain+1,RP_BGN,true); { ??????? }
FITEK:=-abs(FITEK);
TestField;
with O^ do begin
if Hmain^.HSF <= K then
for I:=1 to Nmain do
if Y_OnScr(I,L) then SCR[L,80].txt:=' ';
for I:=Nmain+1 to K-1 do { Элементы меню, получившие }
if N_Codul(I,L) then Codul[L]:=0; { новые коды Codul }
Inc(Kall);
end;
Exit
end end;
procedure Del_String(O : pMenuRec);
var I,K,L,R,F : integer;
begin L:=O^.Codul[O^.Curs];
R:=Nmain;
for K:=Nmain+1 to Hmain^.HSF do
if TSTMAP(L+K-Nmain) then R:=K;
ZERMAP(L+R-Nmain);
for K:=Nmain+1 to R do CopyFore(Hmain,K,K-1);
KillBody(Hmain,R);
FITEK:=-abs(FITEK);
TestField;
with O^ do begin
for I:=1 to Nmain-1 do
if Y_OnScr(I,L) then ISC(80,L,PPC,CPppc);
for K:=Nmain to R do { Элементы меню, получившие }
if N_Codul(K,I) then Codul[I]:=0; { новые коды Codul }
Dec(Kall);
I:=Base+Curs;
if Kall < I then I:=Kall;
WherElt(I,F,K);
if MEAD^.BDS[F].DTL = NIL then I:=I-1; { Комментарий }
if I = 1 then begin
Curs:=1;
Base:=0;
Exit
end; { I = 2,3,4,... }
Curs:=I-Base;
if Curs <= 1 then begin
Curs:=2;
Base:=I-2 { Base = 0,1,2,... }
end;
if 0 < Base then
if Kall < Base+Kscr then begin
K:=Base+Kscr-Kall;
if Base < K then K:=Base;
Curs:=Curs+K;
Base:=Base-K
end
end end;
procedure MenuBody_Edi(O : pMenuRec);
var F : integer;
procedure RENT; { Корректный возврат }
begin with O^ do begin { после отказа от }
Codul[Curs]:=-Codul[Curs]; { операции }
MeDel:=false
end
end;
begin with O^ do begin
Teke:=Gey;
case Teke of
UP : BackCurs(O);
DOWN : ForwCurs(O);
PgUp : Exe_PgUp(O);
PgDn : Exe_PgDn(O);
Enter : begin Inc_String(O);
Goto_Scurs(1,WhereY);
B_Ha_Gey(DOWN)
end;
DEL : Del_String(O);
Ctrl_F1 : RENT;
F2 : begin Mode_F02; RENT end; { OPEN_FMS }
F3 : Menu_F03; { OVER_FMS }
F4 : begin F:=abs(FITEK);
if INFORMAT then ReLinker(F)
else RENT
end;
F5 : begin EXPORTer; RENT end; { INFO_FMS }
F6 : begin F:=abs(FITEK);
if IMPORTer then ReLinker(F) { INFO_FMS }
else RENT
end;
F7 : begin F:=Full_F07; { INFO_FMS }
if 0 < F then ReLinker(F)
else RENT
end;
F8 : begin Menu_F08; RENT end; { OVER_FMS }
F9 : Cha_Modes; { OVER_FMS }
F10, ESC : begin Rend:=EXIT_MGE;
RENT
end;
903 : begin ReLinker(abs(FITEK));
RENT
end;
999 : GENERATION;
end
end end;
procedure MAIN_MGE;
begin MenuRun (aGlob,CodeElem_Edi,
BornElem_Edi,
KillElem_Edi,
BornCurs_Edi,
MenuBody_Edi) end;
end.
|