unit Pascal;

interface

uses
  SysUtils;

type
  TTranslit = (Ru, En, Num, Sym);

function Affiliation(n: integer; p: array of integer): boolean;
function AffiliationRange(n: integer; range: string): boolean;
function ByteAutoToKMGb(bytes: int64; count, measurement: byte): string;
function CodeToStr(s: string): string;
function ConvertRuEn(s: string; En: boolean): string;
function CopyN(s: string; index: byte; c: char): string;
function DeclensionNouns(n: int64; count1, count234, count5: string): string;
function EqualationQuadratic(a, b, c: real; var D, x1, x2: real): boolean;
function Factorial(n: integer): string;
function FormatFileName(FileName: string; Null: char = #0): string;
function FormatPercent(r: real; count: byte): string;
function FractionAdding(a1, b1, a2, b2: integer; var a, b: integer): real;
function FractionCommonDenominator(a, b: integer): integer;
function IntToStrGroup(n: string): string;
function MaxArray(p: array of integer): integer;
function MeanArray(p: array of real): real;
function MinArray(p: array of integer): integer;
function NumberAdd(a, b: string): string;
function NumberMul(a, b: string): string;
function NumberWords(n: int64): string;
function PosN(index: integer; substr, s: string): integer;
function RegistrCharLower(c: char): boolean;
function RegistrCharUpper(c: char): boolean;
function RegistrStringLower(s: string): boolean;
function RegistrStringUpper(s: string): boolean;
function StringLength(s: string; len: integer; c: char; right: boolean = false): string;
function StringReplaceNew(s, OldPattern, NewPattern: string; RegOld, RegNew: boolean): string;
function StrToCode(s: string; len: byte = 1): string;
function StrToFloatNew(s: string): real;
function StrToIntNew(s: string): int64;
function StrToNumber(s: string; sym: string = ''): string;
function SystemNum10to16(n: int64): string;
function SystemNum10to2(n: int64): string;
function SystemNum10toB(n: int64; b: byte): string;
function SystemNum16to10(s: string): int64;
function SystemNum16to2(s: string): string;
function SystemNum2to10(s: string): int64;
function SystemNum2to16(s: string): string;
function SystemNumAto10(s: string; a: byte): int64;
function SystemNumAtoB(s: string; a, b: byte): string;
function SystemNumByte(c: char): byte;
function SystemNumChar(n: byte): char;
function SystemNumN10toB(n: int64; b: byte): string;
function SystemNumR10toB(n: real; b, c: byte): string;
function SystemNumNAto10(s: string; a: byte): int64;
function SystemNumRAto10(s: string; a: byte): real;
function TranslitChar(s: char): TTranslit;
function TranslitRuEn(s: string; En: boolean): string;
function TranslitString(s: string; t: TTranslit): boolean;
function TrimLeftSym(s: string; sym: char = ' '): string;
function TrimRightSym(s: string; sym: char = ' '): string;
function TrimSym(s: string; sym: char = ' '): string;
function Utf8ToAnsiSym(s: string): string;
function WordRandom(len: integer; PROPIS, rus, eng, num: boolean): string;

implementation    

function Affiliation(n: integer; p: array of integer): boolean;
var i: integer;
begin
   Result:=false;
   for i:=Low(p) to High(p) do
      if n=p[i] then
      begin
         Result:=true;
         Exit;
      end;
end;

function AffiliationRange(n: integer; range: string): boolean;
var i, n1, n2: integer;
    s, z: string;
begin
   Result:=false;
   for i:=Length(range) downto 1 do
      if range[i]=' ' then
         Delete(range, i, 1);
   repeat
      i:=Pos(',', range);
      if i>0 then
      begin
         s:=Copy(range, 1, i-1);
         Delete(range, 1, i);
      end else
      begin
         s:=range;
         range:='';
      end;
      if s='' then
         Exit;
      i:=Pos('-', s);
      if i>0 then
      begin
         z:=Copy(s, 1, i-1);
         n1:=StrToInt(z);
         z:=Copy(s, i+1, Length(s));
         n2:=StrToInt(z);
      end else
      begin
         n1:=StrToInt(s);
         n2:=n1;
      end;
      if (n1<=n) and (n<=n2) then
      begin
         Result:=true;
         Exit;
      end;
   until range='';
end;

function ByteAutoToKMGb(bytes: int64; count, measurement: byte): string;
var l: byte;
    r: extended;
    s: string;

   function Meas(n: byte): string;
   const arr: array[0..4, 1..4] of string = (('б', 'бит', 'Б', 'байт'),
            ('Кб', 'Кбит', 'КБ', 'Кбайт'), ('Мб', 'Мбит', 'МБ', 'Мбайт'),
            ('Гб', 'Гбит', 'ГБ', 'Гбайт'), ('Тб', 'Тбит', 'ТБ', 'Тбайт'));
   begin
      Result:='';
      if (n<=4) and (measurement>=1) and (measurement<=4) then
         Result:=arr[n, measurement];
   end;

begin
   r:=bytes;
   s:=Meas(0);
   if bytes>=1E3 then
   begin
      r:=bytes/1024;
      s:=Meas(1);
   end;
   if bytes>=1E6 then
   begin
      r:=bytes/1024/1024;
      s:=Meas(2);
   end;
   if bytes>=1E9 then
   begin
      r:=bytes/1024/1024/1024;
      s:=Meas(3);
   end;
   if bytes>=1E12 then
   begin
      r:=bytes/1024/1024/1024/1024;
      s:=Meas(4);
   end;
   if bytes<1000 then
      count:=0;
   l:=Length(IntToStr(Trunc(r)));
   if l>=count then
      count:=l+1;
   Result:=Format('%*.*f', [l, count-l-1, r]);
   if s<>'' then
      Result:=Result+' '+s;
end;

function CodeToStr(s: string): string;
var i: integer;
begin
   Result:='';
   while s<>'' do
   begin
      i:=Pos('#', s);
      if i=0 then
         Exit;
      Delete(s, 1, i);
      i:=Pos('#', s);
      if i=0 then
         i:=Length(s)+1;
      Result:=Result+Char(StrToInt(Copy(s, 1, i-1)));
      Delete(s, 1, i-1);
   end;
end;

function ConvertRuEn(s: string; En: boolean): string;
const RuEn: array[0..1, 0..32] of string = (('й', 'ц', 'у', 'к', 'е', 'н', 'г',
         'ш', 'щ', 'з', 'ф', 'ы', 'в', 'а', 'п', 'р', 'о', 'л', 'д', 'я', 'ч',
         'с', 'м', 'и', 'т', 'ь', '?', '.', ',', '"', '№', ';', ':'),
        ('q', 'w', 'e', 'r', 't', 'y', 'u', 'i', 'o', 'p', 'a', 's', 'd', 'f',
         'g', 'h', 'j', 'k', 'l', 'z', 'x', 'c', 'v', 'b', 'n', 'm', '&', '/',
         '?', '@', '#', '$', '^'));
      RuEn1: array[0..1, 0..13] of string = (('х', 'Х', 'ъ', 'Ъ', 'ж', 'Ж', 'э',
         'Э', 'б', 'Б', 'ю', 'Ю', 'ё', 'Ё'), ('[', '{', ']', '}', ';', ':', '''',
         '"', ',', '<', '.', '>', '`', '~'));
var i: integer;
begin
   if En then
   begin
      for i:=Low(RuEn[0]) to High(RuEn[0]) do
         s:=StringReplaceNew(s, RuEn[0, i], RuEn[1, i], false, false);
      for i:=Low(RuEn1[0]) to High(RuEn1[0]) do
         s:=StringReplaceNew(s, RuEn1[0, i], RuEn1[1, i], true, false);
   end else
   begin
      for i:=High(RuEn1[0]) downto Low(RuEn1[0]) do
         s:=StringReplaceNew(s, RuEn1[1, i], RuEn1[0, i], false, true);
      for i:=High(RuEn[0]) downto Low(RuEn[0]) do
         s:=StringReplaceNew(s, RuEn[1, i], RuEn[0, i], false, false);
   end;      
   Result:=s;
end;

function CopyN(s: string; index: byte; c: char): string;
var i, n, l: integer;
begin
   n:=1;
   l:=0;
   if index<1 then
      index:=1;
   for i:=1 to Length(s) do
   begin
      if s[i]=c then
      begin
         Dec(index);
         if index<=0 then
            Break;
         if index=1 then
            n:=i+1;
      end else
         if index=1 then
            Inc(l);
   end;
   Result:=Copy(s, n, l);
end;

function DeclensionNouns(n: int64; count1, count234, count5: string): string;
begin
   Result:=IntToStr(n)+' '+count5;
   if n mod 10=1 then
      Result:=IntToStr(n)+' '+count1;
   if (n mod 10>=2) and (n mod 10<=4) then
      Result:=IntToStr(n)+' '+count234;
   if (n mod 100>=11) and (n mod 100<=14) then
      Result:=IntToStr(n)+' '+count5;
end;

function EqualationQuadratic(a, b, c: real; var D, x1, x2: real): boolean;
begin
   x1:=0;
   x2:=0;
   D:=b*b-4*a*c;
   Result:=(D>=0) and (a<>0);
   if not Result then
      Exit;
   x1:=(-b+Sqrt(D))/(2*a);
   x2:=(-b-Sqrt(D))/(2*a);
end;

function Factorial(n: integer): string;
const len = $2000;
var i, j, k, z, um: integer;
    p, p1: array[0..len-1] of byte;
begin
   for i:=1 to len-1 do
      p[i]:=0;
   p[0]:=1;
   for i:=1 to n do
   begin
      for j:=0 to len-1 do
         p1[j]:=0;
      z:=i;
      k:=0;
      repeat
         um:=0;
         for j:=0 to len-1 do
         begin
            if j+k>=len then
               Continue;
            p1[j+k]:=p1[j+k]+um+p[j]*(z mod 10);
            um:=p1[j+k] div 10;
            p1[j+k]:=p1[j+k] mod 10;
         end;
         Inc(k);
         z:=z div 10;
      until z=0;
      for j:=0 to len-1 do
         p[j]:=p1[j];
   end;
   Result:='';
   for i:=0 to len-1 do
      Result:=IntToStr(p[i])+Result;
   while (Result<>'') and (Result[1]='0') do
      Delete(Result, 1, 1);
end;

function FormatFileName(FileName: string; Null: char): string;
var i: integer;
begin
   for i:=Length(FileName) downto 1 do
      case FileName[i] of
      '\', '/', ':', '*', '?', '"', '''', '<', '>', '|':
         if Null=#0 then
            Delete(FileName, i, 1) else
            FileName[i]:=Null;
      end;
   Result:=FileName;
end;

function FormatPercent(r: real; count: byte): string;
var l: byte;
begin
   l:=Length(IntToStr(Trunc(r)));
   if l>=count then
      count:=l+1;
   Result:=Format('%*.*f%%', [l, count-l-1, r]);
end;

function FractionAdding(a1, b1, a2, b2: integer; var a, b: integer): real;
var i, m: integer;
begin
   b:=FractionCommonDenominator(b1, b2);
   a1:=b div b1 * a1;
   a2:=b div b2 * a2;
   a:=a1+a2;
   if a<b then
      m:=Abs(a) else
      m:=Abs(b);
   for i:=m downto 2 do
      if (a mod i = 0) and (b mod i = 0) then
      begin
         a:=a div i;
         b:=b div i;
         Break;
      end;
   Result:=a/b;
end;

function FractionCommonDenominator(a, b: integer): integer;
var z: integer;
begin
   if a>b then
   begin
      z:=a;
      a:=b;
      b:=z;
   end;
   Result:=b;
   while Result mod a<>0 do
      Result:=Result+b;
end;

function IntToStrGroup(n: string): string;
var i: integer;
begin
   i:=Length(n)-2;
   while i>1 do
   begin
      Insert(' ', n, i);
      i:=i-3;
   end;
   Result:=n;
end;

function MaxArray(p: array of integer): integer;
var i: integer;
begin
   Result:=p[Low(p)];
   for i:=Low(p)+1 to High(p) do
      if Result<p[i] then
         Result:=p[i];
end;

function MeanArray(p: array of real): real;
var i: integer;
begin
   Result:=0;
   for i:=Low(p) to High(p) do
      Result:=Result+p[i];
   Result:=Result/(High(p)-Low(p)+1);
end;

function MinArray(p: array of integer): integer;
var i: integer;
begin
   Result:=p[Low(p)];
   for i:=Low(p)+1 to High(p) do
      if Result>p[i] then
         Result:=p[i];
end;

function NumberAdd(a, b: string): string;
var i, len: integer;
    p: array of byte;
begin
   if Length(a)>Length(b) then
      len:=Length(a)+1 else
      len:=Length(b)+1;
   while Length(a)<len do
      a:='0'+a;
   while Length(b)<len do
      b:='0'+b;
   SetLength(p, len);
   Result:='';
   for i:=0 to len-1 do
      p[i]:=0;
   for i:=len downto 2 do
   begin
      p[i-1]:=p[i-1]+StrToInt(a[i])+StrToInt(b[i]);
      if p[i-1]>=10 then
      begin
         p[i-2]:=p[i-1] div 10;
         p[i-1]:=p[i-1] mod 10;
      end;
   end;
   for i:=0 to len-1 do
      Result:=Result+IntToStr(p[i]);
   while (Result<>'') and (Result[1]='0') do
      Delete(Result, 1, 1);
end;

function NumberMul(a, b: string): string;
var i, j: integer;
    s: string;
    p: array of byte;
begin
   SetLength(p, Length(a)+Length(b));
   Result:='';
   for i:=Length(a) downto 1 do
   begin
      s:='';
      for j:=0 to Length(a)+Length(b)-1 do
         p[j]:=0;
      for j:=Length(b) downto 1 do
      begin
         p[i+j-1]:=p[i+j-1]+StrToInt(a[i])*StrToInt(b[j]);
         if p[i+j-1]>=10 then
         begin
            p[i+j-2]:=p[i+j-1] div 10;
            p[i+j-1]:=p[i+j-1] mod 10;
         end;
      end;
      for j:=0 to Length(a)+Length(b)-1 do
         s:=s+IntToStr(p[j]);
      while (s<>'') and (s[1]='0') do
         Delete(s, 1, 1);
      Result:=NumberAdd(Result, s);
   end;
end;

function NumberWords(n: int64): string;
const Words1000: array[1..6, 0..2] of string =
        (('тысяча', 'тысячи', 'тысяч'),
         ('миллион', 'миллиона', 'миллионов'),
         ('миллиард', 'миллиарда', 'миллиардов'),
         ('триллион', 'триллиона', 'триллионов'),
         ('квадриллион', 'квадриллиона', 'квадриллионов'),
         ('квинтиллион', 'квинтиллиона', 'квинтиллионов'));
      Words100: array[1..9] of string =
        ('сто', 'двести', 'триста', 'четыреста', 'пятьсот',
         'шестьсот', 'семьсот', 'восемьсот', 'девятьсот');
      Words10: array[2..9] of string =
        ('двадцать', 'тридцать', 'сорок', 'пятьдесят',
         'шестьдесят', 'семьдесят', 'восемьдесят', 'девяносто');
      Words1: array[0..19] of string =
        ('ноль', 'один', 'два', 'три', 'четыре', 'пять',
         'шесть', 'семь', 'восемь', 'девять', 'десять', 'одиннадцать',
         'двенадцать', 'тринадцать', 'четырнадцать', 'пятнадцать',
         'шестнадцать', 'семнадцать', 'восемнадцать', 'девятнадцать');
      Words1_2: array[1..2] of string = ('одна', 'две');
var n1000: byte;
    s, znak: string;

   function Length3(a, n1000: integer): string;
   var b: byte;
       s: string;
   begin
      a:=a mod 1000; // для защиты
      b:=a div 100;
      a:=a mod 100;
      if b>0 then
         Result:=Words100[b] else
         Result:='';
      if (a>0) and (Result<>'') then
         Result:=Result+' ';
      if a>=20 then
      begin
         b:=a div 10;
         a:=a mod 10;
         if b>0 then
            Result:=Result+Words10[b];
         if a>0 then
         begin
            if Result<>'' then
               Result:=Result+' ';
            s:=Words1[a]; // два миллиона
            if (n1000=1) and (a>=1) and (a<=2) then // один или одна (два или две)
               s:=Words1_2[a]; // две тысячи
            Result:=Result+s;
         end;
      end else
         if a>0 then
         begin
            s:=Words1[a]; // два миллиона
            if (n1000=1) and (a>=1) and (a<=2) then // один или одна (два или две)
               s:=Words1_2[a]; // две тысячи
            Result:=Result+s;
         end;
      if (n1000>0) and (Result<>'') then
      begin
         Result:=Result+' ';
         if n1000>High(Words1000) then
         begin
            Result:=Format('%s(x 10^%d)', [Result, 3*n1000]);
            Exit;
         end;
         s:=Words1000[n1000, 2];
         if a=1 then
            s:=Words1000[n1000, 0];
         if (a>=2) and (a<=4) then
            s:=Words1000[n1000, 1];
         Result:=Result+s;
      end;
   end;

begin
   Result:='';
   if n<0 then
      znak:='минус ' else
      znak:='';
   n:=Abs(n);
   n1000:=0;
   while n>0 do
   begin
      s:=Length3(n mod 1000, n1000);
      Inc(n1000);
      if s<>'' then
      begin
         if Result<>'' then
            Result:=' '+Result;
         Result:=s+Result;
      end;
      n:=n div 1000;
   end;
   Result:=znak+Result;
   if Result='' then
      Result:=Words1[0];
end;

function PosN(index: integer; substr, s: string): integer;
begin
   if index<1 then
      index:=1;
   s:=Copy(s, index, Length(s));
   Result:=Pos(substr, s);
   if Result>0 then
      Result:=index+Result-1;
end;

function RegistrCharLower(c: char): boolean;
begin
   Result:=(c>='a') and (c<='z') or (c>='а') and (c<='я') or (c='ё');
end;

function RegistrCharUpper(c: char): boolean;
begin
   Result:=(c>='A') and (c<='Z') or (c>='А') and (c<='Я') or (c='Ё');
end;

function RegistrStringLower(s: string): boolean;
var i: integer;
begin
   Result:=false;
   for i:=1 to Length(s) do
      if RegistrCharLower(s[i]) then
      begin
         Result:=true;
         Exit;
      end;
end;

function RegistrStringUpper(s: string): boolean;
var i: integer;
begin
   Result:=false;
   for i:=1 to Length(s) do
      if RegistrCharUpper(s[i]) then
      begin
         Result:=true;
         Exit;
      end;
end;

function StringLength(s: string; len: integer; c: char; right: boolean): string;
begin
   while Length(s)<len do
      if right then
         s:=s+c else
         s:=c+s;
   Result:=s;
end;

function StringReplaceNew(s, OldPattern, NewPattern: string; RegOld, RegNew: boolean): string;
var str, patt, sc, np: string;
    len, p: integer;
begin
   if RegOld then
   begin
      str:=s;
      patt:=OldPattern;
   end else
   begin
      str:=AnsiLowerCase(s);
      patt:=AnsiLowerCase(OldPattern);
   end;
   Result:='';
   len:=Length(OldPattern);
   while str<>'' do
   begin
      p:=Pos(patt, str);
      if p=0 then
      begin
         Result:=Result+s;
         Break;
      end;
      Result:=Result+Copy(s, 1, p-1);
      sc:=Copy(s, p, len);
      np:=NewPattern;
      if not RegNew then
         if RegOld then
         begin
            if RegistrStringUpper(sc) and RegistrStringUpper(OldPattern) then
               np:=AnsiUpperCase(NewPattern);
            if not RegistrStringUpper(sc) and not RegistrStringUpper(OldPattern) then
               np:=AnsiLowerCase(NewPattern);
         end else
         begin
            if RegistrStringUpper(sc) then
               np:=AnsiUpperCase(NewPattern) else
               np:=AnsiLowerCase(NewPattern);
         end;
      Result:=Result+np;
      s:=Copy(s, p+len, Length(s));
      str:=Copy(str, p+len, Length(str));
   end;
end;

function StrToCode(s: string; len: byte): string;
var i: integer;
    n: string;
begin
   Result:='';
   for i:=1 to Length(s) do
   begin
      n:=IntToStr(Ord(s[i]));
      while Length(n)<len do
         n:='0'+n;
      Result:=Result+'#'+n;
   end;
end;

function StrToFloatNew(s: string): real;
var e: integer;
    s1, s2: string;
begin
   s:=UpperCase(s);
   e:=Pos('E', s);
   if e>1 then
   begin
      s1:=Copy(s, 1, e-1);
      s2:=Copy(s, e+1, Length(s));
      s1:=StrToNumber(s1, ',');
      s2:=StrToNumber(s2);
      s:=s1+'E'+s2;
   end else
      s:=StrToNumber(s, ',');
   Result:=StrToFloat(s);
end;

function StrToIntNew(s: string): int64;
begin
   s:=StrToNumber(s);
   Result:=StrToInt64(s);
end;

function StrToNumber(s, sym: string): string;
const DS = ',';
var i, z: integer;
begin
   { удаляем посторонние символы }
   for i:=Length(s) downto 1 do
      if Pos(s[i], '0123456789-'+sym)=0 then
         Delete(s, i, 1);
   { удаляем - }
   for i:=Length(s) downto 2 do
      if s[i]='-' then
         Delete(s, i, 1);
   { удаляем , }
   z:=Pos(DS, s);
   if z>0 then
   begin
      for i:=Length(s) downto z+1 do
         if s[i]=DS then
            Delete(s, i, 1);
      if s[1]='-' then
         if (Length(s)>=2) and (s[2]=DS) then
            Delete(s, 2, 1) else
         else
         if s[1]=DS then
            Delete(s, 1, 1);
      if (Length(s)>=1) and (s[Length(s)]=DS) then
         Delete(s, Length(s), 1);
   end;
   if (s='') or (s='-') then
      Result:='0' else
      Result:=s;
end;

function SystemNum10to16(n: int64): string;
var i: byte;
begin
   Result:='';
   while n>0 do
   begin
      i:=n mod 16;
      Result:=SystemNumChar(i)+Result;
      n:=n div 16;
   end;
   if Result='' then
      Result:='0';
end;

function SystemNum10to2(n: int64): string;
var i: byte;
begin
   Result:='';
   while n>0 do
   begin
      i:=n mod 2;
      Result:=IntToStr(i)+Result;
      n:=n div 2;
   end;
   if Result='' then
      Result:='0';
end;

{function SystemNum10to2(n: int64): string;
var i: integer;
begin
   Result:='';
   while n>0 do
   begin
      i:=n and 1;
      Result:=IntToStr(i)+Result;
      n:=n shr 1;
   end;
   if Result='' then
      Result:='0';
end;}

function SystemNum10toB(n: int64; b: byte): string;
var i: byte;
begin
   Result:='';
   if (b<2) or (b>36) then
      Exit;
   while n>0 do
   begin
      i:=n mod b;
      Result:=SystemNumChar(i)+Result;
      n:=n div b;
   end;
   if Result='' then
      Result:='0';
end;

function SystemNum16to10(s: string): int64;
var i, k: byte;
    step: int64;
begin
   Result:=0;
   step:=1;
   for i:=Length(s) downto 1 do
   begin
      k:=SystemNumByte(s[i]);
      Result:=Result+k*step;
      step:=step*16;
   end;
end;

function SystemNum16to2(s: string): string;
const Base: array[0..15, 0..1] of string =
        (('0000', '0'), ('0001', '1'), ('0010', '2'), ('0011', '3'),
         ('0100', '4'), ('0101', '5'), ('0110', '6'), ('0111', '7'),
         ('1000', '8'), ('1001', '9'), ('1010', 'A'), ('1011', 'B'),
         ('1100', 'C'), ('1101', 'D'), ('1110', 'E'), ('1111', 'F'));
var i, j: byte;
begin
   Result:='';
   for i:=1 to Length(s) do
      for j:=Low(Base) to High(Base) do
         if Base[j, 1]=UpCase(s[i]) then
         begin
            Result:=Result+Base[j, 0];
            Break;
         end;
   while (Result<>'') and (Result[1]='0') do
      Delete(Result, 1, 1);
   if Result='' then
      Result:='0';
end;

function SystemNum2to10(s: string): int64;
var i, k: byte;
    step: int64;
begin
   Result:=0;
   step:=1;
   for i:=Length(s) downto 1 do
   begin
      if (s[i]<'0') or (s[i]>'1') then
      begin
         { защита от посторонних символов }
         Result:=0;
         Exit;
      end;
      k:=StrToInt(s[i]);
      Result:=Result+k*step;
      step:=step*2;
   end;
end;

function SystemNum2to16(s: string): string;
const Base: array[0..15, 0..1] of string =
        (('0000', '0'), ('0001', '1'), ('0010', '2'), ('0011', '3'),
         ('0100', '4'), ('0101', '5'), ('0110', '6'), ('0111', '7'),
         ('1000', '8'), ('1001', '9'), ('1010', 'A'), ('1011', 'B'),
         ('1100', 'C'), ('1101', 'D'), ('1110', 'E'), ('1111', 'F'));
var i, j: byte;
begin
   Result:='';
   while Length(s) mod 4<>0 do
      s:='0'+s;
   for i:=1 to Length(s) div 4 do
      for j:=Low(Base) to High(Base) do
         if Base[j, 0]=Copy(s, 4*i-3, 4) then
         begin                 
            Result:=Result+Base[j, 1];
            Break;
         end;
   if Result='' then
      Result:='0';
end;

function SystemNumAto10(s: string; a: byte): int64;
var i, k: byte;
    step: int64;
begin
   Result:=0;
   if (a<2) or (a>36) then
      Exit;
   step:=1;
   for i:=Length(s) downto 1 do
   begin
      k:=SystemNumByte(s[i]);
      Result:=Result+k*step;
      step:=step*a;
   end;
end;

function SystemNumAtoB(s: string; a, b: byte): string;
var i, k: byte;
    n, step: int64;
begin
   Result:='';
   if (a<2) or (a>36) or (b<2) or (b>36) then
      Exit;
   { перевод в десятичное число }
   n:=0;
   step:=1;
   for i:=Length(s) downto 1 do
   begin
      k:=SystemNumByte(s[i]);
      n:=n+k*step;
      step:=step*a;
   end;
   { далее перевод в нужную систему счисления }
   while n>0 do
   begin
      i:=n mod b;
      Result:=SystemNumChar(i)+Result;
      n:=n div b;
   end;
   if Result='' then
      Result:='0';
end;

{function SystemNumAtoB(s: string; a, b: byte): string;
var n: int64;
begin
   n:=SystemNumAto10(s, a);
   Result:=SystemNum10toB(n, b);
end;}

function SystemNumByte(c: char): byte;
begin
   Result:=0;
   c:=UpCase(c);
   if (c>='0') and (c<='9') then
      Result:=Ord(c)-48;
   if (c>='A') and (c<='Z') then
      Result:=Ord(c)-55;
end;

function SystemNumChar(n: byte): char;
begin
   Result:='0';
   if n<=9 then
      Result:=Char(48+n);
   if (n>=10) and (n<=35) then
      Result:=Char(55+n);
end;

function SystemNumN10toB(n: int64; b: byte): string;
var i, k, z, len: byte;              
    min, max: int64;
    minus: boolean;

   procedure BitCount(byt { байты }: byte);
   var a, b: int64;
       bit { биты }: byte;
   begin
      bit:=8*byt-1;
      a:=-(int64(1) shl bit);  // -128
      b:=int64(1) shl bit - 1; // 127
      if (a<=n) and (n<=b) then
      begin
         min:=a;
         max:=b;
         z:=byt;               // 1 (байт)
      end;
   end;

begin
   Result:='';
   if (b<2) or (b>36) then
      Exit;
   { определяем диапазон допустимых чисел, например, от -128 до 127 (1 байт) }
   min:=0;
   max:=0;
   z:=0;
   BitCount(8);
   BitCount(4);
   BitCount(2);
   BitCount(1);
   { определяем длину выводимой строки результата }
   case b of
   2: len:=8*z;
   3: len:=5*z;
   4..6: len:=4*z;
   7..15: len:=3*z;
   else
      len:=2*z;
   end;
   { процесс вычисления }
   minus:=n<0;
   n:=Abs(n);
   z:=1;
   for k:=1 to len do
   begin
      i:=n mod b;
      if minus then
      begin
         i:=b-i+z-1;
         z:=i div b;
         i:=i mod b;
      end;
      Result:=SystemNumChar(i)+Result;
      n:=n div b;
   end;
end;

function SystemNumR10toB(n: real; b, c: byte): string;
var i: byte;
begin
   Result:=SystemNum10toB(Trunc(n), b);
   if c>0 then
      Result:=Result+',';
   for i:=1 to c do
   begin
      n:=Frac(n)*b;
      Result:=Result+SystemNumChar(Trunc(n));
   end;
end;

function SystemNumNAto10(s: string; a: byte): int64;
var i, k, len: byte;
    max, step: int64;
begin
   Result:=0;
   if (a<2) or (a>36) then
      Exit;
   case a of
   2: len:=8;
   3: len:=5;
   4..6: len:=4;
   7..15: len:=3;
   else
      len:=2;
   end;
   k:=Length(s) div len;
   len:=Length(s) mod len;
   if len>0 then
      k:=k+len;             // 1 (байт)
   k:=8*k-1;                // 7 (бит)
   max:=int64(1) shl k - 1; // 127
   Result:=SystemNumAto10(s, a);
   if Result>max then
   begin
      Result:=0;
      step:=1;
      for i:=Length(s) downto 1 do
      begin
         k:=SystemNumByte(s[i]);
         k:=a-k-1;
         Result:=Result+k*step;
         step:=step*a;
      end;
      Result:=-Result-1;
   end;
end;

function SystemNumRAto10(s: string; a: byte): real;
var i, k: byte;
    step: int64;
    sk { дробная часть числа }: string;
begin
   Result:=0;
   if (a<2) or (a>36) then
      Exit;
   k:=Pos(',', s);
   if k>0 then
   begin
      sk:=Copy(s, k+1, Length(s));
      s:=Copy(s, 1, k-1);
   end else
      sk:='';
   Result:=SystemNumAto10(s, a);
   step:=a;
   for i:=1 to Length(sk) do
   begin
      k:=SystemNumByte(sk[i]);
      Result:=Result+k/step;
      step:=step*a;
   end;
end;

function TranslitChar(s: char): TTranslit;
begin
   Result:=Sym;
   if (s>='А') and (s<='я') or (s='ё') or (s='Ё') then
      Result:=Ru;
   if (s>='A') and (s<='z') then
      Result:=En;
   if (s>='0') and (s<='9') then
      Result:=Num;
end;

function TranslitRuEn(s: string; En: boolean): string;
const RuEn: array[0..1, 0..36] of string = (('щ', 'ё', 'ж', 'ц', 'ч', 'ш', 'ы', 'э',
         'ю', 'я', 'а', 'б', 'в', 'в', 'г', 'д', 'е', 'з', 'и', 'й', 'к', 'л', 'м',
         'н', 'о', 'п', 'р', 'с', 'т', 'у', 'ф', 'х', 'ц', 'ъ', 'ы', 'ь', 'ь'),
        ('sch', 'yo', 'zh', 'ts', 'ch', 'sh', 'yi', 'ye', 'yu', 'ya', 'a', 'b', 'v',
         'w', 'g', 'd', 'e', 'z', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'r', 's',
         't', 'u', 'f', 'h', 'c', '''''', 'y', '''', '`'));
var i: integer;
    a, b: byte;
begin
   if En then
   begin
      a:=0;
      b:=1;
   end else
   begin
      a:=1;
      b:=0;
   end;
   for i:=Low(RuEn[0]) to High(RuEn[0]) do
      s:=StringReplaceNew(s, RuEn[a, i], RuEn[b, i], false, false);
   Result:=s;
end;

function TranslitString(s: string; t: TTranslit): boolean;
var i: integer;
begin
   Result:=false;
   for i:=1 to Length(s) do
      if TranslitChar(s[i])=t then
      begin
         Result:=true;
         Exit;
      end;
end;

function TrimLeftSym(s: string; sym: char): string;
begin
   while (s<>'') and (s[1]=sym) do
      Delete(s, 1, 1);
   Result:=s;
end;

function TrimRightSym(s: string; sym: char): string;
begin
   while (s<>'') and (s[Length(s)]=sym) do
      Delete(s, Length(s), 1);
   Result:=s;
end;

function TrimSym(s: string; sym: char): string;
begin
   while (s<>'') and (s[1]=sym) do
      Delete(s, 1, 1);
   while (s<>'') and (s[Length(s)]=sym) do
      Delete(s, Length(s), 1);
   Result:=s;
end;

function Utf8ToAnsiSym(s: string): string;
begin
   s:=Utf8ToAnsi(s);
   s:=StringReplaceNew(s, '&amp;', '&', false, false);
   s:=StringReplaceNew(s, '&lt;', '<', false, false);
   s:=StringReplaceNew(s, '&gt;', '>', false, false);
   s:=StringReplaceNew(s, '&ndash;', #150, false, false);
   s:=StringReplaceNew(s, '&minus;', '-', false, false);
   s:=StringReplaceNew(s, '&mdash;', #151, false, false);
   s:=StringReplaceNew(s, '&deg;', #176, false, false);
   s:=StringReplaceNew(s, '&sect;', #167, false, false);
   s:=StringReplaceNew(s, '&hellip;', #133, false, false);
   s:=StringReplaceNew(s, '&nbsp;', #160, false, false);
   { можно добавить и другие спецсимволы }
   Result:=s;
end;

function WordRandom(len: integer; PROPIS, rus, eng, num: boolean): string;
var b: array[0..255] of boolean;
    i, n: integer;
begin
   Result:='';
   if not PROPIS and not rus and not eng and not num then
      Exit;
   for i:=0 to 255 do
      b[i]:=false;
   if num then
      for i:=48 to 57 do
         b[i]:=true;
   if PROPIS and eng then
      for i:=65 to 90 do
         b[i]:=true;
   if eng then
      for i:=97 to 122 do
         b[i]:=true;
   if PROPIS and rus then
      for i:=192 to 223 do
         b[i]:=true;
   if rus then
      for i:=224 to 255 do
         b[i]:=true;
   n:=0;
   while n<len do
   begin
      Inc(n);
      i:=Random(256);
      if b[i] then
         Result:=Result+Char(i) else
         Dec(n);
   end;
end;

end.