paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-14 00:02:06 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Ondrej Pokorny, to demonstrate alpha blending mode

Browse Source 
git-svn-id: trunk@41341 -
This commit is contained in:
michael 2019-02-16 12:43:14 +00:00
parent 4dca114dfe
commit f737521590
10 changed files with 156 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -2430,6 +2430,7 @@ packages/fcl-fpcunit/src/xmltestreport.pp svneol=native#text/plain
packages/fcl-image/Makefile svneol=native#text/plain
packages/fcl-image/Makefile.fpc svneol=native#text/plain
packages/fcl-image/Makefile.fpc.fpcmake svneol=native#text/plain
packages/fcl-image/examples/DejaVuLGCSans.ttf -text
packages/fcl-image/examples/Makefile svneol=native#text/plain
packages/fcl-image/examples/Makefile.fpc svneol=native#text/plain
packages/fcl-image/examples/createbarcode.lpi svneol=native#text/plain
@ -2437,6 +2438,8 @@ packages/fcl-image/examples/createbarcode.lpr svneol=native#text/plain
packages/fcl-image/examples/createqrcode.lpi svneol=native#text/plain
packages/fcl-image/examples/createqrcode.pp svneol=native#text/plain
packages/fcl-image/examples/drawing.pp svneol=native#text/plain
packages/fcl-image/examples/edit-clear.png -text svneol=unset#image/png
packages/fcl-image/examples/fpcanvasalphadraw.pp svneol=native#text/plain
packages/fcl-image/examples/imgconv.pp svneol=native#text/plain
packages/fcl-image/examples/interpoldemo.pp svneol=native#text/plain
packages/fcl-image/examples/pattern.png -text svneol=unset#image/png

BIN
packages/fcl-image/examples/DejaVuLGCSans.ttf Normal file
View File

Binary file not shown.

BIN
packages/fcl-image/examples/edit-clear.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 773 B

97
packages/fcl-image/examples/fpcanvasalphadraw.pp Normal file
View File

@ -0,0 +1,97 @@
{
Sample program by Ondrey Pokorny to demonstrate drawing modes of the TFPCustomCanvas:
- opaque
- alphablend
- custom blending, using a callback (not-used in this case)
}
program FPCanvasAlphaDraw;
uses FPImage, FPImgCanv, FPCanvas, FPReadPNG, FPWritePNG, Classes, SysUtils, freetype, ftFont;
const
cImageName: array[TFPDrawingMode] of string = ('opaque', 'alphablend', 'not-used');
var
xNew, xImage: TFPMemoryImage;
xCanvas: TFPImageCanvas;
xDrawingMode: TFPDrawingMode;
xRect: TRect;
begin
ftFont.InitEngine;
xNew := nil;
xCanvas := nil;
xImage := nil;
try
xImage := TFPMemoryImage.Create(0, 0);
xImage.LoadFromFile('edit-clear.png');
for xDrawingMode := dmOpaque to dmAlphaBlend do
begin
xNew := TFPMemoryImage.Create(200, 200);
xCanvas := TFPImageCanvas.Create(xNew);
xCanvas.DrawingMode := xDrawingMode;
xCanvas.Pen.Style := psClear;
xCanvas.Brush.FPColor := colRed;
xCanvas.FillRect(0, 0, xNew.Width, xNew.Height);
// draw semi-transparent objects
xCanvas.Brush.FPColor := FPColor($FFFF, $FFFF, $FFFF, $8000);
xRect := Rect(0, 0, 50, 50);
xCanvas.Ellipse(xRect);
xRect.Offset(50, 0);
xCanvas.Rectangle(xRect);
xRect := Rect(0, 50, 50, 100);
xCanvas.Pen.Style := psSolid;
xCanvas.Pen.FPColor := FPColor($FFFF, $FFFF, $FFFF, $8000);
xCanvas.Pen.Width := 4;
xCanvas.Brush.Style := bsClear;
xCanvas.Ellipse(xRect);
xRect.Offset(50, 0);
xCanvas.Rectangle(xRect);
xRect.Offset(50, 0);
xCanvas.Polyline([
Point(xRect.CenterPoint.X, xRect.Top),
Point(xRect.Right, xRect.CenterPoint.Y),
Point(xRect.CenterPoint.X, xRect.Bottom),
Point(xRect.Left, xRect.CenterPoint.Y),
Point(xRect.CenterPoint.X, xRect.Top)]);
xRect.Offset(50, 0);
xCanvas.MoveTo(xRect.TopLeft);
xCanvas.LineTo(xRect.Right, xRect.Top);
xRect := Rect(0, 100, 50, 150);
xCanvas.Draw(xRect.Left, xRect.Top, xImage);
xRect.Offset(50, 0);
xCanvas.StretchDraw(xRect.Left, xRect.Top, xRect.Width, xRect.Height, xImage);
xRect := Rect(0, 150, 50, 200);
xCanvas.Font:=TFreeTypeFont.Create;
xCanvas.Font.FPColor := FPColor($FFFF, $FFFF, $FFFF, $8000);
xCanvas.Font.Name := 'DejaVuLGCSans.ttf';
xCanvas.Font.Size := 15;
(xCanvas.Font as TFreeTypeFont).AntiAliased := True;
xCanvas.TextOut(xRect.Left, xRect.CenterPoint.Y, 'Hello');
xRect.Offset(100, 0);
(xCanvas.Font as TFreeTypeFont).AntiAliased := False;
xCanvas.TextOut(xRect.Left, xRect.CenterPoint.Y, 'Hello');
xNew.SaveToFile(cImageName[xDrawingMode]+'.png');
xCanvas.Font.Free;
xCanvas.Font := nil;
FreeAndNil(xNew);
FreeAndNil(xCanvas);
end;
finally
xCanvas.Free;
xNew.Free;
xImage.Free;
end;
end.

