{Здесь собраны все более-менее универсальные функции и процедуры,
используемые в Unit1.pas}
unit MyFunc;

interface

uses SysUtils, Windows, ComObj, Variants, Classes, Forms;

  function RoundFloat(r: real; i: integer): string;
  function FirstWord(const S: string; Sep: Char = ' '): string;
  function FirstSimpleAfter(m: integer): integer;
  function PJWHash(const aKey: string; aTableSize: integer): integer;
  //function  Hash(const aKey: string; aTableSize: integer): integer;
  function HFind(var List: TStringList; const K: string; var TSize,
                     Index: integer; Sep: char = '|'): boolean;
  function PosCh(aCh: Char; const S: string; StartPos: integer = 1): integer;
  function LastPosCh(aCh: Char; const S: string): integer;
  function RuleLeft(const Rule: string): string;
  function RuleRight(const Rule: string): string;
  function PosN(const P: string; const S: string; StartPos: integer = 1): integer;
  function IsDos(const S: string): boolean;
  function IsKoi(const S: string):boolean;
  function IsUTF(const S: string): boolean;
  function Dos2Win(const aStr: string): string;
  function KOI8ToWin(const aStr: string): string;
  function UTF8ToStr(Value: string): string;
  function UTF8ToStrSmart(Value: string): string;
  function KillTags(S: string; var Bin: TStringList): string;
  function IsNakedStars(const S: string): boolean;
  //function IsNonLetters(S: string): boolean;
  function IsBB(const w: string): boolean;
  function BB(const W: string): string;
  function IsBadAbb(const w: string; m: integer): boolean;
  function Body(const W: string): string;
  function Tail(const W: string): string;
  function StarTail(const W: string): string;
  function Nose(const W: string): string;
  function KillRQuotes(const W: string): string;
  function Quotes(const W: string): string;
  function WCod(const x: string): string;
  function WCodToHex(cod: string): string;
  function RusWord(const x: string): boolean;
  function EngWord(const x: string): boolean;
  function FilterByMask(S, Mask, Dest: string): string;
  function MatchStrings(source, pattern: string):Boolean;
  function Doc2Txt(DocName: string): string;
  //function Doc2Rtf(DocName: string): string;
  function Doc2Htm(DocName: string): string;
  function Demagog2MSWord(MyText: string; DocName: string = ''): boolean;
  function Similarity(const X, Y: string; M: integer): real;
  function SAPI5cbX(): string;
  function SAPI4cbX(): string;
  function Puff(const s: string; MaxLength: integer): string;
  function Cenzored(const w, masks: string; var MustDie: boolean): boolean;
  function Repress(const w: string): string;
  function NumeralToPhrase(const S: string): string;
  function NumToPhr(const S: string): string;
  function AllNumToPhr(const S: string): string;
  //function EncodeBase64(const inStr: string): string;
  function DecodeBase64(const CinLine: string): string;
  function Mark(W: string; Ch: char = '`'): string;
  function UnMark(W: string): string;
  function IsMarked(W: string; Ch: char = '`'): boolean;
  procedure Fragments(const S: string; FS: integer; var Frag, FragPos: TStringList);
  procedure SplitStr(const S: string; var Words: TStringList; Sep: Char = ' ');
  procedure SplitText(const S: string; var Words: TStringList);
  procedure Trunks(const W: string; var Keys: TStringList; Star, Dollar: boolean);
  procedure AllPictures(const Folder: string; var PF: TStringList);
  procedure ProgramRestart;

implementation

