paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-01 07:59:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Gradient implementation, by Werner Pamler. Fixes issue #41257

Browse Source
This commit is contained in:
Michaël Van Canneyt 2025-05-15 08:57:02 +02:00
parent 3c5b049f6b
commit 86ac47508e
3 changed files with 83 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
packages/fcl-image/examples/demogradient.pp Normal file
View File

@ -0,0 +1,24 @@
program demogradient;
uses
Types, FPImage, FPCanvas, FPImgCanv, FPWriteBMP;
var
img: TFPMemoryImage;
canv: TFPCustomCanvas;
begin
img := TFPMemoryImage.Create(256, 128);
try
canv := TFPImageCanvas.Create(img);
try
canv.GradientFill(Rect(0, 0, 128, img.Height), colRed, colYellow, gdVertical);
canv.GradientFill(Rect(128, 0, 256, img.Height), colRed, colYellow, gdHorizontal);
img.SaveToFile('test.bmp');
finally
canv.Free;
end;
finally
img.Free;
end;
end.

57
packages/fcl-image/src/fpcanvas.inc
View File

@ -598,6 +598,63 @@ begin
Colors[x,y]:=colTransparent;
end;
function InterpolateColor(AStartColor, AEndColor: TFPColor; x, Total: Integer): TFPColor;
var
f1, f2: Double;
begin
f2 := x / Total;
f1 := 1.0 - f2;
Result.Red := round(AStartColor.Red * f1 + AEndColor.Red * f2);
Result.Green := round(AStartColor.Green * f1 + AEndColor.Green * f2);
Result.Blue := round(AStartColor.Blue * f1 + AEndColor.Blue * f2);
Result.Alpha := round(AStartColor.Alpha * f1 + AEndColor.Alpha * f2);
end;
procedure TFPCustomCanvas.GradientFill(const ARect: TRect;
AStartColor, AEndColor: TFPColor; ADirection: TFPGradientDirection);
var
x, y, i, n: Integer;
oldPenStyle: TFPPenStyle;
oldPenWidth: Integer;
oldPenColor: TFPColor;
begin
oldPenStyle := Pen.Style;
oldPenWidth := Pen.Width;
oldPenColor := Pen.FPColor;
Pen.Style := psSolid;
Pen.Width := 1;
if ADirection = gdVertical then
begin
n := ARect.Bottom - ARect.Top;
if n = 0 then
exit;
i := 0;
for y := ARect.Top to ARect.Bottom - 1 do
begin
Pen.FPColor := InterpolateColor(AStartColor, AEndColor, i, n);
Line(ARect.Left, y, ARect.Right - 1, y);
inc(i);
end;
end else
begin
n := ARect.Right - ARect.Left;
if n = 0 then
exit;
i := 0;
for x := ARect.Left to ARect.Right - 1 do
begin
Pen.FPColor := InterpolateColor(AStartColor, AEndColor, i, n);
Line(x, ARect.Top, x, ARect.Bottom - 1);
inc(i);
end;
end;
Pen.Style := oldPenStyle;
Pen.Width := oldPenWidth;
Pen.FPColor := oldPenColor;
end;
procedure TFPCustomCanvas.DoRectangleAndFill (const Bounds:TRect);
begin
DoRectangleFill (Bounds);

2
packages/fcl-image/src/fpcanvas.pp
View File

@ -241,6 +241,7 @@ type
TFPDrawingMode = (dmOpaque, dmAlphaBlend, dmCustom);
TFPCanvasCombineColors = function(const color1, color2: TFPColor): TFPColor of object;
TFPGradientDirection = (gdVertical, gdHorizontal);
{ TFPCustomCanvas }
@ -383,6 +384,7 @@ type
procedure StretchDraw (x,y,w,h:integer; source:TFPCustomImage); virtual;
procedure Erase;virtual;
procedure DrawPixel(const x, y: integer; const newcolor: TFPColor);
procedure GradientFill(const ARect: TRect; AStartColor, AEndColor: TFPColor; ADirection: TFPGradientDirection); virtual;
// properties
property LockCount: Integer read FLocks;
property Font : TFPCustomFont read GetFont write SetFont;