(* OVER_FMS использует: D_UNIT *)
(* EXEC_FMS *)
(* FILE_FMS *)
(* HELP_FMS *)
(* KEYS_FMS *)
(* LOAD_FMS *)
(* MENU_FMS *)
(* OKHO_FMS *)
(* SHOW_FMS *)
(* STAK_FMS *)
(* TYPE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O+,R+,S+,V+,X-}
{$M 16384,0,65536}
Unit OVER_FMS; INTERFACE
Uses CRT, UNIF_FMS, TYPE_FMS, OKHO_FMS, STAK_FMS, MENU_FMS,
DOS, KEYS_FMS, LOAD_FMS, HELP_FMS, FILE_FMS, SHOW_FMS,
D_Unit, EXEC_FMS;
procedure Cha_Modes;
procedure Cha_Help(V : integer);
function IN_POCKET(Fn,Tx : String) : boolean;
procedure Menu_F03;
procedure Menu_F08;
function Spec_F07(var Fn : String) : integer;
procedure MACC_HABOPOT(F : integer; var ABC : TYPE_HABOPOT);
function BORN_HABOPOT(F : integer ) : String;
function PrintSubFields(PrProc : PrintString) : integer;
TYPE LinRmod = record N : String[27]; { название элемента }
O : String[ 4]; { если Modes[I] }
Z : String[ 4] { если not Modes[I] }
end;
MaxRmod = array [1..128] of LinRmod;
function SaveMenu_Mds(H,K : integer) : LongInt; { H - начальная }
procedure RestMenu_Mds(L : LongInt);
function CodeElem_Mds(O : pMenuRec; N : integer) : integer;
procedure BornElem_Mds(O : pMenuRec; H,K : integer);
procedure ElseBody_Mds(O : pMenuRec);
procedure MenuBody_Mds(O : pMenuRec);
IMPLEMENTATION
{ Show_Scurs(false); | Типовая схема }
{ ..... меню ....... | отключения }
{ Show_Scurs(true); | курсора для }
{ Rest_Scurs; | редактора MGE }
{;;;;;;;;;;;; AAAAAA_Mds ;;;;;;;;;;;;;;}
function SaveMenu_Mds(H,K : integer) : LongInt; { H - начальная }
begin PUSH(Glob_Menu, SizeOf(Glob_Menu)); { K - конечная }
PUSH(SCR[H] ,(K-H+1)*SizeOf( LinSCR )); { строки экрана }
PUSH(H , SizeOf( integer ));
SaveMenu_Mds:=Get_SP end;
procedure RestMenu_Mds(L : LongInt);
var H : integer;
begin MenuDone(aGlob);
Return_SP(L);
POP(H);
POP(SCR[H]);
POP(Glob_Menu) end;
function CodeElem_Mds(O : pMenuRec; N : integer) : integer;
begin if Modes[N] then CodeElem_Mds:=+N
else CodeElem_Mds:=-N end;
procedure BornElem_Mds(O : pMenuRec; H,K : integer);
var I : integer;
S : String[30];
R : ^MaxRmod;
begin with O^ do begin
R:=Pindx;
for I:=H to K do
with R^[I] do begin
if Modes[I] then S:=O
else S:=Z;
OnScrXYA(Mafi.XH+1,Mafi.YH+I-1,CoMa,N+S)
end
end end;
procedure ElseBody_Mds(O : pMenuRec);
begin with O^ do begin
Rend:=(Teke = ESC);
if Teke = Enter then Modes[Curs]:=not Modes[Curs];
end end;
procedure MenuBody_Mds(O : pMenuRec);
begin MenuBody_All(O,ElseBody_Mds) end;
function HaaaMenu(XH,YH,XK,YK : integer) : LongInt;
begin HaaaMenu:=SaveMenu_Mds(YH,YK+1);
SimpMenu(Glob_Menu);
CuSh(false);
with Glob_Menu do begin
CoCu:=SVbar;
CoMa:=SVpam;
CoSu:=SVpen;
RescFul(Mafi,XH,YH,XK,YK); RescWit(Mafi,CoMa);
RescInc(Mafi,+1, 0,-1, 0); RescPAM(Mafi,CoMa,Wodul)
end end;
CONST EdiRmod : array [1.. 6] of LinRmod =
((N:'Описатели полей ';O:'ВКЛ ';Z:'ВЫКЛ'),
(N:'Язык описателей ';O:'РУС ';Z:'АНГЛ'),
(N:'ПереКод. a --> A ';O:'ВКЛ ';Z:'ВЫКЛ'),
(N:'Звуковые сигналы ';O:'ВКЛ ';Z:'ВЫКЛ'),
(N:'Цветовые сигналы ';O:'ВКЛ ';Z:'ВЫКЛ'),
(N:'Информ. панель ';O:'ВКЛ ';Z:'ВЫКЛ'));
procedure Cha_Modes;
var Wdefi,Wdrus : boolean;
I,M : integer;
S : String[32];
L : LongInt;
begin Wdefi:=Modes[Defi]; { Previous }
Wdrus:=Modes[Drus]; { Values }
if OpnNewInd(true) then S:=NNN(SizeAddMem)
else S:='0';
M:=Length(S)+1;
if 4 < M then Insert(',',S,M-3)
else M:=M-1;
L:=HaaaMenu(3,3,32,19);
with Glob_Menu do begin
Pindx:=addr(EdiRmod);
RescInc(Mafi,+1,+3,-1, 0);
with Mafi do begin
I:=XH+1;
OnScrXYA(I ,YH+7,CoSu,'Cвоб.память'+Csps(M+2)+'байт');
OnScrXYA(I+12,YH+7,CoMa,S);
{ for I:=XH+2 to XK-2 do ISC(I,YH+7,Podul[1,2],CoSu); }
OnScrXYA(XH+3,YH- 2,CoSu,'Режимы редактирования');
OnScrXYA(XH+3,YH+ 9,CoMa,' SFM 2 ');
OnScrXYA(XH+3,YH+10,CoMa,' Редактор сообщений ');
OnScrXYA(XH+3,YH+11,CoMa,'Агентство Edi-Tools,');
OnScrXYA(XH+3,YH+12,CoMa,'тел. (095) 554-44-48')
end
end;
MenuInit(aGlob,6);
MenuRun (aGlob,CodeElem_Mds,
BornElem_Mds,
KillElem_All,
BornCurs_All,
MenuBody_Mds);
RestMenu_Mds(L);
CuSh(true);
with Glob_Menu do begin
if (Wdefi <> Modes[Defi]) or
(Wdrus <> Modes[Drus]) then begin
for I:=1 to OnScr do Codul[I]:=-Codul[I];
for I:=1 to MEAD^.HSF do MEAD^.BDS[I].CR_TOX:=0;
Exit
end;
Codul[Curs]:=-Codul[Curs];
MeDel:=false
end end;
(***********************************************************
procedure BornElem_Esp(O : pMenuRec; H,K : integer);
var I : integer;
S : String[38];
begin with O^ do
for I:=H to K do begin
if I = 1 then S:='ВОССТАНОВИТЬ ПРЕДЫДУЩИЙ вариант строки'
else if I = 2 then S:='СОХРАНИТЬ ТЕКУЩИЙ вариант строки';
OnScrXYA(Mafi.XH+1,Mafi.YH+I-1,CoMa,S);
end end;
procedure ElseBody_Esp(O : pMenuRec);
begin with O^ do begin
if Teke = ESC then begin
Teke:=Enter;
Curs:=3;
end;
Rend:=(Teke = Enter);
end end;
procedure MenuBody_Esp(O : pMenuRec);
begin MenuBody_All(O,ElseBody_Esp) end;
procedure ESCspec;
var C : integer;
L : LongInt;
begin C:=WhereY+1;
L:=HaaaMenu(19,C,62,C+3);
OnScrXYA(38,C,SVpam,' Esc ');
RescInc(Glob_Menu.Mafi,+1,+1,-1, 0);
MenuInit(aGlob,2);
MenuRun (aGlob,CodeElem_All,
BornElem_Esp,
KillElem_All,
BornCurs_All,
MenuBody_Esp);
C:=Glob_Menu.Curs;
RestMenu_Mds(L);
if C = 2 then B_Ha_Gey(Ctrl_F1);
if C = 1 then begin
FirstCorr:=true;
FITEK:=abs(FITEK)+1;
LoadField(FITEK-1);
CX:=1
end end;
************************************************************)
procedure Cha_Help(V : integer);
begin CuSh(false);
if V = F1 then HelpFunc(SVpam,SVpen,SVbar,'F1D')
else HelpFunc(SVpam,SVpen,SVbar,'F1E');
CuSh(true) end;
{ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; }
{ ;;;;;;;;;;;;;;;;;;;;;;;;;;; Menu_F03 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; }
{ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; }
{ MACC_HABOPOT : F - Номер физического поля }
{ ABC - Результат FISQ_HABOPOT }
{ Res = ABC - значения наворота для поля F }
procedure MACC_HABOPOT(F : integer; var ABC : TYPE_HABOPOT);
var B,I,J,K,T : integer;
function LM1(FD : integer) : integer;
begin LM1:=Grupa_VRF(MEAD^.BDS[FD].VRF).K-1
end;
begin B:=0;
for I:=1 to ABC[0] do begin
K:=LM1(ABC[I]);
T:=1;
for J:=B+1 to F-1 do
if MEAD^.BDS[J].LFT = K then begin
T:=T+1;
B:=J
end;
ABC[I]:=T
end end;
function TREE_HABOPOT(F : integer) : String;
var FF,FF_,FG,NG : boolean;
ABC,DEF : TYPE_HABOPOT;
I,J,K,L : integer;
S : String;
function NewGroup(N : integer) : boolean;
var I : integer;
begin NewGroup:=false;
for I:=N+1 to ABC[0] do
if DEF[I] <> 1 then Exit;
NewGroup:=true
end;
begin L:=MEAD^.BDS[F].LFT;
FISQ_HABOPOT(L,ABC); DEF:=ABC;
MACC_HABOPOT(F,DEF);
S:='';
FF_:=false;
for I:=1 to ABC[0] do begin
J:=Grupa_VRF(MEAD^.BDS[ABC[I]].VRF).H;
FF:=(J = L); { First Field }
NG:=NewGroup(I); { New Group }
FG:=(DEF[I] = 1); { First Group }
if not FF then S:=S+'| '
else if not NG then S:=S+'| '
else if not FG then S:=S+'+++'
else if not FF_ then S:=S+'+++'
else S:=S+'+++';
FF_:=FF
end;
TREE_HABOPOT:=S end;
function CodeElem_F03(O : pMenuRec; N : integer) : integer;
begin CodeElem_F03:=MEAD^.BDS[N].HLP end;
procedure BornElem_F03(O : pMenuRec; H,K : integer);
var I,J,F,L : integer;
Q,R : alfa;
begin with O^ do
with Mafi do begin
L:=XK-XH-3;
for I:=H to K do begin
F:=CodeElem_F03(O,Base+I);
Q:=AlfaName(MEAD^.BDS[F].CTP);
R:=AlfaName(MEAD^.BDS[F].TIT);
Q:=Q+R;
J:=Pos(':',Q); if 0 < J then Q[J]:=' ';
J:=Pos(':',Q); if 0 < J then Q[J]:=' ';
LefPress(Q);
R:=TREE_HABOPOT(F);
J:=Length(R);
Q:=LappStr(Q,L-J)+Podul[2,1];
if FINE(F) then Q:=Q+Csps(2)
else Q:=Q+GLK+' ';
OnScrXYA(XH+1 ,YH+I-1,CoMa or $0F,R);
OnScrXYA(XH+1+J,YH+I-1,CoMa ,Q)
end
end end;
{ DEPTH_LOGF : L - Номер логического поля }
{ RES = Количество объемлющих генераторов - Глубина }
function DEPTH_LOGF(L : integer) : integer;
var ABC : TYPE_HABOPOT;
begin FISQ_HABOPOT(L,ABC);
DEPTH_LOGF:=ABC[0] end;
{ DEPTH_MESS : Глубина накрутки генераторов в сообщении }
function DEPTH_MESS : integer;
var I,K,M : integer;
begin M:=0;
for I:=1 to FogMed do begin
K:=DEPTH_LOGF(I);
if M < K then M:=K
end;
DEPTH_MESS:=M end;
function OTCT(F : integer) : integer;
begin with MEAD^ do begin
F:=BDS[F].HLP;
F:=BDS[F].LFT
end;
F:=DEPTH_LOGF(F);
if F <> 0 then F:=3*F+1;
OTCT:=F end;
procedure BornCurs_F03(O : pMenuRec; Base,Curs,Surs : integer);
var I : integer;
begin with O^ do begin
RectElem(O,Cufi,Curs);
Inc(Cufi.XH,OTCT(Base+Curs));
Dec(Cufi.XK,3);
with Cufi do
for I:=XH to XK do SCR[YH,I].att:=CoCu
end end;
procedure ElseBody_F03(O : pMenuRec);
begin with O^ do begin
if Teke = F1 then Help_Win(2,'EF3');
Rend:=(Teke = ESC) or (Teke = Enter);
end end;
procedure MenuBody_F03(O : pMenuRec);
begin MenuBody_All(O,ElseBody_F03) end;
procedure Menu_F03;
var I,L,K,M : integer;
begin with Glob_Menu do begin
Codul[Curs]:=-Codul[Curs];
MeDel:=false
end;
K:=1;
L:=0;
with MEAD^ do
for I:=1 to HSF do
if BDS[I].DTL <> NIL then begin
L:=L+1;
BDS[L].HLP:=I;
if I = abs(FITEK) then K:=L
end;
if L <= 1 then Exit;
PUSH(SCR,SizeOf(SCR));
PUSH(Glob_Menu,SizeOf(Glob_Menu));
CuSh(false);
M:=(3*DEPTH_MESS) div 2 + 2;
if 20 < M then M:=20;
with aGlob^ do begin
RescFul(Mafi,23-M,3,57+M,22);
RescWit(Mafi,SVpam);
RescExt(Mafi,-1, 0);
RescPAM(Mafi,SVpam,Wodul);
with Mafi do COEXYY(XK-3,YH,YK);
RescExt(Mafi,-1,-1);
CoMa:=SVpam;
CoCu:=SVbar;
with Mafi do
if YK-YH+1 < L then begin
RescFul(Grad,XK+1,YH,XK+1,YK);
{ XK:=XK-1 }
end
end;
OnScrCYA(3,SVpam,' Переход к полю: ');
MenuInit(aGlob,L);
AddrCurs(aGlob,K);
MenuRun (aGlob,CodeElem_F03,
BornElem_F03,
KillElem_All,
BornCurs_F03,
MenuBody_F03);
with Glob_Menu do begin
K:=MEAD^.BDS[Base+Curs].HLP;
L:=Teke
end;
POP(Glob_Menu);
POP(SCR);
CuSh(true);
if L = ESC then Exit;
L:=1;
for I:=1 to K-1 do L:=L+MEAD^.BDS[I].CR_FRX;
K:=0;
for I:=1 to L do
if TSTMAP(I) then K:=K+1;
with Glob_Menu do
if (Base+1 < K) and (K < Base+Kscr)
then Curs:=K-Base
else AddrCurs(aGlob,K)
end;
{;;;;;;;;;;;;;;;;;;;;;;;;;;;; Menu_F08 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
function New_F08 : boolean;
var S : String;
begin CuSh(false);
S:=' Копировать сообщение в карман *'+
'Записать новый файл pocket.'+MESSAGE^.ABB+' ?*';
OpnCoo_SP(15,12,66,18,SVpam,S);
COEXXY(19,62,15);
New_F08:=YesC(16,SVbar,SVpam,' Да > < Нет ');
ClsCoo_SP end;
{ BORN_HABOPOT : F - Номер физического поля }
{ Res = 'L' }
{ - наворот }
{ L - номер логического поля }
function BORN_HABOPOT(F : integer) : String;
var HT : String;
I,L,T : integer;
ABC : TYPE_HABOPOT;
begin L:=MEAD^.BDS[F].LFT;
FISQ_HABOPOT(L,ABC);
MACC_HABOPOT(F,ABC);
HT:='';
for I:=1 to ABC[0] do HT:=HT+'.'+NNN(ABC[I]);
if HT <> '' then begin HT[1]:='<'; HT:=HT+'>' end;
BORN_HABOPOT:=HT+NNN(L) end;
{ REQ_PS - Вспомогательная для PrintSubFields }
function REQ_PS(H : pHead; N,Ha,Ko : integer) : String;
var I : integer;
U : String;
begin U:='';
with H^.BDS[N] do
for I:=Ha to Ko do
if CTP^[I] <> UNC then
if CTP^[I] <> '''' then U:=U+CTP^[I]
else U:=U+'''''';
REQ_PS:=U end;
{ PrintSubFields : PrProc - печать строки }
{ Селектор+Лконтекст+Значение+Пконтекст+ }
{ в заданном формате }
{ Процерура печатает все подполя данного сообщения }
function PrintSubFields(PrProc : PrintString) : integer;
var I,R : integer;
procedure REQ(PTH : String; H : pHead);
var I,L,M : integer;
S : String;
begin if H = NIL then Exit;
for I:=1 to H^.HSF do
with H^.BDS[I] do
if DTL = NIL then begin
TEHT(H,I,L,M);
S:='';
SummStr(S,PTH+'.'+NNN(I));
SummStr(S,REQ_PS(H,I, 1,L ));
SummStr(S,REQ_PS(H,I,L +1,L+M));
SummStr(S,REQ_PS(H,I,L+M+1,LFT));
PrProc(R,S)
end else begin
S:=PTH+'.'+NNN(I);
if MN_MEM <> NIL
then S:=S+'<'+NNN(MN_MEM^.Ent)+'>';
REQ(S,DTL)
end
end;
begin R:=0;
for I:=1 to MEAD^.HSF do
if Type_Field(I) = 0 then begin
LoadField(I);
with MEAD^.BDS[I] do REQ(BORN_HABOPOT(I),DTL)
end;
PrintSubFields:=R end;
procedure Wln(S : String);
begin {$I-} writeln(F_text,S);
{$I+} if IOresult = 0 then end;
procedure FTprint(var R : integer; S : String);
begin Wln('FROM: '''+NumbStr(3,S)+''''); { Значение без контекста }
Wln('TO : ' +NumbStr(1,S) ) end; { Селектор }
function ReF_text(Fn : String) : boolean;
begin Assign(F_text,Fn);
{$I-} rewrite(F_text);
{$I+} ReF_text:=(IOresult = 0) end;
{ IN_POCKET : Сформировать КАРМАН в файле Fn }
{ Tx - текст в заголовк }
function IN_POCKET(Fn,Tx : String) : boolean;
var R : integer;
begin if ReF_text(Fn) then begin;
Wln('INPUT '+Tx+': Сообщение MT'+MESSAGE^.ABB);
Wln('LOAD');
R:=PrintSubFields(FTprint);
Cls_Text(F_text);
IN_POCKET:=true
end else IN_POCKET:=false end;
procedure Menu_F08;
var S : String;
begin S:=DIRS[SHB]+'POCKET.'+MESSAGE^.ABB;
if FindFile(S) then
if not New_F08 then Exit;
Wite_Gey;
if IN_POCKET(S,'F8') then begin
S:=DIRS[SHB]+'SAVE.'+MESSAGE^.ABB;
if FindFile(S) then KillFile(S)
end end;
{ Spec_F07 - сброс сообщения в текстовый файл }
{ применяется INFO_FMS.Full_F07 }
{ вынесено в OVER_FMS для скорости }
procedure F7print(var R : integer; S : String);
begin Wln(NumbStr(1,S)+':'''+NumbStr(3,S)+'''') end;
function Spec_F07(var Fn : String) : integer;
begin Spec_F07:=1;
if ReF_text(Fn) then begin
Spec_F07:=PrintSubFields(F7print);
Cls_Text(F_text)
end end;
end.
|