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