diff options
author | marco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2017-06-19 08:51:02 +0000 |
---|---|---|
committer | marco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2017-06-19 08:51:02 +0000 |
commit | 2323b6a565015e94bf92d97cba2dbc7f444d00e1 (patch) | |
tree | e5f61a0e92e688b71838813a8da3a43b11a044fc | |
parent | 0dde2d08a8bd20fb8b0468e53ef0eb6225b596b3 (diff) | |
download | fpc-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.pp | 45 | ||||
-rw-r--r-- | packages/fcl-image/examples/imgconv.pp | 8 | ||||
-rw-r--r-- | packages/fcl-image/examples/pattern.png | bin | 0 -> 471 bytes | |||
-rw-r--r-- | packages/fcl-image/examples/textout.pp | 116 | ||||
-rw-r--r-- | packages/fcl-image/src/fpcanvas.inc | 71 | ||||
-rw-r--r-- | packages/fcl-image/src/fpcanvas.pp | 19 | ||||
-rw-r--r-- | packages/fcl-image/src/fpcdrawh.inc | 47 | ||||
-rw-r--r-- | packages/fcl-image/src/fppixlcanv.pp | 32 | ||||
-rw-r--r-- | packages/fcl-image/src/freetype.pp | 216 | ||||
-rw-r--r-- | packages/fcl-image/src/ftfont.pp | 89 |
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 Binary files differnew file mode 100644 index 0000000000..106e78f437 --- /dev/null +++ b/packages/fcl-image/examples/pattern.png 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 |