Алгоритм переноса русского текста по слогам?
Материал из DRKB
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];
GlasCHAR = ['Й', 'й', 'У', 'у', 'Е', 'е', 'Ю', 'ю', 'А', 'а', 'О', 'о', 'Э', 'э', 'Я', 'я', 'И', 'и',
{ english }
'e', 'E', 'u', 'U', 'i', 'I', 'o', 'O', 'a', 'A', 'j', 'J'];
SoglChar = ['Г', 'г', 'Ц', 'ц', 'К', 'к', 'Н', 'н', 'Ш', 'ш', 'щ', 'Щ',
'З', 'з', 'Х', 'х', 'Ф', 'ф', 'В', 'в', 'П', 'п', 'Р', 'р',
'Л', 'л', 'Д', 'д', 'Ж', 'ж', 'Ч', 'ч', 'С', 'с', 'М', 'м',
'т', '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'];
SpecSign = ['Ы', 'ы', 'Ь', 'ь', 'Ъ', 'ъ'];
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
Result := st_Sogl
else if isGlas(c) then
Result := st_Glas
else if isSpecSign(c) then
Result := st_Spec
else
Result := st_NoDefined;
end;
function isSlogMore(c: pSymbAr; start, len: Integer): Boolean;
var
i: Integer;
glFlag: Boolean;
begin
glFlag := False;
Result := False;
for i := Start to Len-1 do
begin
if c^[i] = st_NoDefined then
Exit;
if (c^[i] = st_Glas) and ((c^[i+1] <> st_Nodefined) or (i <> Start)) then
begin
Result := True;
Exit;
end;
end;
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
Result := False;
while p[pos] <> #0 do
begin
if p[pos] in Spaces then
Exit;
if isGlas(p[pos]) then
begin
Result := True;
Exit;
end;
Inc(pos);
end;
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 (i < Len-2)
and (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.
Alex Gorbunov acdc@media-press.donetsk.ua www.media-press.donetsk.ua (2:465/85.4)
Author: Alex Gorbunov
Source: Взято из FAQ: Delphi and Windows API Tips'n'Tricks http://www.chat.ru/~olmal
ID: 04205