1 {
2 *****************************************************************************
3 This file is part of LazUtils.
4
5 See the file COPYING.modifiedLGPL.txt, included in this distribution,
6 for details about the license.
7 *****************************************************************************
8 }
9 unit LazFreeTypeFPImageDrawer;
10
11 {$mode objfpc}{$H+}
12
13 interface
14
15 uses
16 Classes, SysUtils, EasyLazFreeType, FPimage;
17
18 type
19 TLazIntfImageGetPixelAtProc = procedure(p: pointer; out Color: TFPColor);
20 TLazIntfImageSetPixelAtProc = procedure(p: pointer; const Color: TFPColor);
21
22 { TFPImageFreeTypeDrawer }
23
24 TFPImageFreeTypeDrawer = class(TFreeTypeDrawer)
25 private
26 FColor: TFPColor;
27 FCurX,FCurY: integer;
28 protected
29 FImage: TFPCustomImage;
30 procedure MoveToPixel(x,y: integer); virtual;
GetCurrentColornull31 function GetCurrentColor: TFPColor; virtual;
32 procedure SetCurrentColorAndMoveRight(const AColor: TFPColor); virtual;
33 procedure MoveRight; virtual;
GetClipRectnull34 function GetClipRect: TRect; virtual;
35 protected
36 procedure RenderDirectly(x, y, tx: integer; data: pointer);
37 procedure RenderDirectlyClearType(x, y, tx: integer; data: pointer);
38 procedure InternalMergeColorOver(var merge: TFPColor; const c: TFPColor; calpha: word); inline;
39 procedure MergeColorOver(var merge: TFPColor; const c: TFPColor); inline;
40 procedure MergeColorOver(var merge: TFPColor; const c: TFPColor; ApplyOpacity: byte); inline;
41 procedure DrawPixelAndMoveRight(const c: TFPColor);
42 procedure DrawPixelAndMoveRight(const c: TFPColor; applyOpacity: byte);
43 procedure ClearTypePixelAndMoveRight(Cr,Cg,Cb: byte; const Color: TFPColor);
44 procedure UnclippedDrawPixel(x,y: integer; const c: TFPColor);
45 public
46 ClearTypeRGBOrder: boolean;
47 constructor Create(AImage: TFPCustomImage); virtual;
48 procedure DrawPixel(x,y: integer; const c: TFPColor);
49 procedure ClearTypePixel(x,y: integer; Cr,Cg,Cb: byte; const Color: TFPColor);
50 procedure SetVertLine(x,y1,y2: integer; const c: 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 FillPixels(const c: TFPColor);
55 procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); override;
56 procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); override;
57 destructor Destroy; override;
58 property Image: TFPCustomImage read FImage;
59 end;
60
61 { TFPMemoryImageWithScanline }
62
63 TFPMemoryImageWithScanline = class(TFPMemoryImage)
64 protected
GetScanlinenull65 function GetScanline(y: integer): PFPColor;
66 procedure SetUsePalette ({%H-}Value:boolean);override;
67 public
68 property ScanLine[y: integer]: PFPColor read GetScanline;
69 end;
70
71 { TFPImageWithScanlineFreeTypeDrawer }
72
73 TFPImageWithScanlineFreeTypeDrawer= class(TFPImageFreeTypeDrawer)
74 protected
75 FCurrentColor: PFPColor;
76 procedure MoveToPixel(x,y: integer); override;
GetCurrentColornull77 function GetCurrentColor: TFPColor; override;
78 procedure SetCurrentColorAndMoveRight(const AColor: TFPColor); override;
79 procedure MoveRight; override;
GetClipRectnull80 function GetClipRect: TRect; override;
81 public
82 constructor Create(AImage: TFPCustomImage); override; //requires TFPMemoryImageWithScanline
83 end;
84
85 implementation
86
87 { TFPImageFreeTypeDrawer }
88
89 procedure TFPImageFreeTypeDrawer.MergeColorOver(var merge: TFPColor; const c: TFPColor);
90 begin
91 InternalMergeColorOver(merge,c,c.alpha);
92 end;
93
94 procedure TFPImageFreeTypeDrawer.MergeColorOver(var merge: TFPColor;
95 const c: TFPColor; ApplyOpacity: byte);
96 var
97 calpha: longword;
98 begin
99 calpha := c.alpha*applyOpacity div 255;
100 InternalMergeColorOver(merge,c,calpha);
101 end;
102
103 procedure TFPImageFreeTypeDrawer.UnclippedDrawPixel(x, y: integer; const c: TFPColor);
104 var
105 merge: TFPColor;
106 begin
107 if c.alpha = 0 then exit;
108 MoveToPixel(x,y);
109 if c.alpha = $ffff then
110 SetCurrentColorAndMoveRight(c)
111 else
112 begin
113 merge := GetCurrentColor;
114 MergeColorOver(merge,c);
115 SetCurrentColorAndMoveRight(merge);
116 end;
117 end;
118
119 procedure TFPImageFreeTypeDrawer.DrawPixelAndMoveRight(const c: TFPColor; applyOpacity: byte);
120 var
121 merge: TFPColor;
122 calpha: longword;
123 begin
124 calpha := c.alpha*applyOpacity div 255;
125 if calpha = 0 then
126 begin
127 MoveRight;
128 exit;
129 end;
130 if calpha = $ffff then
131 SetCurrentColorAndMoveRight(c)
132 else
133 begin
134 merge := GetCurrentColor;
135 InternalMergeColorOver(merge,c,calpha);
136 SetCurrentColorAndMoveRight(merge);
137 end;
138 end;
139
140 procedure TFPImageFreeTypeDrawer.DrawPixelAndMoveRight(const c: TFPColor);
141 var
142 merge: TFPColor;
143 begin
144 if (c.alpha = 0) then
145 begin
146 MoveRight;
147 exit;
148 end;
149 if (c.alpha = $ffff) then
150 SetCurrentColorAndMoveRight(c)
151 else
152 begin
153 merge := GetCurrentColor;
154 InternalMergeColorOver(merge,c,c.alpha);
155 SetCurrentColorAndMoveRight(merge);
156 end;
157 end;
158
159 procedure TFPImageFreeTypeDrawer.SetVertLine(x, y1, y2: integer;
160 const c: TFPColor);
161 var y: integer;
162 begin
163 with GetClipRect do
164 begin
165 if (x < Left) or (x >= Right) then exit;
166 if (y1 > y2) then
167 begin
168 y := y1;
169 y1:= y2;
170 y2 := y;
171 end;
172 if y1 < Top then y1 := Top;
173 if y2 >= Bottom then y2 := Bottom-1;
174 end;
175 for y := y1 to y2 do
176 begin
177 MoveToPixel(x,y1);
178 SetCurrentColorAndMoveRight(c);
179 end;
180 end;
181
182 procedure TFPImageFreeTypeDrawer.DrawVertLine(x, y1, y2: integer; const c: TFPColor
183 );
184 var y: integer;
185 begin
186 with GetClipRect do
187 begin
188 if (x < Left) or (x >= Right) then exit;
189 if (y1 > y2) then
190 begin
191 y := y1;
192 y1:= y2;
193 y2 := y;
194 end;
195 if y1 < Top then y1 := Top;
196 if y2 >= Bottom then y2 := Bottom-1;
197 end;
198 for y := y1 to y2 do
199 UnclippedDrawPixel(x,y, c);
200 end;
201
202 procedure TFPImageFreeTypeDrawer.SetHorizLine(x1, y, x2: integer; const c: TFPColor);
203 var i: integer;
204 begin
205 with GetClipRect do
206 begin
207 if (y < Top) or (y >= Bottom) then exit;
208 if (x1 > x2) then
209 begin
210 i := x1;
211 x1:= x2;
212 x2 := i;
213 end;
214 if x1 < Left then x1 := Left;
215 if x2 >= Right then x2 := Right-1;
216 end;
217 MoveToPixel(x1,y);
218 i := x2-x1+1;
219 while i > 0 do
220 begin
221 SetCurrentColorAndMoveRight(c);
222 dec(i);
223 end;
224 end;
225
226 procedure TFPImageFreeTypeDrawer.DrawHorizLine(x1, y, x2: integer;
227 const c: TFPColor);
228 var i: integer;
229 begin
230 with GetClipRect do
231 begin
232 if (y < Top) or (y >= Bottom) then exit;
233 if (x1 > x2) then
234 begin
235 i := x1;
236 x1:= x2;
237 x2 := i;
238 end;
239 if x1 < Left then x1 := Left;
240 if x2 >= Right then x2 := Right-1;
241 end;
242 MoveToPixel(x1,y);
243 i := x2-x1+1;
244 while i > 0 do
245 begin
246 DrawPixelAndMoveRight(c);
247 dec(i);
248 end;
249 end;
250
251 procedure TFPImageFreeTypeDrawer.FillPixels(const c: TFPColor);
252 var yb: integer;
253 begin
254 with GetClipRect do
255 begin
256 for yb := Top to Bottom-1 do
257 SetHorizLine(Left,yb,Right-1,c);
258 end;
259 end;
260
261 procedure TFPImageFreeTypeDrawer.ClearTypePixel(x, y: integer; Cr, Cg, Cb: byte; const Color: TFPColor);
262 begin
263 with GetClipRect do
264 if (x < Left) or (y < Top) or (x >= Right) or (y >= Bottom) then exit;
265
266 MoveToPixel(x,y);
267 ClearTypePixelAndMoveRight(Cr,Cg,Cb,Color);
268 end;
269
270 procedure TFPImageFreeTypeDrawer.ClearTypePixelAndMoveRight(Cr, Cg, Cb: byte;
271 const Color: TFPColor);
272 var merge,mergeClearType: TFPColor;
273 acc: longword;
274 keep,dont_keep: word;
275 begin
276 Cr := Cr*(color.alpha+1) shr 16;
277 Cg := Cg*(color.alpha+1) shr 16;
278 Cb := Cb*(color.alpha+1) shr 16;
279 acc := Cr+Cg+Cb;
280 if acc = 0 then exit;
281
282 merge := GetCurrentColor;
283 mergeClearType.red := (merge.red * (not byte(Cr)) +
284 color.red * Cr + 128) div 255;
285 mergeClearType.green := (merge.green * (not byte(Cg)) +
286 color.green * Cg + 128) div 255;
287 mergeClearType.blue := (merge.blue * (not byte(Cb)) +
288 color.blue * Cb + 128) div 255;
289 mergeClearType.alpha := merge.alpha;
290
291 if (mergeClearType.alpha = $ffff) then
292 SetCurrentColorAndMoveRight(mergeClearType)
293 else
294 begin
295 if Cg <> 0 then
296 MergeColorOver(merge,color,Cg);
297 dont_keep := mergeClearType.alpha shr 1;
298 if dont_keep > 0 then
299 begin
300 keep := 32767 - dont_keep;
301 merge.red := (merge.red * keep + mergeClearType.red * dont_keep) div 32767;
302 merge.green := (merge.green * keep + mergeClearType.green * dont_keep) div 32767;
303 merge.blue := (merge.blue * keep + mergeClearType.blue * dont_keep) div 32767;
304 merge.alpha := mergeClearType.alpha + ((not mergeClearType.alpha)*merge.alpha div 65535);
305 end;
306 SetCurrentColorAndMoveRight(merge);
307 end;
308 end;
309
310 procedure TFPImageFreeTypeDrawer.MoveToPixel(x, y: integer);
311 begin
312 FCurX := x;
313 FCurY := y;
314 end;
315
GetCurrentColornull316 function TFPImageFreeTypeDrawer.GetCurrentColor: TFPColor;
317 begin
318 result := FImage.Colors[FCurX,FCurY];
319 end;
320
321 procedure TFPImageFreeTypeDrawer.SetCurrentColorAndMoveRight(
322 const AColor: TFPColor);
323 begin
324 FImage.Colors[FCurX,FCurY] := AColor;
325 Inc(FCurX);
326 end;
327
328 procedure TFPImageFreeTypeDrawer.MoveRight;
329 begin
330 inc(FCurX);
331 end;
332
TFPImageFreeTypeDrawer.GetClipRectnull333 function TFPImageFreeTypeDrawer.GetClipRect: TRect;
334 begin
335 result := rect(0,0,FImage.Width,FImage.Height);
336 end;
337
338 procedure TFPImageFreeTypeDrawer.RenderDirectly( x,y,tx: integer;
339 data: pointer );
340 var psrc: pbyte;
341 c: TFPColor;
342 tempValue: byte;
343 begin
344 //ensure rendering in bounds
345 with GetClipRect do
346 if (y < Top) or (y >= Bottom) or (x < Left) or (x > Right-tx) then exit;
347
348 c := FColor;
349 psrc := pbyte(data);
350
351 MoveToPixel(x,y);
352 inc(psrc,tx);
353 while tx > 0 do
354 begin
355 tempValue := (psrc-tx)^;
356 if tempValue <> 0 then
357 DrawPixelAndMoveRight(c,tempValue)
358 else
359 MoveRight;
360 dec(tx);
361 end;
362 end;
363
364 procedure TFPImageFreeTypeDrawer.RenderDirectlyClearType(x, y, tx: integer; data: pointer);
365 var xb: integer;
366 psrc: pbyte;
367 Cr,Cg,Cb: byte;
368 begin
369 //ClearType position in third of pixels horizontally (multiple of 3)
370 x := x div 3;
371 tx := tx div 3;
372 //ensure rendering in bounds
373 with GetClipRect do
374 if (y < Top) or (y >= Bottom) or (x < Left) or (x > Right-tx) then exit;
375 if tx=0 then exit;
376
377 psrc := pbyte(data);
378 Cr := (psrc^ + psrc^ + (psrc+1)^) div 3;
379 Cg := (psrc^+ (psrc+1)^ + (psrc+2)^) div 3;
380 if tx > 1 then
381 Cb := ((psrc+1)^ + (psrc+2)^ + (psrc+3)^) div 3
382 else
383 Cb := ((psrc+1)^ + (psrc+2)^ + (psrc+2)^) div 3;
384
385 MoveToPixel(x,y);
386 if Cr+Cg+Cb <> 0 then
387 ClearTypePixelAndMoveRight(Cr,Cg,Cb, FColor)
388 else
389 MoveRight;
390 inc(psrc,3);
391 for xb := 1 to tx-2 do
392 begin
393 Cr := ((psrc-1)^+ psrc^ + (psrc+1)^) div 3;
394 Cg := (psrc^+ (psrc+1)^ + (psrc+2)^) div 3;
395 Cb := ((psrc+1)^ + (psrc+2)^ + (psrc+3)^) div 3;
396 if Cr+Cg+Cb <> 0 then
397 ClearTypePixelAndMoveRight(Cr,Cg,Cb, FColor)
398 else
399 MoveRight;
400 inc(psrc,3);
401 end;
402 if tx > 1 then
403 begin
404 Cr := ((psrc-1)^+ psrc^ + (psrc+1)^) div 3;
405 Cg := (psrc^+ (psrc+1)^ + (psrc+2)^) div 3;
406 Cb := ((psrc+1)^ + (psrc+2)^ + (psrc+2)^) div 3;
407 if Cr+Cg+Cb <> 0 then
408 ClearTypePixelAndMoveRight(Cr,Cg,Cb, FColor);
409 end;
410 end;
411
412 procedure TFPImageFreeTypeDrawer.InternalMergeColorOver(var merge: TFPColor;
413 const c: TFPColor; calpha: word);
414 var
415 a1f, a2f, a12, a12m: cardinal;
416 begin
417 if calpha = 0 then exit;
418 a12 := 65534 - ((not merge.alpha) * (not calpha) shr 16);
419 a12m := a12 shr 1;
420
421 a1f := merge.alpha * (not calpha) shr 16;
422 a2f := calpha - (calpha shr 15);
423
424 merge.red := (merge.red * a1f + c.red * a2f + a12m) div a12;
425 merge.green := (merge.green * a1f + c.green * a2f + a12m) div a12;
426 merge.blue := (merge.blue * a1f + c.blue * a2f + a12m) div a12;
427 merge.alpha := a12 + (a12 shr 15);
428 end;
429
430 constructor TFPImageFreeTypeDrawer.Create(AImage: TFPCustomImage);
431 begin
432 ClearTypeRGBOrder:= true;
433 FImage := AImage;
434 end;
435
436 procedure TFPImageFreeTypeDrawer.DrawPixel(x, y: integer; const c: TFPColor
437 );
438 begin
439 with GetClipRect do
440 if (x < Left) or (y < Top) or (x >= Right) or (y >= Bottom) then exit;
441 UnclippedDrawPixel(x,y,c);
442 end;
443
444 procedure TFPImageFreeTypeDrawer.DrawText(AText: string; AFont: TFreeTypeRenderableFont; x, y: single;
445 AColor: TFPColor);
446 begin
447 FColor := AColor;
448 if AFont.ClearType then
449 AFont.RenderText(AText, x, y, GetClipRect, @RenderDirectlyClearType)
450 else
451 AFont.RenderText(AText, x, y, GetClipRect, @RenderDirectly);
452 end;
453
454 destructor TFPImageFreeTypeDrawer.Destroy;
455 begin
456 inherited Destroy;
457 end;
458
459 procedure TFPImageFreeTypeDrawer.DrawGlyph(AGlyph: integer;
460 AFont: TFreeTypeRenderableFont; x, y: single; AColor: TFPColor);
461 var f: TFreeTypeFont;
462 begin
463 if AFont is TFreeTypeFont then
464 begin
465 f := TFreeTypeFont(AFont);
466 FColor := AColor;
467 if AFont.ClearType then
468 f.RenderGlyph(AGlyph, x, y, GetClipRect, @RenderDirectlyClearType)
469 else
470 f.RenderGlyph(AGlyph, x, y, GetClipRect, @RenderDirectly);
471 end;
472 end;
473
474 { TFPImageWithScanlineFreeTypeDrawer }
475
476 procedure TFPImageWithScanlineFreeTypeDrawer.MoveToPixel(x, y: integer);
477 begin
478 FCurrentColor:= TFPMemoryImageWithScanline(FImage).ScanLine[y]+x;
479 end;
480
GetCurrentColornull481 function TFPImageWithScanlineFreeTypeDrawer.GetCurrentColor: TFPColor;
482 begin
483 result := FCurrentColor^;
484 end;
485
486 procedure TFPImageWithScanlineFreeTypeDrawer.SetCurrentColorAndMoveRight(
487 const AColor: TFPColor);
488 begin
489 FCurrentColor^ := AColor;
490 inc(FCurrentColor);
491 end;
492
493 procedure TFPImageWithScanlineFreeTypeDrawer.MoveRight;
494 begin
495 inc(FCurrentColor);
496 end;
497
TFPImageWithScanlineFreeTypeDrawer.GetClipRectnull498 function TFPImageWithScanlineFreeTypeDrawer.GetClipRect: TRect;
499 begin
500 result := rect(0,0,FImage.Width,FImage.Height);
501 end;
502
503 constructor TFPImageWithScanlineFreeTypeDrawer.Create(AImage: TFPCustomImage);
504 begin
505 inherited Create(AImage);
506 if not (AImage is TFPMemoryImageWithScanline) then
507 raise Exception.Create('Scanline not available');
508 end;
509
510 { TFPMemoryImageWithScanline }
511
TFPMemoryImageWithScanline.GetScanlinenull512 function TFPMemoryImageWithScanline.GetScanline(y: integer): PFPColor;
513 begin
514 if (y < 0) or (y >= Height) then
515 raise ERangeError.Create('Scanline out of bounds');
516 result := PFPColor(FData)+(y*Width);
517 end;
518
519 procedure TFPMemoryImageWithScanline.SetUsePalette(Value: boolean);
520 begin
521 if Value then
522 raise Exception.Create('Palette not supported with scanlines');
523 end;
524
525 end.
526
527
528