Context Navigation

bgravectorize.pas

Last change on this file was 2, checked in by chronos, 5 years ago
Source code taken from https://svn.zdechov.net/PascalClassLibrary/GraphicTest/ rev 543.
File size: 70.9 KB

Line
1	unit BGRAVectorize;
2
3	{$mode objfpc}{$H+}
4
5	interface
6
7	{
8	Font rendering units : BGRAText, BGRATextFX, BGRAVectorize, BGRAFreeType
9
10	This unit provides vectorizers :
11	- VectorizeMonochrome function vectorizes a back'n'white image
12	- TBGRAVectorizedFont allows to vectorize and to load vectorized font and draw them
13
14	TBGRAVectorizedFontRenderer class works like other font renderers, i.e., it can
15	be assigned to the FontRenderer property. You can use it in two different modes :
16	- if you supply a directory, it will look for *.glyphs files in it to load fonts
17	- if you don't supply a directory, fonts will be vectorized from LCL
18
19	Note that unless you want to supply your own glyphs files, you don't need
20	to use explicitely this renderer, because TBGRATextEffectFontRenderer will
21	make use of it if necessary, according to effects parameters used.
22	}
23
24	uses
25	Types, Classes, SysUtils, Graphics, BGRABitmapTypes, BGRATypewriter, BGRATransform, BGRACanvas2D, BGRAText;
26
27	//vectorize a monochrome bitmap
28	function VectorizeMonochrome(ASource: TBGRACustomBitmap; zoom: single; PixelCenteredCoordinates: boolean): ArrayOfTPointF;
29
30	type
31	TBGRAVectorizedFont = class;
32
33	//this is the class to assign to FontRenderer property of TBGRABitmap
34	{ TBGRAVectorizedFontRenderer }
35
36	TBGRAVectorizedFontRenderer = class(TBGRACustomFontRenderer)
37	protected
38	FVectorizedFontArray: array of record
39	FontName: string;
40	FontStyle: TFontStyles;
41	VectorizedFont: TBGRAVectorizedFont;
42	end;
43	FVectorizedFont: TBGRAVectorizedFont;
44	FCanvas2D: TBGRACanvas2D;
45	FDirectoryUTF8: string;
46	function OutlineActuallyVisible: boolean;
47	procedure UpdateFont;
48	function GetCanvas2D(ASurface: TBGRACustomBitmap): TBGRACanvas2D;
49	procedure InternalTextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel; texture: IBGRAScanner);
50	procedure Init;
51	public
52	MaxFontResolution: integer;
53
54	OutlineVisible: boolean;
55	OutlineWidth: single;
56	OutlineColor: TBGRAPixel;
57	OutlineTexture: IBGRAScanner;
58	OuterOutlineOnly: boolean;
59
60	ShadowVisible: boolean;
61	ShadowColor: TBGRAPixel;
62	ShadowRadius: integer;
63	ShadowOffset: TPoint;
64
65	constructor Create; overload;
66	constructor Create(ADirectoryUTF8: string); overload;
67	function GetFontPixelMetric: TFontPixelMetric; override;
68	procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; c: TBGRAPixel; align: TAlignment); overload; override;
69	procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; texture: IBGRAScanner; align: TAlignment); overload; override;
70	procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; texture: IBGRAScanner; align: TAlignment); overload; override;
71	procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; c: TBGRAPixel; align: TAlignment); overload; override;
72	procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel); overload; override;
73	procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; texture: IBGRAScanner); overload; override;
74	procedure CopyTextPathTo(ADest: IBGRAPath; x, y: single; s: string; align: TAlignment); override;
75	function HandlesTextPath: boolean; override;
76	function TextSize(s: string): TSize; override;
77	function TextSize(sUTF8: string; AMaxWidth: integer; {%H-}ARightToLeft: boolean): TSize; override;
78	function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; override;
79	destructor Destroy; override;
80	end;
81
82	TGlyphSizes = array of record
83	Glyph: String;
84	Width,Height: single;
85	end;
86
87	TBGRAVectorizedFontHeader = record
88	Name: string;
89	Style: TFontStyles;
90	EmHeightRatio: single;
91	Resolution: integer;
92	PixelMetric: TFontPixelMetric;
93	end;
94	TBGRAGlyphsInfo = record
95	Name: string;
96	Style: TFontStyles;
97	NbGlyphs: integer;
98	end;
99
100	{ TBGRAVectorizedFont }
101
102	TBGRAVectorizedFont = class(TBGRACustomTypeWriter)
103	private
104	FName : string;
105	FStyle: TFontStyles;
106	FResolution: integer;
107	FFont: TFont;
108	FBuffer: TBGRACustomBitmap;
109	FFullHeight: single;
110	FFontMatrix: TAffineMatrix;
111	FOrientation: single;
112	FQuadraticCurves: boolean;
113	FItalicSlope: single;
114	FWordBreakHandler: TWordBreakHandler;
115	FDirectory: string;
116	FDirectoryContent: array of record
117	Filename: string;
118	FontName: string;
119	FontStyle: TFontStyles;
120	end;
121	FFontEmHeightRatioComputed: boolean;
122	FFontEmHeightRatio: single;
123	FFontPixelMetric: TFontPixelMetric;
124	FFontPixelMetricComputed: boolean;
125	FFontFound: boolean;
126	function GetEmHeight: single;
127	function GetFontPixelMetric: TFontPixelMetric;
128	function GetLCLHeight: single;
129	function GetVectorizeLCL: boolean;
130	procedure SetEmHeight(AValue: single);
131	procedure SetItalicSlope(AValue: single);
132	procedure SetLCLHeight(AValue: single);
133	procedure SetOrientation(AValue: single);
134	procedure SetQuadraticCurves(AValue: boolean);
135	procedure SetResolution(AValue: integer);
136	procedure SetFontMatrix(AValue: TAffineMatrix);
137	procedure SetFullHeight(AValue: single);
138	procedure SetName(AValue: string);
139	procedure SetStyle(AValue: TFontStyles);
140	function GetFontEmHeightRatio: single;
141	procedure SetVectorizeLCL(AValue: boolean);
142	protected
143	procedure UpdateFont;
144	procedure UpdateMatrix;
145	function GetGlyph(AIdentifier: string): TBGRAGlyph; override;
146	procedure DefaultWordBreakHandler(var ABefore, AAfter: string);
147	procedure Init(AVectorize: boolean);
148	function CustomHeaderSize: integer; override;
149	procedure WriteCustomHeader(AStream: TStream); override;
150	procedure ReadAdditionalHeader(AStream: TStream); override;
151	function ReadVectorizedFontHeader(AStream: TStream): TBGRAVectorizedFontHeader;
152	function HeaderName: string; override;
153	procedure SetDirectory(const AValue: string);
154	public
155	UnderlineDecoration,StrikeOutDecoration: boolean;
156	constructor Create; overload;
157	constructor Create(AVectorizeLCL: boolean); overload;
158	destructor Destroy; override;
159	function GetGlyphSize(AIdentifier:string): TPointF;
160	function GetTextGlyphSizes(AText:string): TGlyphSizes;
161	function GetTextSize(AText:string): TPointF;
162	procedure SplitText(var ATextUTF8: string; AMaxWidth: single; out ARemainsUTF8: string);
163	procedure DrawText(ADest: TBGRACanvas2D; ATextUTF8: string; X, Y: Single; AAlign: TBGRATypeWriterAlignment=twaTopLeft); override;
164	procedure CopyTextPathTo(ADest: IBGRAPath; ATextUTF8: string; X, Y: Single;
165	AAlign: TBGRATypeWriterAlignment=twaTopLeft); override;
166	procedure DrawTextWordBreak(ADest: TBGRACanvas2D; ATextUTF8: string; X, Y, MaxWidth: Single; AAlign: TBGRATypeWriterAlignment=twaTopLeft);
167	procedure DrawTextRect(ADest: TBGRACanvas2D; ATextUTF8: string; X1,Y1,X2,Y2: Single; AAlign: TBGRATypeWriterAlignment=twaTopLeft); overload;
168	procedure DrawTextRect(ADest: TBGRACanvas2D; ATextUTF8: string; ATopLeft,ABottomRight: TPointF; AAlign: TBGRATypeWriterAlignment=twaTopLeft); overload;
169	function GetTextWordBreakGlyphBoxes(ATextUTF8: string; X,Y, MaxWidth: Single; AAlign: TBGRATypeWriterAlignment = twaTopLeft): TGlyphBoxes;
170	function GetTextRectGlyphBoxes(ATextUTF8: string; X1,Y1,X2,Y2: Single; AAlign: TBGRATypeWriterAlignment=twaTopLeft): TGlyphBoxes; overload;
171	function GetTextRectGlyphBoxes(ATextUTF8: string; ATopLeft,ABottomRight: TPointF; AAlign: TBGRATypeWriterAlignment=twaTopLeft): TGlyphBoxes; overload;
172	procedure UpdateDirectory;
173	function LoadGlyphsInfo(AFilenameUTF8: string): TBGRAGlyphsInfo;
174
175	property Resolution: integer read FResolution write SetResolution;
176	property Style: TFontStyles read FStyle write SetStyle;
177	property Name: string read FName write SetName;
178	property LCLHeight: single read GetLCLHeight write SetLCLHeight;
179	property EmHeight: single read GetEmHeight write SetEmHeight;
180	property FullHeight: single read FFullHeight write SetFullHeight;
181	property FontMatrix: TAffineMatrix read FFontMatrix write SetFontMatrix;
182	property Orientation: single read FOrientation write SetOrientation;
183	property QuadraticCurves: boolean read FQuadraticCurves write SetQuadraticCurves;
184	property ItalicSlope: single read FItalicSlope write SetItalicSlope;
185	property OnWordBreak: TWordBreakHandler read FWordBreakHandler write FWordBreakHandler;
186	property Directory: string read FDirectory write SetDirectory;
187	property FontEmHeightRatio: single read GetFontEmHeightRatio;
188	property FontPixelMetric: TFontPixelMetric read GetFontPixelMetric;
189	property FontFound: boolean read FFontFound;
190	property VectorizeLCL: boolean read GetVectorizeLCL write SetVectorizeLCL;
191	end;
192
193	implementation
194
195	uses BGRAUTF8, math;
196
197	function VectorizeMonochrome(ASource: TBGRACustomBitmap; zoom: single; PixelCenteredCoordinates: boolean): ArrayOfTPointF;
198	const unitShift = 6;
199	iHalf = 1 shl (unitShift-1);
200	iOut = 10; //0.15
201	iUnit = 1 shl unitShift;
202	iDiag = 13; //0.20
203	useNiceLines = true;
204
205	var
206	n: integer;
207	factor: single;
208	offset: single;
209	p,pprev,pnext : PBGRAPixel;
210	x,y,ix,iy: integer;
211	points: array of record
212	coord: tpoint;
213	prev,next: integer;
214	drawn,{shouldRemove,}removed: boolean;
215	end;
216	nbPoints:integer;
217	PointsPreviousLineStart,PointsCurrentLineStart: integer;
218	cur: packed array[1..9] of boolean;
219	ortho: array of array of boolean;
220
221	polygonF: array of TPointF;
222
223	function AddPoint(x,y,APrev,ANext: integer): integer;
224	begin
225	if nbpoints = length(points) then
226	setlength(points, nbpoints*2+1);
227	result := nbpoints;
228	with points[result] do
229	begin
230	coord := point(x,y);
231	prev := APrev;
232	next := ANext;
233	drawn := false;
234	removed := false;
235	// shouldRemove := false;
236	end;
237	inc(nbpoints);
238	end;
239	procedure AddLine(x1,y1,x2,y2: integer); overload;
240	var i,j,k: integer;
241	begin
242	for i := PointsPreviousLineStart to nbpoints-1 do
243	if (points[i].coord.x = x2) and (points[i].coord.y = y2) and (points[i].prev = -1) then
244	begin
245	for j := i+1 to nbpoints-1 do
246	if (points[j].coord.x = x1) and (points[j].coord.y = y1) and (points[j].next = -1) then
247	begin
248	points[j].next := i;
249	points[i].prev := j;
250	exit;
251	end;
252	k := addpoint(x1,y1,-1,i);
253	points[i].prev := k;
254	exit;
255	end else
256	if (points[i].coord.x = x1) and (points[i].coord.y = y1) and (points[i].next = -1) then
257	begin
258	for j := i+1 to nbpoints-1 do
259	if (points[j].coord.x = x2) and (points[j].coord.y = y2) and (points[j].prev = -1) then
260	begin
261	points[j].prev := i;
262	points[i].next := j;
263	exit;
264	end;
265	k := addpoint(x2,y2,i,-1);
266	points[i].next := k;
267	exit;
268	end;
269	k := addpoint(x1,y1,-1,-1);
270	points[k].next := addpoint(x2,y2,k,-1);
271	end;
272	procedure AddLine(x1,y1,x2,y2,x3,y3: integer); overload;
273	begin
274	AddLine(x1,y1,x2,y2);
275	AddLine(x2,y2,x3,y3);
276	end;
277	procedure AddLine(x1,y1,x2,y2,x3,y3,x4,y4: integer); overload;
278	begin
279	AddLine(x1,y1,x2,y2);
280	AddLine(x2,y2,x3,y3);
281	AddLine(x3,y3,x4,y4);
282	end;
283	procedure AddLine(x1,y1,x2,y2,x3,y3,x4,y4,x5,y5: integer); overload;
284	begin
285	AddLine(x1,y1,x2,y2);
286	AddLine(x2,y2,x3,y3);
287	AddLine(x3,y3,x4,y4);
288	AddLine(x4,y4,x5,y5);
289	end;
290
291	procedure AddPolygon(n: integer);
292
293	procedure Rewind(out cycle: boolean);
294	var cur: integer;
295	begin
296	cur := n;
297	cycle := false;
298	while (points[cur].prev <> -1) do
299	begin
300	cur := points[cur].prev;
301	if cur = n then
302	begin
303	cycle := true; //identify cycle
304	break;
305	end;
306	end;
307	n := cur;
308	end;
309
310	function aligned(start1,end1,start2,end2: integer): boolean;
311	var
312	u,v: TPointF;
313	lu,lv: single;
314	begin
315	if (start1=-1) or (end1=-1) or (start2=-1) or (end2=-1) then
316	begin
317	result :=false;
318	exit;
319	end;
320	u := pointF(points[end1].coord.x - points[start1].coord.x, points[end1].coord.y - points[start1].coord.y);
321	lu := sqrt(u*u);
322	if lu <> 0 then u *= 1/lu;
323	v := pointF(points[end2].coord.x - points[start2].coord.x, points[end2].coord.y - points[start2].coord.y);
324	lv := sqrt(v*v);
325	if lv <> 0 then v *= 1/lv;
326
327	result := u*v > 0.999;
328	end;
329
330	function angle45(prev,cur,next: integer): boolean;
331	var
332	u,v: TPointF;
333	lu,lv,dp: single;
334	begin
335	if (prev=-1) or (cur=-1) or (next=-1) then
336	begin
337	result :=false;
338	exit;
339	end;
340	u := pointF(points[next].coord.x - points[cur].coord.x, points[next].coord.y - points[cur].coord.y);
341	lu := sqrt(u*u);
342	if lu <> 0 then u *= 1/lu;
343	v := pointF(points[cur].coord.x - points[prev].coord.x, points[cur].coord.y - points[prev].coord.y);
344	lv := sqrt(v*v);
345	if lv <> 0 then v *= 1/lv;
346
347	dp := u*v;
348	result := (dp > 0.70) and (dp < 0.72);
349	end;
350
351	procedure RemoveAligned;
352	var cur,prev,next: integer;
353	begin
354	cur := n;
355	prev := -1;
356	while points[cur].next <> -1 do
357	begin
358	next := points[cur].next;
359	//remove aligned points
360	if prev <> -1 then
361	if aligned(prev,cur,cur,next) then points[cur].removed := true;
362
363	if not points[cur].removed then prev := cur;
364	cur := next;
365
366	if next = n then
367	begin
368	next := points[cur].next;
369	if (prev <> -1) and (next <> prev) then
370	if aligned(prev,cur,cur,next) then points[cur].removed := true;
371	break; //cycle
372	end;
373	end;
374	end;
375
376	procedure MakePolygon(cycle: boolean);
377	var ptsF: array of TPointF;
378	nbPtsF: integer;
379	nb,nb2,cur,i: integer;
380	begin
381	cur := n;
382	nb := 0;
383	nb2 := 0;
384	repeat
385	if not points[cur].removed then inc(nb);
386	inc(nb2);
387	cur := points[cur].next;
388	until (cur = -1) or (cur = n) or (nb2 > nbPoints);
389	if (nb2 > nbPoints) or (nb <= 2) then exit;
390
391	setlength(ptsF,nb);
392	cur := n;
393	nbPtsF := 0;
394	repeat
395	with points[cur] do
396	if not removed then
397	begin
398	ptsF[nbPtsF] := pointf(coord.xfactor+offset,coord.yfactor+offset);
399	points[cur].drawn := true;
400	inc(nbPtsF);
401	end;
402	cur := points[cur].next;
403	until (cur = -1) or (cur = n);
404
405	if cycle then
406	begin
407	if polygonF = nil then
408	polygonF := ptsF else
409	begin
410	cur := length(polygonF);
411	setlength(polygonF, length(polygonF)+length(ptsF)+1);
412	polygonF[cur] := EmptyPointF;
413	for i := 0 to high(ptsF) do
414	begin
415	inc(cur);
416	polygonF[cur] := ptsF[i];
417	end;
418	end;
419	end;
420	ptsF := nil;
421	//Bitmap.DrawPolyLineAntialias(ptsF,BGRABlack,1);
422	end;
423
424	function segabslength(cur,next: integer): integer;
425	var
426	tx,ty: integer;
427	begin
428	if (cur = -1) or (next = -1) then result := 0
429	else
430	begin
431	tx := abs(points[next].coord.x - points[cur].coord.x);
432	ty := abs(points[next].coord.y - points[cur].coord.y);
433	if tx > ty then result := tx else result := ty;
434	end;
435	end;
436
437	function getnext(cur: integer): integer;
438	begin
439	result := cur;
440	if result <> -1 then
441	begin
442	repeat
443	result := points[result].next;
444	if result = cur then result := -1;
445	until (result = -1) or not points[result].removed;
446	end;
447	end;
448
449	function getprev(cur: integer): integer;
450	begin
451	result := cur;
452	if result <> -1 then
453	begin
454	repeat
455	result := points[result].prev;
456	if result = cur then result := -1;
457	until (result = -1) or not points[result].removed;
458	end;
459	end;
460
461	procedure NiceLines;
462	var next,next2,prev,cur,len,prevlen,nextlen,expectedlen,nb,
463	rcur,rprev,rprev2,rnext,rnext2,temp: integer;
464	begin
465	cur := n;
466	nb := 0;
467	repeat
468	if not points[cur].removed then
469	begin
470	next := getnext(cur);
471	len := segabslength(cur,next);
472	if (len > iUnit - (iHalf shr 1)) and (len < iUnit + (iHalf shr 1)) then
473	begin
474	prev := getprev(cur);
475	next2 := getnext(next);
476	prevlen := segabslength(prev,cur);
477	nextlen := segabslength(next,next2);
478	if (prevlen > iUnit - (iHalf shr 1)) and (nextlen > iUnit - (iHalf shr 1)) and angle45(prev,cur,next) and angle45(cur,next,next2) and
479	aligned(prev,cur,next,next2) then
480	begin
481	if prevlen > nextlen then
482	begin
483	rprev := AddPoint(points[cur].coord.x - (points[next2].coord.x-points[next].coord.x),
484	points[cur].coord.y - (points[next2].coord.y-points[next].coord.y), prev,cur);
485	points[prev].next := rprev;
486	points[cur].prev := rprev;
487	prev := rprev;
488	expectedlen := nextlen;
489	end else
490	if nextlen > prevlen then
491	begin
492	rnext := AddPoint(points[next].coord.x - (points[prev].coord.x-points[cur].coord.x),
493	points[next].coord.y - (points[prev].coord.y-points[cur].coord.y),
494	next,next2);
495	points[next].next := rnext;
496	points[next2].prev := rnext;
497	next2 := rnext;
498	expectedlen := prevlen;
499	end else
500	expectedlen := (nextlen+prevlen) div 2;
501
502	{ points[cur].shouldRemove := true;
503	points[next].shouldRemove:= true;}
504	points[cur].removed := true;
505	rcur := prev;
506	rnext := cur;
507	temp := prev;
508	repeat
509	rprev := getprev(rcur);
510	if not angle45(rprev,rcur,rnext) or not aligned(rprev,rcur,cur,next) then break;
511	prevlen := segabslength(rprev,rcur);
512	if (prevlen < iUnit - (iHalf shr 1)) or (prevlen > iUnit + (iHalf shr 1)) then break;
513	points[rcur].removed := true;
514	temp := rprev;
515
516	rprev2 := getprev(rprev);
517	if not angle45(rprev2,rprev,rcur) or not aligned(rprev2,rprev,prev,cur) then break;
518	prevlen := segabslength(rprev2,rprev);
519	if abs(prevlen-expectedlen) > 0 then break;
520	points[rprev].removed := true;
521	temp := rprev2;
522
523	rcur := rprev2;
524	rnext := rprev;
525	until (rcur=-1);
526	prev := temp;
527
528	points[next].removed:= true;
529	rcur := next2;
530	rprev := next;
531	temp := next2;
532	repeat
533	rnext := getnext(rcur);
534	if not angle45(rnext,rcur,rprev) or not aligned(rcur,rnext,cur,next) then break;
535	nextlen := segabslength(rnext,rcur);
536	if (nextlen < iUnit - (iHalf shr 1)) or (nextlen > iUnit + (iHalf shr 1)) then break;
537	points[rcur].removed := true;
538	temp := rnext;
539
540	rnext2 := getnext(rnext);
541	if not angle45(rnext2,rnext,rcur) or not aligned(rnext,rnext2,next,next2) then break;
542	nextlen := segabslength(rnext2,rnext);
543	if abs(nextlen-expectedlen) > 0 then break;
544	points[rnext].removed := true;
545	temp := rnext2;
546
547	rcur := rnext2;
548	rprev := rnext;
549	until (rcur=-1);
550	next2 := temp;
551
552	points[prev].next := next2;
553	points[next2].prev := prev;
554
555	next := next2;
556	end;
557	end;
558	cur := next;
559	end else
560	cur := points[cur].next;
561	inc(nb);
562	until (cur=-1) or (cur = n) or (nb>nbPoints);
563	{ cur := n;
564	nb := 0;
565	repeat
566	if not points[cur].removed and points[cur].shouldRemove then
567	begin
568	prev := getprev(cur);
569	next := getnext(cur);
570	points[prev].next := next;
571	points[next].prev := prev;
572	points[cur].removed := true;
573	end;
574	cur := points[cur].next;
575	inc(nb);
576	until (cur=-1) or (cur = n) or (nb>nbPoints);}
577	end;
578
579
580	var cycle: boolean;
581	begin
582	//rewind
583	Rewind(cycle);
584	RemoveAligned;
585	if useNiceLines then NiceLines;
586	MakePolygon(cycle);
587	end;
588
589	begin
590	nbpoints := 0;
591	points := nil;
592	polygonF := nil;
593
594	setlength(ortho,ASource.height,ASource.width);
595	for y := 0 to ASource.Height-1 do
596	begin
597	if y = 0 then
598	pprev := nil
599	else
600	pprev := ASource.ScanLine[y-1];
601	p := ASource.ScanLine[y];
602	if y = ASource.Height-1 then
603	pnext := nil
604	else
605	pnext := ASource.ScanLine[y+1];
606
607	{$hints off}
608	fillchar(cur,sizeof(cur),0);
609	{$hints on}
610	cur[6] := (p^.green <= 128); inc(p);
611	if pprev <> nil then begin cur[9] := (pprev^.green <= 128); inc(pprev); end;
612	if pnext <> nil then begin cur[3] := (pnext^.green <= 128); inc(pnext); end;
613	for x := 0 to ASource.Width-1 do
614	begin
615	cur[1] := cur[2];
616	cur[2] := cur[3];
617	cur[4] := cur[5];
618	cur[5] := cur[6];
619	cur[7] := cur[8];
620	cur[8] := cur[9];
621
622	if x = ASource.Width-1 then
623	begin
624	cur[6]:= false;
625	cur[9]:= false;
626	cur[3]:= false;
627	end else
628	begin
629	cur[6] := (p^.green <= 128); inc(p);
630	if pprev <> nil then begin cur[9] := (pprev^.green <= 128); inc(pprev); end;
631	if pnext <> nil then begin cur[3] := (pnext^.green <= 128); inc(pnext); end;
632	end;
633
634	ortho[y,x] := (cur[5] and not cur[7] and not cur[9] and not cur[3] and not cur[1]);
635	if (not cur[5] and (cur[4] xor cur[6]) and (cur[8] xor cur[2]) and
636	(ord(cur[1])+ord(cur[3])+ord(cur[7])+ord(cur[9]) = 3)) then
637	begin
638	if (not cur[6] and not cur[9] and not cur[8] and ((ASource.getPixel(x-1,y-2).green <= 128) or (ASource.getPixel(x+2,y+1).green <= 128)) ) or
639	(not cur[8] and not cur[7] and not cur[4] and ((ASource.getPixel(x-2,y+1).green <= 128) or (ASource.getPixel(x+1,y-2).green <= 128)) ) or
640	(not cur[4] and not cur[1] and not cur[2] and ((ASource.getPixel(x+1,y+2).green <= 128) or (ASource.getPixel(x-2,y-1).green <= 128)) ) or
641	(not cur[2] and not cur[3] and not cur[6] and ((ASource.getPixel(x-1,y+2).green <= 128) or (ASource.getPixel(x+2,y-1).green <= 128)) ) then
642	ortho[y,x] := true;
643	end;
644	{ or
645	(cur[5] and cur[4] and cur[6] and cur[2] and cur[8] and (Ord(cur[1])+ord(cur[3])+ord(cur[7])+ord(cur[9]) = 3))};
646	//if ortho[y,x] then AddPoint(x shl unitShift,y shl unitShift,-1,-1);
647	end;
648	end;
649
650	PointsCurrentLineStart := nbPoints;
651	for y := 0 to ASource.Height-1 do
652	begin
653	iy := y shl unitShift;
654
655	PointsPreviousLineStart := PointsCurrentLineStart;
656	PointsCurrentLineStart := nbPoints;
657	if y = 0 then
658	pprev := nil
659	else
660	pprev := ASource.ScanLine[y-1];
661	p := ASource.ScanLine[y];
662	if y = ASource.Height-1 then
663	pnext := nil
664	else
665	pnext := ASource.ScanLine[y+1];
666
667	{$hints off}
668	fillchar(cur,sizeof(cur),0);
669	{$hints on}
670	cur[6] := (p^.green <= 128); inc(p);
671	if pprev <> nil then begin cur[9] := (pprev^.green <= 128); inc(pprev); end;
672	if pnext <> nil then begin cur[3] := (pnext^.green <= 128); inc(pnext); end;
673	ix := 0;
674	for x := 0 to ASource.Width-1 do
675	begin
676	cur[1] := cur[2];
677	cur[2] := cur[3];
678	cur[4] := cur[5];
679	cur[5] := cur[6];
680	cur[7] := cur[8];
681	cur[8] := cur[9];
682
683	if x = ASource.Width-1 then
684	begin
685	cur[6]:= false;
686	cur[9]:= false;
687	cur[3]:= false;
688	end else
689	begin
690	cur[6] := (p^.green <= 128); inc(p);
691	if pprev <> nil then begin cur[9] := (pprev^.green <= 128); inc(pprev); end;
692	if pnext <> nil then begin cur[3] := (pnext^.green <= 128); inc(pnext); end;
693	end;
694
695	if cur[5] then
696	begin
697	if not cur[1] and not cur[2] and not cur[3] and not cur[4] and not cur[6] and not cur[7] and not cur[8] and not cur[9] then
698	begin
699	AddLine(ix-iHalf,iy-iDiag,ix-iDiag,iy-iHalf,ix+iDiag,iy-iHalf,ix+iHalf,iy-iDiag,ix+iHalf,iy+iDiag);
700	AddLine(ix+iHalf,iy+iDiag,ix+iDiag,iy+iHalf,ix-iDiag,iy+iHalf,ix-iHalf,iy+iDiag,ix-iHalf,iy-iDiag);
701	end else
702	if cur[6] and not cur[9] and not cur[8] then
703	begin
704	if cur[7] then
705	begin
706	if not ortho[y-1,x] then
707	begin
708	if ortho[y,x-1] then AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf) else
709	AddLine(ix+iHalf,iy-iHalf,ix+iDiag,iy-iHalf,ix-iOut,iy-iUnit+iOut);
710	end;
711	end else
712	if cur[4] then AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf) else
713	if cur[1] then AddLine(ix+iHalf,iy-iHalf,ix-iDiag,iy-iHalf,ix-iUnit+iOut,iy+iOut) else
714	if cur[2] then AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf) else
715	if cur[3] then
716	begin
717	if ortho[y,x+1] then AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf) else
718	AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iDiag,ix+iOut,iy+iUnit-iOut)
719	end else
720	AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy,ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf);
721	end;
722	if cur[8] and not cur[7] and not cur[4] then
723	begin
724	if cur[1] then
725	begin
726	if not ortho[y,x-1] then
727	begin
728	if ortho[y+1,x] then AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf) else
729	AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy-iDiag,ix-iUnit+iOut,iy+iOut);
730	end;
731	end else
732	if cur[2] then AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf) else
733	if cur[3] then AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iDiag,ix+iOut,iy+iUnit-iOut) else
734	if cur[6] then AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf) else
735	if cur[9] then
736	begin
737	if ortho[y-1,x] then AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf) else
738	AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix+iDiag,iy+iHalf,ix+iUnit-iOut,iy-iOut)
739	end else
740	AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf);
741	end;
742	if cur[4] and not cur[1] and not cur[2] then
743	begin
744	if cur[3] then
745	begin
746	if not ortho[y+1,x] then
747	begin
748	if ortho[y,x+1] then AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf) else
749	AddLine(ix-iHalf,iy+iHalf,ix-iDiag,iy+iHalf,ix+iOut,iy+iUnit-iOut);
750	end;
751	end else
752	if cur[6] then AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf) else
753	if cur[9] then AddLine(ix-iHalf,iy+iHalf,ix+iDiag,iy+iHalf,ix+iUnit-iOut,iy-iOut) else
754	if cur[8] then AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf) else
755	if cur[7] then
756	begin
757	if ortho[y,x-1] then AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf) else
758	AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iDiag,ix-iOut,iy-iUnit+iOut)
759	end else
760	AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy,ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf);
761	end;
762	if cur[2] and not cur[3] and not cur[6] then
763	begin
764	if cur[9] then
765	begin
766	if not ortho[y,x+1] then
767	begin
768	if ortho[y-1,x] then AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf) else
769	AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy+iDiag,ix+iUnit-iOut,iy-iOut);
770	end;
771	end else
772	if cur[8] then AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf) else
773	if cur[7] then AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iDiag,ix-iOut,iy-iUnit+iOut) else
774	if cur[4] then AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf) else
775	if cur[1] then
776	begin
777	if ortho[y+1,x] then AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix-iHalf,iy+iHalf) else
778	AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf,ix-iDiag,iy-iHalf,ix-iUnit+iOut,iy+iOut)
779	end else
780	AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf,ix,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf);
781	end;
782
783	if cur[3] and not cur[6] then
784	begin
785	if cur[9] then
786	begin
787	if ortho[y+1,x] and ortho[y-1,x] then AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf) else
788	if ortho[y+1,x] and not ortho[y-1,x] then AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy+iDiag,ix+iUnit-iOut,iy-iOut) else
789	if not ortho[y+1,x] and ortho[y-1,x] then AddLine(ix+iUnit-iOut,iy+iOut,ix+iHalf,iy-iDiag,ix+iHalf,iy-iHalf) else
790	AddLine(ix+iUnit-iOut,iy+iOut,ix+iUnit-iOut*2,iy,ix+iUnit-iOut,iy-iOut);
791	end else
792	if cur[8] then
793	begin
794	if not ortho[y,x+1] then
795	if ortho[y+1,x] then AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf) else
796	AddLine(ix+iUnit-iOut,iy+iOut,ix+iHalf,iy-iDiag,ix+iHalf,iy-iHalf)
797	end else
798	if cur[7] then
799	begin
800	if ortho[y+1,x] and ortho[y,x-1] then
801	AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf) else
802	if ortho[y+1,x] and not ortho[y,x-1] then
803	AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iDiag,ix-iOut,iy-iUnit+iOut) else
804	if not ortho[y+1,x] and ortho[y,x-1] then
805	AddLine(ix+iUnit-iOut,iy+iOut, ix+iDiag,iy-iHalf, ix-iHalf,iy-iHalf) else
806	AddLine(ix+iUnit-iOut,iy+iOut,ix-iOut,iy-iUnit+iOut)
807	end else
808	if cur[4] then AddLine(ix+iUnit-iOut,iy+iOut,ix+iDiag,iy-iHalf,ix-iHalf,iy-iHalf) else
809	if cur[1] then
810	begin
811	if ortho[y+1,x] then AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf) else
812	AddLine(ix+iUnit-iOut,iy+iOut,ix+iDiag,iy-iHalf,ix-iDiag,iy-iHalf,ix-iUnit+iOut,iy+iOut);
813	end else
814	if cur[2] then
815	begin
816	if ortho[y+1,x] then AddLine(ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf) else
817	AddLine(ix+iUnit-iOut,iy+iOut,ix+iDiag,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf);
818	end else
819	AddLine(ix+iUnit-iOut,iy+iOut,ix+iDiag,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iDiag,ix+iOut,iy+iUnit-iOut);
820	end;
821
822	if cur[9] and not cur[8] then
823	begin
824	if cur[7] then
825	begin
826	if ortho[y,x+1] and ortho[y,x-1] then AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf) else
827	if ortho[y,x+1] and not ortho[y,x-1] then AddLine(ix+iHalf,iy-iHalf,ix+iDiag,iy-iHalf,ix-iOut,iy-iUnit+iOut) else
828	if not ortho[y,x+1] and ortho[y,x-1] then AddLine(ix+iOut,iy-iUnit+iOut,ix-iDiag,iy-iHalf,ix-iHalf,iy-iHalf) else
829	AddLine(ix+iOut,iy-iUnit+iOut,ix,iy-iUnit+iOut*2,ix-iOut,iy-iUnit+iOut);
830	end else
831	if cur[4] then
832	begin
833	if not ortho[y-1,x] then
834	if ortho[y,x+1] then AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf) else
835	AddLine(ix+iOut,iy-iUnit+iOut,ix-iDiag,iy-iHalf,ix-iHalf,iy-iHalf)
836	end else
837	if cur[1] then
838	begin
839	if ortho[y,x+1] and ortho[y+1,x] then
840	AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf) else
841	if ortho[y,x+1] and not ortho[y+1,x] then
842	AddLine(ix+iHalf,iy-iHalf,ix-iDiag,iy-iHalf,ix-iUnit+iOut,iy+iOut) else
843	if not ortho[y,x+1] and ortho[y+1,x] then
844	AddLine(ix+iOut,iy-iUnit+iOut, ix-iHalf,iy-iDiag, ix-iHalf,iy+iHalf) else
845	AddLine(ix+iOut,iy-iUnit+iOut,ix-iUnit+iOut,iy+iOut)
846	end else
847	if cur[2] then AddLine(ix+iOut,iy-iUnit+iOut,ix-iHalf,iy-iDiag,ix-iHalf,iy+iHalf) else
848	if cur[3] then
849	begin
850	if ortho[y,x+1] then AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf) else
851	AddLine(ix+iOut,iy-iUnit+iOut,ix-iHalf,iy-iDiag,ix-iHalf,iy+iDiag,ix+iOut,iy+iUnit-iOut);
852	end else
853	if cur[6] then
854	begin
855	if ortho[y,x+1] then AddLine(ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf) else
856	AddLine(ix+iOut,iy-iUnit+iOut,ix-iHalf,iy-iDiag,ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf);
857	end else
858	AddLine(ix+iOut,iy-iUnit+iOut,ix-iHalf,iy-iDiag,ix-iHalf,iy+iHalf,ix+iDiag,iy+iHalf,ix+iUnit-iOut,iy-iOut);
859	end;
860
861	if cur[7] and not cur[4] then
862	begin
863	if cur[1] then
864	begin
865	if ortho[y-1,x] and ortho[y+1,x] then AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf) else
866	if ortho[y-1,x] and not ortho[y+1,x] then AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy-iDiag,ix-iUnit+iOut,iy+iOut) else
867	if not ortho[y-1,x] and ortho[y+1,x] then AddLine(ix-iUnit+iOut,iy-iOut,ix-iHalf,iy+iDiag,ix-iHalf,iy+iHalf) else
868	AddLine(ix-iUnit+iOut,iy-iOut,ix-iUnit+iOut*2,iy,ix-iUnit+iOut,iy+iOut);
869	end else
870	if cur[2] then
871	begin
872	if not ortho[y,x-1] then
873	if ortho[y-1,x] then AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf) else
874	AddLine(ix-iUnit+iOut,iy-iOut,ix-iHalf,iy+iDiag,ix-iHalf,iy+iHalf)
875	end else
876	if cur[3] then
877	begin
878	if ortho[y-1,x] and ortho[y,x+1] then
879	AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf) else
880	if ortho[y-1,x] and not ortho[y,x+1] then
881	AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iDiag,ix+iOut,iy+iUnit-iOut) else
882	if not ortho[y-1,x] and ortho[y,x+1] then
883	AddLine(ix-iUnit+iOut,iy-iOut, ix-iDiag,iy+iHalf, ix+iHalf,iy+iHalf) else
884	AddLine(ix-iUnit+iOut,iy-iOut,ix+iOut,iy+iUnit-iOut)
885	end else
886	if cur[6] then AddLine(ix-iUnit+iOut,iy-iOut,ix-iDiag,iy+iHalf,ix+iHalf,iy+iHalf) else
887	if cur[9] then
888	begin
889	if ortho[y-1,x] then AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf) else
890	AddLine(ix-iUnit+iOut,iy-iOut,ix-iDiag,iy+iHalf,ix+iDiag,iy+iHalf,ix+iUnit-iOut,iy-iOut);
891	end else
892	if cur[8] then
893	begin
894	if ortho[y-1,x] then AddLine(ix-iHalf,iy-iHalf,ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf) else
895	AddLine(ix-iUnit+iOut,iy-iOut,ix-iDiag,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf);
896	end else
897	AddLine(ix-iUnit+iOut,iy-iOut,ix-iDiag,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iDiag,ix-iOut,iy-iUnit+iOut);
898	end;
899
900	if cur[1] and not cur[2] then
901	begin
902	if cur[3] then
903	begin
904	if ortho[y,x-1] and ortho[y,x+1] then AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf) else
905	if ortho[y,x-1] and not ortho[y,x+1] then AddLine(ix-iHalf,iy+iHalf,ix-iDiag,iy+iHalf,ix+iOut,iy+iUnit-iOut) else
906	if not ortho[y,x-1] and ortho[y,x+1] then AddLine(ix-iOut,iy+iUnit-iOut,ix+iDiag,iy+iHalf,ix+iHalf,iy+iHalf) else
907	AddLine(ix-iOut,iy+iUnit-iOut,ix,iy+iUnit-iOut*2,ix+iOut,iy+iUnit-iOut);
908	end else
909	if cur[6] then
910	begin
911	if not ortho[y+1,x] then
912	if ortho[y,x-1] then AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf) else
913	AddLine(ix-iOut,iy+iUnit-iOut,ix+iDiag,iy+iHalf,ix+iHalf,iy+iHalf)
914	end else
915	if cur[9] then
916	begin
917	if ortho[y,x-1] and ortho[y-1,x] then
918	AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf) else
919	if ortho[y,x-1] and not ortho[y-1,x] then
920	AddLine(ix-iHalf,iy+iHalf,ix+iDiag,iy+iHalf,ix+iUnit-iOut,iy-iOut) else
921	if not ortho[y,x-1] and ortho[y-1,x] then
922	AddLine(ix-iOut,iy+iUnit-iOut, ix+iHalf,iy+iDiag, ix+iHalf,iy-iHalf) else
923	AddLine(ix-iOut,iy+iUnit-iOut,ix+iUnit-iOut,iy-iOut)
924	end else
925	if cur[8] then AddLine(ix-iOut,iy+iUnit-iOut,ix+iHalf,iy+iDiag,ix+iHalf,iy-iHalf) else
926	if cur[7] then
927	begin
928	if ortho[y,x-1] then AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf) else
929	AddLine(ix-iOut,iy+iUnit-iOut,ix+iHalf,iy+iDiag,ix+iHalf,iy-iDiag,ix-iOut,iy-iUnit+iOut);
930	end else
931	if cur[4] then
932	begin
933	if ortho[y,x-1] then AddLine(ix-iHalf,iy+iHalf,ix+iHalf,iy+iHalf,ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf) else
934	AddLine(ix-iOut,iy+iUnit-iOut,ix+iHalf,iy+iDiag,ix+iHalf,iy-iHalf,ix-iHalf,iy-iHalf);
935	end else
936	AddLine(ix-iOut,iy+iUnit-iOut,ix+iHalf,iy+iDiag,ix+iHalf,iy-iHalf,ix-iDiag,iy-iHalf,ix-iUnit+iOut,iy+iOut);
937	end;
938	end else
939	if ortho[y,x] then
940	begin
941	if not cur[9] then AddLine(ix+iHalf,iy+iHalf,ix-iHalf,iy+iHalf,ix-iHalf,iy-iHalf) else
942	if not cur[7] then AddLine(ix+iHalf,iy-iHalf,ix+iHalf,iy+iHalf,ix-iHalf,iy+iHalf) else
943	if not cur[1] then AddLine(ix-iHalf,iy-iHalf,ix+iHalf,iy-iHalf,ix+iHalf,iy+iHalf) else
944	if not cur[3] then AddLine(ix-iHalf,iy+iHalf,ix-iHalf,iy-iHalf,ix+iHalf,iy-iHalf);
945	end;
946	inc(ix,iUnit);
947	end;
948	end;
949
950	factor := zoom/iUnit;
951	offset := zoom*0.5;
952	if PixelCenteredCoordinates then Offset -= 0.5;
953	for n := 0 to nbPoints-1 do
954	with points[n] do
955	if not drawn and not removed then
956	AddPolygon(n);
957
958	result := polygonF;
959	end;
960
961	{ TBGRAVectorizedFontRenderer }
962
963	function TBGRAVectorizedFontRenderer.OutlineActuallyVisible: boolean;
964	begin
965	result := OutlineVisible and (abs(OutlineWidth) > 0) and (OutlineColor.Alpha <> 0) or (OutlineTexture <> nil);
966	end;
967
968	procedure TBGRAVectorizedFontRenderer.UpdateFont;
969	var i,neededResolution: integer;
970	begin
971	FVectorizedFont := nil;
972	FontName := Trim(FontName);
973	for i := 0 to high(FVectorizedFontArray) do
974	if (CompareText(FVectorizedFontArray[i].FontName,FontName)=0) and
975	(FVectorizedFontArray[i].FontStyle = FontStyle) then
976	begin
977	FVectorizedFont := FVectorizedFontArray[i].VectorizedFont;
978	break;
979	end;
980
981	if FVectorizedFont = nil then
982	begin
983	FVectorizedFont:= TBGRAVectorizedFont.Create(False);
984	FVectorizedFont.Name := FontName;
985	FVectorizedFont.Style := FontStyle;
986	FVectorizedFont.Directory := FDirectoryUTF8;
987	if not FVectorizedFont.FontFound and LCLFontAvailable then
988	FVectorizedFont.VectorizeLCL := True;
989	Setlength(FVectorizedFontArray,length(FVectorizedFontArray)+1);
990	FVectorizedFontArray[high(FVectorizedFontArray)].FontName := FontName;
991	FVectorizedFontArray[high(FVectorizedFontArray)].FontStyle := FontStyle;
992	FVectorizedFontArray[high(FVectorizedFontArray)].VectorizedFont := FVectorizedFont;
993	end;
994	if FontEmHeight > 0 then
995	FVectorizedFont.EmHeight := FontEmHeight
996	else
997	FVectorizedFont.FullHeight:= -FontEmHeight;
998	if OutlineActuallyVisible then
999	begin
1000	if OuterOutlineOnly then
1001	FVectorizedFont.OutlineMode := twoFillOverStroke
1002	else
1003	FVectorizedFont.OutlineMode := twoStrokeOverFill;
1004	FVectorizedFont.QuadraticCurves := False;
1005	end
1006	else
1007	begin
1008	FVectorizedFont.OutlineMode := twoFill;
1009	FVectorizedFont.QuadraticCurves := FVectorizedFont.FullHeight > FVectorizedFont.Resolution*0.8;
1010	end;
1011	if FVectorizedFont.VectorizeLCL then
1012	begin
1013	neededResolution := trunc((FVectorizedFont.FullHeight+80)/50)*50;
1014	if neededResolution > MaxFontResolution then neededResolution := MaxFontResolution;
1015	if FVectorizedFont.Resolution < neededResolution then FVectorizedFont.Resolution:= neededResolution;
1016	end;
1017	end;
1018
1019	function TBGRAVectorizedFontRenderer.GetCanvas2D(ASurface: TBGRACustomBitmap
1020	): TBGRACanvas2D;
1021	begin
1022	if (FCanvas2D = nil) or (FCanvas2D.surface <> ASurface) then
1023	begin
1024	FCanvas2D.Free;
1025	FCanvas2D := TBGRACanvas2D.Create(ASurface);
1026	end;
1027	result := FCanvas2D;
1028	FCanvas2D.antialiasing:= FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB];
1029	if OutlineTexture <> nil then
1030	FCanvas2D.strokeStyle(OutlineTexture)
1031	else
1032	FCanvas2D.strokeStyle(OutlineColor);
1033	FCanvas2D.lineWidth := abs(OutlineWidth);
1034	if not ShadowVisible then
1035	FCanvas2D.shadowColor(BGRAPixelTransparent)
1036	else
1037	begin
1038	FCanvas2D.shadowColor(ShadowColor);
1039	FCanvas2D.shadowBlur:= ShadowRadius;
1040	FCanvas2D.shadowOffset := PointF(ShadowOffset.X,ShadowOffset.Y);
1041	end;
1042	end;
1043
1044	procedure TBGRAVectorizedFontRenderer.InternalTextRect(
1045	ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string;
1046	style: TTextStyle; c: TBGRAPixel; texture: IBGRAScanner);
1047	var
1048	twAlign : TBGRATypeWriterAlignment;
1049	c2D: TBGRACanvas2D;
1050	intersectedClip,previousClip: TRect;
1051	begin
1052	previousClip := ADest.ClipRect;
1053	if style.Clipping then
1054	begin
1055	intersectedClip := rect(0,0,0,0);
1056	if not IntersectRect(intersectedClip, previousClip, ARect) then exit;
1057	ADest.ClipRect := intersectedClip;
1058	end;
1059	UpdateFont;
1060	FVectorizedFont.Orientation := 0;
1061	case style.Alignment of
1062	taCenter: case style.Layout of
1063	tlCenter: twAlign := twaMiddle;
1064	tlBottom: twAlign := twaBottom;
1065	else twAlign:= twaTop;
1066	end;
1067	taRightJustify:
1068	case style.Layout of
1069	tlCenter: twAlign := twaRight;
1070	tlBottom: twAlign := twaBottomRight;
1071	else twAlign := twaTopRight;
1072	end;
1073	else
1074	case style.Layout of
1075	tlCenter: twAlign := twaLeft;
1076	tlBottom: twAlign := twaBottomLeft;
1077	else twAlign:= twaTopLeft;
1078	end;
1079	end;
1080	c2D := GetCanvas2D(ADest);
1081	if texture = nil then
1082	c2D.fillStyle(c)
1083	else
1084	c2D.fillStyle(texture);
1085	if style.Wordbreak then
1086	FVectorizedFont.DrawTextRect(c2D, sUTF8, x-0.5,y-0.5,ARect.Right-0.5,ARect.Bottom-0.5, twAlign)
1087	else
1088	begin
1089	case style.Layout of
1090	tlCenter: y := (ARect.Top+ARect.Bottom) div 2;
1091	tlBottom: y := ARect.Bottom;
1092	end;
1093	case style.Alignment of
1094	taCenter: FVectorizedFont.DrawText(c2D, sUTF8, (ARect.Left+ARect.Right-1)/2,y-0.5, twAlign);
1095	taRightJustify: FVectorizedFont.DrawText(c2D, sUTF8, ARect.Right-0.5,y-0.5, twAlign);
1096	else
1097	FVectorizedFont.DrawText(c2D, sUTF8, x-0.5,y-0.5, twAlign);
1098	end;
1099	end;
1100	if style.Clipping then
1101	ADest.ClipRect := previousClip;
1102	end;
1103
1104	procedure TBGRAVectorizedFontRenderer.Init;
1105	begin
1106	FVectorizedFontArray := nil;
1107	FDirectoryUTF8 := '';
1108
1109	OutlineVisible:= True;
1110	OutlineColor := BGRAPixelTransparent;
1111	OuterOutlineOnly := false;
1112
1113	ShadowColor := BGRABlack;
1114	ShadowVisible := false;
1115	ShadowOffset := Point(5,5);
1116	ShadowRadius := 5;
1117
1118	MaxFontResolution := 300;
1119	end;
1120
1121	constructor TBGRAVectorizedFontRenderer.Create;
1122	begin
1123	Init;
1124	end;
1125
1126	constructor TBGRAVectorizedFontRenderer.Create(ADirectoryUTF8: string);
1127	begin
1128	Init;
1129	FDirectoryUTF8 := ADirectoryUTF8;
1130	end;
1131
1132	function TBGRAVectorizedFontRenderer.GetFontPixelMetric: TFontPixelMetric;
1133	var factor: single;
1134	begin
1135	UpdateFont;
1136	result := FVectorizedFont.FontPixelMetric;
1137	if FVectorizedFont.Resolution > 0 then
1138	begin
1139	factor := FVectorizedFont.FullHeight/FVectorizedFont.Resolution;
1140	result.Baseline := round(result.Baseline*factor);
1141	result.CapLine := round(result.CapLine*factor);
1142	result.Lineheight := round(result.Lineheight*factor);
1143	result.DescentLine := round(result.DescentLine*factor);
1144	result.xLine := round(result.xLine*factor);
1145	end;
1146	end;
1147
1148	procedure TBGRAVectorizedFontRenderer.TextOutAngle(ADest: TBGRACustomBitmap; x,
1149	y: single; orientation: integer; s: string; c: TBGRAPixel; align: TAlignment);
1150	var
1151	twAlign : TBGRATypeWriterAlignment;
1152	c2D: TBGRACanvas2D;
1153	ofs: TPointF;
1154	begin
1155	UpdateFont;
1156	FVectorizedFont.Orientation := orientation;
1157	case align of
1158	taCenter: twAlign:= twaMiddle;
1159	taRightJustify: twAlign := twaRight;
1160	else twAlign:= twaLeft;
1161	end;
1162	c2D := GetCanvas2D(ADest);
1163	c2D.fillStyle(c);
1164	ofs := PointF(x,y);
1165	ofs += AffineMatrixRotationDeg(-orientation0.1)PointF(0,FVectorizedFont.FullHeight*0.5);
1166	FVectorizedFont.DrawText(c2D, s, ofs.x,ofs.y, twAlign);
1167	end;
1168
1169	procedure TBGRAVectorizedFontRenderer.TextOutAngle(ADest: TBGRACustomBitmap; x,
1170	y: single; orientation: integer; s: string; texture: IBGRAScanner;
1171	align: TAlignment);
1172	var
1173	twAlign : TBGRATypeWriterAlignment;
1174	c2D: TBGRACanvas2D;
1175	begin
1176	UpdateFont;
1177	FVectorizedFont.Orientation := orientation;
1178	case align of
1179	taCenter: twAlign:= twaTop;
1180	taRightJustify: twAlign := twaTopRight;
1181	else twAlign:= twaTopLeft;
1182	end;
1183	c2D := GetCanvas2D(ADest);
1184	c2D.fillStyle(texture);
1185	FVectorizedFont.DrawText(c2D, s, x,y, twAlign);
1186	end;
1187
1188	procedure TBGRAVectorizedFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
1189	y: single; s: string; texture: IBGRAScanner; align: TAlignment);
1190	begin
1191	TextOutAngle(ADest,x,y,FontOrientation,s,texture,align);
1192	end;
1193
1194	procedure TBGRAVectorizedFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
1195	y: single; s: string; c: TBGRAPixel; align: TAlignment);
1196	begin
1197	TextOutAngle(ADest,x,y,FontOrientation,s,c,align);
1198	end;
1199
1200	procedure TBGRAVectorizedFontRenderer.TextRect(ADest: TBGRACustomBitmap;
1201	ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel);
1202	begin
1203	InternalTextRect(ADest,ARect,x,y,s,style,c,nil);
1204	end;
1205
1206	procedure TBGRAVectorizedFontRenderer.TextRect(ADest: TBGRACustomBitmap;
1207	ARect: TRect; x, y: integer; s: string; style: TTextStyle;
1208	texture: IBGRAScanner);
1209	begin
1210	InternalTextRect(ADest,ARect,x,y,s,style,BGRAPixelTransparent,texture);
1211	end;
1212
1213	procedure TBGRAVectorizedFontRenderer.CopyTextPathTo(ADest: IBGRAPath; x, y: single; s: string; align: TAlignment);
1214	var
1215	twAlign : TBGRATypeWriterAlignment;
1216	ofs: TPointF;
1217	begin
1218	UpdateFont;
1219	FVectorizedFont.Orientation := 0;
1220	case align of
1221	taCenter: twAlign:= twaMiddle;
1222	taRightJustify: twAlign := twaRight;
1223	else twAlign:= twaLeft;
1224	end;
1225	ofs := PointF(x,y);
1226	ofs += PointF(0,FVectorizedFont.FullHeight*0.5);
1227	FVectorizedFont.CopyTextPathTo(ADest, s, ofs.x,ofs.y, twAlign);
1228	end;
1229
1230	function TBGRAVectorizedFontRenderer.HandlesTextPath: boolean;
1231	begin
1232	Result:= true;
1233	end;
1234
1235	function TBGRAVectorizedFontRenderer.TextSize(s: string): TSize;
1236	var sizeF: TPointF;
1237	begin
1238	UpdateFont;
1239	sizeF := FVectorizedFont.GetTextSize(s);
1240	result.cx := round(sizeF.x);
1241	result.cy := round(sizeF.y);
1242	end;
1243
1244	function TBGRAVectorizedFontRenderer.TextSize(sUTF8: string;
1245	AMaxWidth: integer; ARightToLeft: boolean): TSize;
1246	var
1247	remains: string;
1248	w,h,totalH: single;
1249	begin
1250	UpdateFont;
1251
1252	result.cx := 0;
1253	totalH := 0;
1254	h := FVectorizedFont.FullHeight;
1255	repeat
1256	FVectorizedFont.SplitText(sUTF8, AMaxWidth, remains);
1257	w := FVectorizedFont.GetTextSize(sUTF8).x;
1258	if round(w)>result.cx then result.cx := round(w);
1259	totalH += h;
1260	sUTF8 := remains;
1261	until remains = '';
1262	result.cy := ceil(totalH);
1263	end;
1264
1265	function TBGRAVectorizedFontRenderer.TextFitInfo(sUTF8: string;
1266	AMaxWidth: integer): integer;
1267	var
1268	remains: string;
1269	begin
1270	UpdateFont;
1271	FVectorizedFont.SplitText(sUTF8, AMaxWidth, remains);
1272	result := length(sUTF8);
1273	end;
1274
1275	destructor TBGRAVectorizedFontRenderer.Destroy;
1276	var i: integer;
1277	begin
1278	FCanvas2D.Free;
1279	for i := 0 to high(FVectorizedFontArray) do
1280	FVectorizedFontArray[i].VectorizedFont.Free;
1281	FVectorizedFontArray := nil;
1282	inherited Destroy;
1283	end;
1284
1285	{ TBGRAVectorizedFont }
1286
1287	procedure TBGRAVectorizedFont.SetResolution(AValue: integer);
1288	begin
1289	if FResolution=AValue then Exit;
1290	FResolution:=AValue;
1291	UpdateFont;
1292	end;
1293
1294	procedure TBGRAVectorizedFont.SetOrientation(AValue: single);
1295	begin
1296	if FOrientation=AValue then Exit;
1297	FOrientation:=AValue;
1298	UpdateMatrix;
1299	end;
1300
1301	procedure TBGRAVectorizedFont.SetItalicSlope(AValue: single);
1302	begin
1303	if FItalicSlope=AValue then Exit;
1304	FItalicSlope:=AValue;
1305	UpdateMatrix;
1306	end;
1307
1308	procedure TBGRAVectorizedFont.SetLCLHeight(AValue: single);
1309	begin
1310	if (AValue > 0) xor (FontEmHeightSign < 0) then
1311	EmHeight := abs(AValue)
1312	else
1313	FullHeight := abs(AValue);
1314	end;
1315
1316	function TBGRAVectorizedFont.GetEmHeight: single;
1317	begin
1318	result := FullHeight * FontEmHeightRatio;
1319	end;
1320
1321	function TBGRAVectorizedFont.GetFontPixelMetric: TFontPixelMetric;
1322	begin
1323	if not FFontPixelMetricComputed and (FFont <> nil) then
1324	begin
1325	FFontPixelMetric := BGRAText.GetLCLFontPixelMetric(FFont);
1326	FFontPixelMetricComputed := true;
1327	end;
1328	result := FFontPixelMetric;
1329	end;
1330
1331	function TBGRAVectorizedFont.GetLCLHeight: single;
1332	begin
1333	result := FullHeight * FontFullHeightSign;
1334	end;
1335
1336	function TBGRAVectorizedFont.GetVectorizeLCL: boolean;
1337	begin
1338	result := FFont <> nil;
1339	end;
1340
1341	procedure TBGRAVectorizedFont.SetEmHeight(AValue: single);
1342	begin
1343	if FontEmHeightRatio > 0 then
1344	FullHeight := AValue / FontEmHeightRatio;
1345	end;
1346
1347	procedure TBGRAVectorizedFont.SetQuadraticCurves(AValue: boolean);
1348	begin
1349	if FQuadraticCurves=AValue then Exit;
1350	FQuadraticCurves:=AValue;
1351	end;
1352
1353	procedure TBGRAVectorizedFont.SetFontMatrix(AValue: TAffineMatrix);
1354	begin
1355	FFontMatrix:=AValue;
1356	UpdateMatrix;
1357	end;
1358
1359	procedure TBGRAVectorizedFont.SetFullHeight(AValue: single);
1360	begin
1361	if FFullHeight=AValue then Exit;
1362	FFullHeight:=AValue;
1363	UpdateMatrix;
1364	end;
1365
1366	procedure TBGRAVectorizedFont.SetName(AValue: string);
1367	begin
1368	if FName=AValue then Exit;
1369	FName:=AValue;
1370	UpdateFont;
1371	end;
1372
1373	procedure TBGRAVectorizedFont.SetStyle(AValue: TFontStyles);
1374	begin
1375	if FStyle=AValue then Exit;
1376	FStyle:=AValue;
1377	UpdateFont;
1378	end;
1379
1380	function TBGRAVectorizedFont.GetFontEmHeightRatio: single;
1381	var
1382	lEmHeight, lFullHeight: single;
1383	OldHeight: integer;
1384	begin
1385	if not FFontEmHeightRatioComputed then
1386	begin
1387	if FFont <> nil then
1388	begin
1389	OldHeight := FFont.Height;
1390	FFont.Height := FontEmHeightSign * 100;
1391	lEmHeight := BGRATextSize(FFont, fqSystem, 'Hg', 1).cy;
1392	FFont.Height := FixLCLFontFullHeight(FFont.Name, FontFullHeightSign * 100);
1393	lFullHeight := BGRATextSize(FFont, fqSystem, 'Hg', 1).cy;
1394	if lEmHeight = 0 then
1395	FFontEmHeightRatio := 1
1396	else
1397	FFontEmHeightRatio := lFullHeight/lEmHeight;
1398	FFontEmHeightRatioComputed := true;
1399	FFont.Height := OldHeight;
1400	end else
1401	begin
1402	result := 1;
1403	exit;
1404	end;
1405	end;
1406	result := FFontEmHeightRatio;
1407	end;
1408
1409	procedure TBGRAVectorizedFont.SetVectorizeLCL(AValue: boolean);
1410	begin
1411	if AValue then
1412	begin
1413	if FFont = nil then
1414	FFont := TFont.Create;
1415	end else
1416	begin
1417	if FFont <> nil then
1418	FreeAndNil(FFont);
1419	end;
1420	UpdateFont;
1421	end;
1422
1423	procedure TBGRAVectorizedFont.UpdateFont;
1424	var i: integer;
1425	bestIndex, bestDistance: integer;
1426	distance: integer;
1427	begin
1428	if FFont <> nil then
1429	begin
1430	ClearGlyphs;
1431	FFont.Name := FName;
1432	FFont.Style := FStyle;
1433	FFont.Height := FixLCLFontFullHeight(FFont.Name, FontFullHeightSign * FResolution);
1434	FFont.Quality := fqNonAntialiased;
1435	FFontEmHeightRatio := 1;
1436	FFontEmHeightRatioComputed := false;
1437	fillchar(FFontPixelMetric,sizeof(FFontPixelMetric),0);
1438	FFontPixelMetricComputed := false;
1439	FFontFound := True;
1440	end else
1441	begin
1442	bestIndex := -1;
1443	bestDistance := 1000;
1444	for i := 0 to high(FDirectoryContent) do
1445	begin
1446	if CompareText(FDirectoryContent[i].FontName,FName) = 0 then
1447	begin
1448	distance := 0;
1449	if (fsBold in FDirectoryContent[i].FontStyle) xor (fsBold in FStyle) then distance += 10;
1450	if (fsItalic in FDirectoryContent[i].FontStyle) xor (fsItalic in FStyle) then distance += 5;
1451	if (fsStrikeOut in FDirectoryContent[i].FontStyle) xor (fsStrikeOut in FStyle) then distance += 1;
1452	if (fsUnderline in FDirectoryContent[i].FontStyle) xor (fsUnderline in FStyle) then distance += 1;
1453	if (bestIndex = -1) or (distance < bestDistance) then
1454	begin
1455	bestIndex := i;
1456	bestDistance := distance;
1457	if FDirectoryContent[i].FontStyle = FStyle then break;
1458	end;
1459	end;
1460	end;
1461	if bestIndex <> -1 then
1462	begin
1463	if not (fsItalic in FDirectoryContent[bestIndex].FontStyle) and (fsItalic in FStyle) then
1464	ItalicSlope := 0.25
1465	else if (fsItalic in FDirectoryContent[bestIndex].FontStyle) and not (fsItalic in FStyle) then
1466	ItalicSlope := -0.25
1467	else
1468	ItalicSlope := 0;
1469
1470	UnderlineDecoration := not (fsUnderline in FDirectoryContent[bestIndex].FontStyle) and (fsUnderline in FStyle);
1471	StrikeOutDecoration := not (fsStrikeOut in FDirectoryContent[bestIndex].FontStyle) and (fsStrikeOut in FStyle);
1472
1473	ClearGlyphs;
1474	LoadGlyphsFromFile(FDirectoryContent[bestIndex].Filename);
1475	FFontFound := True;
1476	end else
1477	FFontFound := false;
1478	end;
1479	end;
1480
1481	procedure TBGRAVectorizedFont.UpdateMatrix;
1482	begin
1483	TypeWriterMatrix := FFontMatrixAffineMatrixRotationDeg(-Orientation0.1)AffineMatrixScale(FFullHeight,FFullHeight)AffineMatrixLinear(PointF(1,0),PointF(-FItalicSlope,1));
1484	end;
1485
1486	constructor TBGRAVectorizedFont.Create;
1487	begin
1488	inherited Create;
1489	Init(True);
1490	end;
1491
1492	constructor TBGRAVectorizedFont.Create(AVectorizeLCL: boolean);
1493	begin
1494	inherited Create;
1495	Init(AVectorizeLCL);
1496	end;
1497
1498	destructor TBGRAVectorizedFont.Destroy;
1499	begin
1500	FFont.Free;
1501	FBuffer.Free;
1502	inherited Destroy;
1503	end;
1504
1505	function TBGRAVectorizedFont.GetGlyphSize(AIdentifier: string): TPointF;
1506	var g: TBGRAGlyph;
1507	begin
1508	g := GetGlyph(AIdentifier);
1509	if g = nil then result := EmptyPointF else
1510	result := PointF(g.WidthFullHeight,g.HeightFullHeight);
1511	end;
1512
1513	function TBGRAVectorizedFont.GetTextGlyphSizes(AText: string): TGlyphSizes;
1514	var
1515	pstr: pchar;
1516	left,charlen: integer;
1517	nextchar: string;
1518	g: TBGRAGlyph;
1519	numChar: integer;
1520	begin
1521	if AText = '' then
1522	begin
1523	result := nil;
1524	exit;
1525	end;
1526	setlength(result, UTF8Length(AText));
1527	pstr := @AText[1];
1528	left := length(AText);
1529	numChar := 0;
1530	while left > 0 do
1531	begin
1532	charlen := UTF8CharacterLength(pstr);
1533	setlength(nextchar, charlen);
1534	move(pstr^, nextchar[1], charlen);
1535	inc(pstr,charlen);
1536	dec(left,charlen);
1537
1538	result[numChar].Glyph := nextchar;
1539	g := GetGlyph(nextchar);
1540	if g <> nil then
1541	begin
1542	result[numChar].Width := g.Width*FullHeight;
1543	result[numChar].Height := g.Height*FullHeight;
1544	end else
1545	begin
1546	result[numChar].Width := 0;
1547	result[numChar].Height := 0;
1548	end;
1549	inc(numChar);
1550	end;
1551	end;
1552
1553	function TBGRAVectorizedFont.GetTextSize(AText: string): TPointF;
1554	var
1555	pstr: pchar;
1556	left,charlen: integer;
1557	nextchar: string;
1558	g: TBGRAGlyph;
1559	gSizeY: single;
1560	begin
1561	result := PointF(0,0);
1562	if AText = '' then exit else
1563	begin
1564	pstr := @AText[1];
1565	left := length(AText);
1566	while left > 0 do
1567	begin
1568	charlen := UTF8CharacterLength(pstr);
1569	setlength(nextchar, charlen);
1570	move(pstr^, nextchar[1], charlen);
1571	inc(pstr,charlen);
1572	dec(left,charlen);
1573
1574	g := GetGlyph(nextchar);
1575	if g <> nil then
1576	begin
1577	result.x += g.Width*FullHeight;
1578	gSizeY := g.Height*FullHeight;
1579	if gSizeY > result.y then result.Y := gSizeY;
1580	end;
1581	end;
1582	end;
1583	end;
1584
1585	procedure TBGRAVectorizedFont.SplitText(var ATextUTF8: string; AMaxWidth: single;
1586	out ARemainsUTF8: string);
1587	var
1588	pstr: pchar;
1589	p,left,charlen: integer;
1590	totalWidth: single;
1591	firstChar: boolean;
1592	nextchar: string;
1593	g: TBGRAGlyph;
1594	begin
1595	totalWidth := 0;
1596	if ATextUTF8 = '' then
1597	begin
1598	ARemainsUTF8 := '';
1599	exit;
1600	end else
1601	begin
1602	p := 1;
1603	pstr := @ATextUTF8[1];
1604	left := length(ATextUTF8);
1605	firstChar := true;
1606	while left > 0 do
1607	begin
1608	if RemoveLineEnding(ATextUTF8,p) then
1609	begin
1610	ARemainsUTF8 := copy(ATextUTF8,p,length(ATextUTF8)-p+1);
1611	ATextUTF8 := copy(ATextUTF8,1,p-1);
1612	exit;
1613	end;
1614
1615	charlen := UTF8CharacterLength(pstr);
1616	setlength(nextchar, charlen);
1617	move(pstr^, nextchar[1], charlen);
1618	inc(pstr,charlen);
1619
1620	g := GetGlyph(nextchar);
1621	if g <> nil then
1622	begin
1623	totalWidth += g.Width*FullHeight;
1624	if not firstChar and (totalWidth > AMaxWidth) then
1625	begin
1626	ARemainsUTF8:= copy(ATextUTF8,p,length(ATextUTF8)-p+1);
1627	ATextUTF8 := copy(ATextUTF8,1,p-1);
1628	if Assigned(FWordBreakHandler) then
1629	FWordBreakHandler(ATextUTF8,ARemainsUTF8) else
1630	DefaultWordBreakHandler(ATextUTF8,ARemainsUTF8);
1631	exit;
1632	end;
1633	end;
1634
1635	dec(left,charlen);
1636	inc(p,charlen);
1637	firstChar := false;
1638	end;
1639	end;
1640	ARemainsUTF8 := ''; //no split
1641	end;
1642
1643	procedure TBGRAVectorizedFont.DrawText(ADest: TBGRACanvas2D; ATextUTF8: string; X,
1644	Y: Single; AAlign: TBGRATypeWriterAlignment);
1645	var underlinePoly: ArrayOfTPointF;
1646	m: TAffineMatrix;
1647	i: integer;
1648	deltaY: single;
1649	begin
1650	inherited DrawText(ADest, ATextUTF8, X, Y, AAlign);
1651	if AAlign in [twaBottom,twaBottomLeft,twaBottomRight] then deltaY := -1 else
1652	if AAlign in [twaLeft,twaMiddle,twaRight] then deltaY := -0.5 else
1653	deltaY := 0;
1654	if UnderlineDecoration and (Resolution > 0) then
1655	begin
1656	underlinePoly := BGRATextUnderline(PointF(0,deltaY), GetTextSize(ATextUTF8).x/FullHeight, FontPixelMetric.Baseline/Resolution,
1657	(FontPixelMetric.Baseline-FontPixelMetric.CapLine)/Resolution);
1658	if underlinePoly <> nil then
1659	begin
1660	m := GetTextMatrix(ATextUTF8, X,Y,AAlign);
1661	for i := 0 to high(underlinePoly) do
1662	underlinePoly[i] := m*underlinePoly[i];
1663	if OutlineMode <> twoPath then ADest.beginPath;
1664	ADest.polylineTo(underlinePoly);
1665	DrawLastPath(ADest);
1666	end;
1667	end;
1668	if StrikeOutDecoration and (Resolution > 0) then
1669	begin
1670	underlinePoly := BGRATextStrikeOut(PointF(0,deltaY), GetTextSize(ATextUTF8).x/FullHeight, FontPixelMetric.Baseline/Resolution,
1671	(FontPixelMetric.Baseline-FontPixelMetric.CapLine)/Resolution, (FontPixelMetric.Baseline-FontPixelMetric.xLine)/Resolution);
1672	if underlinePoly <> nil then
1673	begin
1674	m := GetTextMatrix(ATextUTF8, X,Y,AAlign);
1675	for i := 0 to high(underlinePoly) do
1676	underlinePoly[i] := m*underlinePoly[i];
1677	if OutlineMode <> twoPath then ADest.beginPath;
1678	ADest.polylineTo(underlinePoly);
1679	DrawLastPath(ADest);
1680	end;
1681	end;
1682	end;
1683
1684	procedure TBGRAVectorizedFont.CopyTextPathTo(ADest: IBGRAPath;
1685	ATextUTF8: string; X, Y: Single; AAlign: TBGRATypeWriterAlignment);
1686	var underlinePoly: ArrayOfTPointF;
1687	m: TAffineMatrix;
1688	i: integer;
1689	deltaY: single;
1690	begin
1691	inherited CopyTextPathTo(ADest,ATextUTF8, X, Y, AAlign);
1692	if AAlign in [twaBottom,twaBottomLeft,twaBottomRight] then deltaY := -1 else
1693	if AAlign in [twaLeft,twaMiddle,twaRight] then deltaY := -0.5 else
1694	deltaY := 0;
1695	if UnderlineDecoration and (Resolution > 0) then
1696	begin
1697	underlinePoly := BGRATextUnderline(PointF(0,deltaY), GetTextSize(ATextUTF8).x/FullHeight, FontPixelMetric.Baseline/Resolution,
1698	(FontPixelMetric.Baseline-FontPixelMetric.CapLine)/Resolution);
1699	if underlinePoly <> nil then
1700	begin
1701	m := GetTextMatrix(ATextUTF8, X,Y,AAlign);
1702	ADest.moveTo(m*underlinePoly[0]);
1703	for i := 1 to high(underlinePoly) do
1704	ADest.lineTo(m*underlinePoly[i]);
1705	ADest.closePath;
1706	end;
1707	end;
1708	if StrikeOutDecoration and (Resolution > 0) then
1709	begin
1710	underlinePoly := BGRATextStrikeOut(PointF(0,deltaY), GetTextSize(ATextUTF8).x/FullHeight, FontPixelMetric.Baseline/Resolution,
1711	(FontPixelMetric.Baseline-FontPixelMetric.CapLine)/Resolution, (FontPixelMetric.Baseline-FontPixelMetric.xLine)/Resolution);
1712	if underlinePoly <> nil then
1713	begin
1714	m := GetTextMatrix(ATextUTF8, X,Y,AAlign);
1715	ADest.moveTo(m*underlinePoly[0]);
1716	for i := 1 to high(underlinePoly) do
1717	ADest.lineTo(m*underlinePoly[i]);
1718	ADest.closePath;
1719	end;
1720	end;
1721	end;
1722
1723	procedure TBGRAVectorizedFont.DrawTextWordBreak(ADest: TBGRACanvas2D;
1724	ATextUTF8: string; X, Y, MaxWidth: Single; AAlign: TBGRATypeWriterAlignment);
1725	var ARemains: string;
1726	step: TPointF;
1727	lines: TStringList;
1728	i: integer;
1729	lineShift: single;
1730	oldItalicSlope: single;
1731	lineAlignment: TBGRATypeWriterAlignment;
1732	begin
1733	if (ATextUTF8 = '') or (MaxWidth <= 0) then exit;
1734
1735	oldItalicSlope:= ItalicSlope;
1736	ItalicSlope := 0;
1737	step := TypeWriterMatrix*PointF(0,1);
1738	ItalicSlope := oldItalicSlope;
1739
1740	if AAlign in[twaTop,twaMiddle,twaBottom] then
1741	lineAlignment := twaMiddle
1742	else if AAlign in[twaTopLeft,twaLeft,twaBottomLeft] then
1743	begin
1744	if ItalicSlope < 0 then
1745	lineAlignment:= twaTopLeft
1746	else
1747	lineAlignment := twaBottomLeft;
1748	end else
1749	begin
1750	if ItalicSlope < 0 then
1751	lineAlignment := twaBottomRight
1752	else
1753	lineAlignment := twaTopRight;
1754	end;
1755
1756	if AAlign in[twaTopLeft,twaTop,twaTopRight] then
1757	begin
1758	case lineAlignment of
1759	twaMiddle: lineShift := 0.5;
1760	twaBottomLeft,twaBottomRight: lineShift := 1;
1761	twaTopRight,twaTopLeft : lineShift := 0;
1762	end;
1763	X += step.X*lineShift;
1764	Y += step.Y*lineShift;
1765	repeat
1766	SplitText(ATextUTF8, MaxWidth, ARemains);
1767	DrawText(ADest,ATextUTF8,X,Y,lineAlignment);
1768	ATextUTF8 := ARemains;
1769	X+= step.X;
1770	Y+= step.Y;
1771	until ARemains = '';
1772	end else
1773	begin
1774	lines := TStringList.Create;
1775	repeat
1776	SplitText(ATextUTF8, MaxWidth, ARemains);
1777	lines.Add(ATextUTF8);
1778	ATextUTF8 := ARemains;
1779	until ARemains = '';
1780	if AAlign in[twaLeft,twaMiddle,twaRight] then lineShift := lines.Count/2-0.5
1781	else if AAlign in[twaBottomLeft,twaBottom,twaBottomRight] then lineShift := lines.Count-0.5
1782	else lineShift := -0.5;
1783
1784	case lineAlignment of
1785	twaMiddle: ;
1786	twaBottomLeft,twaBottomRight: lineShift -= 0.5;
1787	twaTopRight,twaTopLeft : lineShift += 0.5;
1788	end;
1789
1790	X -= step.X*lineShift;
1791	Y -= step.Y*lineShift;
1792	for i := 0 to lines.Count-1 do
1793	begin
1794	DrawText(ADest,lines[i],X,Y,lineAlignment);
1795	X+= step.X;
1796	Y+= step.Y;
1797	end;
1798	lines.Free;
1799	end;
1800	end;
1801
1802	procedure TBGRAVectorizedFont.DrawTextRect(ADest: TBGRACanvas2D; ATextUTF8: string;
1803	X1, Y1, X2, Y2: Single; AAlign: TBGRATypeWriterAlignment);
1804	var X,Y: single;
1805	oldOrientation: single;
1806	begin
1807	if X2 <= X1 then exit;
1808	if AAlign in[twaTopLeft,twaTop,twaTopRight] then Y := Y1 else
1809	if AAlign in[twaLeft,twaMiddle,twaRight] then Y := (Y1+Y2)/2 else
1810	if AAlign in[twaBottomLeft,twaBottom,twaBottomRight] then Y := Y2;
1811	if AAlign in[twaLeft,twaTopLeft,twaBottomLeft] then X := X1 else
1812	if AAlign in[twaTop,twaMiddle,twaBottom] then X := (X1+X2)/2 else
1813	if AAlign in[twaRight,twaTopRight,twaBottomRight] then X := X2;
1814	oldOrientation:= Orientation;
1815	Orientation:= 0;
1816	DrawTextWordBreak(ADest,ATextUTF8,X,Y,X2-X1,AAlign);
1817	Orientation:= oldOrientation;
1818	end;
1819
1820	procedure TBGRAVectorizedFont.DrawTextRect(ADest: TBGRACanvas2D; ATextUTF8: string;
1821	ATopLeft, ABottomRight: TPointF; AAlign: TBGRATypeWriterAlignment);
1822	begin
1823	DrawTextRect(ADest,ATextUTF8,ATopLeft.X,ATopLeft.Y,ABottomRight.X,ABottomRight.Y,AAlign);
1824	end;
1825
1826	function TBGRAVectorizedFont.GetTextWordBreakGlyphBoxes(ATextUTF8: string; X, Y,
1827	MaxWidth: Single; AAlign: TBGRATypeWriterAlignment): TGlyphBoxes;
1828	var ARemains: string;
1829	step: TPointF;
1830	lines: TStringList;
1831	i: integer;
1832	lineShift: single;
1833	oldItalicSlope: single;
1834	tempArray: array of TGlyphBoxes;
1835	tempPos,j: integer;
1836	lineAlignment: TBGRATypeWriterAlignment;
1837	begin
1838	result := nil;
1839	if ATextUTF8 = '' then exit;
1840
1841	oldItalicSlope:= ItalicSlope;
1842	ItalicSlope := 0;
1843	step := TypeWriterMatrix*PointF(0,1);
1844	ItalicSlope := oldItalicSlope;
1845
1846	if AAlign in[twaTop,twaMiddle,twaBottom] then
1847	lineAlignment := twaMiddle
1848	else if AAlign in[twaTopLeft,twaLeft,twaBottomLeft] then
1849	begin
1850	if ItalicSlope < 0 then
1851	lineAlignment:= twaTopLeft
1852	else
1853	lineAlignment := twaBottomLeft;
1854	end else
1855	begin
1856	if ItalicSlope < 0 then
1857	lineAlignment := twaBottomRight
1858	else
1859	lineAlignment := twaTopRight;
1860	end;
1861
1862	lines := TStringList.Create;
1863	repeat
1864	SplitText(ATextUTF8, MaxWidth, ARemains);
1865	lines.Add(ATextUTF8);
1866	ATextUTF8 := ARemains;
1867	until ARemains = '';
1868
1869	if AAlign in[twaLeft,twaMiddle,twaRight] then lineShift := lines.Count/2-0.5
1870	else if AAlign in[twaBottomLeft,twaBottom,twaBottomRight] then lineShift := lines.Count-0.5
1871	else lineShift := -0.5;
1872
1873	case lineAlignment of
1874	twaMiddle: ;
1875	twaBottomLeft, twaBottomRight: lineShift -= 0.5;
1876	twaTopRight,twaTopLeft : lineShift += 0.5;
1877	end;
1878
1879	X -= step.X*lineShift;
1880	Y -= step.Y*lineShift;
1881	setlength(tempArray, lines.Count);
1882	tempPos := 0;
1883	for i := 0 to lines.Count-1 do
1884	begin
1885	tempArray[i] := GetTextGlyphBoxes(lines[i],X,Y,lineAlignment);
1886	inc(tempPos, length(tempArray[i]));
1887	X+= step.X;
1888	Y+= step.Y;
1889	end;
1890	lines.Free;
1891	setlength(result, tempPos);
1892	tempPos := 0;
1893	for i := 0 to high(tempArray) do
1894	for j := 0 to high(tempArray[i]) do
1895	begin
1896	result[tempPos] := tempArray[i][j];
1897	inc(tempPos);
1898	end;
1899	end;
1900
1901	function TBGRAVectorizedFont.GetTextRectGlyphBoxes(ATextUTF8: string; X1, Y1, X2,
1902	Y2: Single; AAlign: TBGRATypeWriterAlignment): TGlyphBoxes;
1903	var X,Y,oldOrientation: single;
1904	begin
1905	if X2 <= X1 then
1906	begin
1907	result := nil;
1908	exit;
1909	end;
1910	if AAlign in[twaTopLeft,twaTop,twaTopRight] then Y := Y1 else
1911	if AAlign in[twaLeft,twaMiddle,twaRight] then Y := (Y1+Y2)/2 else
1912	if AAlign in[twaBottomLeft,twaBottom,twaBottomRight] then Y := Y2;
1913	if AAlign in[twaLeft,twaTopLeft,twaBottomLeft] then X := X1 else
1914	if AAlign in[twaTop,twaMiddle,twaBottom] then X := (X1+X2)/2 else
1915	if AAlign in[twaRight,twaTopRight,twaBottomRight] then X := X2;
1916	oldOrientation:= Orientation;
1917	Orientation:= 0;
1918	result := GetTextWordBreakGlyphBoxes(ATextUTF8,X,Y,X2-X1,AAlign);
1919	Orientation:= oldOrientation;
1920	end;
1921
1922	function TBGRAVectorizedFont.GetTextRectGlyphBoxes(ATextUTF8: string; ATopLeft,
1923	ABottomRight: TPointF; AAlign: TBGRATypeWriterAlignment): TGlyphBoxes;
1924	begin
1925	result := GetTextRectGlyphBoxes(ATextUTF8,ATopLeft.X,ATopLeft.Y,ABottomRight.X,ABottomRight.Y,AAlign);
1926	end;
1927
1928	procedure TBGRAVectorizedFont.UpdateDirectory;
1929	var
1930	NbFiles: integer;
1931	SearchRec: TSearchRec;
1932	Info: TBGRAGlyphsInfo;
1933	Fullname: string;
1934	begin
1935	NbFiles := 0;
1936	FDirectoryContent := nil;
1937	if FDirectory = '' then exit;
1938	if (length(FDirectory) > 0) and not (FDirectory[length(FDirectory)] in AllowDirectorySeparators) then
1939	FDirectory += DirectorySeparator;
1940	if FindFirstUTF8(FDirectory +'*.glyphs', faAnyFile, SearchRec) = 0 then
1941	repeat
1942	if (faDirectory or faVolumeId or faSysFile) and SearchRec.Attr = 0 then
1943	begin
1944	Fullname := FDirectory+SearchRec.Name;
1945	Info := LoadGlyphsInfo(Fullname);
1946	if (info.Name <> '') and (info.NbGlyphs > 0) then
1947	begin
1948	if NbFiles = length(FDirectoryContent) then
1949	setlength(FDirectoryContent,2*NbFiles+1);
1950	FDirectoryContent[NbFiles].Filename:= Fullname;
1951	FDirectoryContent[NbFiles].FontName:= info.Name;
1952	FDirectoryContent[NbFiles].FontStyle:= info.Style;
1953	inc(NbFiles);
1954	end;
1955	end;
1956	until FindNext(SearchRec) <> 0;
1957	FindClose(SearchRec);
1958	SetLength(FDirectoryContent,NbFiles);
1959	end;
1960
1961	function TBGRAVectorizedFont.LoadGlyphsInfo(AFilenameUTF8: string): TBGRAGlyphsInfo;
1962	var Stream: TFileStreamUTF8;
1963	twHeader: TBGRACustomTypeWriterHeader;
1964	vfHeader: TBGRAVectorizedFontHeader;
1965	begin
1966	result.Name := '';
1967	result.NbGlyphs := 0;
1968	result.Style := [];
1969	Stream := nil;
1970	try
1971	Stream := TFileStreamUTF8.Create(AFilenameUTF8,fmOpenRead);
1972	Stream.Position := 4;
1973	twHeader := ReadCustomTypeWriterHeader(Stream);
1974	result.NbGlyphs := twHeader.NbGlyphs;
1975	if twHeader.HeaderName = HeaderName then
1976	begin
1977	vfHeader := ReadVectorizedFontHeader(Stream);
1978	result.Name := vfHeader.Name;
1979	result.Style:= vfHeader.Style;
1980	end;
1981	except
1982	on ex:exception do
1983	begin
1984
1985	end;
1986	end;
1987	Stream.Free;
1988	end;
1989
1990	function TBGRAVectorizedFont.GetGlyph(AIdentifier: string): TBGRAGlyph;
1991	var size: TSize;
1992	g: TBGRAPolygonalGlyph;
1993	begin
1994	Result:=inherited GetGlyph(AIdentifier);
1995	if (result = nil) and (FResolution > 0) and (FFont <> nil) then
1996	begin
1997	g := TBGRAPolygonalGlyph.Create(AIdentifier);
1998	size := BGRATextSize(FFont, fqSystem, AIdentifier, 1);
1999	FBuffer.SetSize(size.cx+size.cy,size.cy);
2000	FBuffer.Fill(BGRAWhite);
2001	FBuffer.Canvas.Font := FFont;
2002	FBuffer.Canvas.Font.Color := clBlack;
2003	FBuffer.Canvas.TextOut(size.cy div 2,0,AIdentifier);
2004	g.SetPoints(VectorizeMonochrome(FBuffer,1/FResolution,False));
2005	g.QuadraticCurves := FQuadraticCurves and (OutlineMode in[twoPath, twoFill]);
2006	g.Width := size.cx/size.cy;
2007	g.Height := 1;
2008	g.Offset := PointF(-0.5,0);
2009	SetGlyph(AIdentifier,g);
2010	result := g;
2011	end else
2012	if (result <> nil) and (result is TBGRAPolygonalGlyph) then
2013	TBGRAPolygonalGlyph(result).QuadraticCurves := FQuadraticCurves and (OutlineMode in[twoPath, twoFill]);
2014	end;
2015
2016	procedure TBGRAVectorizedFont.DefaultWordBreakHandler(var ABefore,AAfter: string);
2017	begin
2018	BGRADefaultWordBreakHandler(ABefore,AAfter);
2019	end;
2020
2021	procedure TBGRAVectorizedFont.Init(AVectorize: boolean);
2022	begin
2023	FName := 'Arial';
2024	FStyle := [];
2025	FFontMatrix := AffineMatrixIdentity;
2026	FOrientation := 0;
2027	FResolution := 100;
2028	FFontEmHeightRatio := 1;
2029	FFontEmHeightRatioComputed := false;
2030	if AVectorize then
2031	FFont := TFont.Create
2032	else
2033	FFont := nil;
2034	FBuffer := BGRABitmapFactory.Create;
2035	FFullHeight := 20;
2036	FItalicSlope := 0;
2037	UpdateFont;
2038	UpdateMatrix;
2039	FWordBreakHandler:= nil;
2040	end;
2041
2042	function TBGRAVectorizedFont.CustomHeaderSize: integer;
2043	begin
2044	Result:= (inherited CustomHeaderSize) + 4+length(FName)+4 + sizeof(single) + 4 + 5*4;
2045	end;
2046
2047	procedure TBGRAVectorizedFont.WriteCustomHeader(AStream: TStream);
2048	var metric: TFontPixelMetric;
2049	begin
2050	inherited WriteCustomHeader(AStream);
2051	LEWriteLongint(AStream, length(FName));
2052	AStream.Write(FName[1],length(FName));
2053	LEWriteLongint(AStream, integer(FStyle));
2054	LEWriteSingle(AStream, FontEmHeightRatio);
2055	LEWriteLongint(AStream, Resolution);
2056	metric := FontPixelMetric;
2057	LEWriteLongint(AStream, metric.Baseline);
2058	LEWriteLongint(AStream, metric.xLine);
2059	LEWriteLongint(AStream, metric.CapLine);
2060	LEWriteLongint(AStream, metric.DescentLine);
2061	LEWriteLongint(AStream, metric.Lineheight);
2062	end;
2063
2064	procedure TBGRAVectorizedFont.ReadAdditionalHeader(AStream: TStream);
2065	var Header: TBGRAVectorizedFontHeader;
2066	begin
2067	inherited ReadAdditionalHeader(AStream);
2068	Header := ReadVectorizedFontHeader(AStream);
2069	FName := Header.Name;
2070	FStyle := Header.Style;
2071	if header.EmHeightRatio <> 0 then
2072	begin
2073	FFontEmHeightRatio := Header.EmHeightRatio;
2074	FFontEmHeightRatioComputed := true;
2075	end else
2076	begin
2077	FFontEmHeightRatio := 1;
2078	FFontEmHeightRatioComputed := false;
2079	end;
2080	FFontPixelMetric := Header.PixelMetric;
2081	FFontPixelMetricComputed := True;
2082	if FFont = nil then
2083	FResolution := Header.Resolution;
2084	end;
2085
2086	function TBGRAVectorizedFont.ReadVectorizedFontHeader(AStream: TStream): TBGRAVectorizedFontHeader;
2087	var lNameLength: integer;
2088	begin
2089	lNameLength := LEReadLongint(AStream);
2090	setlength(result.Name, lNameLength);
2091	AStream.Read(result.Name[1],length(result.Name));
2092	result.Style := TFontStyles(LEReadLongint(AStream));
2093	result.EmHeightRatio:= LEReadSingle(AStream);
2094	result.Resolution := LEReadLongint(AStream);
2095	result.PixelMetric.Baseline := LEReadLongint(AStream);
2096	result.PixelMetric.xLine := LEReadLongint(AStream);
2097	result.PixelMetric.CapLine := LEReadLongint(AStream);
2098	result.PixelMetric.DescentLine := LEReadLongint(AStream);
2099	result.PixelMetric.Lineheight := LEReadLongint(AStream);
2100	result.PixelMetric.Defined := result.PixelMetric.Lineheight > 0;
2101	end;
2102
2103	function TBGRAVectorizedFont.HeaderName: string;
2104	begin
2105	Result:= 'TBGRAVectorizedFont';
2106	end;
2107
2108	procedure TBGRAVectorizedFont.SetDirectory(const AValue: string);
2109	begin
2110	if Trim(AValue) = Trim(FDirectory) then exit;
2111	FDirectory := Trim(AValue);
2112	UpdateDirectory;
2113	UpdateFont;
2114	end;
2115
2116	end.
2117

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/Packages/bgrabitmap/bgravectorize.pas

Download in other formats: