summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormarco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2>2017-06-19 08:51:02 +0000
committermarco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2>2017-06-19 08:51:02 +0000
commit2323b6a565015e94bf92d97cba2dbc7f444d00e1 (patch)
treee5f61a0e92e688b71838813a8da3a43b11a044fc
parent0dde2d08a8bd20fb8b0468e53ef0eb6225b596b3 (diff)
downloadfpc-2323b6a565015e94bf92d97cba2dbc7f444d00e1.tar.gz
--- Merging r36400 into '.':
U packages/fcl-image/examples/drawing.pp A packages/fcl-image/examples/pattern.png --- Recording mergeinfo for merge of r36400 into '.': U . --- Merging r36401 into '.': U packages/fcl-image/examples/imgconv.pp --- Recording mergeinfo for merge of r36401 into '.': G . --- Merging r36402 into '.': A packages/fcl-image/examples/textout.pp U packages/fcl-image/src/freetype.pp U packages/fcl-image/src/fpcdrawh.inc U packages/fcl-image/src/fpcanvas.inc U packages/fcl-image/src/fpcanvas.pp U packages/fcl-image/src/ftfont.pp --- Recording mergeinfo for merge of r36402 into '.': G . --- Merging r36403 into '.': U packages/fcl-image/src/fppixlcanv.pp --- Recording mergeinfo for merge of r36403 into '.': G . --- Merging r36404 into '.': G packages/fcl-image/examples/drawing.pp --- Recording mergeinfo for merge of r36404 into '.': G . # revisions: 36400,36401,36402,36403,36404 git-svn-id: https://svn.freepascal.org/svn/fpc/branches/fixes_3_0@36536 3ad0048d-3df7-0310-abae-a5850022a9f2
-rw-r--r--packages/fcl-image/examples/drawing.pp45
-rw-r--r--packages/fcl-image/examples/imgconv.pp8
-rw-r--r--packages/fcl-image/examples/pattern.pngbin0 -> 471 bytes
-rw-r--r--packages/fcl-image/examples/textout.pp116
-rw-r--r--packages/fcl-image/src/fpcanvas.inc71
-rw-r--r--packages/fcl-image/src/fpcanvas.pp19
-rw-r--r--packages/fcl-image/src/fpcdrawh.inc47
-rw-r--r--packages/fcl-image/src/fppixlcanv.pp32
-rw-r--r--packages/fcl-image/src/freetype.pp216
-rw-r--r--packages/fcl-image/src/ftfont.pp89
10 files changed, 554 insertions, 89 deletions
diff --git a/packages/fcl-image/examples/drawing.pp b/packages/fcl-image/examples/drawing.pp
index 1eadcaf04c..33fa274925 100644
--- a/packages/fcl-image/examples/drawing.pp
+++ b/packages/fcl-image/examples/drawing.pp
@@ -1,21 +1,20 @@
{$mode objfpc}{$h+}
program Drawing;
-uses classes, sysutils,
- FPImage, FPCanvas, FPImgCanv, ftFont,
- FPWritePNG, FPReadPNG;
+uses cwstring,classes, sysutils, FPImage, FPCanvas, FPImgCanv, FPWritePNG, FPReadPNG;
const
MyColor : TFPColor = (Red: $7FFF; Green: $0000; Blue: $FFFF; Alpha: alphaOpaque);
procedure DoDraw;
-var canvas : TFPcustomCAnvas;
- ci, image : TFPCustomImage;
- writer : TFPCustomImageWriter;
- reader : TFPCustomImageReader;
- f : TFreeTypeFont;
+
+var
+ canvas : TFPcustomCAnvas;
+ ci,image : TFPCustomImage;
+ writer : TFPCustomImageWriter;
+ reader : TFPCustomImageReader;
+
begin
- f:=Nil;
image := TFPMemoryImage.Create (100,100);
ci := TFPMemoryImage.Create (20,20);
Canvas := TFPImageCanvas.Create (image);
@@ -29,7 +28,7 @@ begin
GrayScale := false;
end;
try
-// ci.LoadFromFile ('test.png', reader);
+ ci.LoadFromFile ('pattern.png', reader);
with Canvas as TFPImageCanvas do
begin
brush.FPcolor:=colwhite;
@@ -54,14 +53,14 @@ begin
blue := green;
end;
pen.style := psSolid;
+
RelativeBrushImage := true;
-{
brush.image := ci;
brush.style := bsimage;
with brush.FPColor do
green := green div 2;
Ellipse (11,11, 89,89);
-}
+
brush.style := bsSolid;
brush.FPColor := MyColor;
@@ -74,36 +73,18 @@ begin
pen.FPColor := colCyan;
ellipseC (50,50, 1,1);
- InitEngine;
- F:=TFreeTypeFont.Create;
- F.Angle:=StrToFloatDef(ParamStr(1),0);
- Font:=F;
-{$IFDEF UNIX}
- Font.Name:='/usr/share/fonts/truetype/ttf-dejavu/DejaVuSans.ttf';
-{$ELSE}
- // On windows, this should be present
- Font.Name:='arial.ttf';
-{$ENDIF}
- Font.Size:=10;
- Font.FPColor:=colWhite;
-// Font.Orientation:=StrToIntDef(ParamStr(1),0);
-
- Canvas.TextOut(10,90,'abc');
end;
writeln ('Saving to "DrawTest.png" for inspection !');
- image.SaveToFile ('DrawTest.png', writer);
+ image.SaveToFile ('DrawTest.png', writer);
finally
- F.Free;
Canvas.Free;
+ ci.free;
image.Free;
writer.Free;
- ci.free;
reader.Free;
end;
end;
begin
-// DefaultFontPath := '/usr/share/fonts/truetype/ttf-dejavu/';
DoDraw;
-
end.
diff --git a/packages/fcl-image/examples/imgconv.pp b/packages/fcl-image/examples/imgconv.pp
index 8012089dad..9048210929 100644
--- a/packages/fcl-image/examples/imgconv.pp
+++ b/packages/fcl-image/examples/imgconv.pp
@@ -19,7 +19,7 @@ program ImgConv;
uses FPWriteXPM, FPWritePNG, FPWriteBMP,
FPReadXPM, FPReadPNG, FPReadBMP, fpreadjpeg,fpwritejpeg,
- fpreadtga,fpwritetga,fpreadpnm,fpwritepnm,
+ fpreadtga,fpwritetga,fpreadpnm,fpwritepnm, fpreadtiff, fpwritetiff,
{$ifndef UseFile}classes,{$endif}
FPImage, sysutils;
@@ -44,6 +44,8 @@ begin
Reader := TFPReaderPNG.Create
else if T = 'T' then
Reader := TFPReaderTarga.Create
+ else if T = 'F' then
+ Reader := TFPReaderTiff.Create
else if T = 'N' then
Reader := TFPReaderPNM.Create
else
@@ -77,6 +79,8 @@ begin
Writer := TFPWriterPNG.Create
else if T = 'T' then
Writer := TFPWriterTARGA.Create
+ else if T = 'F' then
+ Writer := TFPWriterTiff.Create
else if T = 'N' then
Writer := TFPWriterPNM.Create
else
@@ -150,7 +154,7 @@ begin
begin
writeln ('Give filename to read and to write, preceded by filetype:');
writeln ('X for XPM, P for PNG, B for BMP, J for JPEG, T for TGA,');
- writeln ('N for PNM (read only)');
+ writeln ('N for PNM (read only), F for TIFF');
writeln ('example: imgconv X hello.xpm P hello.png');
writeln ('example: imgconv hello.xpm P hello.png');
writeln ('Options for');
diff --git a/packages/fcl-image/examples/pattern.png b/packages/fcl-image/examples/pattern.png
new file mode 100644
index 0000000000..106e78f437
--- /dev/null
+++ b/packages/fcl-image/examples/pattern.png
Binary files differ
diff --git a/packages/fcl-image/examples/textout.pp b/packages/fcl-image/examples/textout.pp
new file mode 100644
index 0000000000..712f83b4e6
--- /dev/null
+++ b/packages/fcl-image/examples/textout.pp
@@ -0,0 +1,116 @@
+{$mode objfpc}{$h+}
+{$CODEPAGE UTF8}
+program textout;
+
+uses
+ cwstring,classes, sysutils, FPImage, FPCanvas, FPImgCanv, ftFont, FPWritePNG, freetype;
+
+const
+ MyColor : TFPColor = (Red: $7FFF; Green: $0000; Blue: $FFFF; Alpha: alphaOpaque);
+
+procedure DoDraw(FN, fnChinese : String);
+
+var
+ canvas : TFPcustomCAnvas;
+ image : TFPCustomImage;
+ writer : TFPCustomImageWriter;
+ f : TFreeTypeFont;
+ S : String;
+ U : UnicodeString;
+
+begin
+ f:=Nil;
+ image := TFPMemoryImage.Create (256,256);
+ Canvas := TFPImageCanvas.Create (image);
+ Writer := TFPWriterPNG.Create;
+ InitEngine;
+ with TFPWriterPNG(Writer) do
+ begin
+ indexed := false;
+ wordsized := false;
+ UseAlpha := false;
+ GrayScale := false;
+ end;
+ try
+ with Canvas as TFPImageCanvas do
+ begin
+ // Clear background
+ brush.FPcolor:=colwhite;
+ brush.style:=bsSolid;
+ pen.mode := pmCopy;
+ pen.style := psSolid;
+ pen.width := 1;
+ pen.FPColor := colWhite;
+ FillRect(0,0,255,255);
+ // Set font
+ F:=TFreeTypeFont.Create;
+ Font:=F;
+ Font.Name:=FN;
+ Font.Size:=14;
+ Font.FPColor:=colBlack;
+ S:='Hello, world!';
+ Canvas.TextOut(20,20,S);
+ U:=UTF8Decode('привет, Мир!');
+ Font.FPColor:=colBlue;
+ Canvas.TextOut(50,50,U);
+ if (FNChinese<>'') then
+ begin
+ Font.Name:=FNChinese;
+ U:=UTF8Decode('你好,世界!');
+ Font.FPColor:=colRed;
+ Canvas.TextOut(20,100,U);
+ end
+ else
+ begin
+ Font.Size:=10;
+ Canvas.TextOut(20,100,'No chinese font available.');
+ end;
+ U:=UTF8Decode('non-ASCII chars: ßéùµàçè§âêû');
+ Font.Size:=10;
+ Canvas.TextOut(20,180,U);
+ end;
+ writeln ('Saving to "TextTest.png" for inspection !');
+ Image.SaveToFile ('TextTest.png', writer);
+ finally
+ F.Free;
+ Canvas.Free;
+ image.Free;
+ writer.Free;
+ end;
+end;
+
+Var
+ D,FontFile, FontFileChinese : String;
+ Info : TSearchRec;
+
+begin
+ // Initialize font search path;
+{$IFDEF UNIX}
+{$IFNDEF DARWIN}
+ D := '/usr/share/fonts/truetype/';
+ DefaultSearchPath:=D;
+ if FindFirst(DefaultSearchPath+AllFilesMask,faDirectory,Info)=0 then
+ try
+ repeat
+ if (Info.Attr and faDirectory)<>0 then
+ if (Info.Name<>'.') and (info.name<>'..') then
+ DefaultSearchPath:=DefaultSearchPath+';'+D+Info.Name;
+ Until FindNext(Info)<>0;
+ finally
+ FindClose(Info);
+ end;
+{$ENDIF}
+{$ENDIF}
+ FontFile:=ParamStr(1);
+ if FontFile='' then
+ FontFile:='LiberationSans-Regular.ttf';
+ FontFileChinese:=ParamStr(2);
+ if FontFileChinese='' then
+ With TFontManager.Create do
+ try
+ FontFileChinese:=SearchFont('wqy-microhei.ttc',False);
+ finally
+ Free;
+ end;
+ DoDraw(FontFile,FontFileChinese);
+end.
diff --git a/packages/fcl-image/src/fpcanvas.inc b/packages/fcl-image/src/fpcanvas.inc
index c00cd955ca..521af4e8f7 100644
--- a/packages/fcl-image/src/fpcanvas.inc
+++ b/packages/fcl-image/src/fpcanvas.inc
@@ -353,6 +353,77 @@ begin
result := DoGetTextWidth (Text);
end;
+procedure TFPCustomCanvas.TextOut (x,y:integer;text:unicodestring);
+begin
+ if Font is TFPCustomDrawFont then
+ TFPCustomDrawFont(Font).DrawText(x,y, text)
+ else
+ DoTextOut (x,y, text);
+end;
+
+procedure TFPCustomCanvas.GetTextSize (text:unicodestring; var w,h:integer);
+begin
+ if Font is TFPCustomDrawFont then
+ TFPCustomDrawFont(Font).GetTextSize (text, w, h)
+ else
+ DoGetTextSize (Text, w, h);
+end;
+
+function TFPCustomCanvas.GetTextHeight (text:unicodestring) : integer;
+begin
+ Result := TextHeight(Text);
+end;
+
+function TFPCustomCanvas.GetTextWidth (text:unicodestring) : integer;
+begin
+ Result := TextWidth(Text);
+end;
+
+function TFPCustomCanvas.TextExtent(const Text: unicodestring): TSize;
+begin
+ GetTextSize(Text, Result.cx, Result.cy);
+end;
+
+function TFPCustomCanvas.TextHeight(const Text: unicodestring): Integer;
+begin
+ if Font is TFPCustomDrawFont then
+ result := TFPCustomDrawFont(Font).GetTextHeight (text)
+ else
+ result := DoGetTextHeight (Text);
+end;
+
+function TFPCustomCanvas.TextWidth(const Text: unicodestring): Integer;
+begin
+ if Font is TFPCustomDrawFont then
+ result := TFPCustomDrawFont(Font).GetTextWidth (text)
+ else
+ result := DoGetTextWidth (Text);
+end;
+
+procedure TFPCustomCanvas.DoTextOut (x,y:integer;text:unicodestring);
+
+begin
+ DoTextOut(x,y,string(text));
+end;
+
+procedure TFPCustomCanvas.DoGetTextSize (text:unicodestring; var w,h:integer);
+
+begin
+ DoGetTextSize(String(Text),w,h);
+end;
+
+function TFPCustomCanvas.DoGetTextHeight (text:unicodestring) : integer;
+
+begin
+ Result:=DoGetTextHeight(String(text));
+end;
+
+function TFPCustomCanvas.DoGetTextWidth (text:unicodestring) : integer;
+
+begin
+ Result:=DoGetTextWidth(String(text));
+end;
+
procedure TFPCustomCanvas.Arc(ALeft, ATop, ARight, ABottom, Angle16Deg,
Angle16DegLength: Integer);
begin
diff --git a/packages/fcl-image/src/fpcanvas.pp b/packages/fcl-image/src/fpcanvas.pp
index 7f7b0bc8ec..83b657f80f 100644
--- a/packages/fcl-image/src/fpcanvas.pp
+++ b/packages/fcl-image/src/fpcanvas.pp
@@ -278,6 +278,10 @@ type
procedure DoGetTextSize (text:string; var w,h:integer); virtual; abstract;
function DoGetTextHeight (text:string) : integer; virtual; abstract;
function DoGetTextWidth (text:string) : integer; virtual; abstract;
+ procedure DoTextOut (x,y:integer;text:unicodestring); virtual;
+ procedure DoGetTextSize (text:unicodestring; var w,h:integer); virtual;
+ function DoGetTextHeight (text:unicodestring) : integer; virtual;
+ function DoGetTextWidth (text:unicodestring) : integer; virtual;
procedure DoRectangle (Const Bounds:TRect); virtual; abstract;
procedure DoRectangleFill (Const Bounds:TRect); virtual; abstract;
procedure DoRectangleAndFill (Const Bounds:TRect); virtual;
@@ -317,6 +321,13 @@ type
function TextExtent(const Text: string): TSize; virtual;
function TextHeight(const Text: string): Integer; virtual;
function TextWidth(const Text: string): Integer; virtual;
+ procedure TextOut (x,y:integer;text:unicodestring); virtual;
+ procedure GetTextSize (text:unicodestring; var w,h:integer);
+ function GetTextHeight (text:unicodestring) : integer;
+ function GetTextWidth (text:unicodestring) : integer;
+ function TextExtent(const Text: unicodestring): TSize; virtual;
+ function TextHeight(const Text: unicodestring): Integer; virtual;
+ function TextWidth(const Text: unicodestring): Integer; virtual;
// using pen and brush
procedure Arc(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: Integer); virtual;
procedure Arc(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); virtual;
@@ -374,11 +385,19 @@ type
procedure GetTextSize (text:string; var w,h:integer);
function GetTextHeight (text:string) : integer;
function GetTextWidth (text:string) : integer;
+ procedure DrawText (x,y:integer; text:unicodestring);
+ procedure GetTextSize (text: unicodestring; var w,h:integer);
+ function GetTextHeight (text: unicodestring) : integer;
+ function GetTextWidth (text: unicodestring) : integer;
protected
procedure DoDrawText (x,y:integer; text:string); virtual; abstract;
procedure DoGetTextSize (text:string; var w,h:integer); virtual; abstract;
function DoGetTextHeight (text:string) : integer; virtual; abstract;
function DoGetTextWidth (text:string) : integer; virtual; abstract;
+ procedure DoDrawText (x,y:integer; text:unicodestring); virtual;
+ procedure DoGetTextSize (text: unicodestring; var w,h:integer); virtual;
+ function DoGetTextHeight (text: unicodestring) : integer; virtual;
+ function DoGetTextWidth (text: unicodestring) : integer; virtual;
end;
TFPEmptyFont = class (TFPCustomFont)
diff --git a/packages/fcl-image/src/fpcdrawh.inc b/packages/fcl-image/src/fpcdrawh.inc
index 891bf34038..93cef40845 100644
--- a/packages/fcl-image/src/fpcdrawh.inc
+++ b/packages/fcl-image/src/fpcdrawh.inc
@@ -77,3 +77,50 @@ function TFPCustomDrawFont.GetTextWidth (text:string) : integer;
begin
result := DoGetTextWidth (Text);
end;
+
+procedure TFPCustomDrawFont.DrawText (x,y:integer; text:UnicodeString);
+begin
+ DoDrawText (x,y, text);
+end;
+
+procedure TFPCustomDrawFont.GetTextSize (text:UnicodeString; var w,h:integer);
+begin
+ DoGetTextSize (text, w,h);
+end;
+
+function TFPCustomDrawFont.GetTextHeight (text:UnicodeString) : integer;
+begin
+ result := DoGetTextHeight (Text);
+end;
+
+function TFPCustomDrawFont.GetTextWidth (text:UnicodeString) : integer;
+begin
+ result := DoGetTextWidth (Text);
+end;
+
+procedure TFPCustomDrawFont.DoDrawText (x,y:integer; text:unicodestring);
+
+begin
+ DoDrawText(x,y,String(text));
+end;
+
+procedure TFPCustomDrawFont.DoGetTextSize (text: unicodestring; var w,h:integer);
+
+begin
+ DoGetTextSize(String(text),w,h);
+end;
+
+
+
+function TFPCustomDrawFont.DoGetTextHeight (text: unicodestring) : integer;
+
+begin
+ Result:=DoGetTextHeight(String(text));
+end;
+
+function TFPCustomDrawFont.DoGetTextWidth (text: unicodestring) : integer;
+
+begin
+ Result:=DoGetTextWidth(String(text));
+end;
+
diff --git a/packages/fcl-image/src/fppixlcanv.pp b/packages/fcl-image/src/fppixlcanv.pp
index 9010a78bc0..6667918717 100644
--- a/packages/fcl-image/src/fppixlcanv.pp
+++ b/packages/fcl-image/src/fppixlcanv.pp
@@ -28,14 +28,18 @@ type
PixelCanvasException = class (TFPCanvasException);
+ { TFPPixelCanvas }
+
TFPPixelCanvas = class (TFPCustomCanvas)
private
FHashWidth : word;
FRelativeBI : boolean;
protected
+ procedure DoCopyRect(x, y: integer; canvas: TFPCustomCanvas; const SourceRect: TRect); override;
function DoCreateDefaultFont : TFPCustomFont; override;
function DoCreateDefaultPen : TFPCustomPen; override;
function DoCreateDefaultBrush : TFPCustomBrush; override;
+ procedure DoDraw(x, y: integer; const image: TFPCustomImage); override;
procedure DoTextOut (x,y:integer;text:string); override;
procedure DoGetTextSize (text:string; var w,h:integer); override;
function DoGetTextHeight (text:string) : integer; override;
@@ -73,12 +77,26 @@ begin
raise PixelCanvasException.Create(sErrNotAvailable);
end;
-constructor TFPPixelCanvas.Create;
+constructor TFPPixelCanvas.create;
begin
inherited;
FHashWidth := DefaultHashWidth;
end;
+procedure TFPPixelCanvas.DoCopyRect(x, y: integer; canvas: TFPCustomCanvas; const SourceRect: TRect);
+Var
+ W,H,XS1,XS2,YS1,YS2 : Integer;
+
+begin
+ XS1:=SourceRect.Left;
+ XS2:=SourceRect.Right;
+ YS1:=SourceRect.Top;
+ YS2:=SourceRect.Bottom;
+ For H:=0 to YS2-YS1 do
+ For W:=0 to XS2-XS1 do
+ Colors[x+h,y+h]:=Canvas.Colors[XS1+W,YS1+H];
+end;
+
function TFPPixelCanvas.DoCreateDefaultFont : TFPCustomFont;
begin
result := TFPEmptyFont.Create;
@@ -108,6 +126,17 @@ begin
result.Style := bsSolid;
end;
+procedure TFPPixelCanvas.DoDraw(x, y: integer; const image: TFPCustomImage);
+
+Var
+ W,h : Integer;
+
+begin
+ For H:=0 to Image.Height-1 do
+ For W:=0 to Image.Width-1 do
+ Colors[x+w,y+h]:=Image.Colors[W,H];
+end;
+
procedure TFPPixelCanvas.DoTextOut (x,y:integer;text:string);
begin
NotImplemented;
@@ -365,4 +394,5 @@ begin
end;
end;
+
end.
diff --git a/packages/fcl-image/src/freetype.pp b/packages/fcl-image/src/freetype.pp
index 923aa18142..271ce2d9e3 100644
--- a/packages/fcl-image/src/freetype.pp
+++ b/packages/fcl-image/src/freetype.pp
@@ -48,11 +48,10 @@ type
PFontBitmap = ^TFontBitmap;
- TStringBitMaps = class
+ TBaseStringBitMaps = class
private
FList : TList;
FBounds : TRect;
- FText : string;
FMode : TBitmapType;
function GetCount : integer;
function GetBitmap (index:integer) : PFontBitmap;
@@ -61,17 +60,30 @@ type
constructor Create (ACount : integer);
destructor destroy; override;
procedure GetBoundRect (out aRect : TRect);
- property Text : string read FText;
property Mode : TBitmapType read FMode;
property Count : integer read GetCount;
property Bitmaps[index:integer] : PFontBitmap read GetBitmap;
end;
+ TStringBitMaps = class(TBaseStringBitMaps)
+ private
+ FText : STring;
+ public
+ property Text : string read FText;
+ end;
+
+ TUnicodeStringBitMaps = class(TBaseStringBitMaps)
+ private
+ FText : UnicodeString;
+ public
+ property Text : Unicodestring read FText;
+ end;
+
TFontManager = class;
PMgrGlyph = ^TMgrGlyph;
TMgrGlyph = record
- Character : char;
+ Character : unicodechar;
GlyphIndex : FT_UInt;
Glyph : PFT_Glyph;
end;
@@ -109,33 +121,41 @@ type
function GetSearchPath : string;
procedure SetSearchPath (AValue : string);
procedure SetExtention (AValue : string);
+ Procedure DoMakeString (Text : Array of cardinal; ABitmaps : TBaseStringBitmaps);
+ Procedure DoMakeString (Text : Array of cardinal; angle: real; ABitmaps : TBaseStringBitmaps);
protected
function GetFontId (afilename:string; anindex:integer) : integer;
function CreateFont (afilename:string; anindex:integer) : integer;
- function SearchFont (afilename:string) : string;
function GetFont (FontID:integer) : TMgrFont;
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 : cardinal) : PMgrGlyph;
+ function CreateGlyph (c : cardinal) : 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;
function MakeString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+ function MakeString (FontId:integer; Text:Unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
+ function MakeString (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
public
constructor Create;
destructor destroy; override;
+ function SearchFont(afilename: string; doraise: boolean=true): string;
function RequestFont (afilename:string) : integer;
function RequestFont (afilename:string; anindex:integer) : integer;
function GetFreeTypeFont (aFontID:integer) : PFT_Face;
function GetString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+ function GetString (FontId:integer; Text:Unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
// Black and white
function GetStringGray (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+ function GetStringGray (FontId:integer; Text:unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
// Anti Aliased gray scale
function GetString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+ function GetString (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
// Black and white, following the direction of the font (left to right, top to bottom, ...)
- function GetStringGray (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+ function GetStringGray (FontId:integer; Text: String; Size:integer) : TStringBitmaps;
+ function GetStringGray (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
// Anti Aliased gray scale, following the direction of the font (left to right, top to bottom, ...)
property SearchPath : string read GetSearchPath write SetSearchPath;
property DefaultExtention : string read FExtention write SetExtention;
@@ -381,11 +401,12 @@ begin
AValue := '';
end;
-function TFontManager.SearchFont (afilename:string) : string;
+function TFontManager.SearchFont (afilename:string; doraise : boolean = true) : string;
// returns full filename of font, taking SearchPath in account
var p,fn : string;
r : integer;
begin
+ Result:='';
if (pos('.', afilename)=0) and (DefaultFontExtention<>'') then
fn := afilename + DefaultFontExtention
else
@@ -401,14 +422,12 @@ begin
repeat
dec (r);
until (r < 0) or FileExists(FPaths[r]+fn);
- if r < 0 then
- raise FreeTypeException.CreateFmt (sErrFontFileNotFound, [fn])
- else
- result := FPaths[r]+fn;
+ if r >= 0 then
+ Result := FPaths[r]+fn;
end
- else
- raise FreeTypeException.CreateFmt (sErrFontFileNotFound, [afilename]);
end;
+ if (Result='') and doRaise then
+ raise FreeTypeException.CreateFmt (sErrFontFileNotFound, [fn])
end;
function TFontManager.GetFontId (afilename:string; anindex:integer) : integer;
@@ -527,13 +546,13 @@ begin
end;
end;
-function TFontManager.CreateGlyph (c : char) : PMgrGlyph;
+function TFontManager.CreateGlyph (c : cardinal) : 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^.character := unicodechar(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
@@ -548,7 +567,7 @@ begin
CurSize^.Glyphs.Add (result);
end;
-function TFontManager.GetGlyph (c : char) : PMgrGlyph;
+function TFontManager.GetGlyph (c : cardinal) : PMgrGlyph;
var r : integer;
begin
With CurSize^ do
@@ -556,7 +575,7 @@ begin
r := Glyphs.Count;
repeat
dec (r)
- until (r < 0) or (PMgrGlyph(Glyphs[r])^.character = c);
+ until (r < 0) or (PMgrGlyph(Glyphs[r])^.character = unicodechar(c));
if r < 0 then
result := CreateGlyph (c)
else
@@ -571,10 +590,48 @@ begin
end;
function TFontManager.MakeString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+
+Var
+ T : Array of cardinal;
+ C,I : Integer;
+
+begin
+ CurFont := GetFont(FontID);
+ InitMakeString (FontID, Size);
+ c := length(text);
+ result := TStringBitmaps.Create(c);
+ result.FText := Text;
+ SetLength(T,Length(Text));
+ For I:=1 to Length(Text) do
+ T[I-1]:=Ord(Text[i]);
+ DoMakeString(T,Angle,Result);
+end;
+
+function TFontManager.MakeString (FontId:integer; Text:Unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
+
+Var
+ T : Array of cardinal;
+ c,I : Integer;
+
+begin
+ CurFont := GetFont(FontID);
+ InitMakeString (FontID, Size);
+ c := length(text);
+ result := TUnicodeStringBitmaps.Create(c);
+ result.FText := Text;
+ SetLength(T,C);
+ For I:=1 to c do
+ T[I-1]:=Ord(Text[i]);
+ DoMakeString(T,Angle,Result);
+end;
+
+
+procedure TFontManager.DoMakeString(Text: Array of cardinal; angle:real; ABitmaps : TBaseStringBitmaps);
+
var g : PMgrGlyph;
bm : PFT_BitmapGlyph;
gl : PFT_Glyph;
- prevIndex, prevx, c, r, rx : integer;
+ prevIndex, prevx, r, rx : integer;
pre, adv, pos, kern : FT_Vector;
buf : PByteArray;
reverse : boolean;
@@ -582,19 +639,15 @@ var g : PMgrGlyph;
FBM : PFontBitmap;
begin
- CurFont := GetFont(FontID);
if (Angle = 0) or // no angle asked, or can't work with angles (not scalable)
((CurFont.Font^.face_flags and FT_FACE_FLAG_SCALABLE)=0) then
- result := MakeString (FontID, Text, Size)
+ DoMakeString (Text, ABitmaps)
else
begin
- InitMakeString (FontID, Size);
- c := length(text);
- result := TStringBitmaps.Create(c);
if (CurRenderMode = FT_RENDER_MODE_MONO) then
- result.FMode := btBlackWhite
+ ABitmaps.FMode := btBlackWhite
else
- result.FMode := bt256Gray;
+ ABitmaps.FMode := bt256Gray;
MakeTransformation (angle, trans);
prevIndex := 0;
prevx := 0;
@@ -602,10 +655,10 @@ begin
pos.y := 0;
pre.x := 0;
pre.y := 0;
- for r := 0 to c-1 do
+ for r := 0 to Length(Text)-1 do
begin
// retrieve loaded glyph
- g := GetGlyph (Text[r+1]);
+ g := GetGlyph (Text[r]);
// check kerning
if UseKerning and (g^.glyphindex <>0) and (PrevIndex <> 0) then
begin
@@ -625,7 +678,7 @@ begin
FTCheck(FT_Glyph_To_Bitmap (gl, CurRenderMode, nil, true),sErrMakingString4);
// Copy what is needed to record
bm := PFT_BitmapGlyph(gl);
- FBM:=result.Bitmaps[r];
+ FBM:=ABitmaps.Bitmaps[r];
with FBM^ do
begin
with gl^.advance do
@@ -675,36 +728,68 @@ begin
// finish rendered glyph
FT_Done_Glyph (gl);
end;
- result.FText := Text;
- result.CalculateGlobals;
+ ABitmaps.CalculateGlobals;
end;
end;
function TFontManager.MakeString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+
+Var
+ T : Array of Cardinal;
+ C,I : Integer;
+
+begin
+ CurFont := GetFont(FontID);
+ InitMakeString (FontID, Size);
+ c := length(text);
+ result := TStringBitmaps.Create(c);
+ result.FText := Text;
+ SetLength(T,Length(Text));
+ For I:=1 to Length(Text) do
+ T[I-1]:=Ord(Text[i]);
+ DoMakeString(T,Result);
+end;
+
+function TFontManager.MakeString (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
+
+Var
+ T : Array of Cardinal;
+ C,I : Integer;
+
+begin
+ CurFont := GetFont(FontID);
+ InitMakeString (FontID, Size);
+ c := length(text);
+ result := TUnicodeStringBitmaps.Create(c);
+ result.FText := Text;
+ SetLength(T,C);
+ For I:=1 to C do
+ T[I-1]:=Ord(Text[i]);
+ DoMakeString(T,Result);
+end;
+
+Procedure TFontManager.DoMakeString (Text : Array of cardinal; ABitmaps : TBaseStringBitmaps);
+
var g : PMgrGlyph;
bm : PFT_BitmapGlyph;
gl : PFT_Glyph;
- e, prevIndex, prevx, c, r, rx : integer;
+ e, prevIndex, prevx, r, rx : integer;
pos, kern : FT_Vector;
buf : PByteArray;
reverse : boolean;
begin
- CurFont := GetFont(FontID);
- InitMakeString (FontID, Size);
- c := length(text);
- result := TStringBitmaps.Create(c);
if (CurRenderMode = FT_RENDER_MODE_MONO) then
- result.FMode := btBlackWhite
+ ABitmaps.FMode := btBlackWhite
else
- result.FMode := bt256Gray;
+ ABitmaps.FMode := bt256Gray;
prevIndex := 0;
prevx := 0;
pos.x := 0;
pos.y := 0;
- for r := 0 to c-1 do
+ for r := 0 to length(text)-1 do
begin
// retrieve loaded glyph
- g := GetGlyph (Text[r+1]);
+ g := GetGlyph (Text[r]);
// check kerning
if UseKerning and (g^.glyphindex <>0) and (PrevIndex <> 0) then
begin
@@ -719,7 +804,7 @@ begin
FTCheck(FT_Glyph_To_Bitmap (gl, CurRenderMode, @pos, true),sErrMakingString4);
// Copy what is needed to record
bm := PFT_BitmapGlyph(gl);
- with result.Bitmaps[r]^ do
+ with ABitmaps.Bitmaps[r]^ do
begin
with gl^.advance do
begin
@@ -761,8 +846,7 @@ begin
// finish rendered glyph
FT_Done_Glyph (gl);
end;
- result.FText := Text;
- result.CalculateGlobals;
+ ABitmaps.CalculateGlobals;
end;
function TFontManager.GetString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
@@ -795,6 +879,36 @@ begin
result := MakeString (FontID, text, Size);
end;
+function TFontManager.GetString (FontId:integer; Text:Unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
+// Black and white
+begin
+ CurRenderMode := FT_RENDER_MODE_MONO;
+ result := MakeString (FontID, text, Size, angle);
+end;
+
+function TFontManager.GetStringGray (FontId:integer; Text:Unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
+// Anti Aliased gray scale
+begin
+ CurRenderMode := FT_RENDER_MODE_NORMAL;
+ result := MakeString (FontID, text, Size, angle);
+end;
+
+{ Procedures without angle have own implementation to have better speed }
+
+function TFontManager.GetString (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
+// Black and white, following the direction of the font (left to right, top to bottom, ...)
+begin
+ CurRenderMode := FT_RENDER_MODE_MONO;
+ result := MakeString (FontID, text, Size);
+end;
+
+function TFontManager.GetStringGray (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
+// Anti Aliased gray scale, following the direction of the font (left to right, top to bottom, ...)
+begin
+ CurRenderMode := FT_RENDER_MODE_NORMAL;
+ result := MakeString (FontID, text, Size);
+end;
+
function TFontManager.RequestFont (afilename:string) : integer;
begin
result := RequestFont (afilename,0);
@@ -821,17 +935,17 @@ end;
{ TStringBitmaps }
-function TStringBitmaps.GetCount : integer;
+function TBaseStringBitmaps.GetCount : integer;
begin
result := FList.Count;
end;
-function TStringBitmaps.GetBitmap (index:integer) : PFontBitmap;
+function TBaseStringBitmaps.GetBitmap (index:integer) : PFontBitmap;
begin
result := PFontBitmap(FList[index]);
end;
-constructor TStringBitmaps.Create (ACount : integer);
+constructor TBaseStringBitmaps.Create (ACount : integer);
var r : integer;
bm : PFontBitmap;
begin
@@ -846,7 +960,7 @@ begin
end;
end;
-destructor TStringBitmaps.destroy;
+destructor TBaseStringBitmaps.destroy;
var r : integer;
bm : PFontBitmap;
begin
@@ -868,7 +982,7 @@ begin
end;
*)
-procedure TStringBitmaps.CalculateGlobals;
+procedure TBAseStringBitmaps.CalculateGlobals;
var
l,r : integer;
@@ -907,7 +1021,7 @@ begin
end;
end;
-procedure TStringBitmaps.GetBoundRect (out aRect : TRect);
+procedure TBaseStringBitmaps.GetBoundRect (out aRect : TRect);
begin
aRect := FBounds;
end;
diff --git a/packages/fcl-image/src/ftfont.pp b/packages/fcl-image/src/ftfont.pp
index 27cb9d2850..7615d7772a 100644
--- a/packages/fcl-image/src/ftfont.pp
+++ b/packages/fcl-image/src/ftfont.pp
@@ -27,12 +27,13 @@ type
private
FResolution : longword;
FAntiAliased : boolean;
- FLastText : TStringBitmaps;
+ FLastText : TBaseStringBitmaps;
FIndex, FFontID : integer;
FFace : PFT_Face;
FAngle : real;
procedure ClearLastText;
protected
+ procedure DrawLastText (atX,atY:integer);
procedure DrawChar (x,y:integer; data:PByteArray; pitch, width, height:integer); virtual;
procedure DrawCharBW (x,y:integer; data:PByteArray; pitch, width, height:integer); virtual;
procedure SetName (AValue:string); override;
@@ -47,7 +48,12 @@ type
procedure DoGetTextSize (text:string; var w,h:integer); override;
function DoGetTextHeight (text:string) : integer; override;
function DoGetTextWidth (text:string) : integer; override;
+ procedure DoDrawText (atx,aty:integer; atext: unicodestring); override;
+ procedure DoGetTextSize (text:unicodestring; var w,h:integer); override;
+ function DoGetTextHeight (text:unicodestring) : integer; override;
+ function DoGetTextWidth (text: unicodestring) : integer; override;
procedure GetText (aText:string);
+ procedure GetText (aText:unicodestring);
procedure GetFace;
public
constructor create; override;
@@ -180,6 +186,36 @@ begin
result := right - left;
end;
+procedure TFreeTypeFont.DoGetTextSize (text:unicodestring; var w,h:integer);
+var r : TRect;
+begin
+ GetText (text);
+ FLastText.GetBoundRect (r);
+ with r do
+ begin
+ w := right - left;
+ h := top - bottom;
+ end;
+end;
+
+function TFreeTypeFont.DoGetTextHeight (text:unicodestring) : integer;
+var r : TRect;
+begin
+ GetText (text);
+ FLastText.GetBoundRect (r);
+ with r do
+ result := top - bottom;
+end;
+
+function TFreeTypeFont.DoGetTextWidth (text:unicodestring) : integer;
+var r : TRect;
+begin
+ GetText (text);
+ FLastText.GetBoundRect (r);
+ with r do
+ result := right - left;
+end;
+
procedure TFreeTypeFont.SetFlags (index:integer; AValue:boolean);
begin
if not (index in [5,6]) then // bold,italic
@@ -213,7 +249,39 @@ var b : boolean;
begin
if assigned (FLastText) then
begin
- if CompareStr(FLastText.Text,aText) <> 0 then
+ if FLastText.InheritsFrom(TUnicodeStringBitmaps) or (CompareStr(TStringBitMaps(FLastText).Text,aText) <> 0) then
+ begin
+ FLastText.Free;
+ b := true;
+ end
+ else
+ begin
+ if FAntiAliased then
+ b := (FLastText.mode <> bt256Gray)
+ else
+ b := (FLastText.mode <> btBlackWhite);
+ if b then
+ FLastText.Free;
+ end;
+ end
+ else
+ b := true;
+ if b then
+ begin
+ FontMgr.Resolution := FResolution;
+ if FAntiAliased then
+ FLastText := FontMgr.GetStringGray (FFontId, aText, Size, Angle)
+ else
+ FLastText := FontMgr.GetString (FFontId, aText, Size, Angle);
+ end;
+end;
+
+procedure TFreeTypeFont.GetText (aText:Unicodestring);
+var b : boolean;
+begin
+ if assigned (FLastText) then
+ begin
+ if FLastText.InheritsFrom(TStringBitmaps) or (TUnicodeStringBitMaps(FLastText).Text<>aText) then
begin
FLastText.Free;
b := true;
@@ -240,10 +308,25 @@ begin
end;
end;
+procedure TFreeTypeFont.DoDrawText (atX,atY:integer; atext:unicodestring);
+
+begin
+ GetText (atext);
+ DrawLastText(atX,atY);
+end;
+
procedure TFreeTypeFont.DoDrawText (atX,atY:integer; atext:string);
-var r : integer;
+
begin
GetText (atext);
+ DrawLastText(atX,atY);
+end;
+
+procedure TFreeTypeFont.DrawLastText (atX,atY:integer);
+
+var r : integer;
+
+begin
with FLastText do
for r := 0 to count-1 do
with Bitmaps[r]^ do