(* SELE_FMS использует: KEYS_FMS *)
(* LAYS_FMS *)
(* LOAD_FMS *)
(* MENU_FMS *)
(* OKHO_FMS *)
(* TEST_FMS *)
(* TYPE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O-,R+,S+,V+,X-}
{$M 16384,0,655360}
Unit SELE_FMS; INTERFACE
Uses DOS, TYPE_FMS, MENU_FMS, OKHO_FMS, KEYS_FMS,
CRT, TEST_FMS, LAYS_FMS, LOAD_FMS, UNIF_FMS;
procedure Max_Menu(H : pHead; N : integer; var EL,KS : integer);
procedure MarkContext(H : pHead; N : integer; C : char);
procedure GarkContext(H : pHead; C : char);
procedure ReLine79;
procedure Pos79(Y : integer; B : boolean);
procedure Corrections;
procedure UnKnField(H : pHead; N : integer);
function Yes_PLC(H : pHead; N : integer) : boolean;
function ClearBody(H : pHead; N : integer) : boolean;
procedure B_CBEPTKA(H : pHead; N : integer);
procedure CBEPTKA(H : pHEAD; N : integer);
procedure CopyFore(H : pHead; F,T : integer);
IMPLEMENTATION
VAR SCR79 : array [1..25] of EltSCR; { with FirstCorrect }
{ Max_menu: }
{ Для заданного меню вычисляет ближайшее совпадение с имеющейся строкой: }
{ EL - номер элемента }
{ KS - последняя совпадающая позиция }
{ Расчитана на обработку только внутренних меню, с внешними не работает! }
{ Используется в EDIS_FMS.MenuControl и в SELE_FMS_Cho_Menu }
procedure Max_Menu(H : pHead; N : integer; var EL,KS : integer);
var I,J,L,C,CP : integer;
MH : pHead;
P : pAlfa;
W : boolean;
function COB(S : Alfa) : integer;
var I,K : integer;
begin K:=0;
for I:=1 to Length(S) do
if I <= C then
if coxCB[I] = S[I] then K:=K+1 else begin
COB:=K;
Exit
end;
COB:=K
end;
begin if H^.BDS[N].MN_MEM^.LON <> '' then Exit; { Допустимый вызов? }
COHT(H,N,L,C);
CTPress(H,N);
CP:=Length(coxCB);
EL:=0;
KS:=0;
with H^.BDS[N] do
for I:=1 to MN_MEM^.HSF do begin
MH:=MN_MEM^.ELT[I].DTL;
J:=Length(coxCB);
if MH = NIL then begin
if J <> C then coxCB:=Copy(CTP^,L+1,C);
P:=Addr(MN_MEM^.ELT[I].CTP^[1]);
J:=L+COB(P^)
end else begin
if J <> CP then CTPress(H,N);
AHATOM(MH,J,W); { J = Max; TEST_FMS }
end;
if KS < J then begin EL:=I; KS:=J end
end end;
procedure MarkContext(H : pHead; N : integer; C : char);
var I : integer;
begin with H^.BDS[N] do
for I:=1 to LFT do
if not FOCH(RFT^[I]) then INP^[I]:=C end;
procedure GarkContext(H : pHead; C : char);
var N : integer;
begin for N:=1 to H^.HSF do
with H^.BDS[N] do
if Sask(BOS,OBS) then
if DTL = NIL then MarkContext(H,N,C)
else GarkContext(DTL,C) end;
procedure Pos79(Y : integer; B : boolean);
begin if B then OnScrXYA(79,Y,CPsys,' ')
else OnScrXYA(79,Y,CPsys,GLK) end; { <- }
procedure CorrField;
var I,J,K,L,F,Y : integer;
H : pHead;
procedure Mark(H : pHead; N : integer);
begin L:=L+1;
if not TSTMAP(L) then Exit;
K:=K+1;
with Glob_Menu do begin
Y:=K-Base;
if Y < 1 then Exit;
if Kscr < Y then Exit;
Inc(Y,Mafi.YH-1);
Pos79(Y, Lask(H,N,MKP))
end
end;
begin F:=abs(FITEK);
L:=0;
K:=0;
for I:=1 to F-1 do
for J:=1 to MEAD^.BDS[I].CR_FRX do begin
L:=L+1;
if TSTMAP(L) then K:=K+1
end;
H:=MEAD^.BDS[F].DTL;
for I:=1 to H^.HSF do
with H^.BDS[I] do
IF DTL^.KND = 8
THEN Mark( H ,I)
ELSE for J:=1 to DTL^.HSF do Mark(DTL,J) end;
procedure UnKnField(H : pHead; N : integer);
var I,J,L,K : integer;
begin FITEK:=-abs(FITEK);
Lset(H,N,TST,false);
if not FirstCorr then Exit;
FirstCorr:=false;
K:=0;
with Glob_Menu do begin
with Mafi do { Запомнить линейку }
for I:=YH to YK do SCR79[I]:=SCR[I,79];
L:=0;
K:=-Base; { Исправить линейку }
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
K:=K+1; { Номер элемента меню }
if OnScr < K then Exit;
if 0 < K then { Элемент - на экране }
if MEAD^.BDS[I].DTL <> NIL { Элемент - не комментарий }
then OnScrXYA(79,MAfi.YH+K-1,CPsys,':')
end
end
end end;
{ UnTST_Imp: TST:=false для полей, содержащих imp(A) }
procedure UnTST_Imp(H : pHead; N : integer; A : char);
var I : integer;
procedure Loop(H : pHead; A : char);
var I : integer;
begin if H <> NIL then
for I:=1 to H^.HSF do UnTST_Imp(H,I,A)
end;
begin with H^.BDS[N] do begin
if VRF <> NIL then
if Pos('imp('+A+')',VRF^) <> 0 then begin
Sset(BOS,TST,false);
FITEK:=-abs(FITEK)
end;
if MN_MEM <> NIL then
if MN_MEM^.LON = '' then with MN_MEM^ do
for I:=1 to HSF do Loop(ELT[I].DTL,A);
if MN_MEM = NIL then Loop( DTL,A)
end end;
procedure ReLine79; { Восстановить линейку }
var I : integer;
begin with Glob_Menu.Mafi do
for I:=YH to YK do SCR[I,79]:=SCR79[I] end;
{ Corrections : - проверить корректность текущего поля }
{ - внести изменения во все связные поля }
{ - внести поправки на экран }
procedure Corrections;
var I,J,K,F : integer;
function I16 : char;
begin if I < 10 then I16:=chr(ord('0')+I)
else I16:=chr(ord('A')+I-10)
end;
begin Test_Diag:=true; { Вывод диагностики проверок }
F:=abs(FITEK); { Save FITEK }
TestField;
ReLine79; { Восстановить линейку }
for I:= 0 to 15 do
with MESSAGE^.DSK[I] do
if BKP[10] <> UNC then
for J:=1 to Length(BKP) do
for K:=1 to MEAD^.HSF do { По всем полям с меткой }
if MEAD^.BDS[K].LFT = ord(BKP[J]) then begin { происхождения ord(BKP[J]) }
LoadField(K);
UnTST_Imp(MEAD,abs(FITEK),I16);
TestField;
if F <> abs(FITEK)
then CorrField
end;
LoadField(F);
CorrField end;
function ClearBody(H : pHead; N : integer) : boolean;
var L,K : integer;
begin with H^.BDS[N] do begin
if DTL = NIL then begin
K:=LFT; { количество незап.позиций }
for L:=1 to LFT do
if INP^[L] = ' ' then K:=K-1;
ClearBody:=(K = 0) and (not Sask(BOS,RP_BGN));
Exit
end;
ClearBody:=false;
if MN_MEM <> NIL then Exit;
for L:=1 to DTL^.HSF do
if not ClearBody(DTL,L) then Exit;
ClearBody:=true
end end;
procedure Calc_CX;
var L : integer;
function Search(unY,unX : boolean) : boolean;
var I : integer;
begin for I:=1 to L do
if OT[I].H = COT[0].H then
if (OT[I].Y = COT[0].Y) or unY then
if (OT[I].X = COT[0].X) or unX then begin
CX:=CX+I;
Search:=true;
Exit
end;
Search:=false
end;
procedure Interval;
begin if L < CX then CX:=L;
if CX < 1 then CX:=1
end;
begin L:=Length(CB);
CX:=1;
if COT[0].X <= 0 then COT[0].X:=-COT[0].X
else CX:=0;
if Search(false,false) then begin { Main }
if L < CX then begin
Interval;
B_Ha_Gey(Enter); (* InputKey Enter if Field is full *)
AutoEnter
end;
Exit;
end;
repeat { SubMain }
if Search(false,true) then begin Interval; Exit end;
if Search(true ,true) then begin Interval; Exit end;
COT[0].Y:=COT[0].H^.BK_POS;
COT[0].H:=COT[0].H^.BK_PTR
until COT[0].H^.KND <> 8;
Interval end;
procedure BBOC(A : Char; M,N,I : integer; P : pHead);
var L : integer;
begin L:=Length(CB)+1;
if 80 <= L then Exit;
CB[0]:=chr(L);
CB[L]:=A;
OT[L].Y:=N;
OT[L].X:=I;
OT[L].H:=P;
OT[L].MIG:=M end;
function Yes_PLC(H : pHead; N : integer) : boolean;
var L,LL,MM : integer;
procedure FCOT(K : integer);
begin L:=L+1;
CCB[L]:=H^.BDS[N].RFT^[K];
COT[L].X:=K;
COT[L].Y:=N;
COT[L].H:=H
end;
begin Yes_PLC:=false;
if Lask(H,N,OBS) then Exit;
if not ClearBody(H,N) then Exit;
while H^.BDS[N].DTL <> NIL do begin
H:=H^.BDS[N].DTL;
N:=1;
if not Lask(H,N,OBS) then Exit;
end;
Yes_PLC:=true;
L:=0;
TEHT(H,N,LL,MM);
if 0 < LL then FCOT( 1);
if 0 < MM then FCOT(LL+1);
CCB[0]:=chr(L) end;
procedure H_CBEPTKA(H : pHead);
var I,N,M : integer;
W,pGES,pRP_ : boolean;
function Pos1st : boolean;
begin if I = 1 then Pos1st:=true
else Pos1st:=not FOCH(H^.BDS[N].RFT^[I-1])
end;
begin for N:=1 to H^.HSF do
with H^.BDS[N] do begin
W:=true;
pGES:=Sask(BOS,GES );
pRP_:=Sask(BOS,RP_BGN);
if Yes_PLC(H,N) then BBOC( PLC,0,N,1,H)
else
if DTL <> NIL then H_CBEPTKA(DTL)
else
for I:=1 to LFT do
if CTP^[I] <> UNC then BBOC(CTP^[I],0,N,I,H) else begin
if pGES then begin
if W and pRP_ then BBOC('R',$80,N,I,H)
else BBOC(' ', 0,N,I,H);
end else
if W then begin
if pRP_ then BBOC('R',$80,N,I,H)
else
if Pos1st then BBOC(' ', 0,N,I,H)
else BBOC(PRS, 0,N,I,H)
end;
W:=false
end
end end;
procedure B_CBEPTKA(H : pHead; N : integer);
begin if Yes_PLC(H,N) then BBOC(PLC,0,N,1,H)
else H_CBEPTKA(H^.BDS[N].DTL) end;
procedure CBEPTKA(H : pHEAD; N : integer);
var I,J,K,CL,XX : integer;
begin CB:='';
B_CBEPTKA(H,N);
XX:=MEAD^.BDS[abs(FITEK)].CR_TOX;
Em_LinWRK(XX+1,Lapos,LinWRK[1].att);
if CX <> 0 then Calc_CX;
CL:=-1;
for I:=1 to Length(CB) do
with OT[I] do begin
if X = 1 then begin
J:=H^.BDS[Y].OKP;
if (J < 0) or (255 < J) then
if CL = CMone then J:=CMtwo
else J:=CMone
end;
if CB[I] = PLC then begin J:=CMplc; K:=J end
else if CB[I] = PRS then K:=((CMplc shl 4) or (CMplc shr 4)) and 255
else begin J:=J or MIG; K:=J end;
ICH(XX+I,CB[I],K);
if CB[I] = PRS then CB[I]:=' ';
CL:=J;
end end;
procedure CopyBody(frH : pHead; frN : integer;
toH : pHead; toN : integer); FORWARD;
procedure CopyHead(F,T : pHead);
var I : integer;
begin if F = NIL then Exit;
for I:=1 to F^.HSF do CopyBody(F,I,T,I) end;
procedure CopyBody(frH : pHead; frN : integer;
toH : pHead; toN : integer);
var F,T : ^Body;
O,K : pMenu;
I : integer;
begin F:=addr(frH^.BDS[frN]);
T:=addr(toH^.BDS[toN]);
T^.BOS :=F^.BOS; { OBS, GES, RP_BGN, MN_GES }
if F^.INP <> NIL then T^.INP^ :=F^.INP^;
if F^.CTP <> NIL then T^.CTP^ :=F^.CTP^;
T^.LFT :=F^.LFT;
if F^.RP_PAT <> NIL then T^.RP_PAT^:=F^.RP_PAT^;
T^.CR_FRX :=F^.CR_FRX;
T^.CR_TOX :=F^.CR_TOX;
T^.CR_TOY :=F^.CR_TOY;
T^.OKP :=F^.OKP;
if F^.TIT <> NIL then T^.TIT^ :=F^.TIT^;
O:=F^.MN_MEM;
K:=T^.MN_MEM;
if O <> NIL then begin
K^.Ent:=O^.Ent;
T^.DTL:=NIL;
for I:=1 to How_ELT(O) do CopyHead(O^.ELT[I].DTL,K^.ELT[I].DTL);
Exit
end;
CopyHead(F^.DTL,T^.DTL) end;
procedure CopyFore(H : pHead; F,T : integer);
begin CopyBody(H,F,H,T);
Hac_Menu(H^.BDS[T].DTL) { LOAD_FMS }
end;
end.
|