1 unit LazFreeTypeIntfDrawer;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 Classes, SysUtils, FPimage,
9 // LazUtils
10 GraphType,
11 // FreeType
12 EasyLazFreeType,
13 // LCL
14 Graphics, IntfGraphics;
15
16 type
17 TLazIntfImageGetPixelAtProc = procedure(p: pointer; out Color: TFPColor);
18 TLazIntfImageSetPixelAtProc = procedure(p: pointer; const Color: TFPColor);
19 TLazIntfHorizLineProc = procedure(x1,y,x2: integer; const Color: TFPColor) of object;
20
21 { TIntfFreeTypeDrawer }
22
23 TIntfFreeTypeDrawer = class(TFreeTypeDrawer)
24 private
25 FColor: TFPColor;
26 FDestination: TLazIntfImage;
27 FHasPixelAtProc: boolean;
28 FGetPixelAtProc: TLazIntfImageGetPixelAtProc;
29 FSetPixelAtProc: TLazIntfImageSetPixelAtProc;
30 FPixelSizeInBytes: longword;
31 FWidth, FHeight: integer;
32 procedure SetDestination(AValue: TLazIntfImage);
33 protected
34 procedure RenderDirectly(x, y, tx: integer; data: pointer);
35 procedure RenderDirectlyClearType(x, y, tx: integer; data: pointer);
36 procedure InternalMergeColorOver(var merge: TFPColor; const c: TFPColor; calpha: word); inline;
37 procedure MergeColorOver(var merge: TFPColor; const c: TFPColor); inline;
38 procedure MergeColorOver(var merge: TFPColor; const c: TFPColor; ApplyOpacity: byte); inline;
39 procedure DrawPixelAt(p: pointer; const c: TFPColor);
40 procedure DrawPixelAt(p: pointer; const c: TFPColor; applyOpacity: byte);
41 procedure ClearTypePixelAt(p: pointer; Cr,Cg,Cb: byte; const Color: TFPColor);
UnclippedGetPixelAddressnull42 function UnclippedGetPixelAddress(x, y: integer): pointer; inline;
ClippedGetPixelAddressnull43 function ClippedGetPixelAddress(x, y: integer): pointer; inline;
44 public
45 ClearTypeRGBOrder: boolean;
46 constructor Create(ADestination: TLazIntfImage);
47 procedure ClippedDrawPixel(x,y: integer; const c: TFPColor);
48 procedure UnclippedDrawPixel(x,y: integer; const c: TFPColor);
49 procedure ClippedClearTypePixel(x,y: integer; Cr,Cg,Cb: byte; const Color: TFPColor);
50 procedure UnclippedClearTypePixel(x,y: integer; Cr,Cg,Cb: byte; const Color: TFPColor);
51 procedure DrawVertLine(x,y1,y2: integer; const c: TFPColor);
52 procedure SetHorizLine(x1,y,x2: integer; const c: TFPColor);
53 procedure DrawHorizLine(x1,y,x2: integer; const c: TFPColor);
54 procedure FillRect(x,y,x2,y2: integer; const c: TFPColor; ASetPixels: boolean = True);
55 procedure FillPixels(const c: TFPColor; ASetPixels: boolean = True);
56 procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); override; overload;
57 procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); override; overload;
58 property Destination: TLazIntfImage read FDestination write SetDestination;
59 destructor Destroy; override;
60 end;
61
62 implementation
63
64 type
65 PFPColorBytes = ^TFPColorBytes;
66 TFPColorBytes = record
67 {$ifdef ENDIAN_LITTLE}
68 Rl, Rh, Gl, Gh, Bl, Bh, Al, Ah: Byte;
69 {$else}
70 Rh, Rl, Gh, Gl, Bh, Bl, Ah, Al: Byte;
71 {$endif}
72 end;
73
74 PFourBytes = ^TFourBytes;
75 TFourBytes = record
76 B0, B1, B2, B3: Byte;
77 end;
78
79 { TIntfFreeTypeDrawer }
80
TIntfFreeTypeDrawer.ClippedGetPixelAddressnull81 function TIntfFreeTypeDrawer.ClippedGetPixelAddress(x, y: integer): pointer;
82 begin
83 if (x < 0) or (x >= Destination.Width) then
84 raise FPImageException.CreateFmt(ErrorText[StrInvalidIndex],[ErrorText[StrImageX],x]);
85 if (y < 0) or (y >= Destination.Height) then
86 raise FPImageException.CreateFmt(ErrorText[StrInvalidIndex],[ErrorText[StrImageY],y]);
87
88 result := pbyte(Destination.GetDataLineStart(y))+(x*FPixelSizeInBytes);
89 end;
90
91 procedure InternalGetPixelAtWithoutAlphaRGB(p: pointer; out Color: TFPColor);
92 begin
93 with PFourBytes(p)^ do
94 begin
95 TFPColorBytes(color).Rh := B0;
96 TFPColorBytes(color).Rl := B0;
97 TFPColorBytes(color).Gh := B1;
98 TFPColorBytes(color).Gl := B1;
99 TFPColorBytes(color).Bh := B2;
100 TFPColorBytes(color).Bl := B2;
101 color.alpha := $ffff;
102 end;
103 end;
104
105 procedure InternalSetPixelAtWithoutAlphaRGB(p: pointer; const Color: TFPColor);
106 begin
107 with PFourBytes(p)^ do
108 begin
109 B0 := TFPColorBytes(color).Rh;
110 B1 := TFPColorBytes(color).Gh;
111 B2 := TFPColorBytes(color).Bh;
112 end;
113 end;
114
115 procedure InternalGetPixelAtWithoutAlphaBGR(p: pointer; out Color: TFPColor);
116 {$IFDEF CPUI386} assembler; {$ASMMODE INTEL}
117 asm
118 mov cl, [eax+2]
119 mov [edx], cl
120 mov [edx+1], cl
121 mov cl, [eax+1]
122 mov [edx+2], cl
123 mov [edx+3], cl
124 mov cl, [eax]
125 mov [edx+4], cl
126 mov [edx+5], cl
127 xor ecx, ecx
128 not ecx
129 mov [edx+6], cx
130 end;
131 {$ELSE}
132 begin
133 with PFourBytes(p)^ do
134 begin
135 TFPColorBytes(color).Rh := B2;
136 TFPColorBytes(color).Rl := B2;
137 TFPColorBytes(color).Gh := B1;
138 TFPColorBytes(color).Gl := B1;
139 TFPColorBytes(color).Bh := B0;
140 TFPColorBytes(color).Bl := B0;
141 color.alpha := $ffff;
142 end;
143 end;
144 {$ENDIF}
145
146 procedure InternalSetPixelAtWithoutAlphaBGR(p: pointer; const Color: TFPColor);
147 {$IFDEF CPUI386} assembler; {$ASMMODE INTEL}
148 asm
149 mov cl, [edx+1]
150 mov [eax+2], cl
151 mov cl, [edx+3]
152 mov [eax+1], cl
153 mov cl, [edx+5]
154 mov [eax], cl
155 end;
156 {$ELSE}
157 begin
158 with PFourBytes(p)^ do
159 begin
160 B2 := TFPColorBytes(color).Rh;
161 B1 := TFPColorBytes(color).Gh;
162 B0 := TFPColorBytes(color).Bh;
163 end;
164 end;
165 {$ENDIF}
166
167 procedure InternalGetPixelAtWithAlphaRGBA(p: pointer; out Color: TFPColor);
168 begin
169 with PFourBytes(p)^ do
170 begin
171 TFPColorBytes(color).Rh := B0;
172 TFPColorBytes(color).Rl := B0;
173 TFPColorBytes(color).Gh := B1;
174 TFPColorBytes(color).Gl := B1;
175 TFPColorBytes(color).Bh := B2;
176 TFPColorBytes(color).Bl := B2;
177 TFPColorBytes(color).Ah := B3;
178 TFPColorBytes(color).Al := B3;
179 end;
180 end;
181
182 procedure InternalSetPixelAtWithAlphaRGBA(p: pointer; const Color: TFPColor);
183 begin
184 with PFourBytes(p)^ do
185 begin
186 B0 := TFPColorBytes(color).Rh;
187 B1 := TFPColorBytes(color).Gh;
188 B2 := TFPColorBytes(color).Bh;
189 B3 := TFPColorBytes(color).Ah;
190 end;
191 end;
192
193 procedure InternalGetPixelAtWithAlphaBGRA(p: pointer; out Color: TFPColor);
194 begin
195 with PFourBytes(p)^ do
196 begin
197 TFPColorBytes(color).Rh := B2;
198 TFPColorBytes(color).Rl := B2;
199 TFPColorBytes(color).Gh := B1;
200 TFPColorBytes(color).Gl := B1;
201 TFPColorBytes(color).Bh := B0;
202 TFPColorBytes(color).Bl := B0;
203 TFPColorBytes(color).Ah := B3;
204 TFPColorBytes(color).Al := B3;
205 end;
206 end;
207
208 procedure InternalSetPixelAtWithAlphaBGRA(p: pointer; const Color: TFPColor);
209 begin
210 with PFourBytes(p)^ do
211 begin
212 B2 := TFPColorBytes(color).Rh;
213 B1 := TFPColorBytes(color).Gh;
214 B0 := TFPColorBytes(color).Bh;
215 B3 := TFPColorBytes(color).Ah;
216 end;
217 end;
218
219 procedure TIntfFreeTypeDrawer.MergeColorOver(var merge: TFPColor; const c: TFPColor);
220 begin
221 InternalMergeColorOver(merge,c,c.alpha);
222 end;
223
224 procedure TIntfFreeTypeDrawer.MergeColorOver(var merge: TFPColor;
225 const c: TFPColor; ApplyOpacity: byte);
226 var
227 calpha: longword;
228 begin
229 calpha := c.alpha*applyOpacity div 255;
230 InternalMergeColorOver(merge,c,calpha);
231 end;
232
233 procedure TIntfFreeTypeDrawer.UnclippedDrawPixel(x, y: integer; const c: TFPColor);
234 var
235 merge: TFPColor;
236 begin
237 if c.alpha = 0 then exit;
238 if FHasPixelAtProc then
239 DrawPixelAt(UnclippedGetPixelAddress(x,y),c)
240 else
241 begin
242 if c.alpha = $ffff then
243 Destination.Colors[x,y] := c
244 else
245 begin
246 merge := Destination.Colors[x,y];
247 MergeColorOver(merge,c);
248 Destination.Colors[x,y] := merge;
249 end;
250 end;
251 end;
252
253 procedure TIntfFreeTypeDrawer.DrawPixelAt(p: pointer; const c: TFPColor; applyOpacity: byte);
254 var
255 merge: TFPColor;
256 calpha: longword;
257 begin
258 calpha := c.alpha*applyOpacity div 255;
259 if calpha = 0 then exit;
260 if calpha = $ffff then
261 FSetPixelAtProc(p, c)
262 else
263 begin
264 FGetPixelAtProc(p, merge);
265 InternalMergeColorOver(merge,c,calpha);
266 FSetPixelAtProc(p, merge);
267 end;
268 end;
269
270 procedure TIntfFreeTypeDrawer.DrawPixelAt(p: pointer; const c: TFPColor);
271 var
272 merge: TFPColor;
273 begin
274 if (c.alpha = 0) then exit;
275 if (c.alpha = $ffff) then
276 FSetPixelAtProc(p, c)
277 else
278 begin
279 FGetPixelAtProc(p, merge);
280 MergeColorOver(merge,c);
281 FSetPixelAtProc(p, merge);
282 end;
283 end;
284
285 procedure TIntfFreeTypeDrawer.ClippedClearTypePixel(x, y: integer; Cr, Cg,
286 Cb: byte; const Color: TFPColor);
287 begin
288 if (x < 0) or (y < 0) or (x >= Destination.Width) or (y >= Destination.Height) then exit;
289 UnclippedClearTypePixel(x,y,Cr,Cg,Cb,Color);
290 end;
291
292 procedure TIntfFreeTypeDrawer.DrawVertLine(x, y1, y2: integer; const c: TFPColor
293 );
294 var y: integer;
295 begin
296 if (x < 0) or (x >= Destination.Width) then exit;
297 if (y1 > y2) then
298 begin
299 y := y1;
300 y1:= y2;
301 y2 := y;
302 end;
303 if y1 < 0 then y1 := 0;
304 if y2 >= Destination.Height then y2 := Destination.Height-1;
305 for y := y1 to y2 do
306 UnclippedDrawPixel(x,y, c);
307 end;
308
309 procedure TIntfFreeTypeDrawer.SetHorizLine(x1, y, x2: integer; const c: TFPColor);
310 var i: integer;
311 pdest: pbyte;
312 step: longword;
313 begin
314 if (y < 0) or (y >= Destination.Height) then exit;
315 if (x1 > x2) then
316 begin
317 i := x1;
318 x1:= x2;
319 x2 := i;
320 end;
321 if x1 < 0 then x1 := 0;
322 if x2 >= Destination.Width then x2 := Destination.Width-1;
323 if FHasPixelAtProc then
324 begin
325 pdest := UnclippedGetPixelAddress(x1,y);
326 step := FPixelSizeInBytes;
327 i := x2-x1+1;
328 while i > 0 do
329 begin
330 FSetPixelAtProc(pdest,c);
331 inc(pdest,step);
332 dec(i);
333 end;
334 end else
335 for i := x1 to x2 do
336 Destination.Colors[i,y] := c;
337 end;
338
339 procedure TIntfFreeTypeDrawer.DrawHorizLine(x1, y, x2: integer;
340 const c: TFPColor);
341 var i: integer;
342 pdest: pbyte;
343 step: longword;
344 begin
345 if (y < 0) or (y >= Destination.Height) then exit;
346 if (x1 > x2) then
347 begin
348 i := x1;
349 x1:= x2;
350 x2 := i;
351 end;
352 if x1 < 0 then x1 := 0;
353 if x2 >= Destination.Width then x2 := Destination.Width-1;
354 if FHasPixelAtProc then
355 begin
356 pdest := UnclippedGetPixelAddress(x1,y);
357 step := FPixelSizeInBytes;
358 i := x2-x1+1;
359 while i > 0 do
360 begin
361 DrawPixelAt(pdest,c);
362 inc(pdest,step);
363 dec(i);
364 end;
365 end else
366 for i := x1 to x2 do
367 UnclippedDrawPixel(i,y,c);
368 end;
369
370 procedure TIntfFreeTypeDrawer.FillRect(x, y, x2, y2: integer;
371 const c: TFPColor; ASetPixels: boolean);
372 var yb,xb: integer;
373 HorizLineProc: TLazIntfHorizLineProc;
374 begin
375 if x2 < x then
376 begin
377 xb:= x;
378 x := x2;
379 x2 := xb;
380 end;
381 if x < 0 then x := 0;
382 if x2 > Destination.Width then x2 := Destination.Width;
383 if (x >= Destination.Width) or (x2 <= 0) then exit;
384 if y2 < y then
385 begin
386 yb := y;
387 y := y2;
388 y2 := yb;
389 end;
390 if y < 0 then y := 0;
391 if y2 > Destination.Height then y2 := Destination.Height;
392 if ASetPixels then HorizLineProc := @SetHorizLine else HorizLineProc := @DrawHorizLine;
393 for yb := y to y2-1 do
394 HorizLineProc(x,yb,x2-1,c);
395 end;
396
397 procedure TIntfFreeTypeDrawer.FillPixels(const c: TFPColor; ASetPixels: boolean = True);
398 var yb: integer;
399 HorizLineProc: TLazIntfHorizLineProc;
400 begin
401 if ASetPixels then HorizLineProc := @SetHorizLine else HorizLineProc := @DrawHorizLine;
402 for yb := 0 to Destination.Height-1 do
403 HorizLineProc(0,yb,Destination.Width-1,c);
404 end;
405
406 procedure TIntfFreeTypeDrawer.UnclippedClearTypePixel(x, y: integer; Cr, Cg, Cb: byte; const Color: TFPColor);
407 var merge,mergeClearType: TFPColor;
408 acc: longword;
409 keep,dont_keep: word;
410 begin
411 Cr := Cr*(color.alpha+1) shr 16;
412 Cg := Cg*(color.alpha+1) shr 16;
413 Cb := Cb*(color.alpha+1) shr 16;
414 acc := Cr+Cg+Cb;
415 if acc = 0 then exit;
416
417 merge := Destination.Colors[x,y];
418 mergeClearType.red := (merge.red * (not byte(Cr)) +
419 color.red * Cr + 128) div 255;
420 mergeClearType.green := (merge.green * (not byte(Cg)) +
421 color.green * Cg + 128) div 255;
422 mergeClearType.blue := (merge.blue * (not byte(Cb)) +
423 color.blue * Cb + 128) div 255;
424 mergeClearType.alpha := merge.alpha;
425
426 if (mergeClearType.alpha = $ffff) then
427 Destination.Colors[x,y]:= mergeClearType
428 else
429 begin
430 if Cg <> 0 then
431 MergeColorOver(merge,color,Cg);
432 dont_keep := mergeClearType.alpha shr 1;
433 if dont_keep > 0 then
434 begin
435 keep := 32767 - dont_keep;
436 merge.red := (merge.red * keep + mergeClearType.red * dont_keep) div 32767;
437 merge.green := (merge.green * keep + mergeClearType.green * dont_keep) div 32767;
438 merge.blue := (merge.blue * keep + mergeClearType.blue * dont_keep) div 32767;
439 merge.alpha := mergeClearType.alpha + ((not mergeClearType.alpha)*merge.alpha div 65535);
440 end;
441 Destination.Colors[x,y] := merge;
442 end;
443 end;
444
445 procedure TIntfFreeTypeDrawer.ClearTypePixelAt(p: pointer; Cr, Cg, Cb: byte;
446 const Color: TFPColor);
447 var merge,mergeClearType: TFPColor;
448 acc: longword;
449 keep,dont_keep: word;
450 begin
451 Cr := Cr*(color.alpha+1) shr 16;
452 Cg := Cg*(color.alpha+1) shr 16;
453 Cb := Cb*(color.alpha+1) shr 16;
454 acc := Cr+Cg+Cb;
455 if acc = 0 then exit;
456
457 FGetPixelAtProc(p, merge);
458 mergeClearType.red := (merge.red * (not byte(Cr)) +
459 color.red * Cr + 128) div 255;
460 mergeClearType.green := (merge.green * (not byte(Cg)) +
461 color.green * Cg + 128) div 255;
462 mergeClearType.blue := (merge.blue * (not byte(Cb)) +
463 color.blue * Cb + 128) div 255;
464 mergeClearType.alpha := merge.alpha;
465
466 if (mergeClearType.alpha = $ffff) then
467 FSetPixelAtProc(p, mergeClearType)
468 else
469 begin
470 if Cg <> 0 then
471 MergeColorOver(merge,color,Cg);
472 dont_keep := mergeClearType.alpha shr 1;
473 if dont_keep > 0 then
474 begin
475 keep := 32767 - dont_keep;
476 merge.red := (merge.red * keep + mergeClearType.red * dont_keep) div 32767;
477 merge.green := (merge.green * keep + mergeClearType.green * dont_keep) div 32767;
478 merge.blue := (merge.blue * keep + mergeClearType.blue * dont_keep) div 32767;
479 merge.alpha := mergeClearType.alpha + ((not mergeClearType.alpha)*merge.alpha div 65535);
480 end;
481 FSetPixelAtProc(p, merge);
482 end;
483 end;
484
TIntfFreeTypeDrawer.UnclippedGetPixelAddressnull485 function TIntfFreeTypeDrawer.UnclippedGetPixelAddress(x, y: integer): pointer;
486 begin
487 result := pbyte(Destination.GetDataLineStart(y))+(x*FPixelSizeInBytes);
488 end;
489
490 procedure TIntfFreeTypeDrawer.SetDestination(AValue: TLazIntfImage);
491 var CanBeOptimized: boolean;
492 RedShiftInBytes,GreenShiftInBytes,BlueShiftInBytes,AlphaShiftInBytes: integer;
493 begin
494 if FDestination=AValue then Exit;
495 FDestination := AValue;
496
497 FGetPixelAtProc := nil;
498 FSetPixelAtProc := nil;
499
500 if FDestination = nil then
501 begin
502 FWidth := 0;
503 FHeight := 0;
504 end else
505 begin
506 FWidth := FDestination.Width;
507 FHeight := FDestination.Height;
508
509 with Destination.DataDescription do
510 CanBeOptimized := (BitsPerPixel and 7 = 0) and
511 (Format = ricfRGBA) and (RedPrec = 8) and (GreenPrec = 8) and (BluePrec = 8) and
512 (RedShift and 7 = 0) and (GreenPrec and 7 = 0) and (BluePrec and 7 = 0) and
513 (((AlphaPrec = 8) and (AlphaShift and 7 = 0)) or (AlphaPrec = 0));
514
515 if CanBeOptimized then
516 begin
517 FPixelSizeInBytes := Destination.DataDescription.BitsPerPixel div 8;
518
519 RedShiftInBytes := Destination.DataDescription.RedShift div 8;
520 GreenShiftInBytes := Destination.DataDescription.GreenShift div 8;
521 BlueShiftInBytes := Destination.DataDescription.BlueShift div 8;
522 AlphaShiftInBytes := Destination.DataDescription.AlphaShift div 8;
523
524 if Destination.DataDescription.ByteOrder = riboMSBFirst then
525 begin
526 RedShiftInBytes := FPixelSizeInBytes-1 - RedShiftInBytes;
527 GreenShiftInBytes := FPixelSizeInBytes-1 - GreenShiftInBytes;
528 BlueShiftInBytes := FPixelSizeInBytes-1 - BlueShiftInBytes;
529 AlphaShiftInBytes := FPixelSizeInBytes-1 - AlphaShiftInBytes;
530 end;
531
532 if Destination.DataDescription.AlphaPrec = 0 then
533 begin
534 if (RedShiftInBytes = 0) and (GreenShiftInBytes = 1) and
535 (BlueShiftInBytes = 2) then
536 begin
537 FGetPixelAtProc := @InternalGetPixelAtWithoutAlphaRGB;
538 FSetPixelAtProc := @InternalSetPixelAtWithoutAlphaRGB;
539 end else
540 if (RedShiftInBytes = 2) and (GreenShiftInBytes = 1) and
541 (BlueShiftInBytes = 0) then
542 begin
543 FGetPixelAtProc := @InternalGetPixelAtWithoutAlphaBGR;
544 FSetPixelAtProc := @InternalSetPixelAtWithoutAlphaBGR;
545 end;
546 end else
547 begin
548 if (RedShiftInBytes = 0) and (GreenShiftInBytes = 1) and
549 (BlueShiftInBytes = 2) then
550 begin
551 FGetPixelAtProc := @InternalGetPixelAtWithAlphaRGBA;
552 FSetPixelAtProc := @InternalSetPixelAtWithAlphaRGBA;
553 end else
554 if (RedShiftInBytes = 2) and (GreenShiftInBytes = 1) and
555 (BlueShiftInBytes = 0) then
556 begin
557 FGetPixelAtProc := @InternalGetPixelAtWithAlphaBGRA;
558 FSetPixelAtProc := @InternalSetPixelAtWithAlphaBGRA;
559 end;
560 end;
561 end;
562 end;
563
564 FHasPixelAtProc := (FGetPixelAtProc<>nil) and (FSetPixelAtProc <> nil);
565 end;
566
567 procedure TIntfFreeTypeDrawer.RenderDirectly( x,y,tx: integer;
568 data: pointer );
569 var psrc: pbyte;
570 c: TFPColor;
571 pdest: pbyte;
572 step: longword;
573 tempValue: byte;
574 begin
575 if Destination <> nil then
576 begin
577 //ensure rendering in bounds
578 if (y < 0) or (y >= Destination.height) or (x < 0) or (x > Destination.width-tx) then exit;
579
580 c := FColor;
581 psrc := pbyte(data);
582
583 if FHasPixelAtProc then
584 begin
585 step := FPixelSizeInBytes;
586 pdest := UnclippedGetPixelAddress(x,y);
587 inc(psrc,tx);
588 while tx > 0 do
589 begin
590 tempValue := (psrc-tx)^;
591 if tempValue <> 0 then
592 DrawPixelAt(pdest,c,tempValue);
593 inc(pdest,step);
594 dec(tx);
595 end;
596 end else
597 while tx > 0 do
598 begin
599 tempValue := psrc^;
600 if tempValue <> 0 then
601 begin
602 c.alpha:= FColor.alpha * tempValue div 255;
603 UnclippedDrawPixel(x,y,c);
604 end;
605 inc(psrc);
606 inc(x);
607 dec(tx);
608 end;
609 end;
610 end;
611
612 procedure TIntfFreeTypeDrawer.RenderDirectlyClearType(x, y, tx: integer; data: pointer);
613 var xb: integer;
614 psrc: pbyte;
615 Cr,Cg,Cb: byte;
616 pdest: pbyte;
617 step: longword;
618 begin
619 if Destination <> nil then
620 begin
621 //ClearType position in third of pixels horizontally (multiple of 3)
622 x := x div 3;
623 tx := tx div 3;
624 //ensure rendering in bounds
625 if (y < 0) or (y >= Destination.height) or (x < 0) or (x > Destination.width-tx) then exit;
626 if tx=0 then exit;
627
628 psrc := pbyte(data);
629 Cr := (psrc^ + psrc^ + (psrc+1)^) div 3;
630 Cg := (psrc^+ (psrc+1)^ + (psrc+2)^) div 3;
631 if tx > 1 then
632 Cb := ((psrc+1)^ + (psrc+2)^ + (psrc+3)^) div 3
633 else
634 Cb := ((psrc+1)^ + (psrc+2)^ + (psrc+2)^) div 3;
635
636 if FHasPixelAtProc then
637 begin
638 step := FPixelSizeInBytes;
639 pdest := UnclippedGetPixelAddress(x,y);
640 if Cr+Cg+Cb <> 0 then
641 ClearTypePixelAt(pdest,Cr,Cg,Cb, FColor);
642 inc(pdest,step);
643 inc(psrc,3);
644 for xb := 1 to tx-2 do
645 begin
646 Cr := ((psrc-1)^+ psrc^ + (psrc+1)^) div 3;
647 Cg := (psrc^+ (psrc+1)^ + (psrc+2)^) div 3;
648 Cb := ((psrc+1)^ + (psrc+2)^ + (psrc+3)^) div 3;
649 if Cr+Cg+Cb <> 0 then
650 ClearTypePixelAt(pdest,Cr,Cg,Cb, FColor);
651 inc(pdest,step);
652 inc(psrc,3);
653 end;
654 if tx > 1 then
655 begin
656 Cr := ((psrc-1)^+ psrc^ + (psrc+1)^) div 3;
657 Cg := (psrc^+ (psrc+1)^ + (psrc+2)^) div 3;
658 Cb := ((psrc+1)^ + (psrc+2)^ + (psrc+2)^) div 3;
659 if Cr+Cg+Cb <> 0 then
660 ClearTypePixelAt(pdest,Cr,Cg,Cb, FColor);
661 end;
662 end else
663 begin
664 if Cr+Cg+Cb <> 0 then
665 UnclippedClearTypePixel(x,y,Cr,Cg,Cb, FColor);
666 inc(x);
667 inc(psrc,3);
668 for xb := 1 to tx-2 do
669 begin
670 Cr := ((psrc-1)^+ psrc^ + (psrc+1)^) div 3;
671 Cg := (psrc^+ (psrc+1)^ + (psrc+2)^) div 3;
672 Cb := ((psrc+1)^ + (psrc+2)^ + (psrc+3)^) div 3;
673 if Cr+Cg+Cb <> 0 then
674 UnclippedClearTypePixel(x,y,Cr,Cg,Cb, FColor);
675 inc(x);
676 inc(psrc,3);
677 end;
678 if tx > 1 then
679 begin
680 Cr := ((psrc-1)^+ psrc^ + (psrc+1)^) div 3;
681 Cg := (psrc^+ (psrc+1)^ + (psrc+2)^) div 3;
682 Cb := ((psrc+1)^ + (psrc+2)^ + (psrc+2)^) div 3;
683 if Cr+Cg+Cb <> 0 then
684 UnclippedClearTypePixel(x,y,Cr,Cg,Cb, FColor);
685 end;
686 end;
687 end;
688 end;
689
690 procedure TIntfFreeTypeDrawer.InternalMergeColorOver(var merge: TFPColor;
691 const c: TFPColor; calpha: word);
692 var
693 a1f, a2f, a12, a12m: cardinal;
694 begin
695 if calpha = 0 then exit;
696 a12 := 65534 - ((not merge.alpha) * (not calpha) shr 16);
697 a12m := a12 shr 1;
698
699 a1f := merge.alpha * (not calpha) shr 16;
700 a2f := calpha - (calpha shr 15);
701
702 merge.red := (merge.red * a1f + c.red * a2f + a12m) div a12;
703 merge.green := (merge.green * a1f + c.green * a2f + a12m) div a12;
704 merge.blue := (merge.blue * a1f + c.blue * a2f + a12m) div a12;
705 merge.alpha := a12 + (a12 shr 15);
706 end;
707
708 constructor TIntfFreeTypeDrawer.Create(ADestination: TLazIntfImage);
709 begin
710 Destination := ADestination;
711 ClearTypeRGBOrder:= true;
712 end;
713
714 procedure TIntfFreeTypeDrawer.ClippedDrawPixel(x, y: integer; const c: TFPColor
715 );
716 begin
717 if (x < 0) or (y < 0) or (x >= Destination.Width) or (y >= Destination.Height) then exit;
718 UnclippedDrawPixel(x,y,c);
719 end;
720
721 procedure TIntfFreeTypeDrawer.DrawText(AText: string; AFont: TFreeTypeRenderableFont; x, y: single;
722 AColor: TFPColor);
723 begin
724 FColor := AColor;
725 if AFont.ClearType then
726 AFont.RenderText(AText, x, y, rect(0,0,Destination.Width,Destination.Height), @RenderDirectlyClearType)
727 else
728 AFont.RenderText(AText, x, y, rect(0,0,Destination.Width,Destination.Height), @RenderDirectly);
729 end;
730
731 procedure TIntfFreeTypeDrawer.DrawGlyph(AGlyph: integer;
732 AFont: TFreeTypeRenderableFont; x, y: single; AColor: TFPColor);
733 var f: TFreeTypeFont;
734 begin
735 if AFont is TFreeTypeFont then
736 begin
737 f := TFreeTypeFont(AFont);
738 FColor := AColor;
739 if AFont.ClearType then
740 f.RenderGlyph(AGlyph, x, y, rect(0,0,Destination.Width,Destination.Height), @RenderDirectlyClearType)
741 else
742 f.RenderGlyph(AGlyph, x, y, rect(0,0,Destination.Width,Destination.Height), @RenderDirectly);
743 end;
744 end;
745
746 destructor TIntfFreeTypeDrawer.Destroy;
747 begin
748 inherited Destroy;
749 end;
750
751 end.
752
753
754