Алгоритм переноса русского текста по слогам

unit Hyper;

interface

uses
  Windows, Classes, SysUtils;

function SetHyph(pc: PChar; MaxSize: Integer): PChar;
function SetHyphString(s : string): string;
function MayBeHyph(p: PChar; pos: Integer): Boolean;

implementation

type
  TSymbol=(st_Empty, st_NoDefined, st_Glas, st_Sogl, st_Spec);
  TSymbAR=array [0..1000] of TSymbol;
  PSymbAr=^TSymbAr;

const
  HypSymb=#$1F;
  Spaces=[' ', ',',';', ':','.','?','!','/', #10, #13 ];
  SpecSign= [ '-', '-','N', '-', 'щ', 'г'];

  GlasCHAR=['e', 'L', 'х', '+', 'v', '-','р', '-', 'ю', '+', ' ', '-',
  'ш', 'L', '|', '|', '2', '|',
  { english }
  'e', 'E', 'u', 'U','i', 'I', 'o', 'O', 'a', 'A', 'j', 'J'];

  SoglChar=['-', 'г' , 'ъ', '|' ,'э', '=' , 'у', '+' , '0', '+' , '', '-' ,
  'ч', '|' , 'i', '-' ,'I', 'L' , 'т', 'T' , 'я', '|' , 'Ё', '|' ,
  'ы', 'T' , 'ф', '-' ,'ц', '|' , '-', '+' , 'ё', 'T' , 'ь', '|' ,
  'E', 'T' , 'с', '+' ,
  { english }
  'q', 'Q','w', 'W', 'r', 'R','t', 'T','y', 'Y','p', 'P','s',
  'S', 'd', 'D','f', 'F', 'g', 'G','h', 'H','k', 'K','l', 'L','z',
  'Z', 'x', 'X','c', 'C', 'v', 'V', 'b', 'B', 'n', 'N','m', 'M' ];

function isSogl(c: Char): Boolean;
begin
  Result := c in SoglChar;
end;

function isGlas(c: Char): Boolean;
begin
  Result := c in GlasChar;
end;

function isSpecSign(c: Char): Boolean;
begin
  Result := c in SpecSign;
end;

function GetSymbType(c: Char): TSymbol;
begin
  if isSogl(c) then
  begin
    Result := st_Sogl;
    exit;
  end;
  if isGlas(c) then
  begin
    Result := st_Glas;
    exit;
  end;
  if isSpecSign(c) then
  begin
    Result := st_Spec;
    exit;
  end;
  Result := st_NoDefined;
end;

function isSlogMore(c: pSymbAr; start, len: Integer): Boolean;
var
  i: Integer;
  glFlag: Boolean;
begin
  glFlag := false;
  for i:=Start to Len-1 do
  begin
    if c^[i]=st_NoDefined then
    begin
      Result := false;
      exit;
    end;
    if (c^[i]=st_Glas)and((c^[i+1]<>st_Nodefined)or(i<>Start)) then
    begin
      Result := True;
      exit;
    end;
  end;
  Result := false;
end;

function SetHyph(pc: PChar; MaxSize: Integer): PChar;
var
  HypBuff : Pointer;
  h : PSymbAr;
  i : Integer;
  len : Integer;
  Cur : Integer;
  cw : Integer;
  Lock: Integer;
begin
  Cur := 0;
  len := StrLen(pc);
  if (MaxSize = 0) or (Len = 0) then
  begin
    Result := nil;
    Exit;
  end;

  GetMem(HypBuff, MaxSize);
  GetMem(h, Len + 1);
  for i:=0 to len-1 do
    h^[i]:=GetSymbType(pc[i]);
  cw:=0;
  Lock:=0;
  for i:=0 to Len-1 do
  begin
    PChar(HypBuff)[cur]:=PChar(pc)[i];Inc(Cur);

    if i>=Len-2 then
      Continue;
    if h^[i]=st_NoDefined then
    begin
      cw:=0;
      Continue;
    end
    else
      Inc(cw);
    if Lock<>0 then
    begin
      Dec(Lock);
      Continue;
    end;
    if cw<=1 then
      Continue;
    if not(isSlogMore(h,i+1,len)) then
      Continue;

    if (h^[i]=st_Sogl)and(h^[i-1]=st_Glas)and
    (h^[i+1]=st_Sogl)and(h^[i+2]<>st_Spec) then
    begin
      PChar(HypBuff)[cur] := HypSymb;
      Inc(Cur);
      Lock := 1;
    end;

    if (h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and
    (h^[i+1]=st_Sogl)and(h^[i+2]=st_Glas) then
    begin
      PChar(HypBuff)[cur] := HypSymb;
      Inc(Cur);
      Lock := 1;
    end;

    if (h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and
    (h^[i+1]=st_Glas)and(h^[i+2]=st_Sogl) then
    begin
      PChar(HypBuff)[cur] := HypSymb;
      Inc(Cur);
      Lock := 1;
    end;

    if (h^[i] = st_Spec) then
    begin
      PChar(HypBuff)[cur] := HypSymb;
      Inc(Cur);
      Lock := 1;
    end;
  end;

  FreeMem(h, Len + 1);
  PChar(HypBuff)[cur] := #0;
  Result := HypBuff;
end;

function Red_GlasMore(p: PChar; pos: Integer): Boolean;
begin
  while p[pos]<>#0 do
  begin
    if p[pos] in Spaces then
    begin
      Result:=False;
      Exit;
    end;
    if isGlas(p[pos]) then
    begin
      Result:=True;
      Exit;
    end;
    Inc(pos);
  end;
  Result:=False;
end;

function Red_SlogMore(p: Pchar; pos: Integer): Boolean;
var
  BeSogl, BeGlas: Boolean;
begin
  BeSogl:=False;
  BeGlas:=False;
  while p[pos]<>#0 do
  begin
    if p[pos] in Spaces then
      Break;
    if not BeGlas then
      BeGlas:=isGlas(p[pos]);
    if not BeSogl then
      BeSogl:=isSogl(p[pos]);
    Inc(pos);
  end;
  Result:=BeGlas and BeSogl;
end;

function MayBeHyph(p:PChar;pos:Integer):Boolean;
var
  i: Integer;
  len: Integer;
begin
  i:=pos;
  Len:=StrLen(p);
  Result:= (Len>3) and (i>2) and (iand (not (p[i] in Spaces))
  and (not (p[i+1] in Spaces)) and (not (p[i-1] in Spaces)) and
  ((isSogl(p[i])and isGlas(p[i-1])and isSogl(p[i+1])and
  Red_SlogMore(p,i+1)) or
  ((isGlas(p[i]))and(isSogl(p[i-1]))and(isSogl(p[i+1]))and(isGlas(p[i+2])))
  or ((isGlas(p[i]))and(isSogl(p[i-1]))and(isGlas(p[i+1])) and
  Red_SlogMore(p,i+1) ) or ((isSpecSign(p[i]))));
end;

function SetHyphString(s : string):string;
var
  Res: PChar;
begin
  Res := SetHyph(PChar(S), Length(S) * 2)
  Result := Res;
  FreeMem(Res, Length(S) * 2);
end;

end.