1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRAText;
3
4 {$mode objfpc}{$H+}
5 {$i bgrabitmap.inc}
6
7 interface
8
9 {$IFDEF LINUX}
10 {$DEFINE SYSTEM_RENDERER_IS_FINE}
11 {$DEFINE SYSTEM_CLEARTYPE_RENDERER_IS_FINE}
12 {$DEFINE RENDER_TEXT_ON_TBITMAP}
13 {$ENDIF}
14 {$IFDEF FREEBSD}
15 {$DEFINE SYSTEM_RENDERER_IS_FINE}
16 {$DEFINE SYSTEM_CLEARTYPE_RENDERER_IS_FINE}
17 {$ENDIF}
18 {$IFDEF DARWIN}
19 {$DEFINE SYSTEM_RENDERER_IS_FINE}
20 {$DEFINE RENDER_TEXT_ON_TBITMAP}
21 {$ENDIF}
22 {$IFDEF WINDOWS}
23 {$IFNDEF LEGACY_FONT_VERTICAL_OFFSET}
24 {$DEFINE FIX_FONT_VERTICAL_OFFSET}
25 {$ENDIF}
26 {$ENDIF}
27 {$IFDEF BGRABITMAP_USE_MSEGUI}
28 {$DEFINE RENDER_TEXT_ON_TBITMAP}
29 {$ENDIF}
30
31 {
32 Font rendering units : BGRAText, BGRATextFX, BGRAVectorize, BGRAFreeType
33
34 This unit provides basic text rendering functions using system renderer
35 (LCL or MSEgui).
36
37 Text functions use a temporary bitmap where the operating system text drawing
38 is used. Then it is scaled down (if antialiasing is activated) and colored.
39
40 These routines are rather slow, so you may use other font renderers
41 like TBGRATextEffectFontRenderer in BGRATextFX if you want to use LCL fonts,
42 or, if you have TrueType fonts files, you may use TBGRAFreeTypeFontRenderer
43 in BGRAFreeType. }
44
45 uses
46 BGRAClasses, SysUtils, BGRAGraphics, BGRABitmapTypes, BGRAPen, BGRAGrayscaleMask
47 {$IFDEF LCL},InterfaceBase, LCLVersion{$ENDIF};
48
49 const
50 RenderTextOnBitmap = {$IFDEF RENDER_TEXT_ON_TBITMAP}true{$ELSE}false{$ENDIF};
51
52 type
53 TWordBreakHandler = BGRABitmapTypes.TWordBreakHandler;
54
55 { TBGRASystemFontRenderer }
56
57 TBGRASystemFontRenderer = class(TBGRACustomFontRenderer)
58 protected
59 FFont: TFont; //font parameters
60 FWordBreakHandler: TWordBreakHandler;
61 FOwnUnderline: boolean;
62 procedure UpdateFont; virtual;
InternalTextSizenull63 function InternalTextSize(sUTF8: string; AShowPrefix: boolean): TSize;
InternalTextSizeAnglenull64 function InternalTextSizeAngle(sUTF8: string; AShowPrefix: boolean; AOrientation: integer): TSize; virtual;
65 procedure InternalTextWordBreak(ADest: TBGRACustomBitmap; ATextUTF8: string;
66 x, y, AMaxWidth: integer; AColor: TBGRAPixel; ATexture: IBGRAScanner;
67 AHorizAlign: TAlignment; AVertAlign: TTextLayout; ARightToLeft: boolean);
68 procedure InternalTextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel; ATexture: IBGRAScanner);
69 procedure InternalTextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; texture: IBGRAScanner;
70 align: TAlignment; AShowPrefix: boolean = false; ARightToLeft: boolean = false);
71 procedure InternalTextOutAngle(ADest: TBGRACustomBitmap; x, y: single; AOrientation: integer; sUTF8: string; c: TBGRAPixel; texture: IBGRAScanner;
72 align: TAlignment; AShowPrefix: boolean = false; ARightToLeft: boolean = false); virtual;
73 procedure InternalTextOutEllipse(ADest: TBGRACustomBitmap; x, y, availableWidth: single; sUTF8: string; c: TBGRAPixel; texture: IBGRAScanner;
74 align: TAlignment; AShowPrefix: boolean = false; ARightToLeft: boolean = false);
75 procedure InternalSplitText(var ATextUTF8: string; AMaxWidth: integer; out ARemainsUTF8: string; out ALineEndingBreak: boolean;
76 AWordBreak: TWordBreakHandler); overload;
77 procedure InternalSplitText(var ATextUTF8: string; AMaxWidth: integer; out ARemainsUTF8: string;
78 AWordBreak: TWordBreakHandler); overload;
InternalGetFontPixelMetricnull79 function InternalGetFontPixelMetric: TFontPixelMetric;
80 procedure DefaultWorkBreakHandler(var ABeforeUTF8, AAfterUTF8: string);
81 public
82 OverrideUnderlineDecoration: boolean; // draw unerline according to computed font pixel metric instead of using system rendering of underline
83 procedure SplitText(var ATextUTF8: string; AMaxWidth: integer; out ARemainsUTF8: string);
GetFontPixelMetricnull84 function GetFontPixelMetric: TFontPixelMetric; override;
FontExistsnull85 function FontExists(AName: string): boolean; override;
PatchSystemFontNamenull86 class function PatchSystemFontName(AName: string): string;
87 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; override;
88 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment; ARightToLeft: boolean); overload; override;
89 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; override;
90 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment; ARightToLeft: boolean); overload; override;
91 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; override;
92 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; override;
93 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; ARightToLeft: boolean); overload; override;
94 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; ARightToLeft: boolean); overload; override;
95 procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); overload; override;
96 procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); overload; override;
97 procedure TextWordBreak(ADest: TBGRACustomBitmap; AText: string; x, y, AMaxWidth: integer; AColor: TBGRAPixel; AHorizAlign: TAlignment; AVertAlign: TTextLayout; ARightToLeft: boolean = false); overload;
98 procedure TextWordBreak(ADest: TBGRACustomBitmap; AText: string; x, y, AMaxWidth: integer; ATexture: IBGRAScanner; AHorizAlign: TAlignment; AVertAlign: TTextLayout; ARightToLeft: boolean = false); overload;
TextSizenull99 function TextSize(sUTF8: string): TSize; overload; override;
TextSizeAnglenull100 function TextSizeAngle(sUTF8: string; orientationTenthDegCCW: integer): TSize; override;
TextSizenull101 function TextSize(sUTF8: string; AMaxWidth: integer; {%H-}ARightToLeft: boolean): TSize; overload; override;
TextFitInfonull102 function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; override;
103 constructor Create;
104 destructor Destroy; override;
105 property OnWordBreak: TWordBreakHandler read FWordBreakHandler write FWordBreakHandler;
106 end;
107
108 {$IFDEF BGRABITMAP_USE_MSEGUI}
109 TMSEFontRenderer = class(TBGRASystemFontRenderer);
110 {$ELSE}
111 TLCLFontRenderer = class(TBGRASystemFontRenderer);
112 {$ENDIF}
113
CleanTextOutStringnull114 function CleanTextOutString(s: string): string; //this works with UTF8 strings as well
RemoveLineEndingnull115 function RemoveLineEnding(var s: string; indexByte: integer): boolean; //this works with UTF8 strings however the index is the byte index
RemoveLineEndingUTF8null116 function RemoveLineEndingUTF8(var sUTF8: string; indexUTF8: integer): boolean;
117
118 procedure BGRATextOut(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; xf, yf: single; sUTF8: string;
119 c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; CustomAntialiasingLevel: Integer = 0;
120 ShowPrefix: boolean = false; RightToLeft: boolean = false);
121
122 procedure BGRATextOutAngle(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; xf, yf: single; orientationTenthDegCCW: integer;
123 sUTF8: string; c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; CustomAntialiasingLevel: Integer = 0);
124
125 procedure BGRATextRect(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; ARect: TRect; xf, yf: single;
126 sUTF8: string; style: TTextStyle; c: TBGRAPixel; tex: IBGRAScanner; CustomAntialiasingLevel: Integer = 0);
127
BGRATextSizenull128 function BGRATextSize(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer): TSize;
BGRATextSizeAnglenull129 function BGRATextSizeAngle(Font: TFont; AOrientation: integer; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer): TSize;
BGRATextFitInfonull130 function BGRATextFitInfo(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer; AMaxWidth: integer): integer;
BGRATextFitInfoAnglenull131 function BGRATextFitInfoAngle(Font: TFont; AOrientation: integer; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer; AMaxWidth: integer): integer;
BGRAOriginalTextSizenull132 function BGRAOriginalTextSize(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: integer): TSize;
BGRAOriginalTextSizeAnglenull133 function BGRAOriginalTextSizeAngle(Font: TFont; AOrientation: integer; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer): TSize;
BGRAOriginalTextSizeExnull134 function BGRAOriginalTextSizeEx(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer;
135 out actualAntialiasingLevel: integer; out extraVerticalMarginDueToRotation: integer): TSize;
BGRAOriginalTextSizeExAnglenull136 function BGRAOriginalTextSizeExAngle(Font: TFont; AOrientation: integer; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer;
137 out actualAntialiasingLevel: integer; out extraVerticalMarginDueToRotation: integer): TSize;
138
BGRATextUnderlinenull139 function BGRATextUnderline(ATopLeft: TPointF; AWidth: Single; AMetrics: TFontPixelMetric): ArrayOfTPointF; overload;
BGRATextUnderlinenull140 function BGRATextUnderline(ATopLeft: TPointF; AWidth: Single; ABaseline, AEmHeight: single): ArrayOfTPointF; overload;
BGRATextStrikeOutnull141 function BGRATextStrikeOut(ATopLeft: TPointF; AWidth: Single; AMetrics: TFontPixelMetric): ArrayOfTPointF; overload;
BGRATextStrikeOutnull142 function BGRATextStrikeOut(ATopLeft: TPointF; AWidth: Single; ABaseline, AEmHeight, AXHeight: single): ArrayOfTPointF; overload;
143
GetFontHeightSignnull144 function GetFontHeightSign: integer;
FontEmHeightSignnull145 function FontEmHeightSign: integer;
FontFullHeightSignnull146 function FontFullHeightSign: integer;
SystemFontAvailablenull147 function SystemFontAvailable: boolean;
GetFineClearTypeAutonull148 function GetFineClearTypeAuto: TBGRAFontQuality;
FixSystemFontFullHeightnull149 function FixSystemFontFullHeight({%H-}AFontName: string; AFontHeight: integer): integer;
150
151 {$IFDEF LCL}
LCLFontAvailablenull152 function LCLFontAvailable: boolean;
FixLCLFontFullHeightnull153 function FixLCLFontFullHeight(AFontName: string; AFontHeight: integer): integer;
154 {$ENDIF}
155
156 procedure BGRAFillClearTypeGrayscaleMask(dest: TBGRACustomBitmap; x,y: integer; xThird: integer; mask: TGrayscaleMask; color: TBGRAPixel; texture: IBGRAScanner = nil; RGBOrder: boolean=true);
157 procedure BGRAFillClearTypeMask(dest: TBGRACustomBitmap; x,y: integer; xThird: integer; mask: TBGRACustomBitmap; color: TBGRAPixel; texture: IBGRAScanner = nil; RGBOrder: boolean=true);
158 procedure BGRAFillClearTypeRGBMask(dest: TBGRACustomBitmap; x,y: integer; mask: TBGRACustomBitmap; color: TBGRAPixel; texture: IBGRAScanner = nil; KeepRGBOrder: boolean=true);
159
160 const FontAntialiasingLevel = {$IFDEF SYSTEM_RENDERER_IS_FINE}3{$ELSE}6{$ENDIF};
161 const FontDefaultQuality = fqAntialiased;
162 const IsLclFontRendererFine = {$IFDEF SYSTEM_RENDERER_IS_FINE}true{$ELSE}false{$ENDIF};
163
GetLCLFontPixelMetricnull164 function GetLCLFontPixelMetric(AFont: TFont): TFontPixelMetric;
165
166 var
167 BGRATextOutImproveReadabilityProc : procedure (bmp: TBGRACustomBitmap; AFont: TFont; xf,yf: single; text: string; color: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; mode : TBGRATextOutImproveReadabilityMode);
168
169 procedure BitmapTextOut(ABitmap: TBitmap; ACoord: TPoint; AText: string);
170 procedure BitmapTextOutAngle(ABitmap: TBitmap; ACoord: TPoint; AText: string; AOrientation: integer);
171 procedure BitmapTextRect(ABitmap: TBitmap; ARect: TRect; ACoord: TPoint;
172 AText: string; const AStyle: TTextStyle);
BitmapTextExtentnull173 function BitmapTextExtent(ABitmap: TBitmap; AText: string): TSize;
BitmapTextExtentAnglenull174 function BitmapTextExtentAngle(ABitmap: TBitmap; AText: string; AOrientation: integer): TSize;
BitmapTextFitInfonull175 function BitmapTextFitInfo(ABitmap: TBitmap; AText: string; AMaxWidth: integer): integer;
BitmapTextFitInfoAnglenull176 function BitmapTextFitInfoAngle(ABitmap: TBitmap; AText: string; AMaxWidth: integer; AOrientation: integer): integer;
177 procedure BitmapFillRect(ABitmap: TBitmap; ARect: TRect; AColor: TColor);
178
179 implementation
180
181 uses Math, BGRATransform, BGRABlend, BGRAUTF8, BGRAUnicode, BGRATextBidi
182 {$IFDEF LCL}, Forms{$IF lcl_fullversion >= 1070000}, lclplatformdef{$ENDIF}{$ENDIF};
183
184 const MaxPixelMetricCount = 100;
185
186 var
187 SystemFontDisabledValue: boolean;
188 fqFineClearTypeComputed: boolean;
189 fqFineClearTypeValue: TBGRAFontQuality;
190 FontHeightSignComputed: boolean;
191 FontHeightSignValue: integer;
192 FontPixelMetricArray: array[0..MaxPixelMetricCount-1] of record
193 usage: integer;
194 name: string;
195 height: integer;
196 italic: boolean;
197 bold: boolean;
198 metric: TFontPixelMetric;
199 end;
200 FontPixelMetricCount: integer;
201
202 {$IFDEF BGRABITMAP_USE_MSEGUI}
203 {$i bgramsegui_text.inc}
204 {$ELSE}
205 procedure BitmapTextOut(ABitmap: TBitmap; ACoord: TPoint; AText: string);
206 begin
207 ABitmap.Canvas.Brush.Style := bsClear;
208 ABitmap.Canvas.TextOut(ACoord.X, ACoord.Y, AText);
209 end;
210
211 procedure BitmapTextOutAngle(ABitmap: TBitmap; ACoord: TPoint; AText: string; AOrientation: integer);
212 begin
213 ABitmap.Canvas.Font.Orientation := AOrientation;
214 BitmapTextOut(ABitmap, ACoord, AText);
215 end;
216
217 procedure BitmapTextRect(ABitmap: TBitmap; ARect: TRect; ACoord: TPoint;
218 AText: string; const AStyle: TTextStyle);
219 begin
220 ABitmap.Canvas.Brush.Style := bsClear;
221 {$IFDEF DARWIN}
222 if AStyle.RightToLeft then AText := UTF8EmbedDirection(AText, true);
223 {$ENDIF}
224 ABitmap.Canvas.TextRect(ARect, ACoord.X, ACoord.Y, AText, AStyle);
225 end;
226
BitmapTextExtentnull227 function BitmapTextExtent(ABitmap: TBitmap; AText: string): TSize;
228 begin
229 {$IFDEF DARWIN}
230 AText := StringReplace(AText, ' ', UTF8_NO_BREAK_SPACE, [rfReplaceAll]);
231 {$ENDIF}
232 result := ABitmap.Canvas.TextExtent(AText);
233 end;
234
BitmapTextExtentAnglenull235 function BitmapTextExtentAngle(ABitmap: TBitmap; AText: string; AOrientation: integer): TSize;
236 begin
237 ABitmap.Canvas.Font.Orientation := AOrientation;
238 result := BitmapTextExtent(ABitmap, AText);
239 end;
240
BitmapTextFitInfonull241 function BitmapTextFitInfo(ABitmap: TBitmap; AText: string; AMaxWidth: integer): integer;
242 begin
243 {$IFDEF DARWIN}
244 AText := StringReplace(AText, ' ', UTF8_NO_BREAK_SPACE, [rfReplaceAll]);
245 {$ENDIF}
246 result := ABitmap.Canvas.TextFitInfo(AText, AMaxWidth);
247 end;
248
BitmapTextFitInfoAnglenull249 function BitmapTextFitInfoAngle(ABitmap: TBitmap; AText: string; AMaxWidth: integer; AOrientation: integer): integer;
250 begin
251 ABitmap.Canvas.Font.Orientation := AOrientation;
252 result := BitmapTextFitInfo(ABitmap, AText, AMaxWidth);
253 end;
254
255 procedure BitmapFillRect(ABitmap: TBitmap; ARect: TRect; AColor: TColor);
256 begin
257 ABitmap.Canvas.Brush.Style := bsSolid;
258 ABitmap.Canvas.Brush.Color := AColor;
259 ABitmap.Canvas.Pen.Style := psClear;
260 ABitmap.Canvas.FillRect(ARect);
261 end;
262 {$ENDIF}
263
264 procedure ComputeFontVerticalBounds(text: string; font: TFont; out top, bottom, totalHeight: integer);
265 var
266 xb,yb: integer;
267 pmask: PBGRAPixel;
268 nbPix: array of integer;
269 nbCur: integer;
270 mean: integer;
271 mask: TBGRACustomBitmap;
272 size: TSize;
273 begin
274 if not SystemFontAvailable then
275 begin
276 top := 0;
277 bottom := 0;
278 totalHeight := 0;
279 exit;
280 end;
281 size := BGRAOriginalTextSize(font,fqSystem,text,FontAntialiasingLevel);
282 mask := BGRABitmapFactory.Create(size.cx,size.cy,BGRABlack);
283 mask.Canvas.Font := font;
284 mask.Canvas.Font.Quality := fqAntialiased;
285 mask.Canvas.Font.Color := clWhite;
286 mask.Canvas.Font.Style := font.style * [fsBold,fsItalic];
287 BitmapTextOut(mask.Bitmap, Point(0,0), text);
288 top := -1;
289 bottom := -1;
290 totalHeight:= mask.Height;
291
292 mean := 0;
293 setlength(nbPix, mask.Height);
294 for yb := 0 to mask.Height-1 do
295 begin
296 pmask := mask.scanline[yb];
297 nbCur := 0;
298 for xb := 0 to mask.Width-1 do
299 begin
300 if (pmask^.green > 0) then inc(nbCur);
301 inc(pmask);
302 end;
303 nbPix[yb] := nbCur;
304 inc(mean,nbCur);
305 end;
306 mean := (mean+ (mask.Height div 2)) div mask.Height;
307
308 for yb := 0 to high(nbPix) do
309 begin
310 if nbPix[yb]> mean div 3 then
311 begin
312 if top = -1 then top := yb
313 else bottom := yb+1;
314 end;
315 end;
316 mask.Free;
317 end;
318
ComputeFontPixelMetricnull319 function ComputeFontPixelMetric(AFont: TFont): TFontPixelMetric;
320 begin
321 ComputeFontVerticalBounds('acemu',AFont,result.xLine,result.Baseline,result.Lineheight);
322 ComputeFontVerticalBounds('gDjSO',AFont,result.CapLine,result.DescentLine,result.Lineheight);
323 if result.xLine = -1 then result.xLine := result.CapLine else
324 if result.CapLine = -1 then result.CapLine := result.xLine;
325 if result.DescentLine = -1 then result.DescentLine := result.Baseline else
326 if result.Baseline = -1 then result.Baseline := result.DescentLine;
327 result.Defined := (result.xLine <> -1) and (result.CapLine <> -1) and (result.Baseline <> -1) and (result.DescentLine <> -1) and
328 (result.Lineheight <> -1);
329 end;
330
ComparePixelMetricnull331 function ComparePixelMetric(index: integer; font: TFont): integer;
332 begin
333 if (index < 0) or (index >= FontPixelMetricCount) then
334 result := 0
335 else
336 begin
337 with FontPixelMetricArray[index] do
338 if (name = font.Name) and (height = font.Height) then
339 result := 0 else
340 if (height > font.Height) then
341 result := 1 else
342 if (height < font.Height) then
343 result := -1 else
344 if name > font.Name then
345 result := 1 else
346 if name < font.Name then
347 result := -1
348 else result := 0;
349 end;
350 end;
351
352 procedure FindPixelMetricPos(AFont: TFont; out startPos,endPos: integer);
353 var middle,iStart,iEnd: integer;
354 begin
355 if FontPixelMetricCount = 0 then
356 begin
357 startPos := 0;
358 endPos := 0;
359 end;
360 iStart:= 0;
361 iEnd:= FontPixelMetricCount;
362 while iStart < iEnd do
363 begin
364 middle := (iStart+iEnd) div 2;
365 if ComparePixelMetric(middle,AFont) >= 0 then
366 iEnd := middle
367 else
368 iStart := middle+1;
369 end;
370 startPos := iStart;
371
372 iStart:= startPos;
373 iEnd:= FontPixelMetricCount;
374 while iStart < iEnd do
375 begin
376 middle := (iStart+iEnd) div 2;
377 if ComparePixelMetric(middle,AFont) <= 0 then
378 iStart := middle+1
379 else
380 iEnd := middle;
381 end;
382 endPos := iEnd;
383 end;
384
385 procedure RemoveOldPixelMetric;
386 var sum,nb,i: integer;
387 begin
388 if FontPixelMetricCount = 0 then exit;
389 sum := 0;
390 for i := 0 to FontPixelMetricCount-1 do
391 inc(sum, FontPixelMetricArray[i].usage);
392 sum := sum div FontPixelMetricCount;
393 nb := 0;
394 for i := 0 to FontPixelMetricCount-1 do
395 begin
396 if FontPixelMetricArray[i].usage > sum then
397 begin
398 FontPixelMetricArray[nb] := FontPixelMetricArray[i];
399 inc(nb);
400 end;
401 end;
402 FontPixelMetricCount := nb;
403 end;
404
GetLCLFontPixelMetricnull405 function GetLCLFontPixelMetric(AFont: TFont): TFontPixelMetric;
406 var i,startPos,endPos: integer;
407 prevHeight,fixHeight: integer;
408 begin
409 if (AFont.Height < -200) or (AFont.Height > 150) then
410 begin
411 prevHeight := AFont.Height;
412 if AFont.Height < 0 then
413 fixHeight := -200
414 else
415 fixHeight := 150;
416 AFont.Height := fixHeight;
417 result := GetLCLFontPixelMetric(AFont);
418 AFont.Height := prevHeight;
419
420 result.Baseline := round(result.Baseline/fixHeight*prevHeight);
421 result.CapLine := round(result.CapLine/fixHeight*prevHeight);
422 result.DescentLine := round(result.DescentLine/fixHeight*prevHeight);
423 result.Lineheight := round(result.Lineheight/fixHeight*prevHeight);
424 result.xLine := round(result.xLine/fixHeight*prevHeight);
425 exit;
426 end;
427
428 FindPixelMetricPos(AFont,startPos,endPos);
429 for i := startPos to endPos-1 do
430 if (FontPixelMetricArray[i].bold = AFont.bold) and
431 (FontPixelMetricArray[i].italic = AFont.Italic) then
432 begin
433 result := FontPixelMetricArray[i].metric;
434 inc(FontPixelMetricArray[i].usage);
435 exit;
436 end;
437 if FontPixelMetricCount = MaxPixelMetricCount then RemoveOldPixelMetric;
438 for i := FontPixelMetricCount downto endPos+1 do
439 FontPixelMetricArray[i] := FontPixelMetricArray[i-1];
440 inc(FontPixelMetricCount);
441 with FontPixelMetricArray[endPos]do
442 begin
443 italic := AFont.Italic;
444 bold := AFont.Bold;
445 usage := 1;
446 name := AFont.Name;
447 height:= AFont.Height;
448 metric := ComputeFontPixelMetric(AFont);
449 result := metric;
450 end;
451 end;
452
453 const DefaultFontHeightSign = -1;
454
BGRATextUnderlinenull455 function BGRATextUnderline(ATopLeft: TPointF;
456 AWidth: Single; AMetrics: TFontPixelMetric): ArrayOfTPointF;
457 begin
458 result := BGRATextUnderline(ATopLeft, AWidth, AMetrics.Baseline,AMetrics.Baseline-AMetrics.CapLine);
459 end;
460
BGRATextUnderlinenull461 function BGRATextUnderline(ATopLeft: TPointF;
462 AWidth: Single; ABaseline, AEmHeight: single): ArrayOfTPointF;
463 var height,y: single;
464 begin
465 height := AEmHeight*0.080;
466 y := ATopLeft.y+ABaseline+1.6*height;
467 result := ComputeWidePolylinePoints([PointF(ATopLeft.x,y),
468 PointF(ATopLeft.x+AWidth,y)],height,BGRABlack,pecFlat,pjsMiter,
469 SolidPenStyle, []);
470 end;
471
BGRATextStrikeOutnull472 function BGRATextStrikeOut(ATopLeft: TPointF; AWidth: Single;
473 AMetrics: TFontPixelMetric): ArrayOfTPointF;
474 begin
475 result := BGRATextStrikeOut(ATopLeft, AWidth, AMetrics.Baseline,AMetrics.Baseline-AMetrics.CapLine,AMetrics.Baseline-AMetrics.xLine);
476 end;
477
BGRATextStrikeOutnull478 function BGRATextStrikeOut(ATopLeft: TPointF; AWidth: Single; ABaseline,
479 AEmHeight, AXHeight: single): ArrayOfTPointF;
480 var height,y: single;
481 begin
482 height := AEmHeight*0.075;
483 y := ATopLeft.y+ABaseline-AXHeight*0.5;
484 result := ComputeWidePolylinePoints([PointF(ATopLeft.x,y),
485 PointF(ATopLeft.x+AWidth,y)],height,BGRABlack,pecFlat,pjsMiter,
486 SolidPenStyle, []);
487 end;
488
GetFontHeightSignnull489 function GetFontHeightSign: integer;
490 var
491 HeightP1, HeightM1: integer;
492 tempBmp: TBitmap;
493 begin
494 if SystemFontDisabledValue then
495 begin
496 result := DefaultFontHeightSign;
497 exit;
498 end;
499
500 if FontHeightSignComputed then
501 begin
502 result := FontHeightSignValue;
503 exit;
504 end;
505
506 if {$IFDEF LCL}WidgetSet.LCLPlatform = lpNoGUI{$ELSE}False{$ENDIF} then
507 begin
508 SystemFontDisabledValue:= True;
509 result := -1;
510 exit;
511 end;
512
513 tempBmp := nil;
514 try
515 tempBmp := TBitmap.Create;
516 tempBmp.Width := 30;
517 tempBmp.Height := 30;
518 tempBmp.Canvas.Font.Name := 'Arial';
519 tempBmp.Canvas.Font.Style := [];
520 tempBmp.Canvas.Font.Height := 20;
521 HeightP1 := BitmapTextExtent(tempBmp, 'Hg').cy;
522 tempBmp.Canvas.Font.Height := -20;
523 HeightM1 := BitmapTextExtent(tempBmp, 'Hg').cy;
524
525 if HeightP1 > HeightM1 then
526 FontHeightSignValue := 1
527 else
528 FontHeightSignValue := -1;
529
530 FontHeightSignComputed := true;
531 result := FontHeightSignValue;
532 except
533 on ex: Exception do
534 begin
535 SystemFontDisabledValue := True;
536 result := -1;
537 end;
538 end;
539 tempBmp.Free;
540 end;
541
GetFineClearTypeAutonull542 function GetFineClearTypeAuto: TBGRAFontQuality;
543 var
544 lclBmp: TBitmap;
545 bgra: TBGRACustomBitmap;
546 x,y: integer;
547 begin
548 if fqFineClearTypeComputed then
549 begin
550 result:= fqFineClearTypeValue;
551 exit;
552 end;
553 result := fqFineAntialiasing;
554 if not SystemFontDisabledValue and not ({$IFDEF LCL}WidgetSet.LCLPlatform = lpNoGUI{$ELSE}False{$ENDIF}) then
555 begin
556 lclBmp := TBitmap.Create;
557 lclBmp.Width := 1;
558 lclBmp.Height := 1;
559 lclBmp.Canvas.Font.Height := -50;
560 lclBmp.Canvas.Font.Quality := fqCleartype;
561 lclBmp.Canvas.Font.Color := clBlack;
562 with BitmapTextExtent(lclBmp, '/') do
563 begin
564 lclBmp.Width := cx;
565 lclBmp.Height := cy;
566 end;
567 BitmapFillRect(lclBmp, rect(0,0,lclBmp.Width,lclBmp.Height), clWhite);
568 BitmapTextOut(lclBmp, Point(0,0), '/');
569 bgra:= BGRABitmapFactory.Create(lclBmp);
570 x:= bgra.Width div 2;
571 for y := 0 to bgra.Height-1 do
572 with bgra.GetPixel(x,y) do
573 if (red<>blue) then
574 begin
575 if blue < red then
576 result:= fqFineClearTypeRGB
577 else
578 result:= fqFineClearTypeBGR;
579 break;
580 end else
581 if (green = 0) then break;
582 bgra.Free;
583 lclBmp.Free;
584 end;
585 fqFineClearTypeValue := result;
586 fqFineClearTypeComputed:= true;
587 end;
588
589 {$IFNDEF WINDOWS}
590 var LCLFontFullHeightRatio : array of record
591 FontName: string;
592 Ratio: single;
593 end;
594 {$ENDIF}
595
FixSystemFontFullHeightnull596 function FixSystemFontFullHeight(AFontName: string; AFontHeight: integer): integer;
597 {$IFNDEF WINDOWS}
598 const TestHeight = 200;
599 var
600 i: Integer;
601 ratio : single;
602 f: TFont;
603 h: LongInt;
604 begin
605 if (AFontHeight = 0) or
606 (AFontHeight*FontEmHeightSign > 0) then
607 result := AFontHeight
608 else
609 begin
610 ratio := EmptySingle;
611 for i := 0 to high(LCLFontFullHeightRatio) do
612 if CompareText(AFontName, LCLFontFullHeightRatio[i].FontName)=0 then
613 begin
614 ratio := LCLFontFullHeightRatio[i].Ratio;
615 break;
616 end;
617 if ratio = EmptySingle then
618 begin
619 f := TFont.Create;
620 f.Quality := fqDefault;
621 f.Name := AFontName;
622 f.Height := FontFullHeightSign*TestHeight;
623 h := BGRATextSize(f, fqSystem, 'Hg', 1).cy;
624 f.Free;
625 if h = 0 then ratio := 1
626 else ratio := TestHeight/h;
627
628 setlength(LCLFontFullHeightRatio, length(LCLFontFullHeightRatio)+1);
629 LCLFontFullHeightRatio[high(LCLFontFullHeightRatio)].FontName:= AFontName;
630 LCLFontFullHeightRatio[high(LCLFontFullHeightRatio)].Ratio:= ratio;
631 end;
632 result := round(AFontHeight*ratio);
633 end;
634 end;
635 {$ELSE}
636 begin
637 result := AFontHeight;
638 end;
639 {$ENDIF}
640
641 {$IFDEF LCL}
LCLFontAvailablenull642 function LCLFontAvailable: boolean;
643 begin
644 result := SystemFontAvailable;
645 end;
646
FixLCLFontFullHeightnull647 function FixLCLFontFullHeight(AFontName: string; AFontHeight: integer): integer;
648 begin
649 result := FixSystemFontFullHeight(AFontName, AFontHeight);
650 end;
651 {$ENDIF}
652
FontEmHeightSignnull653 function FontEmHeightSign: integer;
654 begin
655 result := GetFontHeightSign;
656 end;
657
FontFullHeightSignnull658 function FontFullHeightSign: integer;
659 begin
660 result := -FontEmHeightSign;
661 end;
662
SystemFontAvailablenull663 function SystemFontAvailable: boolean;
664 begin
665 if not FontHeightSignComputed then GetFontHeightSign;
666 result := not SystemFontDisabledValue;
667 end;
668
669 procedure BGRAFillClearTypeGrayscaleMask(dest: TBGRACustomBitmap; x,
670 y: integer; xThird: integer; mask: TGrayscaleMask; color: TBGRAPixel;
671 texture: IBGRAScanner; RGBOrder: boolean);
672 begin
673 BGRAGrayscaleMask.BGRAFillClearTypeGrayscaleMask(dest,x,y,xThird,mask,color,texture,RGBOrder);
674 end;
675
676 procedure BGRAFillClearTypeMask(dest: TBGRACustomBitmap; x,y: integer; xThird: integer; mask: TBGRACustomBitmap; color: TBGRAPixel; texture: IBGRAScanner; RGBOrder: boolean);
677 begin
678 BGRABlend.BGRAFillClearTypeMask(dest,x,y,xThird,mask,color,texture,RGBOrder);
679 end;
680
681 procedure BGRAFillClearTypeRGBMask(dest: TBGRACustomBitmap; x, y: integer;
682 mask: TBGRACustomBitmap; color: TBGRAPixel; texture: IBGRAScanner;
683 KeepRGBOrder: boolean);
684 begin
685 BGRABlend.BGRAFillClearTypeRGBMask(dest,x,y,mask,color,texture,KeepRGBOrder);
686 end;
687
BGRAOriginalTextSizeExnull688 function BGRAOriginalTextSizeEx(Font: TFont; Quality: TBGRAFontQuality;
689 sUTF8: string; CustomAntialiasingLevel: Integer;
690 out actualAntialiasingLevel: integer;
691 out extraVerticalMarginDueToRotation: integer): TSize;
692 begin
693 result := BGRAOriginalTextSizeExAngle(Font, Font.Orientation, Quality, sUTF8,
694 CustomAntialiasingLevel, actualAntialiasingLevel, extraVerticalMarginDueToRotation);
695 end;
696
BGRAOriginalTextSizeExAnglenull697 function BGRAOriginalTextSizeExAngle(Font: TFont; AOrientation: integer;
698 Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer;
699 out actualAntialiasingLevel: integer;
700 out extraVerticalMarginDueToRotation: integer): TSize;
701 var
702 tempBmp: TBitmap;
703 begin
704 actualAntialiasingLevel:= CustomAntialiasingLevel;
705 extraVerticalMarginDueToRotation := 0;
706 if not SystemFontAvailable then
707 result := Size(0,0)
708 else
709 begin
710 tempBmp := nil;
711 try
712 tempBmp := TBitmap.Create;
713 tempBmp.Canvas.Font := Font;
714 if Quality in[fqFineClearTypeBGR,fqFineClearTypeRGB,fqFineAntialiasing] then
715 begin
716 tempBmp.Canvas.Font.Height := Font.Height*CustomAntialiasingLevel;
717 end else
718 begin
719 tempBmp.Canvas.Font.Height := Font.Height;
720 actualAntialiasingLevel:= 1;
721 end;
722 result := BitmapTextExtentAngle(tempBmp, sUTF8, AOrientation);
723 if Font.Orientation <> 0 then
724 begin
725 tempBmp.Canvas.Font.Orientation:= 0;
726 extraVerticalMarginDueToRotation := result.cy -
727 BitmapTextExtentAngle(tempBmp, sUTF8, AOrientation).cy;
728 end;
729 except
730 on ex: exception do
731 begin
732 result := Size(0,0);
733 SystemFontDisabledValue := True;
734 end;
735 end;
736 tempBmp.Free;
737 end;
738 end;
739
BGRATextFitInfonull740 function BGRATextFitInfo(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string;
741 CustomAntialiasingLevel: Integer; AMaxWidth: integer): integer;
742 begin
743 result := BGRATextFitInfoAngle(Font, Font.Orientation, Quality, sUTF8,
744 CustomAntialiasingLevel, AMaxWidth);
745 end;
746
BGRATextFitInfoAnglenull747 function BGRATextFitInfoAngle(Font: TFont; AOrientation: integer; Quality: TBGRAFontQuality; sUTF8: string;
748 CustomAntialiasingLevel: Integer; AMaxWidth: integer): integer;
749 var
750 actualAntialiasingLevel{$IFDEF LCL}{$IF lcl_fullversion < 1070000}, len1{$ENDIF}{$ENDIF}: Integer;
751 tempBmp: TBitmap;
752 begin
753 if (AMaxWidth = 0) or (length(sUTF8)=0) then exit(0);
754 actualAntialiasingLevel:= CustomAntialiasingLevel;
755 if not SystemFontAvailable then
756 result := 0
757 else
758 begin
759 tempBmp := nil;
760 try
761 tempBmp := TBitmap.Create;
762 tempBmp.Canvas.Font := Font;
763 if Quality in[fqFineClearTypeBGR,fqFineClearTypeRGB,fqFineAntialiasing] then
764 begin
765 tempBmp.Canvas.Font.Height := Font.Height*CustomAntialiasingLevel;
766 end else
767 begin
768 tempBmp.Canvas.Font.Height := Font.Height;
769 actualAntialiasingLevel:= 1;
770 end;
771 {$IFDEF LCL}{$IF lcl_fullversion < 1070000}
772 len1 := BitmapTextExtentAngle(tempBmp,
773 copy(sUTF8,1,UTF8CharacterLength(@sUTF8[1])),
774 AOrientation).cx;
775 if len1 > AMaxWidth*actualAntialiasingLevel then exit(0);
776 {$ENDIF}{$ENDIF}
777 result := BitmapTextFitInfoAngle(tempBmp, sUTF8,
778 AMaxWidth*actualAntialiasingLevel, AOrientation);
779 except
780 on ex: exception do
781 begin
782 result := 0;
783 SystemFontDisabledValue := True;
784 end;
785 end;
786 tempBmp.Free;
787 end;
788 end;
789
BGRAOriginalTextSizenull790 function BGRAOriginalTextSize(Font: TFont; Quality: TBGRAFontQuality;
791 sUTF8: string; CustomAntialiasingLevel: Integer): TSize;
792 begin
793 result := BGRAOriginalTextSizeAngle(Font, Font.Orientation, Quality, sUTF8,
794 CustomAntialiasingLevel);
795 end;
796
BGRAOriginalTextSizeAnglenull797 function BGRAOriginalTextSizeAngle(Font: TFont; AOrientation: integer;
798 Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer): TSize;
799 var actualAntialiasingLevel, extraMargin: integer;
800 begin
801 result := BGRAOriginalTextSizeExAngle(Font, AOrientation, Quality, sUTF8,
802 CustomAntialiasingLevel, actualAntialiasingLevel, extraMargin);
803 {$IFDEF FIX_FONT_VERTICAL_OFFSET}
804 if extraMargin > 0 then dec(result.cy, extraMargin);
805 {$ENDIF}
806 end;
807
BGRATextSizenull808 function BGRATextSize(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer): TSize;
809 begin
810 result := BGRATextSizeAngle(Font, Font.Orientation, Quality, sUTF8, CustomAntialiasingLevel);
811 end;
812
BGRATextSizeAnglenull813 function BGRATextSizeAngle(Font: TFont; AOrientation: integer; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer): TSize;
814 begin
815 {$IFDEF SYSTEM_RENDERER_IS_FINE}
816 if Quality = fqFineAntialiasing then Quality:= fqSystem;
817 {$ENDIF}
818 result := BGRAOriginalTextSizeAngle(Font, AOrientation, Quality, sUTF8, CustomAntialiasingLevel);
819 if Quality in[fqFineClearTypeBGR,fqFineClearTypeRGB,fqFineAntialiasing] then
820 begin
821 result.cx := ceil(Result.cx/CustomAntialiasingLevel);
822 result.cy := ceil(Result.cy/CustomAntialiasingLevel);
823 end;
824 end;
825
RemovePrefixnull826 function RemovePrefix(sUTF8: string): string;
827 var i,resLen: integer;
828 begin
829 setlength(result, length(sUTF8));
830 resLen := 0;
831 i := 1;
832 while i <= length(sUTF8) do
833 begin
834 if sUTF8[i] = '&' then
835 begin // double ('&&') indicate single char '&'
836 if (i < length(sUTF8)) and (sUTF8[i+1] = '&') then
837 begin
838 inc(resLen);
839 result[resLen] := '&';
840 inc(i,2);
841 end else
842 // single indicate underline
843 inc(i);
844 end else
845 begin
846 inc(resLen);
847 result[resLen] := sUTF8[i];
848 inc(i);
849 end;
850 end;
851 setlength(result,resLen);
852 end;
853
854 procedure FilterOriginalText(Quality: TBGRAFontQuality; CustomAntialiasingLevel: Integer; var temp: TBGRACustomBitmap;
855 out grayscaleMask: TGrayscaleMask);
856 var
857 n: integer;
858 maxAlpha: UInt32or64;
859 pb: PByte;
860 multiplyX: integer;
861 resampled: TBGRACustomBitmap;
862 begin
863 grayscaleMask := nil;
864 case Quality of
865 fqFineClearTypeBGR,fqFineClearTypeRGB,fqFineAntialiasing:
866 begin
867 if Quality in [fqFineClearTypeBGR,fqFineClearTypeRGB] then multiplyX:= 3 else multiplyX:= 1;
868 if (temp.Height < CustomAntialiasingLevel*8) and (temp.Height >= CustomAntialiasingLevel*3) then
869 begin
870 temp.ResampleFilter := rfSpline;
871 resampled := temp.Resample(round(temp.width/CustomAntialiasingLevel*multiplyX),round(temp.Height/CustomAntialiasingLevel),rmFineResample);
872 grayscaleMask := TGrayscaleMask.Create(resampled,cGreen);
873 FreeAndNil(resampled);
874 end else
875 grayscaleMask := TGrayscaleMask.CreateDownSample(temp, round(temp.width/CustomAntialiasingLevel*multiplyX),round(temp.Height/CustomAntialiasingLevel));
876 FreeAndNil(temp);
877
878 maxAlpha := 0;
879 pb := grayscaleMask.Data;
880 for n := grayscaleMask.NbPixels - 1 downto 0 do
881 begin
882 if Pb^ > maxAlpha then maxAlpha := Pb^;
883 Inc(pb);
884 end;
885 if (maxAlpha <> 0) and (maxAlpha <> 255) then
886 begin
887 pb := grayscaleMask.Data;
888 for n := grayscaleMask.NbPixels - 1 downto 0 do
889 begin
890 pb^:= pb^ * 255 div maxAlpha;
891 Inc(pb);
892 end;
893 end;
894 end;
895 fqSystem:
896 begin
897 grayscaleMask := TGrayscaleMask.Create(temp, cGreen);
898 FreeAndNil(temp);
899 {$IFNDEF LINUX}
900 pb := grayscaleMask.Data;
901 for n := grayscaleMask.NbPixels - 1 downto 0 do
902 begin
903 pb^:= GammaExpansionTab[pb^] shr 8;
904 Inc(pb);
905 end;
906 {$ENDIF}
907 end;
908 end;
909 end;
910
CleanTextOutStringnull911 function CleanTextOutString(s: string): string;
912 begin
913 result := BGRABitmapTypes.CleanTextOutString(s);
914 end;
915
RemoveLineEndingnull916 function RemoveLineEnding(var s: string; indexByte: integer): boolean;
917 begin
918 result := BGRABitmapTypes.RemoveLineEnding(s, indexByte);
919 end;
920
RemoveLineEndingUTF8null921 function RemoveLineEndingUTF8(var sUTF8: string; indexUTF8: integer): boolean;
922 begin
923 result := BGRABitmapTypes.RemoveLineEndingUTF8(sUTF8,indexUTF8);
924 end;
925
926 procedure BGRAInternalRenderText(dest: TBGRACustomBitmap; Quality: TBGRAFontQuality; grayscale: TGrayscaleMask; temp: TBGRACustomBitmap;
927 x,y,xThird: integer; c: TBGRAPixel; tex: IBGRAScanner);
928 begin
929 if Quality in [fqFineClearTypeBGR,fqFineClearTypeRGB,fqSystemClearType] then
930 begin
931 if grayscale <> nil then
932 BGRAFillClearTypeGrayscaleMask(dest,x,y,xThird, grayscale,c,tex,Quality=fqFineClearTypeRGB)
933 else if temp <> nil then
934 BGRAFillClearTypeRGBMask(dest,x,y, temp,c,tex);
935 end
936 else
937 begin
938 if grayscale <> nil then
939 begin
940 if tex <> nil then
941 grayscale.DrawAsAlpha(dest, x, y, tex) else
942 grayscale.DrawAsAlpha(dest, x, y, c);
943 end
944 else if temp <> nil then
945 dest.PutImage(x, y, temp, dmDrawWithTransparency);
946 end;
947 end;
948
949 procedure BGRATextOut(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; xf, yf: single; sUTF8: string;
950 c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; CustomAntialiasingLevel: Integer = 0;
951 ShowPrefix: boolean = false; RightToLeft: boolean = false);
952 var
953 size: TSize;
954 sizeFactor, extraVerticalMargin: integer;
955 xMarginF: single;
956 style: TTextStyle;
957 noPrefix: string;
958 begin
959 if not SystemFontAvailable then exit;
960
961 if CustomAntialiasingLevel = 0 then
962 CustomAntialiasingLevel:= FontAntialiasingLevel;
963
964 if Font.Orientation mod 3600 <> 0 then
965 begin
966 BGRATextOutAngle(bmp,Font,Quality,xf,yf,Font.Orientation,sUTF8,c,tex,align);
967 exit;
968 end;
969
970 {$IFDEF SYSTEM_RENDERER_IS_FINE}
971 if (Quality in [fqFineAntialiasing, fqFineClearTypeRGB, fqFineClearTypeBGR]) and
972 (BGRATextSize(Font, fqSystem, 'Hg', 1).cy >= 13) then
973 begin
974 if Quality = fqFineAntialiasing then Quality := fqSystem;
975 {$IFDEF SYSTEM_CLEARTYPE_RENDERER_IS_FINE}
976 if Quality = GetFineClearTypeAuto then Quality := fqSystemClearType;
977 {$ENDIF}
978 end;
979 {$ENDIF}
980
981 if ShowPrefix then
982 noPrefix := RemovePrefix(sUTF8)
983 else
984 noPrefix := sUTF8;
985
986 size := BGRAOriginalTextSizeEx(Font,Quality,noPrefix,CustomAntialiasingLevel,sizeFactor,extraVerticalMargin);
987 if (size.cx = 0) or (size.cy = 0) then
988 exit;
989
990 if (size.cy >= 144) and (Quality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) and (CustomAntialiasingLevel > 4) then
991 begin
992 CustomAntialiasingLevel:= 4;
993 size := BGRAOriginalTextSizeEx(Font,Quality,noPrefix,CustomAntialiasingLevel,sizeFactor,extraVerticalMargin);
994 end;
995
996 case align of
997 taLeftJustify: ;
998 taCenter: DecF(xf, size.cx/2/sizeFactor);
999 taRightJustify: DecF(xf, size.cx/sizeFactor);
1000 end;
1001
1002 xMarginF := size.cy/sizeFactor;
1003 fillchar({%H-}style,sizeof(style),0);
1004 style.SingleLine := true;
1005 style.Alignment := taLeftJustify;
1006 style.Layout := tlTop;
1007 style.RightToLeft := RightToLeft;
1008 style.ShowPrefix := ShowPrefix;
1009 BGRATextRect(bmp, Font, Quality,
1010 rect(floor(xf-xMarginF), floor(yf)-1, ceil(xf+size.cx/sizeFactor+xMarginF), ceil(yf+size.cy/sizeFactor)+1),
1011 xf,yf, sUTF8, style, c, tex, sizeFactor);
1012 end;
1013
1014 procedure BGRATextOutAngle(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; xf, yf: single;
1015 orientationTenthDegCCW: integer;
1016 sUTF8: string; c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; CustomAntialiasingLevel: Integer = 0);
1017 var
1018 posF: TPointF;
1019 x,y: integer;
1020 deltaX,deltaY: integer;
1021 size: TSize;
1022 temp: TBGRACustomBitmap;
1023 TopLeft,TopRight,BottomRight,BottomLeft: TPointF;
1024 Top,dy: Single;
1025 Left: Single;
1026 cosA,sinA: single;
1027 rotBounds: TRect;
1028 sizeFactor, extraVerticalMargin: integer;
1029 TempFont: TFont;
1030 oldOrientation: integer;
1031 grayscale:TGrayscaleMask;
1032 {$IFDEF RENDER_TEXT_ON_TBITMAP}
1033 tempLCL: TBitmap;
1034 {$ENDIF}
1035
1036 procedure rotBoundsAdd(pt: TPointF);
1037 begin
1038 if pt.x < Left then Left := pt.x;
1039 if pt.y < Top then Top := pt.y;
1040 if floor(pt.X) < rotBounds.Left then rotBounds.Left := floor(pt.X/sizeFactor)*sizeFactor;
1041 if floor(pt.Y) < rotBounds.Top then rotBounds.Top := floor(pt.Y/sizeFactor)*sizeFactor;
1042 if ceil(pt.X) > rotBounds.Right then rotBounds.Right := ceil(pt.X/sizeFactor)*sizeFactor;
1043 if ceil(pt.Y) > rotBounds.Bottom then rotBounds.Bottom := ceil(pt.Y/sizeFactor)*sizeFactor;
1044 end;
1045
1046 begin
1047 if not SystemFontAvailable then exit;
1048
1049 if CustomAntialiasingLevel = 0 then
1050 CustomAntialiasingLevel:= FontAntialiasingLevel;
1051
1052 if orientationTenthDegCCW mod 3600 = 0 then
1053 begin
1054 oldOrientation := Font.Orientation;
1055 Font.Orientation := 0;
1056 BGRATextOut(bmp,Font,Quality,xf,yf,sUTF8,c,tex,align);
1057 Font.Orientation := oldOrientation;
1058 exit;
1059 end;
1060 TempFont := TFont.Create;
1061 TempFont.Assign(Font);
1062 TempFont.Height := Font.Height;
1063 size := BGRAOriginalTextSizeExAngle(TempFont,orientationTenthDegCCW,Quality,sUTF8,CustomAntialiasingLevel,sizeFactor, extraVerticalMargin);
1064 if (size.cx = 0) or (size.cy = 0) then
1065 begin
1066 tempFont.Free;
1067 exit;
1068 end;
1069 {$IFDEF FIX_FONT_VERTICAL_OFFSET}
1070 if extraVerticalMargin > 0 then
1071 dy := -extraVerticalMargin*0.5 -1
1072 else
1073 dy := 0;
1074 {$ELSE}
1075 dy := 0;
1076 {$ENDIF}
1077 tempFont.Free;
1078
1079 cosA := cos(orientationTenthDegCCW*Pi/1800);
1080 sinA := sin(orientationTenthDegCCW*Pi/1800);
1081 TopLeft := PointF(sinA*dy,cosA*dy);
1082 posF := PointF(xf,yf);
1083 posF.Offset( TopLeft * (1/sizeFactor) );
1084 TopRight := TopLeft + PointF(cosA*size.cx,-sinA*size.cx);
1085 BottomRight := TopRight + PointF(sinA*size.cy,cosA*size.cy);
1086 BottomLeft := TopLeft + PointF(sinA*size.cy,cosA*size.cy);
1087 rotBounds := rect(0,0,0,0);
1088 Top := 0;
1089 Left := 0;
1090 rotBoundsAdd(TopRight);
1091 rotBoundsAdd(BottomRight);
1092 rotBoundsAdd(BottomLeft);
1093 inc(rotBounds.Right);
1094 inc(rotBounds.Bottom);
1095
1096 posF.Offset( Left/sizeFactor, Top/sizeFactor );
1097 case align of
1098 taLeftJustify: ;
1099 taCenter:
1100 posF.Offset( -TopRight*(1/(2*sizeFactor)) );
1101 taRightJustify:
1102 posF.Offset( -TopRight*(1/sizeFactor) );
1103 end;
1104 x := floor(posF.x);
1105 deltaX := round((posF.x - x)*sizeFactor);
1106 y := floor(posF.y);
1107 deltaY := round((posF.y - y)*sizeFactor);
1108 if deltaX <> 0 then inc(rotBounds.Right, sizeFactor);
1109 if deltaY <> 0 then inc(rotBounds.Bottom, sizeFactor);
1110
1111 {$IFDEF RENDER_TEXT_ON_TBITMAP}
1112 tempLCL := TBitmap.Create;
1113 tempLCL.Width := rotBounds.Right-rotBounds.Left;
1114 tempLCL.Height := rotBounds.Bottom-rotBounds.Top;
1115 BitmapFillRect(tempLCL, Rect(0,0,tempLCL.Width,tempLCL.Height), clBlack);
1116 with tempLCL do begin
1117 {$ELSE}
1118 temp := BGRABitmapFactory.Create(rotBounds.Right-rotBounds.Left,rotBounds.Bottom-rotBounds.Top, BGRABlack);
1119 with temp do begin
1120 {$ENDIF}
1121 Canvas.Font := Font;
1122 Canvas.Font.Color := clWhite;
1123 Canvas.Font.Height := round(Font.Height*sizeFactor);
1124 BitmapTextOutAngle({$IFDEF RENDER_TEXT_ON_TBITMAP}tempLCL{$ELSE}temp.Bitmap{$ENDIF},
1125 Point(-rotBounds.Left+deltaX, -rotBounds.Top+deltaY), sUTF8,
1126 orientationTenthDegCCW);
1127 end;
1128 {$IFDEF RENDER_TEXT_ON_TBITMAP}
1129 temp := BGRABitmapFactory.create(tempLCL,False);
1130 tempLCL.Free;
1131 {$ENDIF}
1132
1133 FilterOriginalText(Quality,CustomAntialiasingLevel,temp,grayscale);
1134 BGRAInternalRenderText(bmp, Quality, grayscale,temp, x,y,0, c,tex);
1135 temp.Free;
1136 grayscale.Free;
1137 end;
1138
1139 procedure BGRATextRect(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; ARect: TRect; xf, yf: single;
1140 sUTF8: string; style: TTextStyle; c: TBGRAPixel; tex: IBGRAScanner; CustomAntialiasingLevel: Integer = 0);
1141 var
1142 lim: TRect;
1143 tx, ty: integer;
1144 temp: TBGRACustomBitmap;
1145 sizeFactor: integer;
1146 cr: TRect;
1147 grayscale:TGrayscaleMask;
1148 {$IFDEF RENDER_TEXT_ON_TBITMAP}
1149 tempLCL: TBitmap;
1150 {$ENDIF}
1151 begin
1152 if not SystemFontAvailable then exit;
1153
1154 if CustomAntialiasingLevel = 0 then
1155 CustomAntialiasingLevel:= FontAntialiasingLevel;
1156
1157 cr := bmp.ClipRect;
1158 if ARect.Left < cr.Left then
1159 lim.Left := cr.Left else lim.Left := ARect.Left;
1160 if ARect.Top < cr.Top then
1161 lim.Top := cr.Top else lim.Top := ARect.Top;
1162 if ARect.Right > cr.Right then
1163 lim.Right := cr.Right else lim.Right := ARect.Right;
1164 if ARect.Bottom > cr.Bottom then
1165 lim.Bottom := cr.Bottom else lim.Bottom := ARect.Bottom;
1166
1167 tx := lim.Right - lim.Left;
1168 ty := lim.Bottom - lim.Top;
1169 if (tx <= 0) or (ty <= 0) then
1170 exit;
1171
1172 {$IFDEF SYSTEM_RENDERER_IS_FINE}
1173 if (Quality in [fqFineAntialiasing, fqFineClearTypeRGB, fqFineClearTypeBGR]) and
1174 (BGRATextSize(Font, fqSystem, 'Hg', 1).cy >= 13) then
1175 begin
1176 if Quality = fqFineAntialiasing then Quality := fqSystem;
1177 {$IFDEF SYSTEM_CLEARTYPE_RENDERER_IS_FINE}
1178 if Quality = GetFineClearTypeAuto then Quality := fqSystemClearType;
1179 {$ENDIF}
1180 end;
1181 {$ENDIF}
1182
1183 if Quality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB] then
1184 sizeFactor := CustomAntialiasingLevel
1185 else
1186 sizeFactor := 1;
1187
1188 {$IFDEF RENDER_TEXT_ON_TBITMAP}
1189 tempLCL := TBitmap.Create;
1190 tempLCL.Width := tx*sizeFactor;
1191 tempLCL.Height := ty*sizeFactor;
1192 BitmapFillRect(tempLCL, Rect(0,0,tempLCL.Width,tempLCL.Height), clBlack);
1193 with tempLCL do begin
1194 {$ELSE}
1195 temp := BGRABitmapFactory.Create(tx*sizeFactor, ty*sizeFactor, BGRABlack);
1196 with temp do begin
1197 {$ENDIF}
1198 Canvas.Font := Font;
1199 Canvas.Font.Orientation := 0;
1200 if Quality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB] then Canvas.Font.Height := Font.Height*CustomAntialiasingLevel
1201 else Canvas.Font.Height := Font.Height;
1202 Canvas.Font.Color := clWhite;
1203 BitmapTextRect({$IFDEF RENDER_TEXT_ON_TBITMAP}tempLCL{$ELSE}temp.Bitmap{$ENDIF}, rect(lim.Left-ARect.Left, lim.Top-ARect.Top,
1204 (ARect.Right-ARect.Left)*sizeFactor, (ARect.Bottom-ARect.Top)*sizeFactor),
1205 Point(round((xf - lim.Left)*sizeFactor), round((yf - lim.Top)*sizeFactor)),
1206 sUTF8, style);
1207 end;
1208 {$IFDEF RENDER_TEXT_ON_TBITMAP}
1209 temp := BGRABitmapFactory.create(tempLCL,False);
1210 tempLCL.Free;
1211 {$ENDIF}
1212
1213 FilterOriginalText(Quality,CustomAntialiasingLevel,temp,grayscale);
1214 BGRAInternalRenderText(bmp, Quality, grayscale,temp, lim.left,lim.top,0, c,tex);
1215 temp.Free;
1216 grayscale.Free;
1217 end;
1218
1219 { TBGRASystemFontRenderer }
1220
1221 { Update font properties to internal TFont object }
1222 procedure TBGRASystemFontRenderer.UpdateFont;
1223 var fixedHeight: integer;
1224 fs: TFontStyles;
1225 patchedName: String;
1226 begin
1227 patchedName := PatchSystemFontName(FontName);
1228 if FFont.Name <> patchedName then
1229 FFont.Name := patchedName;
1230 fs := FontStyle;
1231 if (OverrideUnderlineDecoration or (CompareText(Trim(patchedName),'FreeSans')=0) or
1232 (CompareText(Trim(patchedName),'FreeMono')=0) or (CompareText(Trim(patchedName),'FreeSerif')=0))
1233 and (fsUnderline in fs) then
1234 begin
1235 Exclude(fs, fsUnderline);
1236 FOwnUnderline := true;
1237 end else
1238 FOwnUnderline := false;
1239 if FFont.Style <> fs then
1240 FFont.Style := fs;
1241 if FontEmHeight < 0 then
1242 fixedHeight := FixSystemFontFullHeight(patchedName, FontEmHeight * FontEmHeightSign)
1243 else
1244 fixedHeight := FontEmHeight * FontEmHeightSign;
1245 if FFont.Height <> fixedHeight then
1246 FFont.Height := fixedHeight;
1247 if FontQuality = fqSystemClearType then
1248 FFont.Quality := fqCleartype
1249 else
1250 FFont.Quality := FontDefaultQuality;
1251 end;
1252
InternalTextSizenull1253 function TBGRASystemFontRenderer.InternalTextSize(sUTF8: string;
1254 AShowPrefix: boolean): TSize;
1255 begin
1256 result := InternalTextSizeAngle(sUTF8, AShowPrefix, FontOrientation);
1257 end;
1258
InternalTextSizeAnglenull1259 function TBGRASystemFontRenderer.InternalTextSizeAngle(sUTF8: string;
1260 AShowPrefix: boolean; AOrientation: integer): TSize;
1261 begin
1262 if AShowPrefix then sUTF8 := RemovePrefix(sUTF8);
1263 result := BGRAText.BGRATextSizeAngle(FFont, AOrientation, FontQuality,
1264 sUTF8, FontAntialiasingLevel);
1265 if (result.cy >= 24)
1266 and (FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB])
1267 and (FontAntialiasingLevel > 4) then
1268 result := BGRAText.BGRATextSizeAngle(FFont, AOrientation, FontQuality,
1269 sUTF8, 4);
1270 end;
1271
1272 procedure TBGRASystemFontRenderer.SplitText(var ATextUTF8: string;
1273 AMaxWidth: integer; out ARemainsUTF8: string);
1274 var WordBreakHandler: TWordBreakHandler;
1275 begin
1276 UpdateFont;
1277 if Assigned(FWordBreakHandler) then
1278 WordBreakHandler := FWordBreakHandler
1279 else
1280 WordBreakHandler := @DefaultWorkBreakHandler;
1281
1282 InternalSplitText(ATextUTF8, AMaxWidth, ARemainsUTF8, WordBreakHandler);
1283 end;
1284
GetFontPixelMetricnull1285 function TBGRASystemFontRenderer.GetFontPixelMetric: TFontPixelMetric;
1286 begin
1287 UpdateFont;
1288 result := InternalGetFontPixelMetric;
1289 end;
1290
TBGRASystemFontRenderer.FontExistsnull1291 function TBGRASystemFontRenderer.FontExists(AName: string): boolean;
1292 var
1293 i: Integer;
1294 begin
1295 {$IFDEF LCL}
1296 for i := 0 to Screen.Fonts.Count-1 do
1297 if CompareText(Screen.Fonts[i], AName) = 0 then exit(true);
1298 result := false;
1299 {$ELSE}
1300 result := true;
1301 {$ENDIF}
1302 end;
1303
TBGRASystemFontRenderer.PatchSystemFontNamenull1304 class function TBGRASystemFontRenderer.PatchSystemFontName(AName: string): string;
1305 begin
1306 if AName = 'serif' then
1307 result := {$IFDEF DARWIN}'Times'{$ELSE}'serif'{$ENDIF}
1308 else if AName = 'monospace' then
1309 result := {$IFDEF DARWIN}'Courier'{$ELSE}{$IFDEF LINUX}'DejaVu Sans Mono'{$ELSE}'monospace'{$ENDIF}{$ENDIF}
1310 else result := AName;
1311 end;
1312
1313 procedure TBGRASystemFontRenderer.TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer;
1314 sUTF8: string; c: TBGRAPixel; align: TAlignment);
1315 begin
1316 UpdateFont;
1317 InternalTextOutAngle(ADest,x,y,orientationTenthDegCCW,sUTF8,c,nil,align,false,false);
1318 end;
1319
1320 procedure TBGRASystemFontRenderer.TextOutAngle(ADest: TBGRACustomBitmap; x,
1321 y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel;
1322 align: TAlignment; ARightToLeft: boolean);
1323 begin
1324 UpdateFont;
1325 InternalTextOutAngle(ADest,x,y,orientationTenthDegCCW,sUTF8,c,nil,align,false,ARightToLeft);
1326 end;
1327
1328 procedure TBGRASystemFontRenderer.TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer;
1329 sUTF8: string; texture: IBGRAScanner; align: TAlignment);
1330 begin
1331 UpdateFont;
1332 InternalTextOutAngle(ADest,x,y,orientationTenthDegCCW,sUTF8,BGRAPixelTransparent,texture,align,false,false);
1333 end;
1334
1335 procedure TBGRASystemFontRenderer.TextOutAngle(ADest: TBGRACustomBitmap; x,
1336 y: single; orientationTenthDegCCW: integer; sUTF8: string;
1337 texture: IBGRAScanner; align: TAlignment; ARightToLeft: boolean);
1338 begin
1339 UpdateFont;
1340 InternalTextOutAngle(ADest,x,y,orientationTenthDegCCW,sUTF8,BGRAPixelTransparent,texture,align,false,ARightToLeft);
1341 end;
1342
1343 procedure TBGRASystemFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string;
1344 texture: IBGRAScanner; align: TAlignment);
1345 begin
1346 UpdateFont;
1347 InternalTextOut(ADest, x,y, sUTF8, BGRAPixelTransparent,texture, align);
1348 end;
1349
1350 procedure TBGRASystemFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel;
1351 align: TAlignment);
1352 begin
1353 UpdateFont;
1354 InternalTextOut(ADest, x,y, sUTF8, c,nil, align);
1355 end;
1356
1357 procedure TBGRASystemFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
1358 y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment;
1359 ARightToLeft: boolean);
1360 begin
1361 UpdateFont;
1362 InternalTextOut(ADest, x,y, sUTF8, BGRAPixelTransparent,texture, align,
1363 False, ARightToLeft);
1364 end;
1365
1366 procedure TBGRASystemFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
1367 y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment;
1368 ARightToLeft: boolean);
1369 begin
1370 UpdateFont;
1371 InternalTextOut(ADest, x,y, sUTF8, c,nil, align, false, ARightToLeft);
1372 end;
1373
1374 procedure TBGRASystemFontRenderer.TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string;
1375 style: TTextStyle; c: TBGRAPixel);
1376 begin
1377 UpdateFont;
1378 InternalTextRect(ADest,ARect,x,y,sUTF8,style,c,nil);
1379 end;
1380
1381 procedure TBGRASystemFontRenderer.TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string;
1382 style: TTextStyle; texture: IBGRAScanner);
1383 begin
1384 UpdateFont;
1385 InternalTextRect(ADest,ARect,x,y,sUTF8,style,BGRAPixelTransparent,texture);
1386 end;
1387
1388 procedure TBGRASystemFontRenderer.TextWordBreak(ADest: TBGRACustomBitmap;
1389 AText: string; x, y, AMaxWidth: integer; AColor: TBGRAPixel;
1390 AHorizAlign: TAlignment; AVertAlign: TTextLayout; ARightToLeft: boolean);
1391 begin
1392 UpdateFont;
1393 InternalTextWordBreak(ADest,AText,x,y,AMaxWidth,AColor,nil,AHorizAlign,AVertAlign,ARightToLeft);
1394 end;
1395
1396 procedure TBGRASystemFontRenderer.TextWordBreak(ADest: TBGRACustomBitmap;
1397 AText: string; x, y, AMaxWidth: integer; ATexture: IBGRAScanner;
1398 AHorizAlign: TAlignment; AVertAlign: TTextLayout; ARightToLeft: boolean);
1399 begin
1400 UpdateFont;
1401 InternalTextWordBreak(ADest,AText,x,y,AMaxWidth,BGRAPixelTransparent,ATexture,AHorizAlign,AVertAlign,ARightToLeft);
1402 end;
1403
1404 procedure TBGRASystemFontRenderer.InternalTextWordBreak(
1405 ADest: TBGRACustomBitmap; ATextUTF8: string; x, y, AMaxWidth: integer;
1406 AColor: TBGRAPixel; ATexture: IBGRAScanner; AHorizAlign: TAlignment;
1407 AVertAlign: TTextLayout; ARightToLeft: boolean);
1408 var remains, part, curText,nextText: string;
1409 stepX,stepY: integer;
1410 lines: TStringList;
1411 i: integer;
1412 lineShift: single;
1413 WordBreakHandler: TWordBreakHandler;
1414 lineEndingBreak: boolean;
1415 bidiLayout: TBidiTextLayout;
1416 bidiAlign: TBidiTextAlignment;
1417 begin
1418 if (ATextUTF8 = '') or (AMaxWidth <= 0) then exit;
1419
1420 if Assigned(FWordBreakHandler) then
1421 WordBreakHandler := FWordBreakHandler
1422 else
1423 WordBreakHandler := @DefaultWorkBreakHandler;
1424
1425 if ContainsBidiIsolateOrFormattingUTF8(ATextUTF8) or
1426 (pos(UTF8_LINE_SEPARATOR, ATextUTF8) <> 0) then
1427 begin
1428 bidiLayout := TBidiTextLayout.Create(self, ATextUTF8, ARightToLeft);
1429 bidiLayout.WordBreakHandler:= WordBreakHandler;
1430 bidiLayout.AvailableWidth := AMaxWidth;
1431 case AHorizAlign of
1432 taLeftJustify: bidiAlign:= btaLeftJustify;
1433 taRightJustify: begin
1434 bidiAlign:= btaRightJustify;
1435 dec(x, AMaxWidth);
1436 end
1437 else
1438 begin
1439 bidiAlign:= btaCenter;
1440 dec(x, AMaxWidth div 2);
1441 end;
1442 end;
1443 for i := 0 to bidiLayout.ParagraphCount-1 do
1444 bidiLayout.ParagraphAlignment[i] := bidiAlign;
1445 case AVertAlign of
1446 tlBottom: bidiLayout.TopLeft := PointF(x, y - bidiLayout.TotalTextHeight);
1447 tlCenter: bidiLayout.TopLeft := PointF(x, y - bidiLayout.TotalTextHeight/2);
1448 end;
1449 if ATexture <> nil then bidiLayout.DrawText(ADest, ATexture)
1450 else bidiLayout.DrawText(ADest, AColor);
1451 bidiLayout.Free;
1452 exit;
1453 end;
1454
1455 stepX := 0;
1456 stepY := TextSize('Hg').cy;
1457
1458 lines := TStringList.Create;
1459 curText := ATextUTF8;
1460 repeat
1461 InternalSplitText(curText, AMaxWidth, remains, lineEndingBreak, WordBreakHandler);
1462 part := curText;
1463 if not lineEndingBreak then
1464 // append following direction to part
1465 case GetFirstStrongBidiClassUTF8(remains) of
1466 ubcLeftToRight: if ARightToLeft then AppendStr(part, UnicodeCharToUTF8(UNICODE_LEFT_TO_RIGHT_MARK));
1467 ubcRightToLeft,ubcArabicLetter: if not ARightToLeft then AppendStr(part, UnicodeCharToUTF8(UNICODE_RIGHT_TO_LEFT_MARK));
1468 end;
1469 lines.Add(part);
1470 // prefix next part with previous direction
1471 nextText := remains;
1472 if not lineEndingBreak then
1473 case GetLastStrongBidiClassUTF8(curText) of
1474 ubcLeftToRight: if ARightToLeft then nextText := UnicodeCharToUTF8(UNICODE_LEFT_TO_RIGHT_MARK) + nextText;
1475 ubcRightToLeft,ubcArabicLetter: if not ARightToLeft then nextText := UnicodeCharToUTF8(UNICODE_RIGHT_TO_LEFT_MARK) + nextText;
1476 end;
1477 curText := nextText;
1478 until remains = '';
1479 if AVertAlign = tlCenter then lineShift := lines.Count/2
1480 else if AVertAlign = tlBottom then lineShift := lines.Count
1481 else lineShift := 0;
1482
1483 dec(X, round(stepX*lineShift));
1484 dec(Y, round(stepY*lineShift));
1485 for i := 0 to lines.Count-1 do
1486 begin
1487 InternalTextOut(ADest,x,y,lines[i],AColor,ATexture,AHorizAlign,false,ARightToLeft);
1488 inc(X, stepX);
1489 inc(Y, stepY);
1490 end;
1491 lines.Free;
1492 end;
1493
1494 procedure TBGRASystemFontRenderer.InternalTextRect(ADest: TBGRACustomBitmap;
1495 ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel;
1496 ATexture: IBGRAScanner);
1497 var
1498 oldOrientation: integer;
1499 previousClip, intersected: TRect;
1500 lines: TStringList;
1501 iStart,i,h: integer;
1502 availableWidth: integer;
1503 begin
1504 if sUTF8='' then exit;
1505 previousClip := ADest.ClipRect;
1506 if style.Clipping then
1507 begin
1508 intersected := TRect.Intersect(previousClip, ARect);
1509 if intersected.IsEmpty then exit;
1510 ADest.ClipRect := intersected;
1511 end;
1512 if style.SystemFont then FFont.Name := 'default';
1513
1514 if not (style.Alignment in[taCenter,taRightJustify]) then ARect.Left := x;
1515 if not (style.Layout in[tlCenter,tlBottom]) then ARect.top := y;
1516 if (ARect.Right <= ARect.Left) and style.Clipping then
1517 begin
1518 ADest.ClipRect := previousClip;
1519 exit;
1520 end;
1521 if style.Layout = tlCenter then Y := (ARect.Top+ARect.Bottom) div 2 else
1522 if style.Layout = tlBottom then Y := ARect.Bottom else
1523 Y := ARect.Top;
1524 if style.Alignment = taCenter then X := (ARect.Left+ARect.Right) div 2 else
1525 if style.Alignment = taRightJustify then X := ARect.Right else
1526 X := ARect.Left;
1527 oldOrientation := FontOrientation;
1528 FontOrientation := 0;
1529 if style.Wordbreak then
1530 begin
1531 if style.ShowPrefix then sUTF8 := RemovePrefix(sUTF8); //prefix not handled
1532 InternalTextWordBreak(ADest,sUTF8,X,Y,ARect.Right-ARect.Left,c,ATexture,
1533 style.Alignment,style.Layout,style.RightToLeft);
1534 end
1535 else
1536 begin
1537 lines := nil;
1538 iStart := 1;
1539
1540 if not style.SingleLine then
1541 begin
1542 i := iStart;
1543 while i <= length(sUTF8) do
1544 begin
1545 if sUTF8[i] in[#13,#10] then
1546 begin
1547 if not assigned(lines) then lines := TStringList.Create;
1548 lines.add(copy(sUTF8,iStart,i-iStart));
1549 if (sUTF8[i]=#13) and (i < length(sUTF8)) and (sUTF8[i+1]=#10) then inc(i);
1550 iStart := i+1
1551 end;
1552 inc(i);
1553 end;
1554 end;
1555
1556 if style.Alignment = taLeftJustify then
1557 availableWidth := ARect.Right-X
1558 else
1559 availableWidth := ARect.Right-ARect.Left;
1560 if availableWidth < 0 then availableWidth:= 0;
1561
1562 if lines = nil then //only one line
1563 begin
1564 if style.Layout = tlCenter then dec(Y, InternalTextSize(sUTF8,style.ShowPrefix).cy div 2);
1565 if style.Layout = tlBottom then dec(Y, InternalTextSize(sUTF8,style.ShowPrefix).cy);
1566 if style.EndEllipsis then
1567 InternalTextOutEllipse(ADest,X,Y,availableWidth,sUTF8,c,ATexture,style.Alignment,
1568 style.ShowPrefix,style.RightToLeft)
1569 else
1570 InternalTextOut(ADest,X,Y,sUTF8,c,ATexture,style.Alignment,
1571 style.ShowPrefix,style.RightToLeft);
1572 end else
1573 begin //multiple lines
1574 lines.add(copy(sUTF8, iStart, length(sUTF8)-iStart+1));
1575 h := InternalTextSize('Hg',False).cy;
1576 if style.Layout = tlCenter then dec(Y, h*lines.Count div 2);
1577 if style.Layout = tlBottom then dec(Y, h*lines.Count);
1578 for i := 0 to lines.Count-1 do
1579 begin
1580 if style.EndEllipsis then
1581 InternalTextOutEllipse(ADest,X,Y,availableWidth,lines[i],c,ATexture,style.Alignment,
1582 style.ShowPrefix,style.RightToLeft)
1583 else
1584 InternalTextOut(ADest,X,Y,lines[i],c,ATexture,style.Alignment,
1585 style.ShowPrefix,style.RightToLeft);
1586 inc(Y,h);
1587 end;
1588 lines.Free;
1589 end;
1590
1591 end;
1592
1593 FontOrientation := oldOrientation;
1594 if style.Clipping then
1595 ADest.ClipRect := previousClip;
1596 end;
1597
1598 procedure TBGRASystemFontRenderer.InternalTextOut(ADest: TBGRACustomBitmap; x,
1599 y: single; sUTF8: string; c: TBGRAPixel; texture: IBGRAScanner;
1600 align: TAlignment; AShowPrefix: boolean = false; ARightToLeft: boolean = false);
1601 begin
1602 InternalTextOutAngle(ADest, x,y, FontOrientation, sUTF8, c, texture,
1603 align, ASHowPrefix, ARightToLeft);
1604 end;
1605
1606 procedure TBGRASystemFontRenderer.InternalTextOutAngle(ADest: TBGRACustomBitmap; x,
1607 y: single; AOrientation: integer; sUTF8: string; c: TBGRAPixel; texture: IBGRAScanner;
1608 align: TAlignment; AShowPrefix: boolean = false; ARightToLeft: boolean = false);
1609 var mode : TBGRATextOutImproveReadabilityMode;
1610 s: TSize;
1611 pts: ArrayOfTPointF;
1612 m: TAffineMatrix;
1613 i: Integer;
1614 begin
1615 if sUTF8='' then exit;
1616 {$IF defined(LINUX) or defined(DARWIN)}
1617 //help LCL detect the correct direction
1618 case GetFirstStrongBidiClassUTF8(sUTF8) of
1619 ubcRightToLeft, ubcArabicLetter: if not ARightToLeft then sUTF8 := UnicodeCharToUTF8(UNICODE_LEFT_TO_RIGHT_MARK) + sUTF8;
1620 else
1621 begin //suppose left-to-right
1622 if ARightToLeft then sUTF8 := UnicodeCharToUTF8(UNICODE_RIGHT_TO_LEFT_MARK) + sUTF8;
1623 end;
1624 end;
1625 {$ENDIF}
1626 if Assigned(BGRATextOutImproveReadabilityProc) and
1627 (FontQuality in[{$IFNDEF SYSTEM_RENDERER_IS_FINE}fqFineAntialiasing,{$ENDIF}
1628 fqFineClearTypeBGR,fqFineClearTypeRGB]) and
1629 (AOrientation mod 3600 = 0) then
1630 begin
1631 case FontQuality of
1632 fqFineClearTypeBGR: mode := irClearTypeBGR;
1633 fqFineClearTypeRGB: mode := irClearTypeRGB;
1634 else
1635 mode := irNormal;
1636 end;
1637 if AShowPrefix then sUTF8 := RemovePrefix(sUTF8); //prefix not handled
1638 BGRATextOutImproveReadabilityProc(ADest,FFont,x,y,sUTF8,c,texture,align,mode);
1639 end else
1640 begin
1641 if AOrientation = 0 then
1642 BGRAText.BGRATextOut(ADest,FFont,FontQuality,x,y,sUTF8,c,texture,align,
1643 0,AShowPrefix,ARightToLeft)
1644 else
1645 BGRAText.BGRATextOutAngle(ADest,FFont,FontQuality,x,y,AOrientation,
1646 sUTF8,c,texture,align,0);
1647 end;
1648 if FOwnUnderline then
1649 begin
1650 s := InternalTextSizeAngle(sUTF8, AShowPrefix, AOrientation);
1651 pts := BGRATextUnderline(PointF(x,y),s.cx,InternalGetFontPixelMetric);
1652 if AOrientation mod 3600 <> 0 then
1653 begin
1654 m := AffineMatrixTranslation(x,y)*
1655 AffineMatrixRotationDeg(-AOrientation/10)*
1656 AffineMatrixTranslation(-x,-y);
1657 for i := 0 to high(pts) do
1658 pts[i] := m*pts[i];
1659 end;
1660 if texture<>nil then
1661 ADest.FillPolyAntialias(pts, texture, false)
1662 else
1663 ADest.FillPolyAntialias(pts, c, false);
1664 end;
1665 end;
1666
1667 procedure TBGRASystemFontRenderer.InternalTextOutEllipse(
1668 ADest: TBGRACustomBitmap; x, y, availableWidth: single; sUTF8: string;
1669 c: TBGRAPixel; texture: IBGRAScanner; align: TAlignment;
1670 AShowPrefix: boolean; ARightToLeft: boolean);
1671 var remain: string;
1672 begin
1673 if sUTF8='' then exit;
1674 if InternalTextSize(sUTF8,AShowPrefix).cx > availableWidth then
1675 begin
1676 InternalSplitText(sUTF8, round(availableWidth - InternalTextSize('...',AShowPrefix).cx), remain, nil);
1677 AppendStr(sUTF8, '...');
1678 end;
1679 InternalTextOut(ADest,x,y,sUTF8,c,texture,align,AShowPrefix,ARightToLeft);
1680 end;
1681
1682 procedure TBGRASystemFontRenderer.InternalSplitText(var ATextUTF8: string;
1683 AMaxWidth: integer; out ARemainsUTF8: string; out ALineEndingBreak: boolean; AWordBreak: TWordBreakHandler);
1684 var p,skipCount, charLen: integer;
1685 zeroWidth: boolean;
1686 u: LongWord;
1687 begin
1688 ALineEndingBreak:= false;
1689 if ATextUTF8= '' then
1690 begin
1691 ARemainsUTF8 := '';
1692 exit;
1693 end;
1694 if RemoveLineEnding(ATextUTF8,1) then
1695 begin
1696 ARemainsUTF8:= ATextUTF8;
1697 ATextUTF8 := '';
1698 ALineEndingBreak:= true;
1699 exit;
1700 end;
1701 if InternalTextSize(ATextUTF8, false).cx <= AMaxWidth then
1702 begin
1703 for p := 1 to length(ATextUTF8) do
1704 begin
1705 if RemoveLineEnding(ATextUTF8,p) then
1706 begin
1707 ARemainsUTF8:= copy(ATextUTF8,p,length(ATextUTF8)-p+1);
1708 ATextUTF8 := copy(ATextUTF8,1,p-1);
1709 ALineEndingBreak:= true;
1710 exit;
1711 end;
1712 end;
1713 ARemainsUTF8 := '';
1714 exit;
1715 end;
1716
1717 if AMaxWidth <= 0 then
1718 skipCount := 0
1719 else
1720 skipCount := BGRATextFitInfo(FFont, FontQuality, ATextUTF8, FontAntialiasingLevel, AMaxWidth);
1721
1722 if skipCount <= 0 then skipCount := 1;
1723
1724 p := 1;
1725 zeroWidth := true;
1726 repeat
1727 charLen := UTF8CharacterLength(@ATextUTF8[p]);
1728 u := UTF8CodepointToUnicode(@ATextUTF8[p], charLen);
1729 if not IsZeroWidthUnicode(u) then
1730 zeroWidth:= false;
1731 inc(p, charLen); //UTF8 chars may be more than 1 byte long
1732 dec(skipCount);
1733
1734 if RemoveLineEnding(ATextUTF8,p) then
1735 begin
1736 ARemainsUTF8:= copy(ATextUTF8,p,length(ATextUTF8)-p+1);
1737 ATextUTF8 := copy(ATextUTF8,1,p-1);
1738 ALineEndingBreak:= true;
1739 exit;
1740 end;
1741 until ((skipCount <= 0) and not zeroWidth) or (p >= length(ATextUTF8)+1);
1742
1743 ARemainsUTF8:= copy(ATextUTF8,p,length(ATextUTF8)-p+1);
1744 ATextUTF8 := copy(ATextUTF8,1,p-1); //this includes the whole last UTF8 char
1745 if Assigned(AWordBreak) then AWordBreak(ATextUTF8,ARemainsUTF8);
1746 end;
1747
1748 procedure TBGRASystemFontRenderer.InternalSplitText(var ATextUTF8: string;
1749 AMaxWidth: integer; out ARemainsUTF8: string; AWordBreak: TWordBreakHandler);
1750 var lineEndingBreak: boolean;
1751 begin
1752 InternalSplitText(ATextUTF8,AMaxWidth,ARemainsUTF8,lineEndingBreak,AWordBreak);
1753 end;
1754
InternalGetFontPixelMetricnull1755 function TBGRASystemFontRenderer.InternalGetFontPixelMetric: TFontPixelMetric;
1756 var fxFont: TFont;
1757 begin
1758 if FontQuality in[fqSystem,fqSystemClearType] then
1759 result := GetLCLFontPixelMetric(FFont)
1760 else
1761 begin
1762 FxFont := TFont.Create;
1763 FxFont.Assign(FFont);
1764 FxFont.Height := fxFont.Height*FontAntialiasingLevel;
1765 Result:= GetLCLFontPixelMetric(FxFont);
1766 if Result.Baseline <> -1 then Result.Baseline:= round((Result.Baseline-1)/FontAntialiasingLevel);
1767 if Result.CapLine <> -1 then Result.CapLine:= round(Result.CapLine/FontAntialiasingLevel);
1768 if Result.DescentLine <> -1 then Result.DescentLine:= round((Result.DescentLine-1)/FontAntialiasingLevel);
1769 if Result.Lineheight <> -1 then Result.Lineheight:= round(Result.Lineheight/FontAntialiasingLevel);
1770 if Result.xLine <> -1 then Result.xLine:= round(Result.xLine/FontAntialiasingLevel);
1771 FxFont.Free;
1772 end;
1773 end;
1774
1775 procedure TBGRASystemFontRenderer.DefaultWorkBreakHandler(var ABeforeUTF8,
1776 AAfterUTF8: string);
1777 begin
1778 BGRADefaultWordBreakHandler(ABeforeUTF8,AAfterUTF8);
1779 end;
1780
TextSizenull1781 function TBGRASystemFontRenderer.TextSize(sUTF8: string): TSize;
1782 var oldOrientation: integer;
1783 begin
1784 oldOrientation:= FontOrientation;
1785 FontOrientation:= 0;
1786 UpdateFont;
1787 result := InternalTextSize(sUTF8,False);
1788 FontOrientation:= oldOrientation;
1789 end;
1790
TextSizeAnglenull1791 function TBGRASystemFontRenderer.TextSizeAngle(sUTF8: string;
1792 orientationTenthDegCCW: integer): TSize;
1793 var oldOrientation: integer;
1794 begin
1795 oldOrientation:= FontOrientation;
1796 FontOrientation:= orientationTenthDegCCW;
1797 UpdateFont;
1798 result := InternalTextSize(sUTF8,False);
1799 FontOrientation:= oldOrientation;
1800 end;
1801
TextSizenull1802 function TBGRASystemFontRenderer.TextSize(sUTF8: string;
1803 AMaxWidth: integer; ARightToLeft: boolean): TSize;
1804 var
1805 remains: string;
1806 h, i, w: integer;
1807 WordBreakHandler: TWordBreakHandler;
1808 layout: TBidiTextLayout;
1809 begin
1810 UpdateFont;
1811
1812 if Assigned(FWordBreakHandler) then
1813 WordBreakHandler := FWordBreakHandler
1814 else
1815 WordBreakHandler := @DefaultWorkBreakHandler;
1816
1817 if ContainsBidiIsolateOrFormattingUTF8(sUTF8) then
1818 begin
1819 layout := TBidiTextLayout.Create(self, sUTF8, ARightToLeft);
1820 layout.WordBreakHandler:= WordBreakHandler;
1821 layout.AvailableWidth := AMaxWidth;
1822 for i := 0 to layout.ParagraphCount-1 do
1823 layout.ParagraphAlignment[i] := btaLeftJustify;
1824 result.cx := 0;
1825 for i := 0 to layout.PartCount-1 do
1826 begin
1827 w := ceil(layout.PartRectF[i].Right);
1828 if w > result.cx then result.cx := w;
1829 end;
1830 result.cy := ceil(layout.TotalTextHeight);
1831 layout.Free;
1832 end else
1833 begin
1834 result.cx := 0;
1835 result.cy := 0;
1836 h := InternalTextSize('Hg',False).cy;
1837 repeat
1838 InternalSplitText(sUTF8, AMaxWidth, remains, WordBreakHandler);
1839 with InternalTextSize(sUTF8, false) do
1840 if cx > result.cx then result.cx := cx;
1841 inc(result.cy, h);
1842 sUTF8 := remains;
1843 until remains = '';
1844 end;
1845 end;
1846
TBGRASystemFontRenderer.TextFitInfonull1847 function TBGRASystemFontRenderer.TextFitInfo(sUTF8: string; AMaxWidth: integer
1848 ): integer;
1849 begin
1850 UpdateFont;
1851 result := BGRATextFitInfo(FFont, FontQuality, sUTF8, FontAntialiasingLevel, AMaxWidth);
1852 end;
1853
1854 constructor TBGRASystemFontRenderer.Create;
1855 begin
1856 FFont := TFont.Create;
1857 end;
1858
1859 destructor TBGRASystemFontRenderer.Destroy;
1860 begin
1861 FFont.Free;
1862 inherited Destroy;
1863 end;
1864
1865 initialization
1866
1867 fqFineClearType := @GetFineClearTypeAuto;
1868
1869 end.
1870
1871