Есть ли у кого алгоритм переноса русского текста по слогам?
Вот, когда-то писал для QuarkXPress, который русских переносов не понимает. Hе понимает сложные слова, но в 98% работает нормально.
{*********************************************************** * * * Hypernation for QuarkQPress * * written by Gorbunov A. A. * * acdc@media-press.donetsk.ua * * * ************************************************************}
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
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; { Tекущая позиция в разультирующем массиве} 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;
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 (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])andRed_SlogMore(p,i+1))