var
  NONLETTERS: set of char = ['.',',',':',';','!','?',#133,'"',#171,#187,'(',')'];


{Перезапустить программу}
procedure ProgramRestart;
var
  FullProgPath: PChar;
  PMSI: TStartupInfo;
  PMPI: TProcessInformation;
begin
  FillChar(PMSI,SizeOf(PMSI),#0);
  PMSI.cb := SizeOf(PMSI);
  FullProgPath := PChar(Application.ExeName);
  try
    CreateProcess(nil, FullProgPath, nil, nil, False, NORMAL_PRIORITY_CLASS,
                  nil, nil, PMSI, PMPI);
    Application.Terminate;
  except
  end;
end;


{Округление вещественного числа до заданного к-ва десятичных знаков}
function RoundFloat(r: real; i: integer): string;
begin
  DecimalSeparator := '.';
  Result:=FloatToStr(Round(r*exp(i*ln(10)))/(exp(i*ln(10))));
end;


{Первое слово в строке}
function FirstWord(const S: string; Sep: Char = ' '): string;
var
  k: integer;
begin
  k := PosCh(Sep,S);
  if k > 0 then Result := Copy(S,1,k-1)
           else Result := S;
end;


{Первое простое число, равное или превышающее m}
function FirstSimpleAfter(m: integer): integer;
var
  n, k: integer;
  simple: boolean;
begin
  n := m;
  if n mod 2 = 0 then Inc(n);
  while True do begin
    k := 3;
    simple := True;
    while k*k<n do begin
      if (n mod k = 0) then simple := False;
      Inc(k);
    end;
    if not simple then Inc(n,2)
                  else begin
                    Result := n;
                    exit;
                  end;
  end;
end;


{Хеш-функция(P.J.Weinberger). Настоятельно рекомендуется, чтобы
aTableSize было простым числом}
function PJWHash(const aKey: string; aTableSize: integer): integer;
var
  G: longint;
  i: integer;
  Hash: longint;
begin
  Hash := 0;
  for i := 1 to Length(akey) do begin
    Hash := (Hash shl 4)+ord(aKey[i]);
    G := Hash and longint($F0000000);
    if (G <> 0) then
      Hash := (Hash xor (G shr 24)) xor G;
  end;
  Result := Hash mod aTableSize;
end;


//{Простейшая хеш-функция для строк. Может, кому пригодится :)}
//function  Hash(const aKey: string; aTableSize: integer): integer;
//const  M=31;
//var i: integer;
//begin
//   Result:=0;
//   for  i:=1  to  length(aKey) do
//     Result := (M*Result+ord(aKey[i])) mod aTableSize;
//end;


{Поиск в хеш-таблице, содержащей строки вида K|rule1|rule2|...}
function HFind(var List: TStringList; const K: string; var TSize,
                   Index: integer; Sep: char = '|'): boolean;
var
  i1: integer;
  Key: string;
begin
  Index := PJWHash(K,TSize);
  i1 := Index;
  while True do begin
    if List[Index] = '' then begin  {Строка пуста - не найдено}
      Result := False;
      exit;
    end else begin
      Key := FirstWord(List[Index],Sep);
      if Key = K then begin  {Строка не пуста, ключ совпал - найдено}
        Result := True;
        exit;
      end;
    end;
    {Если мы здесь, значит ключ не совпал - проверить следующую строку}
    Inc(Index);
    if Index = TSize then Index := 0;
    if Index = i1 then begin  {Переполнение хеш-таблицы!}
      Index := -1;
      Result := False;
      exit;
    end;
  end;  {Бесконечный цикл}
end;


{Все огрызки заданного слова в порядке убывания длины, с добавлением * слева,
справа, с обеих сторон. Первым "огрызком" является само слово. Далее четные
огрызки отличаются от нечетных отсутствием $ впереди и нижним регистром всех
символов. Если знака $ в словаре нет, то огрызки вида $... не генерируются.
Если знака * в словаре нет, то огрызки не генерируются вовсе!}
procedure Trunks(const W: string; var Keys: TStringList; Star, Dollar: boolean);
var
  i, j, n: integer;
  K, K1, hvost, shnobel: string;
begin
  Keys.Clear;
  if W = '' then exit;
  hvost := Tail(W);
  shnobel := Nose(W);
  K := W;
  {Ежели слово со знаками препинания, кавычками и скобками,
  то начинаем с него, как оно есть}
  if shnobel+hvost <> '' then begin
    if Dollar then Keys.Append('$'+K);
    Keys.Append(AnsiLowerCase(K));
  end;
  if Body(K) <> '' then K := Body(K);  {!}
  if Dollar then Keys.Append('$'+K);
  Keys.Append(AnsiLowerCase(K));
  n := Length(K);
  {Затем огрызки в порядке убывания длины}
  if Star then begin
    for i := 0 to n-1 do
    for j := 1 to i+1 do begin
      K1 := Copy(K,j,n-i);
      if j = 1 then begin
        if Dollar then Keys.Append('$'+K1+'*');
        Keys.Append(AnsiLowerCase(K1)+'*');
        if Dollar then Keys.Append('$*'+K1+'*');
        Keys.Append('*'+AnsiLowerCase(K1)+'*');
      end;
      if j = i+1 then begin  {Здесь учитываем и варианты со знаками препинания}
        if Dollar then begin
          Keys.Append('$*'+K1);
          if hvost <> '' then Keys.Append('$*'+K1+hvost);
        end;
        Keys.Append('*'+AnsiLowerCase(K1));
        if hvost <> '' then Keys.Append('*'+AnsiLowerCase(K1)+hvost);
        if i <> 0 then begin
          if Dollar then Keys.Append('$*'+K1+'*');
          Keys.Append('*'+AnsiLowerCase(K1)+'*');
        end;
      end;
      if (1 < j) and (j < i+1) then begin
        if Dollar then Keys.Append('$*'+K1+'*');
        Keys.Append('*'+AnsiLowerCase(K1)+'*');
      end;
    end;
  {Огрызки из одной * м.б. в комбинации со знаками препинания
  Примеры:  *, и все.=, и всё. | *, тем большую=, тем бо<льшую}
    if Dollar then Keys.Append('$*');
    Keys.Append('*');
    if hvost <> '' then begin
      if Dollar then Keys.Append('$*'+hvost);
      Keys.Append('*'+hvost);
    end;
    if shnobel <> '' then begin
      if Dollar then Keys.Append('$'+shnobel+'*');
      Keys.Append(shnobel+'*');
    end;
   {!Экзотика, потому в самом конце. Ежели слово со знаками препинания,
   кавычками и скобками... то оно же с добавлением звездочек}
    if shnobel+hvost <> '' then begin
      if Dollar then Keys.Append('$'+W+'*');
      Keys.Append(AnsiLowerCase(W)+'*');
      if Dollar then Keys.Append('$*'+W+'*');
      Keys.Append('*'+AnsiLowerCase(W)+'*');
    end;
  end;
end;


{Обработка правила цензуры:
_CENZ_=маска_слова1 маска_слова2 ... маска_нач_слова1..маска_кон_слова1 ...
Примеры:
_CENZ_=[*] <*>   - игнорировать слово в квадратных и угловых скобках
_CENZ_=бля* еб* ёб* хуй хуя хуе* хуё*  - игнорировать слова по маске или целиком
_CENZ_=[*..*] [ .. ]   - игнорировать ВСЕ слова внутри квадратных скобок;
                         в 1-м случае скобки прилегают вплотную к словам,
                         во 2-м скобки отделены от слов пробелами}
function Cenzored(const w, masks: string; var MustDie: boolean): boolean;
  function Proba(x, m: string): boolean;
  begin
    Result := False;
    if m = '' then exit;    
    if Tail(m) = '' then Result := MatchStrings(AnsiLowerCase(Body(x)),m)
                    else Result := MatchStrings(AnsiLowerCase(x),m);
  end;
var
  i, k: integer;
  b: TStringList;
  c1, c2: string;
begin
  Result := False;
  if w = '' then exit;
  b := TStringList.Create;
  SplitStr(masks,b);
  for i := 0 to b.Count-1 do begin
    {маска1..маска2 - захватывает множество слов}
    c1 := '';
    c2 := '';
    k := Pos('..',b[i]);
    if k > 0 then begin
      c1 := Copy(b[i],1,k-1);
      c2 := Copy(b[i],k+2,Length(b[i])-k-1);
    end;
    if Proba(w,c1) then begin
      Result := True;
      MustDie := True;
    end;
    if Proba(w,c2) then begin
      Result := True;
      MustDie := False;
    end;
    if MustDie then Result := True;
    {маска, соответствующая одному слову}
    if (b[i] <> '*') and Proba(w,b[i]) then Result := True;
  end;
  b.Free;
end;


{Поиск СИМВОЛА в строке. Работает в 5 раз быстрее стандартной Pos(), т.к.
не производится неявного преобразования символьного типа в строковый}
function PosCh(aCh: Char; const S: string; StartPos: integer = 1): integer;
var
  i: integer;
begin
  Result := 0;
  for i := StartPos to Length(S) do
    if (S[i] = aCh) then begin
      Result := i;
      exit;
    end;
end;


function LastPosCh(aCh: Char; const S: string): integer;
var
  i: integer;
begin
  Result := 0;
  for i := Length(S) downto 1 do
    if (S[i] = aCh) then begin
      Result := i;
      exit;
    end;
end;


{2 следующие функции позврляют создать быстродействующие аналоги
методов TStringList: .Names() и .ValueFromIndex(), но деление строки
производится по ПОСЛЕДНЕМУ знаку "="}

{Левая часть правила LeftString=RightString}
function RuleLeft(const Rule: string): string;
begin
  Result := Copy(Rule,1,LastPosCh('=',Rule)-1);
end;

{Правая часть правила LeftString=RightString}
function RuleRight(const Rule: string): string;
begin
  Result := Copy(Rule,LastPosCh('=',Rule)+1,Length(Rule));
end;


{Поиск подстроки в строке методом "грубой силы". В цикле может работать заметно
быстрее стандартной Pos(), т.к. позволяет продолжать поиск уже от найденного}
function PosN(const P: string; const S: string; StartPos: integer = 1): integer;
var
  i, j: Integer;
begin
  Result := 0;
  if Length(P) > Length(S) then exit;
  for i := StartPos to Length(S) - Length(P) + 1 do
    for j := 1 to Length(P) do
      if P[j] <> S[i + j - 1] then break
      else if j = Length(P) then begin
        Result := i;
        exit;
      end;
end;


{Кусочек строки в начале, два в середке, кусочек в конце}
function Probe(const S: string; m: integer): string;
var
  S1, S2, S3: string;
  n: integer;
begin
  n := Length(S);
  if n <= 4*m then begin
    Result := S;
    exit;
  end;
  S1 := Copy(S,1,m);
  S2 := Copy(S,Round(n/2)-m,2*m);
  S3 := Copy(S,n-m,m);
  Result := S1+' '+S2+' '+S3;
end;


{Распознание кодировки DOS по местоположению символов в кодовой таблице}
function IsDos(const S: string): boolean;
  var
    i, win, dos: integer;
    Frag: string;
  begin
    win := 0; dos := 0; Result := False;
    if S = '' then exit;
    Frag := Probe(Trim(S),80);
    for i := 1 to Length(Frag) do begin
      case ord(Frag[i]) of
        128..175: Inc(dos);
        196..255: Inc(win);
      end;
    end;
    if win < dos then Result:=true;
end;


function Dos2Win(const aStr: String): String;
begin
  Result := aStr;
  if Result='' then Exit;
  OemToChar(PChar(Result),PChar(Result));
end;


function IsKoi(const S: string):boolean;
  {Распознание кодировки KOI8-R по аномалии в частоте появления букв
  'Пп' и 'Аа'. В KOI8-R им соответствуют буквы 'оО' и 'юЮ'. В русских
  текстах "о" встречается в 33 раза чаще "ю", а "п" в 3.3 раза реже "а".
  И если "Пп" появляется в тексте ЧАЩЕ "Аа", то... вы меня поняли :).
  Для русских текстов длиннее 250 символов распознание практически 100%-е}
var
    i, win, koi: integer;
    Frag: string;
begin
  win := 0; koi := 0; Result := False;
  if S = '' then exit;
  Frag := Probe(Trim(S),400);
  for i := 1 to Length(Frag) do begin
    case ord(Frag[i]) of
      207: Inc(koi);
      239: Inc(koi);
      192: Inc(win);
      224: Inc(win);
    end;
  end;
  //if win < koi then result := True;
  {Если текст короткий, то подсчет частоты букв ненадежен.
  Заранее даем win-кодировке фору в 1 балл :)}
  if win+1 < koi then result := True;