22
packages/fcl-image/src/ellipses.pp
View File

@ -337,7 +337,7 @@ end;
procedure PutPixelCopy(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
begin
with Canv do
Colors[x,y] := color;
DrawPixel(x,y,color);
end;
procedure PutPixelXor(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
@ -508,7 +508,7 @@ begin
for r := 0 to info.infolist.count-1 do
with PEllipseInfoData (info.infolist[r])^ do
for y := ytopmin to ybotmax do
colors[x,y] := c;
DrawPixel(x,y,c);
finally
info.Free;
end;
@ -530,7 +530,7 @@ begin
with PEllipseInfoData (info.infolist[r])^ do
for y := ytopmin to ybotmax do
if (y mod width) = 0 then
canv.colors[x,y] := c;
canv.DrawPixel(x,y,c);
finally
info.Free;
end;
@ -548,7 +548,7 @@ begin
with PEllipseInfoData (info.infolist[r])^ do
if (x mod width) = 0 then
for y := ytopmin to ybotmax do
canv.colors[x,y] := c;
canv.DrawPixel(x,y,c);
finally
info.Free;
end;
@ -569,7 +569,7 @@ begin
w := width - 1 - (x mod width);
for y := ytopmin to ybotmax do
if (y mod width) = w then
canv.colors[x,y] := c;
canv.DrawPixel(x,y,c);
end;
finally
info.Free;
@ -591,7 +591,7 @@ begin
w := (x mod width);
for y := ytopmin to ybotmax do
if (y mod width) = w then
canv.colors[x,y] := c;
canv.DrawPixel(x,y,c);
end;
finally
info.Free;
@ -616,7 +616,7 @@ begin
begin
wy := y mod width;
if (wy = w1) or (wy = w2) then
canv.colors[x,y] := c;
canv.DrawPixel(x,y,c);
end;
end;
finally
@ -636,11 +636,11 @@ begin
with PEllipseInfoData (info.infolist[r])^ do
if (x mod width) = 0 then
for y := ytopmin to ybotmax do
canv.colors[x,y] := c
canv.DrawPixel(x,y,c)
else
for y := ytopmin to ybotmax do
if (y mod width) = 0 then
canv.colors[x,y] := c;
canv.DrawPixel(x,y,c);
finally
info.Free;
end;
@ -660,7 +660,7 @@ begin
begin
w := (x mod image.width);
for y := ytopmin to ybotmax do
canv.colors[x,y] := Image.colors[w, (y mod image.height)];
canv.DrawPixel(x,y,Image.colors[w, (y mod image.height)]);
end;
finally
info.Free;
@ -692,7 +692,7 @@ begin
yi := (y - yo) mod image.height;
if yi < 0 then
inc (yi, image.height);
canv.colors[x,y] := Image.colors[xi, yi];
canv.DrawPixel(x,y,Image.colors[xi, yi]);
end;
end;
finally

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

@ -571,6 +571,16 @@ begin
end;
end;
procedure TFPCustomCanvas.DrawPixel(const x, y: integer;
const newcolor: TFPColor);
begin
case FDrawingMode of
dmOpaque: Colors[x,y] := newcolor;
dmAlphaBlend: Colors[x,y] := AlphaBlend(Colors[x,y], newcolor);
dmCustom: Colors[x,y] := FOnCombineColors(Colors[x,y], newcolor);
end;
end;
procedure TFPCustomCanvas.Erase;
var
x,y:Integer;
@ -784,7 +794,7 @@ begin
begin
xx := r - x;
for t := yi to ym do
colors [r,t] := AlphaBlend(colors [r,t], image.colors[xx,t-y]);
DrawPixel(r,t, image.colors[xx,t-y]);
end;
end;

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

@ -233,6 +233,9 @@ type
function IsPointInRegion(AX, AY: Integer): Boolean; override;
end;
TFPDrawingMode = (dmOpaque, dmAlphaBlend, dmCustom);
TFPCanvasCombineColors = function(const color1, color2: TFPColor): TFPColor of object;
{ TFPCustomCanvas }
TFPCustomCanvas = class(TPersistent)
@ -243,6 +246,8 @@ type
FHelpers : TList;
FLocks : integer;
FInterpolation : TFPCustomInterpolation;
FDrawingMode : TFPDrawingMode;
FOnCombineColors : TFPCanvasCombineColors;
function AllowFont (AFont : TFPCustomFont) : boolean;
function AllowBrush (ABrush : TFPCustomBrush) : boolean;
function AllowPen (APen : TFPCustomPen) : boolean;
@ -370,6 +375,7 @@ type
procedure Draw (x,y:integer; image:TFPCustomImage);
procedure StretchDraw (x,y,w,h:integer; source:TFPCustomImage);
procedure Erase;virtual;
procedure DrawPixel(const x, y: integer; const newcolor: TFPColor);
// properties
property LockCount: Integer read FLocks;
property Font : TFPCustomFont read GetFont write SetFont;
@ -384,6 +390,8 @@ type
property Height : integer read GetHeight write SetHeight;
property Width : integer read GetWidth write SetWidth;
property ManageResources: boolean read FManageResources write FManageResources;
property DrawingMode : TFPDrawingMode read FDrawingMode write FDrawingMode;
property OnCombineColors : TFPCanvasCombineColors read FOnCombineColors write FOnCombineColors;
end;
TFPCustomDrawFont = class (TFPCustomFont)

4
packages/fcl-image/src/fpinterpolation.inc
View File

@ -17,7 +17,7 @@ begin
for dx := 0 to w-1 do
for dy := 0 to h-1 do
Canvas.Colors[x+dx,y+dy] := Image.Colors[dx*iw div w, dy*ih div h];
Canvas.DrawPixel(x+dx,y+dy, Image.Colors[dx*iw div w, dy*ih div h]);
end;
{ TFPBaseInterpolation }
@ -223,7 +223,7 @@ begin
NewCol.blue:=Min(NewCol.blue+round(Col.blue*f),$ffff);
NewCol.alpha:=Min(NewCol.alpha+round(Col.alpha*f),$ffff);
end;
Canvas.Colors[x+dx,y+dy]:=AlphaBlend(Canvas.Colors[x+dx,y+dy], NewCol);
Canvas.DrawPixel(x+dx,y+dy, NewCol);
end;
end;
finally

14
packages/fcl-image/src/ftfont.pp
View File

@ -353,8 +353,16 @@ procedure TFreeTypeFont.DrawChar (x,y:integer; data:PByteArray; pitch, width, he
var
pixelcolor: TFPColor;
begin
pixelcolor := AlphaBlend(canv.colors[x,y], FPImage.FPColor(c.red, c.green,c.blue, (t+1) shl 8 - 1));
canv.colors[x,y] := pixelcolor;
case canv.DrawingMode of
dmOpaque:
begin
pixelcolor := FPImage.FPColor(c.red, c.green,c.blue, (t+1) shl 8 - 1); // opaque: ignore c.Alpha
canv.colors[x,y] := AlphaBlend(canv.colors[x,y], pixelcolor);
end;
else
pixelcolor := FPImage.FPColor(c.red, c.green,c.blue, ((t+1) shl 8 - 1) * c.Alpha div $ffff); // apply c.Alpha
canv.DrawPixel(x,y,pixelcolor);
end;
end;
var b,rx,ry : integer;
@ -380,7 +388,7 @@ begin
begin
rb := rx mod 8;
if (data^[b+l] and bits[rb]) <> 0 then
canvas.colors[x+rx,y+ry] := FPColor;
canvas.DrawPixel(x+rx,y+ry, FPColor);
if rb = 7 then
inc (l);
end;

26
packages/fcl-image/src/pixtools.pp
View File

@ -75,7 +75,7 @@ begin
begin
for x := x1 to x2 do
for y := y1 to y2 do
colors[x,y] := color;
DrawPixel(x,y,color);
end;
end;
@ -104,7 +104,7 @@ type
procedure PutPixelCopy(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
begin
with Canv do
Colors[x,y] := color;
DrawPixel(x,y,color);
end;
procedure PutPixelXor(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
@ -557,7 +557,7 @@ begin
with image do
for x := x1 to x2 do
for y := y1 to y2 do
Canv.colors[x,y] := colors[x mod width, y mod height];
Canv.DrawPixel(x,y, colors[x mod width, y mod height]);
end;
procedure FillRectangleImageRel (Canv:TFPCustomCanvas; x1,y1, x2,y2:integer; const Image:TFPCustomImage);
@ -566,7 +566,7 @@ begin
with image do
for x := x1 to x2 do
for y := y1 to y2 do
Canv.colors[x,y] := colors[(x-x1) mod width, (y-y1) mod height];
Canv.DrawPixel(x,y, colors[(x-x1) mod width, (y-y1) mod height]);
end;
type
@ -890,7 +890,7 @@ end;
procedure SetFloodColor (Canv:TFPCustomCanvas; x,y:integer; data:pointer);
begin
Canv.colors[x,y] := PFPColor(data)^;
Canv.DrawPixel(x,y, PFPColor(data)^);
end;
procedure FillFloodColor (Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
@ -967,7 +967,7 @@ var r : PFloodHashRec;
begin
r := PFloodHashRec(data);
if (y mod r^.width) = 0 then
Canv.colors[x,y] := r^.color;
Canv.DrawPixel(x,y,r^.color);
end;
procedure SetFloodHashVer(Canv:TFPCustomCanvas; x,y:integer; data:pointer);
@ -975,7 +975,7 @@ var r : PFloodHashRec;
begin
r := PFloodHashRec(data);
if (x mod r^.width) = 0 then
Canv.colors[x,y] := r^.color;
Canv.DrawPixel(x,y,r^.color);
end;
procedure SetFloodHashDiag(Canv:TFPCustomCanvas; x,y:integer; data:pointer);
@ -985,7 +985,7 @@ begin
r := PFloodHashRec(data);
w := r^.width;
if ((x mod w) + (y mod w)) = (w - 1) then
Canv.colors[x,y] := r^.color;
Canv.DrawPixel(x,y,r^.color);
end;
procedure SetFloodHashBDiag(Canv:TFPCustomCanvas; x,y:integer; data:pointer);
@ -995,7 +995,7 @@ begin
r := PFloodHashRec(data);
w := r^.width;
if (x mod w) = (y mod w) then
Canv.colors[x,y] := r^.color;
Canv.DrawPixel(x,y,r^.color);
end;
procedure SetFloodHashCross(Canv:TFPCustomCanvas; x,y:integer; data:pointer);
@ -1005,7 +1005,7 @@ begin
r := PFloodHashRec(data);
w := r^.width;
if ((x mod w) = 0) or ((y mod w) = 0) then
Canv.colors[x,y] := r^.color;
Canv.DrawPixel(x,y,r^.color);
end;
procedure SetFloodHashDiagCross(Canv:TFPCustomCanvas; x,y:integer; data:pointer);
@ -1016,7 +1016,7 @@ begin
w := r^.width;
if ( (x mod w) = (y mod w) ) or
( ((x mod w) + (y mod w)) = (w - 1) ) then
Canv.colors[x,y] := r^.color;
Canv.DrawPixel(x,y,r^.color);
end;
procedure FillFloodHash (Canv:TFPCustomCanvas; x,y:integer; width:integer; SetHashColor:TFuncSetColor; const c:TFPColor);
@ -1109,7 +1109,7 @@ var r : PFloodImageRec;
begin
r := PFloodImageRec(data);
with r^.image do
Canv.colors[x,y] := colors[x mod width, y mod height];
Canv.DrawPixel(x,y,colors[x mod width, y mod height]);
end;
procedure FillFloodImage (Canv:TFPCustomCanvas; x,y :integer; const Image:TFPCustomImage);
@ -1142,7 +1142,7 @@ begin
yi := (y - yo) mod height;
if yi < 0 then
yi := height - yi;
Canv.colors[x,y] := colors[xi,yi];
Canv.DrawPixel(x,y,colors[xi,yi]);
end;
end;