{$A+,B-,D-,E+,F-,G-,I+,L+,N-,O-,R+,S+,V+,X-}
{$M 1024,0,0}
unit UNIF_FMS; INTERFACE
uses CRT, DOS;
VAR H_time, M_time, S_time : word;
function TimeSec : LongInt;
function TimeOvr(var T : LongInt; D : LongInt) : boolean;
function F16(N,M : integer) : integer;
function Csps(N : integer) : String;
function NNN(L : LongInt) : String;
function Ichar(I : integer) : boolean;
function Inumb(I : integer) : boolean;
function Cchar(I : char ) : boolean;
function Cnumb(I : char ) : boolean;
function DnCase(A : char ) : char;
function ValHex(A : char ) : integer;
function OnlyNumb(S : String; N : integer) : boolean;
function Exis_Dir(var SSS : String) : boolean;
procedure Val_Int(S : String; var R,K : integer);
function MinPos(P,S : String) : integer;
procedure Psps(var S ); { S : AnyString}
procedure ComPress(var S ); { S : AnyString}
procedure LefPress(var S ); { S : AnyString}
procedure TwoPress(var S ); { S : AnyString}
function UpCaseChr( C : char ) : char;
procedure UpCaseStr(var S ); { S : AnyString}
procedure DnCaseStr(var S ); { S : AnyString}
procedure LimitStr(var S; L : integer); { S : AnyString}
function LappStr(var S; L : integer) : String; { S : AnyString}
function PrefStr(P : String; var S) : boolean; { S : AnyString}
function HiPar(Key : String; var Val,Par : String) : boolean;
procedure SummStr( var S : String; C : string);
function QuanStr( var S : String ) : integer;
procedure BounStr(N : integer; var S : String; var H,L : integer);
function NumbStr(N : integer; var S : String) : String;
function MembStr( V,S : String) : integer;
procedure ExchStr(N : integer; var S : String; C : String);
function Fin_Str(var H,T : String) : boolean;
function LTFn(A,B : String) : boolean; { FileNames A < B }
procedure Merase(var A; L : integer);
function Rus_Numb(S : String; R3 : byte) : String;
IMPLEMENTATION
function TimeSec : LongInt;
var U : word;
T : LongInt;
begin GetTime(H_time,M_time,S_time,U);
T:=60*H_time+M_time;
TimeSec:=60*T +S_time end;
function TimeOvr(var T : LongInt; D : LongInt) : boolean;
var N : LongInt;
begin TimeOvr:=true;
N:=TimeSec;
if N < T then N:=86400+N;
if N < T+D then TimeOvr:=false
else if N < 86400 then T:=N
else T:=N-86400 end;
function F16(N,M : integer) : integer;
begin F16:=(N shr M) and $F end;
function Ichar(I : integer) : boolean;
begin Ichar:=((ord('A') <= I) and (I <= ord('Z'))) or
((ord('a') <= I) and (I <= ord('z'))) end;
function Inumb(I : integer) : boolean;
begin Inumb:=(ord('0') <= I) and (I <= ord('9')) end;
function Cchar(I : char) : boolean;
begin Cchar:=Ichar(ord(I)) end;
function Cnumb(I : char) : boolean;
begin Cnumb:=('0' <= I) and (I <= '9') end;
{ OnlyNumb : true, если S - непустая строка цифр }
{ И (если 0 < N, то) Length(S) = N }
function OnlyNumb(S : String; N : integer) : boolean;
var I,L : integer;
begin OnlyNumb:=false;
L:=Length(S);
if L = 0 then Exit;
if N <= 0 then N:=L
else if N <> L then Exit;
for I:=1 to N do
if not Cnumb(S[I]) then Exit;
OnlyNumb:=true end;
Const LBC:String[64] = 'абвгдежзийклмнопрстуфхцчшщъыьэюя'+
'АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ';
function DnCase(A : char) : char;
var K : integer;
begin if ('A' <= A) and (A <= 'Z')
then A:=chr(ord('a')+ord(A)-ord('A'));
K:=Pos(A,LBC);
if 32 < K then A:=LBC[K-32];
DnCase:=A end;
function Exis_Dir(var SSS : String) : boolean;
var I,K,W : integer;
P : boolean;
begin Exis_Dir:=false;
UpCaseStr(SSS);
W:=Length(SSS);
if (W = 0) or (68 < W) then Exit;
P:=false;
for I:=1 to W do begin
K:=Pos(SSS[I],LBC);
if 32 < K then begin { На самом деле : 0 < K }
P:=true;
SSS[I]:=LBC[K-32]
end
end;
if P then Exit;
if SSS[W] <> '\' then SSS:=SSS+'\';
W:=Length(SSS);
{$I-} MkDir(Copy(SSS,1,W-1));
{$I+} W:=IOresult;
Exis_Dir:=(W = 0) or (W = 5) end;
procedure Val_Int(S : String; var R,K : integer);
var L : LongInt;
begin R:=0;
Val(S,L,K);
if K <> 0 then Exit;
if (-32768 <= L) and (L <= 32767)
then R:=L
else K:=Length(S) end;
function MinPos(P,S : String) : integer;
var I,J,K : integer;
begin K:=Length(S)+1;
for I:=1 to Length(P) do begin
J:=Pos(P[I],S);
if 0 < J then
if J < K then K:=J
end;
MinPos:=K end;
function Csps(N : integer) : String;
var I : integer;
S : String;
begin if 255 < N then N:=255
else if N < 0 then N:=0;
for I:=1 to N do S[I]:=' ';
S[0]:=chr(N);
Csps:=S end;
function NNN(L : LongInt) : String;
var S : String;
begin Str(L,S); NNN:=S end;
procedure ComPress(var S); { S : AnyString}
var L : integer;
C : ^String;
begin C:=addr(S);
L:=Length(C^);
while (0 < L) and (C^[L] = ' ') do L:=L-1;
C^[0]:=chr(L) end;
procedure LefPress(var S); { S : AnyString}
var C : ^String;
I : integer;
begin C:=addr(S);
for I:=1 to Length(C^) do
if C^[I] <> ' ' then begin
if 1 < I then Delete(C^,1,I-1);
Exit
end;
C^:='' end;
procedure TwoPress(var S); { S : AnyString}
var I,J,L,E : integer;
C : ^String;
begin C:=addr(S);
L:=0;
E:=0;
for I:=1 to Length(C^) do
if C^[I] = ' ' then begin
if 0 < L then E:=E+1
end else begin
for J:=L+1 to L+E do C^[J]:=' ';
L:=L+E+1; C^[L]:=C^[I];
E:=0
end;
C^[0]:=chr(L) end;
procedure Psps(var S); { S : AnyString}
var C : ^String;
A : char;
I,L : integer;
begin C:=addr(S);
A:=' ';
L:=0;
for I:=1 to Length(C^) do
if (A <> ' ') or (C^[I] <> ' ') then begin
L:=L+1;
A:=C^[I];
C^[L]:=A
end;
C^[0]:=chr(L) end;
function UpCaseChr(C : char) : char;
var K : integer;
begin C:=UpCase(C);
K:=Pos(C,LBC);
if (0 < K) and (K <= 32) then UpCaseChr:=LBC[K+32]
else UpCaseChr:=C end;
procedure UpCaseStr(var S); { S : AnyString}
var I : integer;
C : ^String;
begin C:=addr(S);
for I:=1 to Length(C^) do C^[I]:=UpCaseChr(C^[I]) end;
procedure DnCaseStr(var S); { S : AnyString}
var I : integer;
C : ^String;
begin C:=addr(S);
for I:=1 to Length(C^) do C^[I]:=DnCase(C^[I]) end;
function ValHex(A : char) : integer;
begin ValHex:=-1;
if ('0' <= A) and (A <= '9') then ValHex:=ord(A)-ord('0');
if ('A' <= A) and (A <= 'F') then ValHex:=ord(A)-ord('A')+10 end;
procedure LimitStr(var S; L : integer); { S : AnyString}
var C : ^String;
begin C:=addr(S);
if L < Length(C^) then C^[0]:=chr(L) end;
function LappStr(var S; L : integer) : String; { S : AnyString}
var C : ^String;
R : String;
I : integer;
begin C:=addr(S);
R:=C^;
for I:=Length(R)+1 to L do R[I]:=' ';
R[0]:=chr(L);
LappStr:=R end;
function PrefStr(P : String; var S) : boolean;
var C : ^String;
K : integer;
begin C:=addr(S);
while P <> '' do begin
K:=Pos(P[Length(P)],P);
if Pos(Copy(P,1,K-1),C^) = 1 then begin
PrefStr:=true;
Exit
end;
Delete(P,1,K)
end;
PrefStr:=false end;
{ HiPar - потрошитель строки - параметров Par }
{ В строке Par найти P1+' '+Key+???+' '+P2 }
{ Если УСПЕХ, то RES = true, Val = ???, Par = P1+' '+P2 }
function HiPar(Key : String; var Val,Par : String) : boolean;
var K,N : integer;
begin HiPar:=false;
ComPress(Par);
if Par <> '' then begin
Psps(Par);
Par:=' '+Par+' ';
K:=Pos(' '+Key,Par);
if K = 0 then Exit;
Val:=Copy(Par,K+1,255);
N:=Pos(' ',Val);
Delete(Par,K+1,N);
Val[0]:=chr(N-1);
Delete(Val,1,Length(Key));
HiPar:=true;
end end;
{ SummStr = S := S + C + УникальныйСимвол }
procedure SummStr(var S : String; C : string);
var A : char;
I,L : integer;
begin L:=Length(S);
LimitStr(C,254-L);
if L = 0 then A:=chr(0)
else A:=S[L];
if Pos(A,C) <> 0 then begin
repeat
A:=Succ(A);
until (Pos(A,C) = 0) and (Pos(A,S) = 0);
for I:=1 to L do
if S[I] = S[L] then S[I]:=A
end;
S:=S+C+A end;
function Fin_Str(var H,T : String) : boolean;
var K : integer;
begin if T = '' then Fin_Str:=false else begin
K:=Length(T);
K:=Pos(T[K],T);
H:=Copy(T,1,K-1);
Delete(T,1,K);
Fin_Str:=true
end end;
{ Дополнительные функции обработки упакованных строк }
{ QuanStr - Количество упакованных строк }
{ BounStr - Hачало и Length строки номер N | H = 0 }
{ NumbStr - Строка номер N; '' - если отсутствует }
{ ExchStr - Заменить строку номер N на строку C }
{ при необходимости дописать пустыми строками }
function QuanStr(var S : String) : integer;
var I,K,L : integer;
begin K:=0;
L:=Length(S);
for I:=1 to L do
if S[I] = S[L] then K:=K+1;
QuanStr:=K end;
procedure BounStr(N : integer; var S : String; var H,L : integer);
var I,K : integer;
Z : char;
begin K:=0;
Z:=S[Length(S)];
for I:= 1 to Length(S) do
if S[I] = Z then begin
if 0 < N then begin
H:=K+1;
L:=I-1-K;
K:=I;
N:=N-1
end
end;
if 0 < N then begin
H:=0;
L:=N
end end;
function NumbStr(N : integer; var S : String) : String;
var H,L : integer;
begin BounStr(N,S,H,L);
if H <> 0 then NumbStr:=Copy(S,H,L)
else NumbStr:='' end;
function MembStr(V,S : String) : integer;
var C : String;
K : integer;
begin K:=0;
while Fin_Str(C,S) do begin
K:=K+1;
if C = V then begin
MembStr:=K;
Exit
end
end;
MembStr:=0 end;
procedure ExchStr(N : integer; var S : String; C : String);
var R : String;
I,H,K,L : integer;
Z,Y : char;
begin Z:=S[Length(S)];
BounStr(N,S,H,L);
if H = 0 then begin
while 1 < L do begin
SummStr(S,'');
L:=L-1
end;
SummStr(S,C);
Exit
end;
R:=Copy(S,H+L+1,255);
S:=Copy(S, 1,H-1);
if S <> '' then begin { Минимизировать маркер конца }
Y:=chr(0);
while (Y <> Z) and (Pos(Y,S) <> 0) do Y:=Succ(Y);
for I:=1 to Length(S) do
if S[I] = Z then S[I]:=Y
end;
SummStr(S,C);
while R <> '' do begin
K:=Pos(Z,R);
SummStr(S,Copy(R,1,K-1));
Delete(R,1,K)
end end;
function LTFn(A,B : String) : boolean; { FileNames A < B }
var I,L : integer;
begin if A[0] < B[0] then begin L:=Length(A); LTFn:=true end
else begin L:=Length(B); LTFn:=false end;
for I:=1 to L do
if A[I] <> B[I] then begin
if A[I] = '.' then LTFn:=true
else if B[I] = '.' then LTFn:=false
else LTFn:=(A[I] < B[I]);
Exit
end end;
procedure Merase(var A; L : integer);
var I : integer;
begin for I:=1 to 3 do begin
FillChar(A,L,$FF);
FillChar(A,L,$00) { Важно! - Память остается 0 }
end end;
{ Rus_Numb : S - число }
{ R3 - }
function Rus_Numb(S : String; R3 : byte) : String;
var C : String[40];
SS : String;
procedure Ney(N : integer; SC : String);
var I : integer;
R,D : String[40];
procedure Rey(A : char);
begin I:=Pos('('+A+')',SC);
if I = 0 then R:='' else begin
Delete(SC,1,I+2);
I:=Pos(' ',SC);
if I = 0 then I:=Length(SC)+1;
R:=Copy(SC,1,I-1)
end
end;
begin Rey(S[N]);
I:=Length(R);
if R[I] = '*' then begin
D:=Copy(R,1,I-1);
Rey('*');
R:=D+R
end;
C:=R
end;
procedure Appc;
begin if C <> '' then SS:=SS+' '+C;
C:=''
end;
begin S[4]:=chr(ord('0')+R3);
Ney(1,'(1)сто (2)двести (3)триста '+
'(4)четыреста (5)пять* (6)шесть* '+
'(7)семь* (8)восемь* (9)девять* (*)сот');
SS:=C;
if S[2] = '1' then begin
Ney(3,'(0)десять (1)один* (2)две* (3)три* '+
'(4)четыр* (5)пят* (6)шест* (7)сем* '+
'(8)восем* (9)девят* (*)надцать');
Appc;
Ney(4,'(1)тысяч (2)миллионов (3)миллиардов '+
'(4)триллионов (5)квадрильонов');
Appc
end else begin
Ney(2,'(2)двадцать (3)тридцать (4)сорок (5)пят* (6)шест* '+
'(7)сем* (8)восем* (9)девяносто (*)ьдесят');
Appc;
Ney(3,'(1)одна (2)две (3)три (4)четыре (5)пять '+
'(6)шесть (7)семь (8)восемь (9)девять');
if S[4] <> '1' then
if C <> '' then
if S[3] = '1' then C:='один'
else if S[3] = '2' then C:='два';
Appc;
if S <> '000' then begin
Ney(4,'(1)тысяч (2)миллион (3)миллиард '+
'(4)триллион (5)квадрильон');
Appc;
if R3 = 1 then Ney(3,'(1)а (2)и (3)и (4)и');
if R3 > 1 then Ney(3,'(0)ов (2)а (3)а (4)а '+
'(5)ов (6)ов (7)ов (8)ов (9)ов');
SS:=SS+C
end
end;
Psps(SS);
Rus_Numb:=SS
end;
end.
|