(* TYPE_FMS использует: TONE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F-,G-,I+,L+,N-,O-,R+,S+,V+,X-}
{$M 16384,0,65536}
unit TYPE_FMS; INTERFACE
uses CRT, DOS, UNIF_FMS;
CONST HBmax = 1024; { Max подполей в одном Head }
HE = 80; { Max элементов в одном Menu }
FormatChars = 'naixdsyu'; {порядок!!}{ Допустимые форматы символов }
UNC = chr( 0);
PLC = chr( 4);
PRS = chr(220); { Парус }
GLK = chr(221); { Птичка }
PPC = chr(222); { Добавить строку }
COMAP = 128; { 16*COMAP = Max строк в сооб }
{$I TONE_FMS.PAS } { СТАНДАРТНЫЕ ОКРАСКИ }
CONST SVpam : integer = $70; { Процессы }
SVpen : integer = $71;
SVbar : integer = $30;
CONST Alphabets : array [1..8,0..15] of word = ( { naixdsyu }
{ n } ($0000,$0000,$0000,$03FF,$0000,$0000,$0000,$0000,
$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000),
{ a } ($0000,$0000,$0000,$0000,$FFFE,$07FF,$0000,$0000,
$FFFF,$FFFF,$0000,$0000,$0000,$0000,$0000,$0000),
{ i } ($0000,$0000,$0000,$03FF,$FFFE,$07FF,$0000,$0000,
$FFFF,$FFFF,$0000,$0000,$0000,$0000,$0000,$0000),
{ x } ($0000,$0000,$FFFF,$FBFF,$FFFF,$FFFF,$0001,$7800,
$FFFF,$FFFF,$0000,$0000,$0000,$0000,$0000,$0000),
{ d } ($0000,$0000,$5000,$03FF,$0000,$0000,$0000,$0000,
$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000),
{ s } ($0000,$0000,$2800,$0000,$0000,$0000,$0000,$0000,
$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000),
{ y } ($0000,$0000,$FB81,$83FF,$FFFE,$07FF,$0000,$0000,
$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000),
{ u } ($0000,$0000,$FFFF,$FBFF,$FFFF,$FFFF,$FFFF,$7FFF,
$FFFF,$FFFF,$FFFF,$0000,$0000,$0000,$FFFF,$0000));
CONST OBS = 0; { Признак обязательности }
GES = 1; { Признак жесткого формата }
RP_BGN = 2; { Объявлен повторный ввод }
MN_GES = 3; { Тип меню: жесткое/мягкое }
TST = 4; { Признак проверенного поля }
EMP = 5; { if TST then Поле - пусто }
COF = 6; { if TST then Поле - корректно }
MKP = 7; { MKP = false if для строки нужно <= }
UNE = 8; { Un Edit }
TYPE Alfa = String [80];
pString = ^String;
pAlfa = ^Alfa;
pHead = ^Head;
pMenu = ^Menu;
pMESSAGE = ^TypeMESSAGE;
Body = record BOS : word; { Шкала boolean признаков ** }
RFT : pAlfa; { Развернутый формат }
INP : pAlfa; { Признаки ввода в позицию }
CTP : pAlfa; { Результирующая строка }
{ Лог.Номер Поля } LFT : byte; { Длина RFT }
DTL : pHead; { Поддерево }
RP_PAT : pAlfa; { Образец для сравнения }
{ К-во стр. в Поле } CR_FRX : byte; { Автокорректор ввода; From }
{ База X на экране } CR_TOX : byte; { Автокорректор ввода; To X }
CR_TOY : byte; { Автокорректор ввода; To Y }
MN_MEM : pMenu; { Меню значений }
OKP : integer; { Окраска. -1 - автоокраска }
TIT : pAlfa; { Название подполя }
{ Генератор группы } VRF : pAlfa; { Проверка }
HLP : word; { Help }
end;
Head = record BK_PTR : pHEAD; { Обратная ссылка }
BK_POS : byte; { Уточнение обр.ссылки }
KND : byte; { + Сорт }
HSF : word; { Количество подполей }
BDS : array [1..HBmax] of Body; { Подполя }
end;
TypeDESK = record CTP : String[ 8];
BKP : String[10]
end;
TypeMESSAGE = record ABB : String[8 ];
FUN : String[80];
DSK : array [0..15] of TypeDESK;
INF : array [1..98] of byte;
DTL : pHead end;
{ INF[ 1] = 0 - Первый вход в редактор }
{ INF[ 2.. 7] - Режимы редактирования }
{ INF[ 8..24] - Ссылка MOR }
{ INF[90..98] - Имя шаблона }
Elem = record CTP : pString; { Текст элемента меню }
DTL : pHead; { NIL или формат ввода }
end;
Menu = record LON : String[8]; { Лог.имя внешнего [DBF]файла }
SXS : byte; { Размер по X SubField }
SYS : byte; { Размер по Y SubField }
SXM : byte; { Размер по X MainField }
HSF : integer; { Количество элементов меню * }
Co_Mai : byte; { Окраска главного поля }
Co_Sub : byte; { Окраска вспом. поля }
Co_Cur : byte; { Окраска курсора }
Co_Sys : byte; { Окраска "карандаша" }
Ent : integer; { Позиция последнего Enter * }
ELT : array [1..HE] of Elem; { Элементы меню }
end;
{ Специальные структуры редактора }
TYPE Posy = record X,Y : ShortInt;
H : pHead;
MIG : byte; { Мигание }
end;
CONST MESSAGE : pMESSAGE = NIL; { Скелет сообщения }
VAR FIMAP : array [0..COMAP] of word; { Карта строк }
DOMAP : array [0..COMAP] of integer;{ Заполненность ДО }
FITEK : integer; { Загруженное поле }
MEAD : pHEAD;
Hmain,Hroot : pHead; { Позиция редактора }
Nmain : integer; { строки }
SP_screen : LongInt; { Поз.стека для SCR }
SP_config : LongInt; { П.стека для Config }
ADM : char; { Режим эксплуатации }
Termi : char; { Код терминала }
VAR coxCB,CB : alfa;
coxCX,CX : integer;
coxOT,OT : array [0..80] of Posy;
COT : array [0.. 2] of Posy;
CCB : String[2];
MayEnter : boolean; { Разрешение на Enter }
MayUP : boolean; { Разрешение на UP }
MayDOWN : boolean; { Разрешение на DOWN }
FirstCorr : boolean; { Первая корректировка поля }
GrandCorr : boolean; { Признак редакт. сообщения }
Test_Diag : boolean; { Управление контролем }
{ True - диагностику - на экран }
Modes : array [1..6] of boolean; { Режимы работы рекатора }
CONST Defi = 1; { Описатели полей ВКЛ/ВЫКЛ }
Drus = 2; { Язык описателей РУС/АНГЛ }
UpCa = 3; { ПереКод. a --> A ВКЛ/ВЫКЛ }
Soun = 4; { Звуковые сигналы ВКЛ/ВЫКЛ }
Colo = 5; { Цветовые сигналы ВКЛ/ВЫКЛ }
Pinf = 6; { Информ. панель ВКЛ/ВЫКЛ }
VAR DIRS : array [0..6] of DirStr; { Каталоги окружения }
CONST OWN = 0; { Собственная from Param(0) }
WRK = 1; { Рабочая from _WORK }
RDY = 2; { Сообщения from _READY }
SHB = 3; { Шаблоны from _SHAB }
PFM = 4; { Печ.формы from _FORMS }
MTF = 5; { MT формы from _MTFOR }
TMR = 6; { Временные файлы }
TYPE Grupa_VRF = record KP : byte; { Max к-во повторений }
KG : byte; { Вып. к-во повторений }
H : byte; { Начало - лог.н. поля }
K : byte { Конец - лог.н. поля }
end;
PrintString = procedure(var R : integer; S : String);
{R - Пред+Посл результат вывода строки S}
Types = record MTT : ExtStr; { Запись индекса MT_BASE }
SCT : LongInt end;
{ Простейшие функции }
function TSTMAP(I : integer) : boolean;
procedure ONEMAP(I : integer);
procedure ZERMAP(I : integer);
function FOCH (A : char) : boolean;
function COOprk(F : char; var C : char) : boolean;
function COOunp(F,C : char) : boolean;
procedure TEHT (H : pHead; N : integer; var L,M : integer);
procedure COHT (H : pHead; N : integer; var L,C : integer);
procedure CTPress(H : pHead; N : integer );
function Only_DTL(H : pHead; N : integer) : boolean;
function How_ELT(M : pMenu) : integer;
procedure UnoStr(var S; H : pHead; N : integer; B : boolean);
function Lask(H : pHead; N : integer; X : integer) : boolean;
function Sask(B : word; X : integer) : boolean;
procedure Sset(var B : word; XXX : integer; E : boolean);
procedure Lset(H : pHead; N : integer; XXX : integer; E : boolean);
function AlfaName(P : pAlfa) : Alfa;
procedure KillHead(H : pHead);
procedure KillBody(H : pHead; N : integer);
function Type_Field(N : integer) : integer;
function AGENT(N : integer; var Cko,Len : integer) : boolean;
function FINE(F : integer) : boolean;
function GATA : boolean;
IMPLEMENTATION
function TSTMAP(I : integer) : boolean;
begin TSTMAP:=odd(FIMAP[I shr 4] shr (I and 15)) end;
procedure ONEMAP(I : integer);
var L : integer;
W,T : word;
begin L:=I shr 4;
W:=I and 15;
T:=FIMAP[L];
if odd(T shr W) then Exit;
FIMAP[L]:=T or (1 shl W);
for W:=L+1 to COMAP do Inc(DOMAP[W]) end;
procedure ZERMAP(I : integer);
var L : integer;
W,T : word;
begin L:=I shr 4;
W:=I and 15;
T:=FIMAP[L];
if not odd(T shr W) then Exit;
FIMAP[L]:=T and ($FFFF xor (1 shl W));
for W:=L+1 to COMAP do Dec(DOMAP[W]) end;
function FOCH(A : char) : boolean;
begin FOCH:=(0 < Pos(A,FormatChars)) end;
function prk(var C : char) : char;
begin if Modes[UpCa] then C:=UpCaseChr(C); { NB: var! }
prk:=C end;
function InAlph(N,K : integer) : boolean;
begin InAlph:=odd(Alphabets[N,K shr 4] shr (K and 15)) end;
function COOTB(H : char; var B : char) : boolean;
var N : integer;
W : boolean;
begin N:=Pos(H,FormatChars);
if N = 0 then begin
B:=UNC;
COOTB:=false
end else begin
W:=InAlph(N,ord(prk(B)));
if (H = 'd') and (not W) then begin { Исключение для d }
B:=UpCaseChr(B);
W:=InAlph(4,ord(B)); { x? }
if W then
if B = ' ' then B:=','
else B:='.'
end;
COOTB:=W
end end;
{ COOprk : F - символ формата; C - поступивший символ }
{ Res = TRUE, если С соответствует F + [Перекодировка C] }
function COOprk(F : char; var C : char) : boolean;
begin if FOCH(F) then COOprk:=COOTB(F,C)
else COOprk:=(F = prk(C)) end;
function COOunp(F,C : char) : boolean;
begin COOunp:=COOprk(F,C) end;
procedure TEHT(H : pHead; N : integer; var L,M : integer);
var I : integer;
begin L:=0;
M:=0;
with H^.BDS[N] do
for I:=1 to LFT do
if FOCH(RFT^[I]) then Inc(M)
else if M = 0 then Inc(L) end;
procedure COHT(H : pHead; N : integer; var L,C : integer);
var I,M,F,U : integer;
begin TEHT(H,N,L,M);
with H^.BDS[N] do begin
F:=0;
U:=0;
for I:=L+1 to L+M do
if CTP^[I] = UNC then Inc(U)
else if U = 0 then Inc(F);
if U+F = M then C:=F
else C:=0
end end;
procedure CTPress(H : pHead; N : integer);
var I : integer;
begin with H^.BDS[N] do
if Sask(BOS,GES) then coxCB:=CTP^ else begin
coxCB:='';
for I:=1 to Length(CTP^) do
if CTP^[I] <> UNC then coxCB:=coxCB+CTP^[I]
end end;
function Only_DTL(H : pHead; N : integer) : boolean;
begin with H^.BDS[N] do
Only_DTL:=(DTL <> NIL) and (MN_MEM = NIL) end;
function How_ELT(M : pMenu) : integer;
begin How_ELT:=0;
if M <> NIL then
if M^.LON = '' then How_ELT:=M^.HSF end;
procedure UnoStr(var S; H : pHead; N : integer; B : boolean);
var I,L,M : integer;
begin String(S):='';
L:=0;
M:=H^.BDS[N].LFT;
if not B then TEHT(H,N,L,M);
with H^.BDS[N] do
for I:=L+1 to L+M do
if CTP^[I] <> UNC
then String(S):=String(S)+CTP^[I] end;
{ H^.BDS[N].XXX:=expression; -> Lset(H,N,XXX,E) }
{ with XXX:=expression; -> Sset(BOS,XXX,E) }
{ if H^.BDS[N].XXX -> Lask(H,N,XXX) }
{ if XXX -> Sask(BOS,XXX) }
function Lask(H : pHead; N : integer; X : integer) : boolean;
begin Lask:=odd(H^.BDS[N].BOS shr X) end;
function Sask(B : word; X : integer) : boolean;
begin Sask:=odd(B shr X) end;
procedure Sset(var B : word; XXX : integer; E : boolean);
begin if E then B:=B or (1 shl XXX)
else B:=B and (not (1 shl XXX)) end;
procedure Lset(H : pHead; N : integer; XXX : integer; E : boolean);
begin Sset(H^.BDS[N].BOS,XXX,E) end;
function AlfaName(P : pAlfa) : Alfa;
var S : String;
begin if P = NIL then S:='\\'
else S:=P^+'\'+P^+'\';
if Modes[Drus] then AlfaName:=NumbStr(1,S)
else AlfaName:=NumbStr(2,S) end;
procedure KillHead(H : pHead);
var I : integer;
begin if H = NIL then Exit;
for I:=1 to H^.HSF do KillBody(H,I) end;
procedure KillBody(H : pHead; N : integer);
var I : integer;
begin with H^.BDS[N] do begin
if 0 < LFT then begin
Sset(BOS,RP_BGN,false);
for I:=1 to LFT do begin
if FOCH(RFT^[I]) then CTP^[I]:=UNC;
INP^[I]:=' ';
if RP_PAT <> NIL then RP_PAT^[I]:=UNC
end
end;
if MN_MEM <> NIL then begin
DTL:=NIL;
MN_MEM^.Ent:=0;
for I:=1 to How_ELT(MN_MEM) do
KillHead(MN_MEM^.ELT[I].DTL)
end;
KillHead(DTL);
Sset(BOS,EMP,true );
Sset(BOS,TST,false);
Sset(BOS,UNE,false)
end end;
{ Type_Field - Тип поля 0 - обыкновенное; }
{ 1 - генератор группы }
function Type_Field(N : integer) : integer;
begin with MEAD^.BDS[N] do begin
if VRF <> NIL then Type_Field:=1
else Type_Field:=0
end end;
{ AGENT : N - является активным генератором }
{ и при этом: Cko - кол-во генераций }
{ Len - кол-во полей в одной генерации }
function AGENT(N : integer; var Cko,Len : integer) : boolean;
begin AGENT:=false;
with MEAD^.BDS[N] do
if VRF <> NIL then
with Grupa_VRF(VRF) do
if 1 < Kg then begin
AGENT:=true;
Cko:=Kg;
Len:=K-H
end end;
{ FINE : F - номер поля }
{ Res = TRUE, если поле корректно }
function FINE(F : integer) : boolean;
begin with MEAD^.BDS[F] do
if Type_Field(F) = 1 then FINE:=true { Генератор группы }
else if DTL = NIL then FINE:=true
else FINE:=Sask(BOS,TST) and Sask(BOS,COF) end;
{ GATA : Оценить полную корректность сообщения }
function GATA : boolean;
var I : integer;
begin GATA:=false;
for I:=1 to MEAD^.HSF do
if not FINE(I) then Exit;
GATA:=true end;
end.
|