end;


function IsUTF(const S: string): boolean;
var
  c: string;
begin
  Result := False;
  c := AnsiLowerCase(Copy(S,1,512));
  if (PosN('encoding="utf-8"',c) > 0) or (PosN('charset=utf-8"',c) > 0) then
    Result := True;
end;


function KOI8ToWin(const aStr: String): String;
var
  n,i,j,k: integer;
  const
  Koi: string =
  #128#129#130#131#132#133#134#135#136#137#138#139#140#141#142#143+
  #144#145#146#147#148#149#150#151#152#153#154#155#156#157#158#159+
  #160#161#162#163#164#165#166#167#168#169#170#171#172#173#174#175+
  #176#177#178#179#180#181#182#183#184#185#186#187#188#189#190#191+
  #192#193#194#195#196#197#198#199#200#201#202#203#204#205#206#207+
  #208#209#210#211#212#213#214#215#216#217#218#219#220#221#222#223+
  #224#225#226#227#228#229#230#231#232#233#234#235#236#237#238#239+
  #240#241#242#243#244#245#246#247#248#249#250#251#252#253#254#255;
  Win: string =
  #128#129#130#131#132#133#134#135#136#137#138#139#140#141#142#143+
  #144#145#146#147#148#149#150#151#152#153#218#155#176#157#183#159+
  #160#161#162#184#186#165#166#191#168#169#170#171#172#173#174#175+
  #156#177#178#168#170#181#182#175#184#185#186#187#188#189#190#185+
  #254#224#225#246#228#229#244#227#245#232#233#234#235#236#237#238+
  #239#255#240#241#242#243#230#226#252#251#231#248#253#249#247#250+
  #222#192#193#214#196#197#212#195#213#200#201#202#203#204#205#206+
  #207#223#208#209#210#211#198#194#220#219#199#216#221#217#215#218;
begin
  Result := '';
  if aStr = '' then Exit;
  n := Length(aStr);
  for i:=1 to n do begin
    k := 0;
    for j := 1 to 128 do
      if aStr[i] = Koi[j] then begin
        k := j;
        break;
      end;
    if k <> 0 then Result := Result+Win[k]
              else Result := Result+aStr[i];
  end;
end;

{Следующие 2 функции найдены в Инете, автор - неизвестен.
Предназначены для замены неправильно работающей стандартной
ф-ции UTF8ToAnsi(), которая по непонятным причинам, часто
возвращает пустую строку вместо сконвертированной}

{Convert string from UTF-8 format into ASCII}
function UTF8ToStr(Value: String): String;
var
  buffer: Pointer;
  BufLen: LongWord;
begin
  BufLen := Length(Value) + 4;
  GetMem(buffer, BufLen);
  FillChar(buffer^, BufLen, 0);
  MultiByteToWideChar(CP_UTF8, 0, @Value[1], BufLen - 4, buffer, BufLen);
  Result := WideCharToString(buffer);
  FreeMem(buffer, BufLen);
end;

{Convert string from UTF-8 format mixed with standart ASCII symbols($00..$7f)}
function UTF8ToStrSmart(Value: String): String;
var
  Digit: String;
  i: integer; // Word;
  HByte: Byte;
  Len: Byte;
begin
  Result := '';
  Len := 0;
  if Value = '' then Exit;
  for i := 1 to Length(Value) do
  begin
    if Len > 0 then
    begin
      Digit := Digit + Value[i];
      Dec(Len);
      if Len = 0 then
        Result := Result + UTF8ToStr(Digit);
    end else
    begin
      HByte := Ord(Value[i]);
      if HByte in [$00..$7f] then       //Standart ASCII chars
        Result := Result + Value[i]
      else begin
        //Get length of UTF-8 char
        if HByte and $FC = $FC then
          Len := 6
        else if HByte and $F8 = $F8 then
          Len := 5
        else if HByte and $F0 = $F0 then
          Len := 4
        else if HByte and $E0 = $E0 then
          Len := 3
        else if HByte and $C0 = $C0 then
          Len := 2
        else begin
          Result := Result + Value[i];
          Continue;
        end;
        Dec(Len);
        Digit := Value[i];
      end;
    end;
  end;
end;


{Удаление тегов из html-подобного текста.
Блоки внедренного бинарного кода запоминается в TStringList.
Для каждого блока сохраняется ведущий тег <binary...>, т.к. он
содержит информацию об имени и типе внедренного файла}
function KillTags(S: string; var Bin: TStringList): string;
var
  i, j, k, m: integer;
  htag: boolean;
  copied, hcopied, c, ReplIt, DeleIt: string;
  a: TStringList;
  b: TStringList;
