1 {
2 /***************************************************************************
3 lazcanvas.pas
4 ---------------
5
6 ***************************************************************************/
7
8 *****************************************************************************
9 This file is part of the Lazarus Component Library (LCL)
10
11 See the file COPYING.modifiedLGPL.txt, included in this distribution,
12 for details about the license.
13 *****************************************************************************
14
15 Author: Felipe Monteiro de Carvalho
16
17 Abstract:
18 Classes and functions for extending TFPImageCanvas to support more stretching
19 filters and to support all features from the LCL TCanvas
20
21 TLazCanvas also fixes various small problems and incompatibilities between
22 TFPImageCanvas versions, making the interface smoother for its users
23
24 Dont use anything from the LCL here as this unit should be kept strictly independent
25 only LCLProc for DebugLn is allowed, but only during debuging
26 }
27 unit LazCanvas;
28
29 {$mode objfpc}{$H+}
30 { $define lazcanvas_debug}
31 { $define lazcanvas_profiling}
32 {$ifndef Darwin}// Strangely the new fast copy crashes in Mac OS X in apps with sub-controls
33 {$define lazcanvas_new_fast_copy}
34 {$endif}
35
36 interface
37
38 uses
39 // RTL
40 Classes, SysUtils, contnrs, Math,
41 // FCL-Image
42 fpimgcanv, fpcanvas, fpimage, clipping, pixtools, fppixlcanv,
43 // LCL
44 IntfGraphics, LazRegions
45 {$if defined(lazcanvas_debug) or defined(lazcanvas_profiling)}
46 , LazSysUtils, LCLProc
47 {$endif}
48 ;
49
50 type
51
52 TLazCanvasImageFormat = (
53 clfOther,
54 clfRGB16_R5G6B5,
55 clfRGB24, clfRGB24UpsideDown, clfBGR24,
56 clfBGRA32, clfRGBA32, clfARGB32);
57
58 { TFPSharpInterpolation }
59
60 // This does a very sharp and square interpolation for stretching,
61 // similar to StretchBlt from the Windows API
62 TFPSharpInterpolation = class (TFPCustomInterpolation)
63 protected
64 procedure Execute (x,y,w,h : integer); override;
65 end;
66
67 { TLazCanvasState }
68
69 TLazCanvasState = class
70 public
71 Brush: TFPCustomBrush;
72 Pen: TFPCustomPen;
73 Font: TFPCustomFont;
74 BaseWindowOrg: TPoint;
75 WindowOrg: TPoint;
76 Clipping: Boolean;
77 ClipRegion: TFPCustomRegion;
78 destructor Destroy; override;
79 end;
80
81 { TLazCanvas }
82
83 TLazCanvas = class(TFPImageCanvas)
84 private
85 FAssignedBrush: TFPCustomBrush;
86 FAssignedFont: TFPCustomFont;
87 FAssignedPen: TFPCustomPen;
88 FBaseWindowOrg: TPoint;
89 {$if defined(ver2_6)}
90 FLazClipRegion: TFPCustomRegion;
91 {$endif}
92 FWindowOrg: TPoint; // already in absolute coords with BaseWindowOrg summed up
93 GraphicStateList: TFPList; // TLazCanvasState
GetAssignedBrushnull94 function GetAssignedBrush: TFPCustomBrush;
GetAssignedPennull95 function GetAssignedPen: TFPCustomPen;
GetAssignedFontnull96 function GetAssignedFont: TFPCustomFont;
GetWindowOrgnull97 function GetWindowOrg: TPoint;
98 procedure SetWindowOrg(AValue: TPoint);
99 protected
100 procedure SetColor (x,y:integer; const AValue:TFPColor); override;
DoCreateDefaultFontnull101 function DoCreateDefaultFont : TFPCustomFont; override;
102 // Routines broken/unimplemented/incompatible in FPC
103 procedure DoRectangle (const Bounds:TRect); override;
104 procedure DoRectangleFill (const Bounds:TRect); override;
105 procedure DoPolygonFill (const points:array of TPoint); override;
106 // Routines which don't work with out extended clipping in TFPImageCanvas
107 procedure DoLine (x1,y1,x2,y2:integer); override;
108 // Other abstract routines that need implementation
109 procedure DoCopyRect(x,y:integer; canvas:TFPCustomCanvas; Const SourceRect:TRect); override;
110 procedure DoDraw(x,y:integer; const AImage: TFPCustomImage); override;
111 public
112 HasNoImage: Boolean;
113 NativeDC: PtrInt; // Utilized by LCL-CustomDrawn
114 ExtraFontData: TObject; // Utilized by LCL-CustomDrawn
115 ImageFormat: TLazCanvasImageFormat; // Utilized by LCL-CustomDrawn for speeding up drawing
116 SelectedBitmap: TObject; // Utilized by LCL-CustomDrawn, type TCDBitmap
117 constructor create (AnImage : TFPCustomImage);
118 destructor destroy; override;
119 procedure SetLazClipRegion(ARegion: TLazRegion);
120 // Canvas states list
121 function SaveState: Integer;
122 procedure RestoreState(AIndex: Integer);
123 // A simple operation to bring the Canvas in the default LCL TCanvas state
124 procedure ResetCanvasState;
125 // Alpha blending operations
126 procedure AlphaBlend(ASource: TLazCanvas;
127 const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
128 procedure AlphaBlendIgnoringDestPixels(ASource: TLazCanvas;
129 const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
130 procedure AlphaBlend_Image(ASource: TFPCustomImage;
131 const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
132 procedure DoDrawImage(x,y:integer; const AImage: TFPCustomImage);
133 procedure CanvasCopyRect(ASource: TFPCustomCanvas;
134 const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
135 // Fills the entire drawing with a color
136 // AIgnoreClippingAndWindowOrg speeds up the drawing a lot, but it is dangerous,
137 // don't use it unless you know what you are doing!
138 procedure FillColor(AColor: TFPColor; AIgnoreClippingAndWindowOrg: Boolean = False);
139 // Utilized by LCLIntf.SelectObject and by RestoreState
140 // This needed to be added because Pen/Brush.Assign raises exceptions
141 procedure AssignPenData(APen: TFPCustomPen);
142 procedure AssignBrushData(ABrush: TFPCustomBrush);
143 procedure AssignFontData(AFont: TFPCustomFont);
144 // These properties are utilized to implement LCLIntf.SelectObject
145 // to keep track of which brush handle was assigned to this canvas
146 // They are not utilized by TLazCanvas itself
147 property AssignedPen: TFPCustomPen read GetAssignedPen write FAssignedPen;
148 property AssignedBrush: TFPCustomBrush read GetAssignedBrush write FAssignedBrush;
149 property AssignedFont: TFPCustomFont read GetAssignedFont write FAssignedFont;
150 //
151 // SetWindowOrg operations will be relative to BaseWindowOrg,
152 // This is very useful for implementing the non-native wincontrol,
153 // because operations of SetWindowOrg inside a non-native wincontrol will be
154 // based upon the BaseWindowOrg which is set relative to the Form canvas
155 property BaseWindowOrg: TPoint read FBaseWindowOrg write FBaseWindowOrg;
156 {$if defined(ver2_6)}
157 property ClipRegion: TFPCustomRegion read FLazClipRegion write FLazClipRegion;
158 {$endif}
159 property WindowOrg: TPoint read GetWindowOrg write SetWindowOrg;
160 end;
161
162 implementation
163
164 { TLazCanvasState }
165
166 destructor TLazCanvasState.Destroy;
167 begin
168 if Brush <> nil then Brush.Free;
169 if Pen <> nil then Pen.Free;
170 inherited Destroy;
171 end;
172
173 { TLazCanvas }
174
TLazCanvas.GetAssignedBrushnull175 function TLazCanvas.GetAssignedBrush: TFPCustomBrush;
176 begin
177 if FAssignedBrush = nil then
178 Result := TFPEmptyBrush.Create
179 else
180 Result := FAssignedBrush;
181 end;
182
GetAssignedPennull183 function TLazCanvas.GetAssignedPen: TFPCustomPen;
184 begin
185 if FAssignedPen = nil then
186 Result := TFPEmptyPen.Create
187 else
188 Result := FAssignedPen;
189 end;
190
GetAssignedFontnull191 function TLazCanvas.GetAssignedFont: TFPCustomFont;
192 begin
193 if FAssignedFont = nil then
194 Result := TFPEmptyFont.Create
195 else
196 Result := FAssignedFont;
197 end;
198
TLazCanvas.GetWindowOrgnull199 function TLazCanvas.GetWindowOrg: TPoint;
200 begin
201 Result := Point(FWindowOrg.X-FBaseWindowOrg.X, FWindowOrg.Y-FBaseWindowOrg.Y)
202 end;
203
204 procedure TLazCanvas.SetWindowOrg(AValue: TPoint);
205 begin
206 FWindowOrg.X := AValue.X+FBaseWindowOrg.X;
207 FWindowOrg.Y := AValue.Y+FBaseWindowOrg.Y;
208 {$ifdef lazcanvas_debug}
209 DebugLn(Format('[TLazCanvas.SetWindowOrg] AValue=%d,%d BaseWindowOrg=%d,%d', [AValue.X, AValue.Y, FBaseWindowOrg.X, FBaseWindowOrg.y]));
210 {$endif}
211 end;
212
213 procedure TLazCanvas.SetColor(x, y: integer; const AValue: TFPColor);
214 var
215 lx, ly: Integer;
216 begin
217 lx := x + FWindowOrg.X;
218 ly := y + FWindowOrg.Y;
219 {$if defined(ver2_6)}
220 if Clipping and (not FLazClipRegion.IsPointInRegion(lx, ly)) then
221 Exit;
222 if (lx >= 0) and (lx < width) and (ly >= 0) and (ly < height) then
223 Image.Colors[lx,ly] := AValue;
224 {$else}
225 if Clipping and (not FClipRegion.IsPointInRegion(lx, ly)) then
226 Exit;
227 if (lx >= 0) and (lx < width) and (ly >= 0) and (ly < height) then
228 FImage.Colors[lx,ly] := AValue;
229 {$endif}
230 end;
231
TLazCanvas.DoCreateDefaultFontnull232 function TLazCanvas.DoCreateDefaultFont: TFPCustomFont;
233 begin
234 result := TFPEmptyFont.Create;
235 Result.Size := 0; // To allow it to use the default platform size
236 Result.FPColor := colBlack;
237 end;
238
239 // The coordinates utilized by DoRectangle in fcl-image are not TCanvas compatible
240 // so we reimplement it here
241 procedure TLazCanvas.DoRectangle (const Bounds:TRect);
242 var pattern : longword;
243
244 procedure CheckLine (x1,y1, x2,y2 : integer);
245 begin
246 // if clipping then
247 // CheckLineClipping (ClipRect, x1,y1, x2,y2);
248 if x1 >= 0 then
249 DrawSolidLine (self, x1,y1, x2,y2, Pen.FPColor)
250 end;
251
252 procedure CheckPLine (x1,y1, x2,y2 : integer);
253 begin
254 // if clipping then
255 // CheckLineClipping (ClipRect, x1,y1, x2,y2);
256 if x1 >= 0 then
257 DrawPatternLine (self, x1,y1, x2,y2, pattern, Pen.FPColor)
258 end;
259
260 var b : TRect;
261 r : integer;
262
263 begin
264 b := bounds;
265 b.right := b.Right-1;
266 b.bottom := b.bottom-1;
267 if pen.style = psSolid then
268 for r := 1 to pen.width do
269 begin
270 CheckLine (b.left,b.top,b.left,b.bottom);
271 CheckLine (b.left,b.bottom,b.right,b.bottom);
272 CheckLine (b.right,b.bottom,b.right,b.top);
273 CheckLine (b.right,b.top,b.left,b.top);
274 DecRect (b);
275 end
276 else if pen.style <> psClear then
277 begin
278 if pen.style = psPattern then
279 pattern := Pen.pattern
280 else
281 pattern := PenPatterns[pen.style];
282 CheckPLine (b.left,b.top,b.left,b.bottom);
283 CheckPLine (b.left,b.bottom,b.right,b.bottom);
284 CheckPLine (b.right,b.bottom,b.right,b.top);
285 CheckPLine (b.right,b.top,b.left,b.top);
286 end;
287 end;
288
289 procedure TLazCanvas.DoRectangleFill(const Bounds: TRect);
290 var
291 b : TRect;
292 begin
293 b := Bounds;
294 SortRect (b);
295
296 // Optimize when filling everything
297 if (b.Left = 0) and (b.Top = 0) and (b.Right = Width) and (b.Bottom = Height)
298 and (Brush.Style = bsSolid) and (FWindowOrg.X = 0) and (FWindowOrg.Y = 0)
299 and ((Clipping=False) {or cliprect=entire area}) then
300 begin
301 FillColor(Brush.FPColor, True);
302 Exit;
303 end;
304
305 case Brush.style of
306 bsSolid : FillRectangleColor (self, b.left,b.top, b.right,b.bottom);
307 bsPattern : FillRectanglePattern (self, b.left,b.top, b.right,b.bottom, brush.pattern);
308 bsImage :
309 if assigned (brush.image) then
310 if RelativeBrushImage then
311 FillRectangleImageRel (self, b.left,b.top, b.right,b.bottom, brush.image)
312 else
313 FillRectangleImage (self, b.left,b.top, b.right,b.bottom, brush.image)
314 else
315 raise PixelCanvasException.Create (sErrNoImage);
316 bsBDiagonal : FillRectangleHashDiagonal (self, b, HashWidth);
317 bsFDiagonal : FillRectangleHashBackDiagonal (self, b, HashWidth);
318 bsCross :
319 begin
320 FillRectangleHashHorizontal (self, b, HashWidth);
321 FillRectangleHashVertical (self, b, HashWidth);
322 end;
323 bsDiagCross :
324 begin
325 FillRectangleHashDiagonal (self, b, HashWidth);
326 FillRectangleHashBackDiagonal (self, b, HashWidth);
327 end;
328 bsHorizontal : FillRectangleHashHorizontal (self, b, HashWidth);
329 bsVertical : FillRectangleHashVertical (self, b, HashWidth);
330 end;
331 end;
332
333 // unimplemented in FPC
334 // algorithm explained here: http://alienryderflex.com/polygon_fill/
335 procedure TLazCanvas.DoPolygonFill(const points: array of TPoint);
336 var
337 lBoundingBox: TRect;
338 x, y, i: integer;
339 // faster version
340 nodes, j, swap, polyCorners: Integer;
341 nodeX: array of Integer;
342 begin
343 if Brush.Style = bsClear then Exit;
344
345 // Find the Bounding Box of the Polygon
346 lBoundingBox := Rect(0, 0, 0, 0);
347 for i := low(Points) to High(Points) do
348 begin
349 lBoundingBox.Left := Min(Points[i].X, lBoundingBox.Left);
350 lBoundingBox.Top := Min(Points[i].Y, lBoundingBox.Top);
351 lBoundingBox.Right := Max(Points[i].X, lBoundingBox.Right);
352 lBoundingBox.Bottom := Max(Points[i].Y, lBoundingBox.Bottom);
353 end;
354
355 // good but very slow polygon fill function
356 {// Now scan all points using IsPointInPolygon
357 for x := lBoundingBox.Left to lBoundingBox.Right do
358 for y := lBoundingBox.Top to lBoundingBox.Bottom do
359 begin
360 if IsPointInPolygon(X, Y, Points) then SetColor(X, Y, Brush.FPColor);
361 end;
362 Exit;
363 }
364
365 // Loop through the rows of the image.
366 polyCorners := Length(points);
367 for y := lBoundingBox.Top to lBoundingBox.Bottom do
368 begin
369 // Build a list of nodes.
370 nodes := 0;
371 j := polyCorners-1;
372 for i := 0 to polyCorners-1 do
373 begin
374 if (points[i].Y < y) and (points[j].Y >= y) or
375 (points[j].Y < y) and (points[i].Y >= Y) then
376 begin
377 SetLength(nodeX, nodes+1);
378 nodeX[nodes] := Round(points[i].X + (y-points[i].Y) / (points[j].Y-points[i].Y) * (points[j].X-points[i].X));
379 Inc(nodes);
380 end;
381 j := i;
382 end;
383
384 // Sort the nodes, via a simple “Bubble” sort.
385 i := 0;
386 while (i<nodes-1) do
387 begin
388 if (nodeX[i]>nodeX[i+1]) then
389 begin
390 swap := nodeX[i];
391 nodeX[i] := nodeX[i+1];
392 nodeX[i+1] := swap;
393 if (i <> 0) then Dec(i);
394 end
395 else
396 Inc(i);
397 end;
398
399 // Fill the pixels between node pairs.
400 i := 0;
401 while i<nodes do
402 begin
403 if (nodeX[i ] >= lBoundingBox.Right) then break;
404 if (nodeX[i+1] > lBoundingBox.Left) then
405 begin
406 if (nodeX[i ] < lBoundingBox.Left) then nodeX[i] := lBoundingBox.Left;
407 if (nodeX[i+1] > lBoundingBox.Right) then nodeX[i+1] := lBoundingBox.Right;
408 for X := nodeX[i] to nodeX[i+1]-1 do
409 SetColor(X, Y, Brush.FPColor);
410 end;
411
412 i := i + 2;
413 end;
414 end;
415 end;
416
417 procedure TLazCanvas.DoLine(x1, y1, x2, y2: integer);
418 procedure DrawOneLine (xx1,yy1, xx2,yy2:integer);
419 begin
420 if Clipping then
421 CheckLineClipping (ClipRect, xx1,yy1, xx2,yy2);
422 DrawSolidLine (self, xx1,yy1, xx2,yy2, Pen.FPColor);
423 end;
424
425 procedure SolidThickLine;
426 var w1, w2, r : integer;
427 MoreHor : boolean;
428 begin
429 // determine lines above and under
430 w1 := pen.width div 2;
431 w2 := w1;
432 if w1+w2 = pen.width then
433 dec (w1);
434 // determine slanting
435 MoreHor := (abs(x2-x1) < abs(y2-y1));
436 if MoreHor then
437 begin // add lines left/right
438 for r := 1 to w1 do
439 DrawOneLine (x1-r,y1, x2-r,y2);
440 for r := 1 to w2 do
441 DrawOneLine (x1+r,y1, x2+r,y2);
442 end
443 else
444 begin // add lines above/under
445 for r := 1 to w1 do
446 DrawOneLine (x1,y1-r, x2,y2-r);
447 for r := 1 to w2 do
448 DrawOneLine (x1,y1+r, x2,y2+r);
449 end;
450 end;
451
452 begin
453 { We can are not clip here because we clip in each drawn pixel
454 or introduce a more complex algorithm to take into account lazregions
455 if Clipping then
456 CheckLineClipping (ClipRect, x1,y1, x2,y2);}
457 case Pen.style of
458 psSolid :
459 begin
460 DrawSolidLine (self, x1,y1, x2,y2, Pen.FPColor);
461 if pen.width > 1 then
462 SolidThickLine;
463 end;
464 psPattern:
465 DrawPatternLine (self, x1,y1, x2,y2, pen.pattern);
466 // Patterned lines have width always at 1
467 psDash, psDot, psDashDot, psDashDotDot :
468 DrawPatternLine (self, x1,y1, x2,y2, PenPatterns[Pen.Style]);
469 end;
470 end;
471
472 procedure TLazCanvas.DoCopyRect(x, y: integer; canvas: TFPCustomCanvas;
473 const SourceRect: TRect);
474 begin
475 CanvasCopyRect(canvas, X, Y, SourceRect.Left, SourceRect.Top,
476 SourceRect.right-SourceRect.Left, SourceRect.Bottom-SourceRect.Top);
477 end;
478
479 procedure TLazCanvas.DoDraw(x, y: integer; const AImage: TFPCustomImage);
480 begin
481 AlphaBlend_Image(AImage, X, Y, 0, 0, AImage.Width, AImage.Height);
482 end;
483
484 constructor TLazCanvas.create(AnImage: TFPCustomImage);
485 begin
486 inherited Create(AnImage);
487 GraphicStateList := TFPList.Create;
488 HasNoImage := AnImage = nil;
489 end;
490
491 destructor TLazCanvas.destroy;
492 begin
493 GraphicStateList.Free;
494 if FAssignedBrush <> nil then FAssignedBrush.Free;
495 if FAssignedPen <> nil then FAssignedPen.Free;
496 inherited destroy;
497 end;
498
499 procedure TLazCanvas.SetLazClipRegion(ARegion: TLazRegion);
500 begin
501 Clipping := True;
502 {$if defined(ver2_6)}
503 ClipRect := TLazRegionRect(ARegion.Parts.Items[0]).Rect;
504 FLazClipRegion := ARegion;
505 {$else}
506 ClipRegion := ARegion;
507 {$endif}
508 end;
509
TLazCanvas.SaveStatenull510 function TLazCanvas.SaveState: Integer;
511 var
512 lState: TLazCanvasState;
513 begin
514 lState := TLazCanvasState.Create;
515
516 lState.Brush := Brush.CopyBrush;
517 lState.Pen := Pen.CopyPen;
518 lState.Font := Font.CopyFont;
519 lState.BaseWindowOrg := BaseWindowOrg;
520 lState.WindowOrg := WindowOrg;
521 lState.Clipping := Clipping;
522
523 Result := GraphicStateList.Add(lState);
524 end;
525
526 // if AIndex is positive, it represents the wished saved dc instance
527 // if AIndex is negative, it's a relative number from last pushed state
528 procedure TLazCanvas.RestoreState(AIndex: Integer);
529 var
530 lState: TLazCanvasState;
531 begin
532 if AIndex < 0 then AIndex := AIndex + GraphicStateList.Count;
533 lState := TLazCanvasState(GraphicStateList.Items[AIndex]);
534 GraphicStateList.Delete(AIndex);
535 if lState = nil then Exit;
536
537 AssignPenData(lState.Pen);
538 AssignBrushData(lState.Brush);
539 AssignFontData(lState.Font);
540 BaseWindowOrg := lState.BaseWindowOrg;
541 WindowOrg := lState.WindowOrg;
542 Clipping := lState.Clipping;
543
544 lState.Free;
545 end;
546
547 procedure TLazCanvas.ResetCanvasState;
548 begin
549 Pen.FPColor := colBlack;
550 Pen.Style := psSolid;
551
552 Brush.FPColor := colWhite;
553 Brush.Style := bsSolid;
554 end;
555
556 procedure TLazCanvas.AlphaBlend(ASource: TLazCanvas;
557 const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
558 var
559 x, y, CurDestX, CurDestY, CurSrcX, CurSrcY: Integer;
560 MaskValue, InvMaskValue: Word;
561 CurColor, SrcColor: TFPColor;
562 lDrawWidth, lDrawHeight: Integer;
563 begin
564 // Take care not to draw outside the destination area
565 lDrawWidth := Min(Self.Width - ADestX, ASource.Width - ASourceX);
566 lDrawHeight := Min(Self.Height - ADestY, ASource.Height - ASourceY);
567 lDrawWidth := Min(lDrawWidth, ASourceWidth);
568 lDrawHeight := Min(lDrawHeight, ASourceHeight);
569 //DebugLn(Format('[TLazCanvas.AlphaBlend] lDrawWidth=%d lDrawHeight=%d',
570 // [lDrawWidth, lDrawHeight]));
571 for y := 0 to lDrawHeight - 1 do
572 begin
573 for x := 0 to lDrawWidth - 1 do
574 begin
575 CurDestX := ADestX + x;
576 CurDestY := ADestY + y;
577 CurSrcX := ASourceX + x;
578 CurSrcY := ASourceY + y;
579
580 // Never draw outside the destination
581 if (CurDestX < 0) or (CurDestY < 0) then Continue;
582
583 MaskValue := ASource.Colors[CurSrcX, CurSrcY].alpha;
584 InvMaskValue := $FFFF - MaskValue;
585
586 if MaskValue = $FFFF then
587 begin
588 Self.Colors[CurDestX, CurDestY] := ASource.Colors[CurSrcX, CurSrcY];
589 end
590 else if MaskValue > $00 then
591 begin
592 CurColor := Self.Colors[CurDestX, CurDestY];
593 SrcColor := ASource.Colors[CurSrcX, CurSrcY];
594
595 CurColor.Red := Round(
596 CurColor.Red * InvMaskValue / $FFFF +
597 SrcColor.Red * MaskValue / $FFFF);
598
599 CurColor.Green := Round(
600 CurColor.Green * InvMaskValue / $FFFF +
601 SrcColor.Green * MaskValue / $FFFF);
602
603 CurColor.Blue := Round(
604 CurColor.Blue * InvMaskValue / $FFFF +
605 SrcColor.Blue * MaskValue / $FFFF);
606
607 CurColor.alpha := alphaOpaque;
608
609 {DebugLn(Format('Alpha blending pixels Old=%d %d Src=%d %d New=%d %d alpha=%d',
610 [Self.Colors[CurDestX, CurDestY].Red, Self.Colors[CurDestX, CurDestY].Green,
611 SrcColor.Red, SrcColor.Green,
612 CurColor.Red, CurColor.Green,
613 MaskValue
614 ]));}
615
616 Self.Colors[CurDestX, CurDestY] := CurColor;
617 end;
618 end;
619 end;
620 end;
621
622 // This is a safer version in case one doesnt trust the destination pixels
623 // It will draw as if the target area contained opaque white
624 procedure TLazCanvas.AlphaBlendIgnoringDestPixels(ASource: TLazCanvas;
625 const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer
626 );
627 var
628 x, y, CurDestX, CurDestY, CurSrcX, CurSrcY: Integer;
629 MaskValue, InvMaskValue: Word;
630 CurColor, SrcColor: TFPColor;
631 lDrawWidth, lDrawHeight: Integer;
632 begin
633 // Take care not to draw outside the destination area
634 lDrawWidth := Min(Self.Width - ADestX, ASource.Width - ASourceX);
635 lDrawHeight := Min(Self.Height - ADestY, ASource.Height - ASourceY);
636 lDrawWidth := Min(lDrawWidth, ASourceWidth);
637 lDrawHeight := Min(lDrawHeight, ASourceHeight);
638 //DebugLn(Format('[TLazCanvas.AlphaBlendIgnoringDestPixels] lDrawWidth=%d lDrawHeight=%d',
639 //[lDrawWidth, lDrawHeight]));
640 for y := 0 to lDrawHeight - 1 do
641 begin
642 for x := 0 to lDrawWidth - 1 do
643 begin
644 CurDestX := ADestX + x;
645 CurDestY := ADestY + y;
646 CurSrcX := ASourceX + x;
647 CurSrcY := ASourceY + y;
648
649 // Never draw outside the destination
650 if (CurDestX < 0) or (CurDestY < 0) then Continue;
651
652 MaskValue := ASource.Colors[CurSrcX, CurSrcY].alpha;
653 InvMaskValue := $FFFF - MaskValue;
654
655 if MaskValue = $FFFF then
656 begin
657 Self.Colors[CurDestX, CurDestY] := ASource.Colors[CurSrcX, CurSrcY];
658 end
659 // Theorically it should be > 0 but we make a filter here to exclude low-alpha pixels
660 // because those cause small white pixels in the image
661 else if MaskValue > $4000 then
662 begin
663 SrcColor := ASource.Colors[CurSrcX, CurSrcY];
664
665 CurColor.Red := InvMaskValue + (SrcColor.Red * MaskValue) div $FFFF;
666 CurColor.Green := InvMaskValue + (SrcColor.Green * MaskValue) div $FFFF;
667 CurColor.Blue := InvMaskValue + (SrcColor.Blue * MaskValue) div $FFFF;
668 CurColor.alpha := alphaOpaque;
669
670 Self.Colors[CurDestX, CurDestY] := CurColor;
671 end;
672 end;
673 end;
674 end;
675
676 procedure TLazCanvas.AlphaBlend_Image(ASource: TFPCustomImage; const ADestX,
677 ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
678 var
679 SrcCanvas: TLazCanvas;
680 begin
681 SrcCanvas := TLazCanvas.Create(ASource);
682 try
683 AlphaBlend(SrcCanvas, ADestX, ADestY,
684 ASourceX, ASourceY, ASourceWidth, ASourceHeight);
685 finally
686 SrcCanvas.Free;
687 end;
688 end;
689
690 procedure TLazCanvas.DoDrawImage(x, y: integer; const AImage: TFPCustomImage);
691 begin
692 DoDraw(x, y, AImage);
693 end;
694
695 procedure TLazCanvas.CanvasCopyRect(ASource: TFPCustomCanvas; const ADestX, ADestY,
696 ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
697 var
698 ALazSource: TLazCanvas absolute ASource;
699 x, y, CurDestX, CurDestY, CurSrcX, CurSrcY: Integer;
700 lDrawWidth, lDrawHeight: Integer;
701 lColor: TFPColor;
702 {$IFDEF lazcanvas_profiling}
703 lTimeStart: TDateTime;
704 {$ENDIF}
705 {$ifdef lazcanvas_new_fast_copy}
706 lScanlineSrc, lScanlineDest: PByte;
707 lBytesPerPixel: Byte;
708 {$ENDIF}
709 begin
710 {$IFDEF lazcanvas_profiling}
711 lTimeStart := NowUTC();
712 {$ENDIF}
713
714 // Take care not to draw outside the source and also not outside the destination area
715 lDrawWidth := Min(Self.Width - ADestX - FWindowOrg.X, ASource.Width - ASourceX);
716 lDrawHeight := Min(Self.Height - ADestY - FWindowOrg.Y, ASource.Height - ASourceY);
717 lDrawWidth := Min(lDrawWidth, ASourceWidth);
718 lDrawHeight := Min(lDrawHeight, ASourceHeight);
719
720 {$ifdef lazcanvas_new_fast_copy}
721 // If the formats match, make a fast copy of the data itself, without pixel conversion
722 if (ASource is TLazCanvas) and
723 (Image is TLazIntfImage) and (ALazSource.Image is TLazIntfImage) and
724 (ImageFormat in [clfRGB24, clfRGB24UpsideDown, clfBGR24, clfBGRA32, clfRGBA32, clfARGB32]) and
725 (ImageFormat = ALazSource.ImageFormat) then
726 begin
727 case ImageFormat of
728 clfRGB24, clfRGB24UpsideDown, clfBGR24: lBytesPerPixel := 3;
729 clfBGRA32, clfRGBA32, clfARGB32: lBytesPerPixel := 4;
730 else
731 lBytesPerPixel := 4;
732 end;
733
734 for y := 0 to lDrawHeight - 1 do
735 begin
736 CurDestY := ADestY + y + FWindowOrg.Y;
737 if CurDestY >= Height then Continue;
738 CurSrcY := ASourceY + y;
739
740 lScanlineSrc := TLazIntfImage(ALazSource.Image).GetDataLineStart(CurSrcY);
741 lScanlineDest := TLazIntfImage(Image).GetDataLineStart(CurDestY);
742 if (lScanlineSrc = nil) or (lScanlineDest = nil) then Break;
743 Inc(lScanlineSrc, (ASourceX)*lBytesPerPixel);
744 Inc(lScanlineDest, (ADestX + FWindowOrg.X)*lBytesPerPixel);
745
746 move(lScanlineSrc^, lScanlineDest^, lBytesPerPixel * lDrawWidth);
747 end;
748 end
749 // General case of copying
750 else
751 {$endif}
752 begin
753 for y := 0 to lDrawHeight - 1 do
754 begin
755 for x := 0 to lDrawWidth - 1 do
756 begin
757 CurDestX := ADestX + x;
758 CurDestY := ADestY + y;
759 CurSrcX := ASourceX + x;
760 CurSrcY := ASourceY + y;
761
762 // Never draw outside the destination
763 if (CurDestX < 0) or (CurDestY < 0) then Continue;
764
765 lColor := ASource.Colors[CurSrcX, CurSrcY];
766 Self.Colors[CurDestX, CurDestY] := lColor;
767 end;
768 end;
769 end;
770
771 {$IFDEF lazcanvas_profiling}
772 DebugLn(Format('[TLazCanvas.CanvasCopyRect] Paint duration: %d ms', [DateTimeToTimeStamp(NowUTC() - lTimeStart).Time]));
773 {$ENDIF}
774 end;
775
776 procedure TLazCanvas.FillColor(AColor: TFPColor;
777 AIgnoreClippingAndWindowOrg: Boolean);
778 var
779 x, y: Integer;
780 begin
781 if AIgnoreClippingAndWindowOrg then
782 begin
783 if Image is TLazIntfImage then
784 TLazIntfImage(Image).FillPixels(AColor)
785 else
786 for y := 0 to Height-1 do
787 for x := 0 to Width-1 do
788 Image.Colors[x, y] := AColor;
789 end
790 else
791 begin
792 for y := 0 to Height-1 do
793 for x := 0 to Width-1 do
794 SetColor(x, y, AColor);
795 end;
796 end;
797
798 procedure TLazCanvas.AssignPenData(APen: TFPCustomPen);
799 begin
800 if APen = nil then Exit;
801 Pen.FPColor := APen.FPColor;
802 Pen.Style := APen.Style;
803 Pen.Width := APen.Width;
804 end;
805
806 procedure TLazCanvas.AssignBrushData(ABrush: TFPCustomBrush);
807 begin
808 if ABrush = nil then Exit;
809 Brush.FPColor := ABrush.FPColor;
810 Brush.Style := ABrush.Style;
811 end;
812
813 procedure TLazCanvas.AssignFontData(AFont: TFPCustomFont);
814 begin
815 if AFont = nil then Exit;
816 Font.FPColor := AFont.FPColor;
817 Font.Name := AFont.Name;
818 Font.Size := AFont.Size;
819 Font.Bold := AFont.Bold;
820 Font.Italic := AFont.Italic;
821 Font.Underline := AFont.Underline;
822 {$IF (FPC_FULLVERSION<=20600)}
823 Font.{%H-}StrikeTrough := AFont.{%H-}StrikeTrough; //old version with typo
824 {$ELSE}
825 Font.StrikeThrough := AFont.StrikeThrough;
826 {$ENDIF}
827 end;
828
829 { TFPWindowsSharpInterpolation }
830
831 procedure TFPSharpInterpolation.Execute(x, y, w, h: integer);
832 // paint Image on Canvas at x,y,w*h
833 var
834 srcx, srcy: Integer; // current coordinates in the source image
835 dx, dy, dw, dh: Integer; // current coordinates in the destination canvas
836 lWidth, lHeight: Integer; // Image size
837 lColor: TFPColor;
838 begin
839 if (w<=0) or (h<=0) or (image.Width=0) or (image.Height=0) then
840 exit;
841
842 lWidth := Image.Width-1;
843 lHeight := Image.Height-1;
844 dw := w - 1;
845 dh := h - 1;
846
847 for dx := 0 to w-1 do
848 for dy := 0 to h-1 do
849 begin
850 srcx := Round((dx / dw) * lWidth);
851 srcy := Round((dy / dh) * lHeight);
852 lColor := Image.Colors[srcx, srcy];
853 Canvas.Colors[dx+x, dy+y] := lColor;
854 end;
855 end;
856
857 end.
858
859