(* FACE_FMS использует: D_UNIT *)
(* FILE_FMS *)
(* KEYS_FMS *)
(* LOAD_FMS *)
(* MC_TOPIC *)
(* OPEN_FMS *)
(* OVER_FMS *)
(* SELE_FMS *)
(* TYPE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O+,R+,S+,V+,X-}
{$M 16384,0,65536}
Unit FACE_FMS;
INTERFACE
Uses DOS, TYPE_FMS, LOAD_FMS, UNIF_FMS, OVER_FMS,
CRT, FILE_FMS, SELE_FMS, OPEN_FMS, MC_TOPIC,
D_Unit, KEYS_FMS;
function Pth_Audi(var S : String ) : integer;
function Pth_Load(var S : String; Md : boolean;
var H : pHead; var N : integer) : boolean;
procedure Val_Load(var S : String;
H : pHead; N : integer);
function FORT(C : String; var S : String) : boolean;
function From_To( var F,T : String) : boolean;
function NORC( var F,T : String) : boolean;
Type PrName = function( S : String) : String;
WrName = procedure(var C,S : String);
procedure UniTra(var F,T : String; VaName : PrName; PuName : WrName);
procedure TRANSH(var F,T : String; VaName : PrName);
function IFS_LOAD( Tname : String; VaName : PrName) : integer;
CONST BASEL : String[16] = ''; { Базовый наворот для подстановки }
{ в селектор. Процедура SORC }
procedure DefaultSelector(var F : String );
procedure SetDefaultSelector( F : integer);
function HEAD_HABOPOT(var HT : String;
var L : integer;
var SR : String) : boolean;
IMPLEMENTATION
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Pth_Load ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{ GROUP : F - Номер поля }
{ Res = false, если поле НЕ генератор }
{ true + На - начало группы; Ko - конец группы }
{ Mg - допустимый МАX; Tg - тек. к-во генераций }
function GROUP(F : integer; var Ha,Ko,Mg,Tg : integer) : boolean;
begin with MEAD^.BDS[F] do
if VRF = NIL then GROUP:=false
else
with Grupa_VRF(VRF) do begin
GROUP:=true;
Ha:=H;
Ko:=K;
Mg:=KP;
Tg:=KG
end end;
function Log_Num(var N : integer; var G : String) : boolean;
var E : integer;
begin Val_Int(G,N,E);
if N < 0 then E:=1
else if 255 < N then E:=1;
Log_Num:=(E = 0) end;
{ Fin_Num : S = 'nnn.mmm.kkk.' Вспомогательная для HEAD_HABOPOT }
{ Res = TRUE + N = Value('nnn') }
{ FALSE else }
function Fin_Num(var N : integer; var S : String) : boolean;
var G : String;
begin if Fin_Str(G,S) then Fin_Num:=Log_Num(N,G)
else Fin_Num:=false end;
{ HEAD_HABOPOT : Селектор Sr -> Наворот HT + Лог.Н.Поля L + Остаток Sr }
{ Res = FALSE, если Sr задан с ошибкой }
function HEAD_HABOPOT(var HT : String;
var L : integer;
var Sr : String) : boolean;
var C,S : String;
W : boolean;
K : integer;
begin C:=Sr;
TwoPress(C);
W:=true;
K:=Pos('>',C);
HT:='';
if 0 < K then
if C[1] = '<' then begin
S:=Copy(C,2,K-2)+'.';
Delete(C,1,K);
while (S <> '') and W do
if Fin_Num(K,S) then HT:=HT+chr(K)
else W:=false
end;
K:=Pos('.',C); { Выч.L - Номер лог.поля }
W:=W and (1 < K);
if W then begin
S:=Copy(C,1,K-1);
Delete(C,1,K );
if S[1] <> '~' then W:=Log_Num(L,S) else begin
Delete(S,1,1);
K:=SFNn(S);
if 0 < K then L:=MEAD^.BDS[K].LFT
else W:=false
end;
if W then Sr:=C
end;
HEAD_HABOPOT:=W end;
{ REAL_HABOPOT : HT - Наворот }
{ L - Номер логического поля }
{ RES : Номер физического поля }
{ 0 - ошибка НЕТ ТАКОГО ПОЛЯ }
function REAL_HABOPOT(HT : String; L : integer) : integer;
var B,I : integer;
ABC : TYPE_HABOPOT;
procedure Skip(F,R : integer);
var H,K,M,T : integer;
begin if R = 1 then Exit;
if GROUP(F,H,K,M,T) then;
K:=K-1;
with MEAD^ do
while B < HSF do begin
B:=B+1;
if BDS[B].LFT = K then begin
R:=R-1;
if R = 1 then Exit
end
end
end;
begin REAL_HABOPOT:=0;
if L < 1 then Exit;
if FogMed < L then Exit;
if HT = '' then begin
if PthMed[L] = 0 then REAL_HABOPOT:=FisMed[L];
Exit
end;
FISQ_HABOPOT(L,ABC);
B:=0;
if ABC[0] = Length(HT) then
for I:=1 to ABC[0] do Skip(ABC[I],ord(HT[I]));
with MEAD^ do
for I:=B+1 to HSF do
if BDS[I].LFT = L then begin
REAL_HABOPOT:=I;
Exit
end end;
{ BMV - вспомогательная для Pth_Load }
{ S = n.xxx ==> N:=n|-1; M:=m|-1; S:=xxx }
procedure BMV(var N,M : integer; var S : String);
var I,K,L,R : integer;
function NNB(H,L : integer) : boolean;
begin if 0 < L then Val_Int(Copy(S,H,L),R,L)
else L:=1;
NNB:=(L <> 0)
end;
begin N:=-1;
M:=-1;
K:=MinPos('.',S);
if K = 1 then Exit;
if S[K-1] <> '>' then L:=K else begin
L:=Pos('<',S);
if L = 0 then Exit;
if NNB(L+1,K-2-L) then Exit;
M:=R
end;
if NNB(1,L-1) then Exit;
N:=R;
Delete(S,1,K) end;
{ Pth_Load : S - путь }
{ Res : + if Md then настроены все меню for WRITE }
{ else меню не настраивались for READ }
{ TRUE - ПУТЬ СУЩЕСТВУЕТ | FALSE - ПУТЬ НЕ СУЩЕСТВУЕТ }
function Pth_Load(var S : String; Md : boolean;
var H : pHead; var N : integer) : boolean;
var M : integer;
HT : String;
function NMK(var D : pHead; MN : pMenu) : boolean;
begin NMK:=true;
if MN <> NIL then with MN^ do begin
if M < 1 then Exit;
if HSF < M then Exit;
H:=ELT[M].DTL;
if Md then begin
D:=H;
Ent:=M;
FITEK:=-abs(FITEK)
end;
NMK:=false
end
end;
begin Pth_Load:=false;
if not HEAD_HABOPOT(HT,M,S) then Exit;
M:=REAL_HABOPOT(HT,M);
if M = 0 then Exit;
LoadField(M);
H:=MEAD^.BDS[M].DTL;
if H = NIL then Exit;
while S <> '' do begin
BMV(N,M,S);
if N < 1 then Exit;
if H^.HSF < N then Exit;
if S <> '' then begin
with H^.BDS[N] do
if M < 0
then H:=DTL
else if NMK(DTL,MN_MEM) then Exit;
if H = NIL then Exit
end
end;
Pth_Load:=(H^.BDS[N].DTL = NIL) end;
{ TEST_HABOPOT : HT - Наворот }
{ L - Номер логического поля }
{ Res = True, если наворот удовлетворяет формату сообщения }
function TEST_HABOPOT(HT : String; L : integer) : boolean;
var I,H,K,M,T : integer;
ABC : TYPE_HABOPOT;
begin TEST_HABOPOT:=false;
if L < 1 then Exit; { Проверка на диапазон }
if FogMed < L then Exit; { логических полей }
FISQ_HABOPOT(L,ABC);
if ABC[0] <> Length(HT) then Exit;
for I:=1 to ABC[0] do
if GROUP(ABC[I],H,K,M,T) then begin
if M < ord(HT[I]) then Exit
end else Exit;
TEST_HABOPOT:=true end;
{ Pth_InTo : S - путь *** ПРОВЕРКА СЕЛЕКТОРА *** }
{ F = +1 - Проверять указанное поле | -1 - Проверять лог.поле }
{ Res = 0 - путь существует + все меню настроены правильно }
{ 1 - путь существует + есть отличия в настройке меню }
{ 2 - путь не существует }
function Pth_InTo(S : String; F : integer) : integer;
var M,N,R : integer;
H : pHead;
HT : String;
function NMK(var D : pHead; MN : pMenu) : boolean;
begin NMK:=true;
if MN <> NIL then with MN^ do begin
if M < 1 then Exit;
if HSF < M then Exit;
if Ent <> M then R:=1;
H:=ELT[M].DTL;
NMK:=false
end
end;
begin Pth_InTo:=2;
if not HEAD_HABOPOT(HT,M,S) then Exit;
if not TEST_HABOPOT(HT,M ) then Exit;
if 0 < F then F:=REAL_HABOPOT(HT,M)
else F:=M;
if F < 1 then Exit;
LoadField(F);
H:=MEAD^.BDS[F].DTL;
if H = NIL then Exit;
R:=0;
while S <> '' do begin
BMV(N,M,S);
if N < 1 then Exit; { Pth_InTo = 2 ! }
if H^.HSF < N then Exit; { Pth_InTo = 2 ! }
if S <> '' then begin
with H^.BDS[N] do
if M < 0
then H:=DTL
else if NMK(DTL,MN_MEM) then Exit;
if H = NIL then Exit; { Pth_InTo = 2 ! }
end
end;
if H^.BDS[N].DTL <> NIL then R:=2;
Pth_InTo:=R end;
{ Pth_Audi: S - путь *** ПРОВЕРКА СЕЛЕКТОРА *** }
{ Res : 0 - путь существует + все меню настроены правильно }
{ 1 - путь существует + есть отличия в настройке меню }
{ 2 - путь не существует }
function Pth_Audi(var S : String) : integer;
begin Pth_Audi:=Pth_InTo(S,+1) end;
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Val_Load ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
procedure Val_Load(var S : String; H : pHead; N : integer);
var I,J,L,M : integer;
A : char;
function BBH : boolean;
begin BBH:=false;
with H^.BDS[N] do
if COOprk(RFT^[L+J],A) then begin
CTP^[L+J]:= A ;
INP^[L+J]:='I';
BBH:=true
end
end;
function FS : boolean;
begin FS:=false;
if J < M then
if S <> '' then begin
J:=J+1;
A:=S[1];
Delete(S,1,1);
FS:=true
end
end;
procedure FuGES;
begin J:=0;
while FS do
if not BBH then
with H^.BDS[N] do begin
CTP^[L+J]:=UNC;
INP^[L+J]:=' '
end
end;
procedure NoGES;
begin J:=0;
while FS do
if not BBH then begin
A:=' '; { Попытка заменить символ пробелом }
if not BBH then J:=J-1 { Переход к следующему символу }
end
end;
begin if H = NIL then Exit;
if N < 1 then Exit;
if H^.HSF < N then Exit;
TEHT(H,N,L,M);
with H^.BDS[N] do begin
if Sask(BOS,GES) then FuGES
else NoGES;
for I:=J+1 to M do begin
CTP^[L+I]:=UNC; { Clear }
INP^[L+I]:=' '
end;
if RP_PAT <> NIL then begin
RP_PAT^:=CTP^;
Sset(BOS,RP_BGN,false)
end;
MarkContext(H,N,'I'); { SELE_FMS : Context:='I' }
FITEK:=-abs(FITEK);
Sset(BOS,TST,false);
{ Sset(BOS,UNE,.....) }
end end;
{ FORT : Извлечь из F_text в S строку, начинающуюся префиксом C }
{ TRUE - строка нашлась + S - остаток строки }
{ FALSE - такой строки не нашлось }
function FORT(C : String; var S : String) : boolean;
var W : boolean;
begin W:=false;
while (not eof(F_text)) and (not W) do begin
Readln(F_text,S);
LefPress(S);
W:=(Pos(C,S) = 1)
end;
if W then begin
Delete(S,1,Length(C));
TwoPress(S)
end;
FORT:=W end;
{ From_To : найти в F_text очередную пару смежных строк }
{ с префиксами FROM: и TO : }
{ FALSE, если такой пары не нашлось }
function From_To(var F,T : String) : boolean;
begin if FORT('FROM:',F) then From_To:=FORT('TO :',T)
else From_To:=false end;
{ NORC : чтение Имени(true) или Константы(false) }
{ из непустой строки T; }
{ строка T усекается; результат - в F }
function NORC(var F,T : String) : boolean;
var I : integer;
W : boolean;
function LST_QVQ : boolean;
begin if Length(T) <= I then LST_QVQ:=true
else LST_QVQ:=(T[I+1] <> '''')
end;
begin if T[1] <> '''' then begin
NORC:=true;
I:=MinPos(' ',T);
F:=Copy(T,1,I-1);
end else begin
NORC:=false;
I:=1;
F:='';
W:=true;
while (I < Length(T)) and W do begin
I:=I+1;
if T[I] <> '''' then F:=F+T[I]
else if LST_QVQ then W:=false
else begin
F:=F+T[I];
Delete(T,I+1,1)
end
end
end;
Delete(T,1,I);
LefPress(T) end;
{ DefaultSelector : F - селектор }
{ Выполнить настройку селектора }
{ по умолчанию }
procedure DefaultSelector(var F : String);
var I,K,L : integer;
ABC : TYPE_HABOPOT;
W : boolean;
begin if BASEL = '' then Exit;
K:=MinPos('.',F);
Val_Int(Copy(F,1,K-1),L,I);
if I <> 0 then Exit;
if L < 1 then Exit;
if FogMed < L then Exit;
FISQ_HABOPOT(L,ABC);
K:=ABC[0];
if 1 <= K then
if K <= Length(BASEL) then begin
F:='>'+F;
for I:=K downto 1 do F:='.'+NNN(ord(BASEL[I]))+F;
F[1]:='<'
end end;
{ F - номер физического поля для построения наворота по умолчанию }
procedure SetDefaultSelector(F : integer);
var ABC : TYPE_HABOPOT;
I : integer;
begin FISQ_HABOPOT(MEAD^.BDS[F].LFT,ABC);
MACC_HABOPOT( F ,ABC); { OVER_FMS }
BASEL[0]:=chr(ABC[0]);
for I:=1 to ABC[0] do BASEL[I]:=chr(ABC[I]) end;
{ MAKE_HABOPOT : HT - Наворот }
{ L - Номер логического поля }
{ SQ - последовательность полей }
{ Реализовать наворот, если это необходимо }
{ Res = TRUE если не было сбоев в алгоритме }
function MAKE_HABOPOT(HT : String; L : integer; SQ : pCKT) : boolean;
var I,B : integer;
ABC : TYPE_HABOPOT;
function Lnumb(N : integer) : integer;
begin N:=abs(SQ^[N].FLD);
Lnumb:=MEAD^.BDS[N].LFT
end;
function GEGE(K : integer) : integer;
var I : integer;
begin for I:=B+1 to SQ^[0].FLD do
if Lnumb(I) = K then begin
GEGE:=I;
Exit
end;
GEGE:=0;
MAKE_HABOPOT:=false
end;
procedure Skip(F,R : integer);
var H,K,M,T : integer;
begin if R = 1 then Exit;
if GROUP(F,H,K,M,T) then;
M:=GEGE(K); { M - Генератор Групп }
if 0 < M then begin
T:=abs(SQ^[M].GEN);
if T < R then
if Gene_SEQ(SQ,M,R-T) <> 0 then begin { Вып.дост.к-во генераций }
MAKE_HABOPOT:=false;
Exit
end;
K:=K-1;
while B < SQ^[0].FLD do begin
B:=B+1;
if Lnumb(B) = K then begin
R:=R-1;
if R = 1 then Exit
end
end
end
end;
begin MAKE_HABOPOT:=true;
FISQ_HABOPOT(L,ABC);
B:=0;
if ABC[0] = Length(HT) then
for I:=1 to ABC[0] do Skip(ABC[I],ord(HT[I])) end;
{ LOOP_HABOPOT : Сканировать TO-строки F_text }
{ Проверить допустимость селекторов }
{ Выполнить необходимые генерации групп }
{ RES = 0 - О'К }
{ 1610 - Не хватает оперативной памяти }
{ 1616 - Ошибка записи на диск }
{ 3000 - Неправильный селектор }
{ 3001 - Ошибка алгоритма генерации }
{ 4nn - Ошибка при повт.открытии сообщения }
function LOOP_HABOPOT : integer;
var C,G,S : String;
I,K,L : integer;
SQ : pCKT;
begin SQ:=NIL;
L:=0;
for I:=1 to FogMed do
if PthMed[I] <> 0 then L:=1;
if L = 1 then
if Init_SEQ(SQ) <> 0 then begin
LOOP_HABOPOT:=1610;
Exit
end;
while FORT('TO :',C) do { Контроль TO-строк }
while C <> '' do
if NORC(G,C) then begin { Читать селектор }
DefaultSelector(G);
if Pth_InTo(G,-1) = 2 then begin
LOOP_HABOPOT:=3000;
Exit
end;
if HEAD_HABOPOT(S,L,G ) then; { Повторно - 1-й раз в Pth_InTo }
if not MAKE_HABOPOT(S,L,SQ) then begin
LOOP_HABOPOT:=3001;
Exit
end
end;
if SQ = NIL then L:=0 else begin
L:=Make_SEQ(SQ,'');
if L = 0 then
if not OpnMed(D_Init_Name) then L:=Err_D_Init
end;
LOOP_HABOPOT:=L end;
{ PuMess : процедура записи в п/поле сообщения }
{ !!! ADM !!! }
{ C - Селектор }
{ S - Значение }
procedure PuMess(var C,S : String);
var G,R,T : String;
H : pHead;
N : integer;
W : boolean;
begin DefaultSelector(C);
T:=C; { Запомнить селектор }
if not Pth_Load(C,false,H,N) then Exit; { Установить подполе }
W:=Lask(H,N,UNE);
W:=(not W) or (W and (ADM = '9'));
if W then begin { Блокировать запись в защищенные подполя}
UnoStr(G,H,N,false); { Запомнить значение подполя }
if S <> '' then Val_Load(S,H,N) else begin
KillBody(H,N);
FITEK:=-abs(FITEK)
end;
UnoStr(R,H,N,false); { Новое значение подполя }
if R <> G then { Если значение подполя изменилось, }
if Pth_Load(T,true,H,N) then { то [настроить меню] }
end end;
{ UniTra : F - FROM-строка }
{ T - TO-строка }
{ VaName - функция вычисления значения параметра }
{ PuName - procedure записи строки в параметр }
{ PuName должна удалять "взятые" символы! }
{ RES = Загрузка в сообщение }
procedure UniTra(var F,T : String; VaName : PrName; PuName : WrName);
var C,S,O : String;
procedure Disch(C : String);
var K : integer;
begin K:=255-Length(S);
if Length(C) <= K then K:=Length(C);
S:=S+Copy(C, 1, K );
O:= Copy(C,K+1,255)
end;
begin S:=''; { Активная часть значения }
O:=''; { Остаток }
while T <> '' do begin
while (F <> '') and (O = '') do begin
if NORC(C,F) then C:=VaName(C);
Disch(C)
end;
if NORC(C,T) then PuName(C,S);
Disch(O)
end end;
{ TRANSH : F - FROM-строка + !!! ADM !!! }
{ T - TO-строка }
{ VaName - функция вычисления значения параметра }
{ RES = Загрузка в сообщение }
procedure TRANSH(var F,T : String; VaName : PrName);
begin UniTra(F,T,VaName,PuMess) end;
{ IFS_LOAD : Tname - имя загружаемого файла }
{ если Tname = '', то Файл F_text - открыт }
{ VaName - функция вычисления значения параметра }
{ RES = 0 - О'К }
{ 1610 - Не хватает оперативной памяти }
{ 1616 - Ошибка записи на диск }
{ 3000 - Неправильный селектор }
{ 3001 - Ошибка алгоритма генерации }
{ 4nn - Ошибка при повт.открытии сообщения }
function IFS_LOAD(Tname : String; VaName : PrName) : integer;
var F,T : String;
R : integer;
begin if Tname = '' then Reset(F_text)
else if OpenText(Tname) then
else Exit;
R:=LOOP_HABOPOT;
if R = 0 then begin
Reset(F_text);
while From_To(F,T) do TRANSH(F,T,VaName)
end;
WritField;
IFS_LOAD:=R;
if Tname <> '' then Cls_Text(F_text) end;
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
end.
|