On Tue 4 Oct 2011, michael.vancann...@wisa.be wrote:
> If you need some UTF8 extensions to the freetype unit, feel free to make
> some suggestions, and we'll see what we can do.
>
> When the unit was made, unicode support was a thing of the distant future.
> (a future which of course crept up on us faster than we imagined)
attached is a patch, which (if applied correctly...) seems to work, yay! Here
is
a picture:
http://david9.freepgs.com/i/spline-unicode-text.png
I copied a few UTF8 string functions from the LCLProc unit, so that is kind of
sloppy but there it is. I'm not sure if analogs exist within fpc.
Surprisingly little needed to be changed!
diff --git a/packages/fcl-image/src/freetype.pp b/packages/fcl-image/src/freetype.pp
index 92ba876..4a17dae 100644
--- a/packages/fcl-image/src/freetype.pp
+++ b/packages/fcl-image/src/freetype.pp
@@ -36,6 +36,7 @@ uses sysutils, classes, freetypeh, FPImgCmn;
{$endif}
type
+ chartype = cardinal;
FreeTypeException = class (exception);
@@ -71,7 +72,7 @@ type
PMgrGlyph = ^TMgrGlyph;
TMgrGlyph = record
- Character : char;
+ Character : chartype;
GlyphIndex : FT_UInt;
Glyph : PFT_Glyph;
end;
@@ -117,8 +118,8 @@ type
procedure GetSize (aSize, aResolution : integer);
function CreateSize (aSize, aResolution : integer) : PMgrSize;
procedure SetPixelSize (aSize, aResolution : integer);
- function GetGlyph (c : char) : PMgrGlyph;
- function CreateGlyph (c : char) : PMgrGlyph;
+ function GetGlyph (c : chartype) : PMgrGlyph;
+ function CreateGlyph (c : chartype) : PMgrGlyph;
procedure MakeTransformation (angle:real; out Transformation:FT_Matrix);
procedure InitMakeString (FontID, Size:integer);
function MakeString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
@@ -526,13 +527,13 @@ begin
end;
end;
-function TFontManager.CreateGlyph (c : char) : PMgrGlyph;
+function TFontManager.CreateGlyph (c : chartype) : PMgrGlyph;
var e : integer;
begin
new (result);
FillByte(Result^,SizeOf(Result),0);
result^.character := c;
- result^.GlyphIndex := FT_Get_Char_Index (CurFont.font, ord(c));
+ result^.GlyphIndex := FT_Get_Char_Index (CurFont.font, c);
//WriteFT_Face(CurFont.Font);
e := FT_Load_Glyph (CurFont.font, result^.GlyphIndex, FT_Load_Default);
if e <> 0 then
@@ -547,7 +548,7 @@ begin
CurSize^.Glyphs.Add (result);
end;
-function TFontManager.GetGlyph (c : char) : PMgrGlyph;
+function TFontManager.GetGlyph (c : chartype) : PMgrGlyph;
var r : integer;
begin
With CurSize^ do
@@ -569,11 +570,126 @@ begin
UseKerning := ((Curfont.font^.face_flags and FT_FACE_FLAG_KERNING) <> 0);
end;
+function UTF8CharacterLength(p: PChar): integer;
+begin
+ if p<>nil then begin
+ if ord(p^)<%11000000 then begin
+ // regular single byte character (#0 is a character, this is pascal ;)
+ Result:=1;
+ end
+ else if ((ord(p^) and %11100000) = %11000000) then begin
+ // could be 2 byte character
+ if (ord(p[1]) and %11000000) = %10000000 then
+ Result:=2
+ else
+ Result:=1;
+ end
+ else if ((ord(p^) and %11110000) = %11100000) then begin
+ // could be 3 byte character
+ if ((ord(p[1]) and %11000000) = %10000000)
+ and ((ord(p[2]) and %11000000) = %10000000) then
+ Result:=3
+ else
+ Result:=1;
+ end
+ else if ((ord(p^) and %11111000) = %11110000) then begin
+ // could be 4 byte character
+ if ((ord(p[1]) and %11000000) = %10000000)
+ and ((ord(p[2]) and %11000000) = %10000000)
+ and ((ord(p[3]) and %11000000) = %10000000) then
+ Result:=4
+ else
+ Result:=1;
+ end
+ else
+ Result:=1
+ end else
+ Result:=0;
+end;
+
+function UTF8Length(p: PChar; ByteCount: PtrInt): PtrInt;
+var
+ CharLen: LongInt;
+begin
+ Result:=0;
+ while (ByteCount>0) do begin
+ inc(Result);
+ CharLen:=UTF8CharacterLength(p);
+ inc(p,CharLen);
+ dec(ByteCount,CharLen);
+ end;
+end;
+
+function UTF8Length(const s: string): PtrInt;
+begin
+ Result:=UTF8Length(PChar(s),length(s));
+end;
+
+function UTF8CharacterToUnicode(p: PChar; out CharLen: integer): Cardinal;
+begin
+ if p<>nil then begin
+ if ord(p^)<%11000000 then begin
+ // regular single byte character (#0 is a normal char, this is pascal ;)
+ Result:=ord(p^);
+ CharLen:=1;
+ end
+ else if ((ord(p^) and %11100000) = %11000000) then begin
+ // could be double byte character
+ if (ord(p[1]) and %11000000) = %10000000 then begin
+ Result:=((ord(p^) and %00011111) shl 6)
+ or (ord(p[1]) and %00111111);
+ CharLen:=2;
+ end else begin
+ Result:=ord(p^);
+ CharLen:=1;
+ end;
+ end
+ else if ((ord(p^) and %11110000) = %11100000) then begin
+ // could be triple byte character
+ if ((ord(p[1]) and %11000000) = %10000000)
+ and ((ord(p[2]) and %11000000) = %10000000) then begin
+ Result:=((ord(p^) and %00011111) shl 12)
+ or ((ord(p[1]) and %00111111) shl 6)
+ or (ord(p[2]) and %00111111);
+ CharLen:=3;
+ end else begin
+ Result:=ord(p^);
+ CharLen:=1;
+ end;
+ end
+ else if ((ord(p^) and %11111000) = %11110000) then begin
+ // could be 4 byte character
+ if ((ord(p[1]) and %11000000) = %10000000)
+ and ((ord(p[2]) and %11000000) = %10000000)
+ and ((ord(p[3]) and %11000000) = %10000000) then begin
+ Result:=((ord(p^) and %00001111) shl 18)
+ or ((ord(p[1]) and %00111111) shl 12)
+ or ((ord(p[2]) and %00111111) shl 6)
+ or (ord(p[3]) and %00111111);
+ CharLen:=4;
+ end else begin
+ Result:=ord(p^);
+ CharLen:=1;
+ end;
+ end
+ else begin
+ // invalid character
+ Result:=ord(p^);
+ CharLen:=1;
+ end;
+ end else begin
+ Result:=0;
+ CharLen:=0;
+ end;
+end;
+
function TFontManager.MakeString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
var g : PMgrGlyph;
bm : PFT_BitmapGlyph;
gl : PFT_Glyph;
- prevIndex, prevx, c, r, rx : integer;
+ prevIndex, prevx, c, r, rx, cl : integer;
+ uc : chartype;
+ pc : pchar;
pre, adv, pos, kern : FT_Vector;
buf : PByteArray;
reverse : boolean;
@@ -586,7 +702,7 @@ begin
else
begin
InitMakeString (FontID, Size);
- c := length(text);
+ c := utf8length(text);
result := TStringBitmaps.Create(c);
if (CurRenderMode = FT_RENDER_MODE_MONO) then
result.FMode := btBlackWhite
@@ -599,10 +715,16 @@ begin
pos.y := 0;
pre.x := 0;
pre.y := 0;
- for r := 0 to c-1 do
- begin
+ pc := pchar(text);
+ r := -1;
+ // get the unicode for the character. Also performed at the end of the while loop.
+ uc := UTF8CharacterToUnicode (pc, cl);
+ while (uc>0) and (cl>0) do begin
// retrieve loaded glyph
- g := GetGlyph (Text[r+1]);
+ g := GetGlyph (uc);
+ // increment pchar by character length
+ inc (pc, cl);
+ inc (r);
// check kerning
if UseKerning and (g^.glyphindex <>0) and (PrevIndex <> 0) then
begin
@@ -665,7 +787,9 @@ begin
pre.x := prevx;
// finish rendered glyph
FT_Done_Glyph (gl);
- end;
+ // Get the next unicode
+ uc := UTF8CharacterToUnicode (pc, cl);
+ end;
result.FText := Text;
result.CalculateGlobals;
end;
@@ -675,15 +799,16 @@ function TFontManager.MakeString (FontId:integer; Text:string; Size:integer) : T
var g : PMgrGlyph;
bm : PFT_BitmapGlyph;
gl : PFT_Glyph;
- e, prevIndex, prevx, c, r, rx : integer;
+ e, prevIndex, prevx, r, rx, cl : integer;
+ uc : chartype;
+ pc : pchar;
pos, kern : FT_Vector;
buf : PByteArray;
reverse : boolean;
begin
CurFont := GetFont(FontID);
InitMakeString (FontID, Size);
- c := length(text);
- result := TStringBitmaps.Create(c);
+ result := TStringBitmaps.Create(utf8length(text));
if (CurRenderMode = FT_RENDER_MODE_MONO) then
result.FMode := btBlackWhite
else
@@ -692,10 +817,16 @@ begin
prevx := 0;
pos.x := 0;
pos.y := 0;
- for r := 0 to c-1 do
- begin
+ pc := pchar(text);
+ r := -1;
+ // get the unicode for the character. Also performed at the end of the while loop.
+ uc := UTF8CharacterToUnicode (pc, cl);
+ while (cl>0) and (uc>0) do begin
// retrieve loaded glyph
- g := GetGlyph (Text[r+1]);
+ g := GetGlyph (uc);
+ // increment pchar by character length
+ inc (pc, cl);
+ inc (r);
// check kerning
if UseKerning and (g^.glyphindex <>0) and (PrevIndex <> 0) then
begin
@@ -751,7 +882,9 @@ begin
pos.x := prevx;
// finish rendered glyph
FT_Done_Glyph (gl);
- end;
+ // Get the next unicode
+ uc := UTF8CharacterToUnicode (pc, cl);
+ end; // while
result.FText := Text;
result.CalculateGlobals;
end;
_______________________________________________
fpc-pascal maillist - fpc-pascal@lists.freepascal.org
http://lists.freepascal.org/mailman/listinfo/fpc-pascal