begin
  Bin.Clear;
  a := TStringList.Create;
  b := TStringList.Create;
  ReplIt := '&copy;=(c)|&nbsp;= |&amp;=&|&lt;=<|&gt;=>|&quot;="|&ndash;=-|'+
            '&mdash;=-|&laguo="|&raquo;="|&hellip;=...';
  DeleIt := '<script=</script|<genre=</genre|<style=</style|'+
            '<stylesheet=</stylesheet|<id=</id|<author=</author|'+
            '<lang=</lang|<src-lang=</src-lang|<document-info=</document-info|'+
            '<history=</history|<date=</date|<program-used=</program-used|'+
            '<custom-info=</custom-info|<!--=-->';
  SplitStr(ReplIt,a,'|');
  SplitStr(DeleIt,b,'|');
  htag := False;
  Result := '';
  i := 0;
  while i <= Length(S) do begin
    Inc(i);
    if (S[i] = '&') and not htag then begin
      for j := 0 to a.Count-1 do
        if AnsiLowerCase(Copy(S,i,Length(a.Names[j]))) = a.Names[j] then begin
          Result := Result+a.ValueFromIndex[j];
          Inc(i,Length(a.Names[j])-1);
        end;
    end else begin
      if S[i] = '<' then begin
        htag := True;
        for j := 0 to b.Count-1 do
          if AnsiLowerCase(Copy(S,i,Length(b.Names[j]))) = b.Names[j] then begin
            k := PosN(b.ValueFromIndex[j],S,i+1);
            if k > 0 then i := k;
          end;
        if AnsiLowerCase(Copy(S,i,7)) = '<binary' then begin  {Проверка на внедренный бинарный код}
          k := PosN('>',S,i+1);
          if k > 0 then begin
            hcopied := Copy(S,i,k-i+1);
            m := PosN('</binary',S,k+1);
            if m > 0 then begin
              copied := Copy(S,k+1,m-k);
              i := m;
            end else copied := '';
          end else begin
            hcopied := '';
            copied := '';
          end;
          if (hcopied <> '') and (copied <> '') then Bin.Add(AnsiLowerCase(hcopied)+copied);
        end;
      end else begin
      c := S[i];
      {----------------------------------------------}
      if S[i] = #9 then c := ' ';
      if S[i] in [#150,#151] then c := '-';
      if S[i] in [#132,#147,#171,#187] then c := '"';
      if S[i] = #133 then c := '...';
      if S[i] = #169 then c := '(c)';      
      {----------------------------------------------}
      end;
      if not htag then Result := Result+c;
      if htag and (i < Length(S)-1) and (AnsiLowerCase(Copy(S,i,3)) = '<p>')
        then Result := Result+#13#10;
      if S[i] = '>' then htag := False;
    end;
  end;
  a.Free;
  b.Free;
end;


{Пометить слово неким символом впереди; снять пометку; проверить пометку}
function Mark(W: string; Ch: char = '`'): string; begin Result := Ch+W; end;
function UnMark(W: string): string; begin Result := Copy(W,2,Length(W)-1); end;
function IsMarked(W: string; Ch: char = '`'): boolean; begin Result := False; if W = '' then exit; Result := (W[1] = Ch); end;


{Состоит ли строка из одного повторяющегося через пробел(ы) или двойного символа}
function IsNakedStars(const S: string): boolean;
var
  i: integer;
begin
  Result := True;
  if Pos('**',S) > 0 then begin
    Result := False;
    exit;
  end;
  for i := 1 to Length(S) do if not (S[i] in ['*',' ']) then begin
    Result := False;
    exit;
  end;
end;


//function IsNonLetters(S: string): boolean;
//var
//  i: integer;
//begin
//  Result := True;
//  for i := 1 to Length(S) do
//    if not (S[i] in NONLETTERS) then begin
//      Result := False;
//      exit;
//    end;
//end;

{Проверка слова на 1-ю большую букву С ИГНОРИРОВАНИЕМ КАВЫЧЕК И СКОБОК}
function IsBB(const w: string): boolean;
var
  N, i: integer;
begin
  Result := False;
  N := Length(W);
  for i := 1 to N do begin
    if not (W[i] in NONLETTERS)
      then begin
         if W[i] in ['А'..'Я','Ё','A'..'Z'] then Result := True;
         break;
      end
  end;
end;


{Делает 1-ю букву в слове большой}
function BB(const W: string): string;
var
  N, i: integer;
begin
  Result := W;
  if W = '' then exit;
  N := Length(W);
  for i := 1 to N do begin
    if not (W[i] in NONLETTERS)
      then begin
         Result := Copy(W,1,i-1)+AnsiUpperCase(W[i])+Copy(W,i+1,N-i+1);
         break;
      end
  end;
end;


{Слишком длинное слово из больших букв - это не аббревиатура,
а просто слово, написанное большими буквами!}
function IsBadAbb(const w: string; m: integer): boolean;
var
  i, k, n: integer;
begin
  Result := False;
  if w = '' then exit;
  n := Length(w);
  k := 0;
  for i := 1 to n do if w[i] in ['А'..'Я','Ё','A'..'Z'] then begin
    Inc(k);
    if (k > m) or (w[i] in ['Ъ','Ь','Ё','Ы','Й']) then begin
      Result := True;
      exit;
    end;
  end;
end;


{Удалить из строки все не-буквенные и не-цифровые символы}
function Repress(const w: string): string;
var
  i, n: integer;
begin
  Result := '';
  if w = '' then exit;
  n := Length(w);
  for i := 1 to n do
    if w[i] in ['А'..'Я','Ё','A'..'Z','0'..'9','а'..'я','ё','a'..'z','_','-',' ']
      then Result := Result+w[i];
end;


{Нечеткое сравнение строк X, Y. 0 - ничего общего, 1 - ну, очень похожи.
Ищутся все подстроки строки X, не большие M символов, в строке Y и количество
успешных поисков делится на общее число подстрок. Отношение "сходства" не
транзитивно! Sim(X,Y) не равно, вообще говоря, Sim(Y,X). Еще одно важное
свойство: если X целиком содержится в Y, то Sim(X,Y) = 1}
function Similarity(const X, Y: string; M: integer): real;
function Sim(const X, Y: string; M: integer): real;
var
  n, i, j, Good, Vsego: integer;
  a, b, c: string;
  R: real;
begin
  R := 0;
  n := Length(X);
  Vsego := 0;
  Good := 0;
  a := X;
  b := Y;
  for i := n-m to n-1 do
    for j := 1 to i+1 do begin
      c := Copy(a,j,n-i);
      Inc(Vsego);
      if Pos(AnsiLowerCase(c),AnsiLowerCase(b)) > 0 then Inc(Good);
    end;
  if Vsego > 0 then R := Good/Vsego;
  Result := R;
end;  {Sim}
var
  a, b: real;
begin
 {Транзитивный вариант нечеткого сравнения строк}
  a := Sim(X,Y,M);
  b := Sim(Y,X,M);
  if a > b then Similarity := a
           else Similarity := b;
end;


{Удаляет из строки "не буквенные" символы справа и слева.
Body('...Элементарно, Ватсон!..') ==> 'Элементарно, Ватсон'}
function Body(const W: string): string;
var
  N, i: integer;
  a: string;
begin
  N := Length(W);
  a := '';
  //if (N > 0) and (N <= 3) and (W[N] = ')') then begin Result := W; exit; end;
  //if (N > 0) and (N <= 4) and (W[1] = '(') and (W[N] = ')') then begin Result := W; exit; end;
  for i := N downto 1 do begin
    {Остальные знаки считаются "буквами"}
    if not (W[i] in NONLETTERS) then begin
      a := Copy(W,1,i);
      break;
    end
  end;
  N := Length(a);
  for i := 1 to N do begin
    if not (a[i] in NONLETTERS) then begin
      a := Copy(a,i,N-i+1);
      break;
    end
  end;
  Result := a;
end;


{Возвращает строку из "не буквенных" знаков справа.
Tail('Элементарно, Ватсон!..') ==> '!..'}
function Tail(const W: string): string;
var
  N, i: integer;
  b: string;
begin
  N := Length(W);
  b := W;
  for i := N downto 1 do begin
    {Остальные знаки считаются "буквами"}
    if not (W[i] in NONLETTERS)
      then begin
         b := Copy(W,i+1,N-i+1);
         break;
      end
  end;
  Result := b;
end;


{Возвращает строку из "не буквенных" знаков справа, "замкнутых" звездочкой.
StarTail('1)*') ==> ')'
StartTail('$Tел.*') ==> '.'}
function StarTail(const W: string): string;
begin
  Result := '';
  if W[Length(W)] = '*' then Result := Tail(Copy(W,1,Length(W)-1));
end;


{Возвращает строку из "не буквенных" знаков слева.
Nose('("...О, черт!..")') ==> '("...'}
function Nose(const W: string): string;
var
  N, i: integer;
  b: string;
begin
  N := Length(W);
  b := W;
  for i := 1 to N do begin
    if not (W[i] in NONLETTERS)
      then begin
         b := Copy(W,1,i-1);
         break;
      end
  end;
  Result := b;
end;


{Убрать кавычки и скобки СПРАВА}
function KillRQuotes(const W: string): string;
var
  N: integer;
  Bod, Tai: string;
begin
  Result := W;
  if W = '' then exit;  
  N := Length(W);
  if (N <= 3) and (W[N] = ')') then begin Result := W; exit; end;
  if (N <= 4) and (W[1] = '(') and (W[N] = ')') then begin Result := W; exit; end;
  Bod := Body(W);
  Tai := Tail(W);
  Tai := StringReplace(Tai,'(','',[rfReplaceAll]);
  Tai := StringReplace(Tai,')','',[rfReplaceAll]);
  Tai := StringReplace(Tai,'"','',[rfReplaceAll]);
  Tai := StringReplace(Tai,#171,'',[rfReplaceAll]);
  Tai := StringReplace(Tai,#187,'',[rfReplaceAll]);
  Result := Bod+Tai;
end;


{Только кавычки и скобки, обнаруженные в данной строке}
function Quotes(const W: string): string;
var
  i, j, N: integer;
  a, b: string;
begin
  Result := '';
  if W = '' then exit;  
  N := Length(W);
  b := StringOfChar(' ',N);
  SetString(a,PChar(b),N);
  j := 1;
  for i := 1 to N do begin
    if W[i] in [#171,#187,'"','(',')'] then begin
      a[j] := W[i];
      Inc(j);
    end;
  end;
  Result := TrimRight(a);
end;


function WCod(const x: string): string;
var
  k: integer;
  b: string;
begin
  Result := '0000';
  b := '0';
  k := Pos(' ',x);
  if  k > 0 then b := Copy(x, k+1, 1);
  if b = '1' then Result := '0001';
  if b = '2' then Result := '0010';
  if b = '3' then Result := '0011';
  if b = '4' then Result := '0100';
  if b = '5' then Result := '0101';
  if b = '6' then Result := '0110';
  if b = '7' then Result := '0111';
  if b = '8' then Result := '1000';
  if b = '9' then Result := '1001';
  if b = 'A' then Result := '1010';
  if b = 'B' then Result := '1011';
  if b = 'C' then Result := '1100';
  if b = 'D' then Result := '1101';
  if b = 'E' then Result := '1110';
  if b = 'F' then Result := '1111';
end;


function WCodToHex(cod: string): string;
begin
  Result := '';
  if cod = '0001' then Result := '1';
  if cod = '0010' then Result := '2';
  if cod = '0011' then Result := '3';
  if cod = '0100' then Result := '4';
  if cod = '0101' then Result := '5';
  if cod = '0110' then Result := '6';
  if cod = '0111' then Result := '7';
  if cod = '1000' then Result := '8';
  if cod = '1001' then Result := '9';
  if cod = '1010' then Result := 'A';
  if cod = '1011' then Result := 'B';
  if cod = '1100' then Result := 'C';
  if cod = '1101' then Result := 'D';
  if cod = '1110' then Result := 'E';
  if cod = '1111' then Result := 'F';
end;


function RusWord(const x: string): boolean;
var
  i, n: integer;
begin
  if x = '' then begin Result := True; exit; end;
  Result := True;
  n := Length(x);
  for i := 1 to n do begin
    if not (x[i] in ['а'..'я','А'..'Я','ё','Ё']) then begin
      Result := False;
      break;
    end;
  end;
end;


function EngWord(const x: string): boolean;
var
  i, n: integer;
begin
  if x = '' then begin Result := True; exit; end;
  Result := True;
  n := Length(x);
  for i := 1 to n do begin
    if not (x[i] in ['a'..'z','A'..'Z',#39]) then begin
      Result := False;
      break;
    end;
  end;
end;


{Замена в слове S по правилу Mask=Dest. Например:
Правило               Результат
-------------------------------------------------
крабьими=кра<бьими    крабьими=кра<бьими
туник*=туни<к         туниками ==> туни<ками
                      туникой ==> туни<кой
*ъем=ъём              подъем ==> подъём
                      объем ==> объём
*астерт*=астёрт       растертый ==> растёртый
-------------------------------------------------
Подразумевается, что вопрос о "подходящести" слова
по маске уже решен положительно}
function FilterByMask(S, Mask, Dest: string): string;
var
  Nos, Tai, S0: string;
  Dollar: boolean;
  k: integer;
begin
  Dollar := False;
  if (Length(S) > 0) and (S[1] = '$') then begin
    S := Copy(S,2,Length(S)-1);
    Nos := Nose(S);
    Tai := Tail(S);
    S := '$'+Body(S)+Tai;
    Dollar := True;
  end else begin
    Nos := Nose(S);
    Tai := Tail(S);
  end;
  {Чтобы обрабатывать на общих основаниях замены по правилам $*...=Dest
  В остальных случаях $ замену не испортит, т.к. в Dest его нет}
  if (Length(S) > 1) and (Length(Mask) > 1)
                     and (Mask[1] = '$') and (Mask[2] = '*') then begin
    S := Copy(S,2,Length(S)-1);
    Mask := Copy(Mask,2,Length(Mask)-1);
  end;
  S0 := AnsiLowerCase(S);  //
  Result := S;
  {Экстраординарный случай: замена отдельно стоящих знаков препинания!}
  if (Body(Mask) = '') and (Tail(Mask) <> '') then begin
    Result := Dest;
    exit;
  end;
  {Нетипичный случай, замену не делать}
  if (Dest = '') and (Mask <> '*') and (Body(Mask) = '*') then begin
    Result := S;
    exit;
  end;
  {Слово совпало со словарным}
//  if S = Mask then begin
  if (Dollar and (S = Mask)) or (not Dollar and (S0 = Mask)) then begin
    Result := Dest;
    exit;
  end;
  {Слово без правых кавычек и скобок совпало со словарным}
//  if KillRQuotes(S) = Mask then begin
  if (Dollar and (KillRQuotes(S) = Mask)) or (not Dollar and (KillRQuotes(S0) = Mask))  then begin
    Result := Nos+Dest+Quotes(Tai);
    exit;
  end;
  {Слово без знака препинания совпало со словарным}
//  if Body(S) = Mask then begin
  if (Dollar and (Body(S) = Mask)) or (not Dollar and (Body(S0) = Mask)) then begin
    Result := Nos+Dest+Tai;
    exit;
  end;
  {Слово (с препинанием или без!) подходит по маске со звездочкой в начале}
  if (Mask[1] = '*') and (Mask[Length(Mask)] <> '*') then begin
    if Tail(Mask) = '' {сравнение по маске делалось БЕЗ учета знаков препинания в S}
      then Result := Copy(S,1,Length(S)-Length(Tai)-Length(Mask)+1)+Body(Dest)+Tai
      else Result := Copy(S,1,Length(S)-Length(Mask)+1)+Dest; ///+Tai;
    exit;
  end;
  {Слово (м.б. со знаком препинания) подходит по маске со звездочкой в конце}
  if (Mask[1] <> '*') and (Mask[Length(Mask)] = '*') then begin
    if Dollar then Result := Nos+Dest+Copy(S,Length(Mask),Length(S)-Length(Mask)+1)
              else Result := Nos+Dest+Copy(S,Length(Nos)+Length(Mask),Length(S)-Length(Nos)-Length(Mask)+1);
    if Dest = '' then Result := Mark(Result);  {Пометить измененное слово, как "охвосток"}
    exit;
  end;
  {Слово подходит по маске со звездочками с обеих сторон}
  if (Mask[1] = '*') and (Mask[Length(Mask)] = '*') then begin
  Result := StringReplace(S,Copy(Mask,2,Length(Mask)-2),Dest,[rfReplaceAll,rfIgnoreCase]);
    exit;
  end;
end;


{*********************************************************************
Сравнение строки по маске. Строка не должна содержать * и ?.
Маска (искомый образ) может содержать любые символы.
Пример: MatchStrings('David Stidolph','*St*') ==> True.
Автор оригинального C-кода: Sean Stanley.
Автор портации на Delphi: David Stidolph.
Очень быстро работающая функция!
**********************************************************************}
{Все лишнее закомментировано! Теперь "?" в тексте МОЖЕТ содержаться!!!
Функция IsWildPattern - вообще здесь не использовалась, и видимо,
была включена на всякий пожарный случай: если захочется проверить,
что pattern - действительно является маской, т.е. содержит * и/или ?}
Function MatchStrings(source, pattern: string):Boolean;
var
  pSource : Array [0..255] of Char;
  pPattern : Array [0..255] of Char;

Function MatchPattern(element, pattern:PChar): Boolean;
//Function IsPatternWild(pattern: PChar):Boolean;
//Begin
//  Result:=StrScan(pattern,'*')<> nil;
//  If not Result Then Result:=StrScan(pattern,'?')<> nil;
//End;
Begin
  If StrComp(pattern,'*')=0
  Then Result := True
  Else If (element^ = Chr(0)) and (pattern^ <> Chr(0))
       Then Result:=False
       Else If element^ = Chr(0)
            Then Result := True
            Else Begin
              Case pattern^ of
                '*': If MatchPattern(element,@pattern[1])
                     Then Result:=True
                     Else Result := MatchPattern(@element[1],pattern);
              //  '?': Result := MatchPattern(@element[1],@pattern[1]);
              Else If element^=pattern^
                   Then Result := MatchPattern(@element[1],@pattern[1])
                   Else Result := False;
              End;
            End;
End;

Begin
  Result := False;
  if Length(source) > 255 then exit;
  if Length(pattern) > 255 then exit;
  StrPCopy(pSource,source);
  StrPCopy(pPattern,pattern);
  Result:=MatchPattern(pSource,pPattern);
End;
{**********************************************************************}


{Конвертация DOC => TXT с использованием OLE-объекта MS Word.
Эта функция сразу СОХРАНЯЕТ созданный txt-файл и возвращает его ИМЯ.
Допустимые значения FileFormat:
  Word 2000/XP
   0        Нормальный (формат Word)
   1        Шаблон документа
   2        Только текст (extended characters saved in ANSI character set)
   3        Текст+Переносы (plain text with line breaks; extended 
            characters saved in ANSI character set) 
   4        Только текст (PC-8) (extended characters saved in IBM PC 
            character set)
   5        Текст+Переносы (PC-8) (text with line breaks; extended
            characters saved in IBM PC character set) 
   6        Формат Rich-text (RTF)
  Word XP
   7        Unicode / Encoded Text
   8        HTML
   9        Web-архив
  10        Filtered HTML
}
function Doc2Txt(DocName: string): string;
var
  WordApp: Variant;
  TxtName: string;
begin
  try
    WordApp := CreateOleObject('Word.Application');
  except
    Result := '';
    exit;
  end;
  TxtName := ChangeFileExt(DocName, '.txt');
  WordApp.Documents.Open(DocName);
//  WordApp.ActiveDocument.SaveAs(FileName := TxtName, FileFormat := 2);
  WordApp.ActiveDocument.SaveAs(TxtName, 2);
  WordApp.ActiveDocument.Close;
  WordApp.Quit;
  WordApp := UnAssigned;
  Result := TxtName;
end;

{Аналогично. DOC => RTF. Сейчас не нужна}
//function Doc2Rtf(DocName: string): string;
//var
//  WordApp: Variant;
//  TxtName: string;
//begin
//  try
//    WordApp := CreateOleObject('Word.Application');
//  except
//    Result := '';
//    exit;
//  end;
//  TxtName := ChangeFileExt(DocName, '.rtf');
//  WordApp.Documents.Open(DocName);
//  WordApp.ActiveDocument.SaveAs(TxtName, 6);
//  WordApp.ActiveDocument.Close;
//  WordApp.Quit;
//  WordApp := UnAssigned;
//  Result := TxtName;
//end;

{Аналогично. DOC => HTML}
function Doc2Htm(DocName: string): string;
var
  WordApp: Variant;
  HtmName: string;
begin
  try
    WordApp := CreateOleObject('Word.Application');
  except
    Result := '';
    exit;
  end;
  HtmName := ChangeFileExt(DocName, '.htm');
  WordApp.Documents.Open(DocName);
  WordApp.ActiveDocument.SaveAs(HtmName, 8);
  WordApp.ActiveDocument.Close;
  WordApp.Quit;
  WordApp := UnAssigned;
  Result := HtmName;
end;

{Запись строки MyText в документ MS Word. Если имя файла документа не задано,
создается новый документ. Запись текста производится за позицией курсора.
По материалам статьи Андрея Нечаева (http://nech.tamb.ru)}
function Demagog2MSWord(MyText: string; DocName: string = ''): boolean;
var
  WordApp: Variant;
begin
  Result := True;
  try
    WordApp := CreateOleObject('Word.Application');
  except
    Result := False;
    exit;
  end;
  WordApp.Visible := True;
  if DocName = '' then WordApp.Documents.Add  {Создание нового документа}
                  else WordApp.Documents.Open(DocName); {открытие существующего документа}
  WordApp.Selection.TypeText(Text := MyText);
  WordApp.Selection.TypeParagraph;  {добавление нового абзаца}
end;
    

function SAPI4cbX(): string;
begin
  Result :=  'x1'+#13#10+'x2'+#13#10+'x4'+#13#10+'x8'+#13#10+'x16'+#13#10+
             'x32'+#13#10+'x64'#13#10+'MAX';
end;


function SAPI5cbX(): string;
begin
  Result :=
  'SAFT8kHz8BitMono'    +#13#10+
  'SAFT8kHz8BitStereo'  +#13#10+
  'SAFT8kHz16BitMono'   +#13#10+
  'SAFT8kHz16BitStereo' +#13#10+
  'SAFT11kHz8BitMono'   +#13#10+
  'SAFT11kHz8BitStereo' +#13#10+
  'SAFT11kHz16BitMono'  +#13#10+
  'SAFT11kHz16BitStereo'+#13#10+
  'SAFT12kHz8BitMono'   +#13#10+
  'SAFT12kHz8BitStereo' +#13#10+
  'SAFT12kHz16BitMono'  +#13#10+
  'SAFT12kHz16BitStereo'+#13#10+
  'SAFT16kHz8BitMono'   +#13#10+
  'SAFT16kHz8BitStereo' +#13#10+
  'SAFT16kHz16BitMono'  +#13#10+
  'SAFT16kHz16BitStereo'+#13#10+
  'SAFT22kHz8BitMono'   +#13#10+
  'SAFT22kHz8BitStereo' +#13#10+
  'SAFT22kHz16BitMono'  +#13#10+
  'SAFT22kHz16BitStereo'+#13#10+
  'SAFT24kHz8BitMono'   +#13#10+
  'SAFT24kHz8BitStereo' +#13#10+
  'SAFT24kHz16BitMono'  +#13#10+
  'SAFT24kHz16BitStereo'+#13#10+
  'SAFT32kHz8BitMono'   +#13#10+
  'SAFT32kHz8BitStereo' +#13#10+
  'SAFT32kHz16BitMono'  +#13#10+
  'SAFT32kHz16BitStereo'+#13#10+
  'SAFT44kHz8BitMono'   +#13#10+
  'SAFT44kHz8BitStereo' +#13#10+
  'SAFT44kHz16BitMono'  +#13#10+
  'SAFT44kHz16BitStereo'+#13#10+
  'SAFT48kHz8BitMono'   +#13#10+
  'SAFT48kHz8BitStereo' +#13#10+
  'SAFT48kHz16BitMono'  +#13#10+
  'SAFT48kHz16BitStereo';
end;


{Разрядка пробелами, до заданной длины, строки, в которой слова изначально
разделялись ЕДИНСТВЕННЫМ пробелом. Если на входе - строка пробелов, возвращается
пустая строка. Используется при форматировании литературного текста}
function Puff(const s: string; MaxLength: integer): string;
var
  w: TStringList;
  m, i, j, n, delta: integer;
begin
  Result := '';
  w := TStringList.Create;
  SplitStr(s,w);
  m := 0;
  n := w.Count;
  if n = 0 then exit;
  for i := 0 to n-1 do begin
    if i < n-1 then w[i] := w[i]+' ';
    m := m+Length(w[i]);
  end;
  delta := MaxLength-m;
  while delta > 0 do begin
    j := Random(n-1);
    if w[j] <> '- ' then begin
      w[j] := w[j]+' ';
      Dec(delta);
    end;
  end;
  for i := 0 to n-1 do Result := Result+w[i];
  w.Free;
end;


{Запомнить текст в TStringList фрагментами не менее заданного числа байт,
с остановкой на первом абзаце (включительно!), выходящем за обозначенный предел.
В результате, если текст вообще не разделен на абзацы, то последний (он же -
первый) "абзац" окажется равен всему тексту :(}
procedure Fragments(const S: string; FS: integer; var Frag, FragPos: TStringList);
function DelimPos(const S: string; StartPos: integer = 1): integer;
var
  i, j: integer;
  P, Q: string;
begin
  P := #13#10+' ';  {Начало нового абзаца}
  Q := #13#10#13;   {Пустая строка - 2 EOL подряд; но достаточно обнаружить эти 3 символа}
  Result := 0;
  if Length(S) <3 then exit;
  for i := StartPos to Length(S) - 2 do
    for j := 1 to 3 do
      if (P[j] <> S[i + j - 1]) and (Q[j] <> S[i + j - 1]) then break
      else if j = 3 then begin
        Result := i;
        exit;
      end;
end;
var
  k, k0, N, j, p, FragSize: integer;
  L, Buf: string;
begin
  if FS > 0 then FragSize := FS else FragSize := 999999999;
  Frag.Clear; FragPos.Clear;
  Buf := '';
  p := 1;
  j := 0;  {Размер очередного фрагмента в байтах с учетом EOL}
  N := Length(S);
  k0 := 1;
  k := 1;
  while k > 0 do begin
    k := DelimPos(S,k);  {Начало нового абзаца или пустая строка}
    if k > 0 then begin  {Очередной абзац}
      L := Copy(S,k0,k-k0);
      //if L <> '' then begin Buf := Buf+L+#13#10; Inc(j,Length(L)+2); end;
      Buf := Buf+L+#13#10; Inc(j,Length(L)+2);
      if (j > FragSize-Length(L)-2) then begin  {Записываем фрагмент}
        Frag.Add(Buf);  FragPos.Add(IntToStr(p)); j := 0; Inc(p,Length(Buf)); Buf := '';
      end;
      Inc(k,2);
      k0 := k;
    end;
  end;
  if k0 < N then begin
    L := Copy(S,k0,N-k0+1);  {Последний абзац}
    //if L <> '' then begin Buf := Buf+L+#13#10; Inc(j,Length(L)+2); end;
    Buf := Buf+L+#13#10; Inc(j,Length(L)+2);
    if (j > FragSize-Length(L)-2) then begin
      Frag.Add(Buf); FragPos.Add(IntToStr(p)); Inc(p,Length(Buf)); Buf := '';
    end;
  end;
  if Buf <> '' then begin  {Записываем последний (неполный) фрагмент}
    Frag.Add(Buf);  FragPos.Add(IntToStr(p)); Buf := '';
  end;
end;



{Список Words всех слов строки S, не содержащей Eol.
Конечные знаки препинания ВКЛЮЧАЮТСЯ в слово}
procedure SplitStr(const S: string; var Words: TStringList; Sep: Char = ' ');
var
  n, k: integer;
  W: string;
begin
  Words.Clear;
  n := 1;
  k := 1;
  while k >0 do begin
    k := PosCh(Sep,S,k);
    if k >0 then begin
      W := Copy(S,n,k-n);
      Inc(k);
      n := k;
      {Пустые и слишком длинные "слова" игнорируем!}
      if (W <> '') and (Length(W) < 100) then Words.Add(W);
    end;
  end;
  if k < Length(S) then begin  {Остался "хвостик" - последнее слово}
    W := Copy(S,n,Length(S)-k+1);
    if (W <> '') and (Length(W) < 100) then Words.Add(W);
  end;
end;


{Список Words всех слов в строке, содержащей Eol. Конечные знаки препинания
ВКЛЮЧАЮТСЯ в слово. Абзацные отступы и пустые строки являются отдельными
"словами"}
procedure SplitText(const S: string; var Words: TStringList);
var
  WL: TStringList;
  k, k0, N, j: integer;
  L: string;
begin
  Words.Clear;
  WL := TStringList.Create;
  N := Length(S);
  k0 := 1;
  k := 1;
  while k > 0 do begin
    k := PosN(#13#10,S,k);
    if k > 0 then begin  {Работаем с очередной строкой}
      L := Copy(S,k0,k-k0);
      if Trim(L) = '' then Words.Add('_E_')
                      else if L[1] = ' ' then Words.Add('_Z_');
      WL.Clear;
      SplitStr(L,WL);
      for j := 0 to WL.Count-1 do Words.Add(WL[j]);
      Inc(k,2);
      k0 := k;
    end;
  end;
  if k0 < N then begin
    L := Copy(S,k0,N-k0+1);  {Последняя строка}
    if Trim(L) = '' then Words.Add('_E_')
    else if L[1] = ' ' then Words.Add('_Z_');
    WL.Clear;
    SplitStr(L,WL);
    for j := 0 to WL.Count-1 do Words.Add(WL[j]);
  end;
  WL.Free;
end;


{Функция для представления всех чисел в строке прописью.
Пример: e2-e4 ==> едва-ечетыре}
function AllNumToPhr(const S: string): string;
var
  i, j, n: integer;
  cnum: string;
begin
  Result := '';
  n := Length(S);
  i := 1;
  while i <= n do begin
    if(S[i] in ['0'..'9','.']) then begin
      j := i;
      while (S[j] in ['0'..'9','.']) do Inc(j);
      cnum := Copy(S,i,j-i);
      Result := Result+NumToPhr(cnum);
      i := j-1;
    end else Result := Result+S[i];
    Inc(i);
  end;
end;

{Функция для представления числа прописью.
Число может содержать десятичную точку. Строка с нечисловыми символами
или слишком большое число возвращаются неизменными}
function NumToPhr(const S: string): string;
var
  k, m, i: integer;
  C, D: string;
  const
  Dec: array[1..12] of string =
  ('десятых','сотых','тысячных','десятитысячных','стотысячных','милионных',
   'десятимиллионных','стомиллионных','миллиардных','десятимиллиардных',
   'стомиллиардных','триллионных');
begin
  for i := 1 to Length(S) do begin
    if not (S[i] in ['0'..'9','.']) then begin  {Не числовая строка}
      Result := S;
      exit;
    end;
  end;
  k := Pos('.',S);
  if k = 0 then begin
    if Length(S) > 27 then begin
      Result := S;  {Слишком большое число}
      exit;
    end;
    Result := NumeralToPhrase(S);
    exit;
  end else begin
    C := Copy(S,1,k-1);
    if Length(C) > 27 then begin
      Result := S;
      exit;
    end;
    D := Copy(S,k+1,Length(S)-k);
    m := Length(D);
    if m = 0 then begin
      Result := NumeralToPhrase(C);
      exit;
    end;
    if m > 12 then m := 12;
    Result := NumeralToPhrase(C)+' и '+NumeralToPhrase(D)+' '+Dec[m];
  end;
end;

{******************************************************************************}
{(c) Игорь Ковалевский, Владикавказ, 1997-1999 г.}

{Функция для представления целого числа прописью от 0 до 999 септиллионов.
Замечание. Не числовые символы воспринимаются, как цифра 0}
function NumeralToPhrase(const S: string): string;
  function GeniCase(const S: string; C1,C2,C3: string): string;
  var
    Det1, Det2: integer;
  begin
    Det2 := StrToIntDef(Copy(S,Length(S)-1,2),0);
    Det1 := Det2 mod 10;
    if (Det1=1) and not(Det2=11)
      then GeniCase:=C1
      else
        if (Det1>1) and (Det1<5) and not( (Det2>11) and (Det2<15) )
          then GeniCase:=C2
          else GeniCase:=C3;
  end;
const
  DigitsF: array[1..10] of string =
  ('','одна ','две ','три ','четыре ','пять ','шесть ','семь ','восемь ','девять ');
  DigitsM: array[1..3] of string =
  ('','один ','два ');
  Teens: array[1..10] of string =
  ('десять ','одиннадцать ','двенадцать ','тринадцать ','четырнадцать ',
   'пятнадцать ','шестнадцать ','семнадцать ','восемнадцать ','девятнадцать ');
  Tens: array[1..10] of string =
  ('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ',
   'семьдесят ','восемьдесят ','девяносто ');
  Hundreds: array[1..10] of string =
  ('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ',
   'восемьсот ','девятьсот ');
var
  I, L, R, V, P :integer;
  C : string;
begin
  C:=S;
  L:=Length(C);
  P:=0;
  Result:='';
  for I:=1 to L do begin
    R:=(L - I + 1) mod 3;
    V:=StrToIntDef(Copy(C,I,1),0);
    case R of
      0: begin
           Result:=Result + Hundreds[V+1];
           if (V>0) then Inc(P);
         end;
      1: begin
           if (V > 0) then Inc(P);
           if (V > 2) then Result := Result+DigitsF[V+1]
                      else if ((L-i) = 3) then Result := Result+DigitsF[V+1]
                                          else Result := Result+DigitsM[V+1];
           if P > 0 then case (L-I+1) of
                           4: Result := Result+GeniCase( C[I],'тысяча ',
                                                              'тысячи ',
                                                              'тысяч ');
                           7: Result := Result+GeniCase( C[I],'миллион ',
                                                              'миллиона ',
                                                              'миллионов ');
                          10: Result := Result+GeniCase( C[I],'миллиард ',
                                                              'миллиарда ',
                                                              'миллиардов ');
                          13: Result := Result+GeniCase( C[I],'триллион ',
                                                              'триллиона ',
                                                              'триллионов ');
                          16: Result := Result+GeniCase( C[I],'квадриллион ',
                                                              'квадриллиона ',
                                                              'квадриллионов ');
                          19: Result := Result+GeniCase( C[I],'квинтиллион ',
                                                             'квинтиллиона ',
                                                             'квинтиллинов ');
                          22: Result := Result+GeniCase( C[I],'секстиллион ',
                                                             'секстиллиона ',
                                                             'секстиллионов ');
                          25: Result := Result+GeniCase( C[I],'септиллион ',
                                                             'септиллиона ',
                                                             'септиллионов ');
                         end;
           P:=0;
         end;
      2: begin
           if (V <> 1) then Result := Result+Tens[V+1]
                       else begin
                              Result:= Result+Teens[StrToIntDef(Copy(C,I+1,1),0)+1];
                              Delete(C,I+1,1);
                              Insert('0',C,I+1);
                            end;
           if (V > 0) then Inc(P);
         end;
    end;
  end;
  Result := Trim(Result);
  if (Result = '') then Result := 'ноль';
  //Result:=AnsiUpperCase(Result[1])+Copy(Result,2,Length(Result)-1);
end;
{******************************************************************************}

{Составление списка PF всех файлов-картинок в заданном каталоге}
procedure AllPictures(const Folder: string; var PF: TStringList);
var
  path, ext: string;
  srf: TSearchRec;
begin
  PF.Clear;
  path := Folder+'\';
  if FindFirst(path+'*.*',faAnyFile,srf) = 0 then
  begin
    repeat
      ext := AnsiLowerCase(ExtractFileExt(srf.Name));
      if (ext = '.bmp') or (ext = '.jpg') or (ext = '.jpeg') or (ext = '.png')
                        or (ext = '.gif') then PF.add(Path+srf.Name);
    until (FindNext(srf) <> 0);
    FindClose(srf.FindHandle);  {Освободить ресурсы, используемые этими успешными, поисками}
  end;
end;


///////////////// Процедуры кодирования и декодирования Base64 /////////////////
{Кодирование}  //ПОКА НЕ НУЖНА
//function EncodeBase64(const inStr: string): string;
//  function Encode_Byte(b: Byte): char;
//  const
//    Base64Code: string[64] =
//      'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
//  begin
//    Result := Base64Code[(b and $3F)+1];
//  end;
//var
//  i: Integer;
//begin
//  i := 1;
//  Result := '';
//  while i <= Length(InStr) do
//  begin
//    Result := Result + Encode_Byte(Byte(inStr[i]) shr 2);
//    Result := Result + Encode_Byte((Byte(inStr[i]) shl 4) or (Byte(inStr[i+1]) shr 4));
//    if i+1 <= Length(inStr) then
//      Result := Result + Encode_Byte((Byte(inStr[i+1]) shl 2) or (Byte(inStr[i+2]) shr 6))
//    else
//      Result := Result + '=';
//    if i+2 <= Length(inStr) then
//      Result := Result + Encode_Byte(Byte(inStr[i+2]))
//    else
//      Result := Result + '=';
//    Inc(i, 3);
//  end;
//end;

{Декодирование}
function DecodeBase64(const CinLine: string): string;
const
  RESULT_ERROR = -2;
var
  inLineIndex: Integer;
  c: Char;
  x: SmallInt;
  c4: Word;
  StoredC4: array[0..3] of SmallInt;
  InLineLength: Integer;
begin
  Result := '';
  inLineIndex := 1;
  c4 := 0;
  InLineLength := Length(CinLine);

  while inLineIndex <= InLineLength do
  begin
    while (inLineIndex <= InLineLength) and (c4 < 4) do
    begin
      c := CinLine[inLineIndex];
      case c of
        '+'     : x := 62;
        '/'     : x := 63;
        '0'..'9': x := Ord(c) - (Ord('0')-52);
        '='     : x := -1;
        'A'..'Z': x := Ord(c) - Ord('A');
        'a'..'z': x := Ord(c) - (Ord('a')-26);
      else
        x := RESULT_ERROR;
      end;
      if x <> RESULT_ERROR then
      begin
        StoredC4[c4] := x;
        Inc(c4);
      end;
      Inc(inLineIndex);
    end;

    if c4 = 4 then
    begin
      c4 := 0;
      Result := Result + Char((StoredC4[0] shl 2) or (StoredC4[1] shr 4));
      if StoredC4[2] = -1 then Exit;
      Result := Result + Char((StoredC4[1] shl 4) or (StoredC4[2] shr 2));
      if StoredC4[3] = -1 then Exit;
      Result := Result + Char((StoredC4[2] shl 6) or (StoredC4[3]));
    end;
  end;
end;
////////////////////////////////////////////////////////////////////////////////


end.
