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

--- Merging r40995 into '.':

Browse Source 
U    packages/fcl-image/src/fpreadgif.pas
--- Recording mergeinfo for merge of r40995 into '.':
 U   .
--- Merging r41341 into '.':
A    packages/fcl-image/examples/DejaVuLGCSans.ttf
A    packages/fcl-image/examples/edit-clear.png
A    packages/fcl-image/examples/fpcanvasalphadraw.pp
U    packages/fcl-image/src/ellipses.pp
U    packages/fcl-image/src/fpcanvas.inc
U    packages/fcl-image/src/fpcanvas.pp
U    packages/fcl-image/src/fpinterpolation.inc
U    packages/fcl-image/src/ftfont.pp
U    packages/fcl-image/src/pixtools.pp
--- Recording mergeinfo for merge of r41341 into '.':
 G   .
--- Merging r41409 into '.':
G    packages/fcl-image/src/fpreadgif.pas
--- Recording mergeinfo for merge of r41409 into '.':
 G   .
--- Merging r41410 into '.':
U    packages/fcl-image/examples/imgconv.pp
--- Recording mergeinfo for merge of r41410 into '.':
 G   .
--- Merging r41411 into '.':
G    packages/fcl-image/examples/imgconv.pp
--- Recording mergeinfo for merge of r41411 into '.':
 G   .
--- Merging r41546 into '.':
U    packages/fcl-image/src/clipping.pp
--- Recording mergeinfo for merge of r41546 into '.':
 G   .
--- Merging r41550 into '.':
G    packages/fcl-image/src/ellipses.pp
U    packages/fcl-image/src/fpcolcnv.inc
U    packages/fcl-image/src/fpimage.pp
U    packages/fcl-image/src/fpwritexpm.pp
G    packages/fcl-image/src/ftfont.pp
--- Recording mergeinfo for merge of r41550 into '.':
 G   .
--- Merging r41802 into '.':
G    packages/fcl-image/examples/imgconv.pp
--- Recording mergeinfo for merge of r41802 into '.':
 G   .

# revisions: 40995,41341,41409,41410,41411,41546,41550,41802
r40995 | marco | 2019-01-22 16:11:04 +0100 (Tue, 22 Jan 2019) | 3 lines
Changed paths:
   M /trunk/packages/fcl-image/src/fpreadgif.pas

 * don't hangt on corrupt gifs, exit loops at end of streams.
   Fixes mantis #34919
r41341 | michael | 2019-02-16 13:43:14 +0100 (Sat, 16 Feb 2019) | 1 line
Changed paths:
   A /trunk/packages/fcl-image/examples/DejaVuLGCSans.ttf
   A /trunk/packages/fcl-image/examples/edit-clear.png
   A /trunk/packages/fcl-image/examples/fpcanvasalphadraw.pp
   M /trunk/packages/fcl-image/src/ellipses.pp
   M /trunk/packages/fcl-image/src/fpcanvas.inc
   M /trunk/packages/fcl-image/src/fpcanvas.pp
   M /trunk/packages/fcl-image/src/fpinterpolation.inc
   M /trunk/packages/fcl-image/src/ftfont.pp
   M /trunk/packages/fcl-image/src/pixtools.pp

* Patch from Ondrej Pokorny, to demonstrate alpha blending mode
r41409 | michael | 2019-02-22 09:03:39 +0100 (Fri, 22 Feb 2019) | 1 line
Changed paths:
   M /trunk/packages/fcl-image/src/fpreadgif.pas

* Patch from Anton Kavalenka to fix gif reading (bug ID 35134)
r41410 | michael | 2019-02-22 09:05:24 +0100 (Fri, 22 Feb 2019) | 1 line
Changed paths:
   M /trunk/packages/fcl-image/examples/imgconv.pp

* Support reading gifs
r41411 | michael | 2019-02-22 09:07:21 +0100 (Fri, 22 Feb 2019) | 1 line
Changed paths:
   M /trunk/packages/fcl-image/examples/imgconv.pp

* Add gif to help message
r41546 | michael | 2019-03-02 11:29:44 +0100 (Sat, 02 Mar 2019) | 1 line
Changed paths:
   M /trunk/packages/fcl-image/src/clipping.pp

* Fix bug #35127 in CheckRectClipping, patch from Ondrej Pokorny
r41550 | michael | 2019-03-02 13:13:31 +0100 (Sat, 02 Mar 2019) | 1 line
Changed paths:
   M /trunk/packages/fcl-image/src/ellipses.pp
   M /trunk/packages/fcl-image/src/fpcolcnv.inc
   M /trunk/packages/fcl-image/src/fpimage.pp
   M /trunk/packages/fcl-image/src/fpwritexpm.pp
   M /trunk/packages/fcl-image/src/ftfont.pp

* optimization by Ondrej Pokorny, add const in front of TFPColor arguments where possible (bug ID 35131)
r41802 | michael | 2019-03-26 23:24:49 +0100 (Tue, 26 Mar 2019) | 1 line
Changed paths:
   M /trunk/packages/fcl-image/examples/imgconv.pp

* Enhance example to allow specify grayscale for tiff

git-svn-id: branches/fixes_3_2@41915 -
This commit is contained in:
marco 2019-04-20 20:24:17 +00:00
parent 1a93a41c86
commit bcb47e7c64
16 changed files with 213 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -2356,6 +2356,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
@ -2363,6 +2364,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.

21
packages/fcl-image/examples/imgconv.pp
View File

@ -17,7 +17,7 @@ program ImgConv;
{_$define UseFile}
uses FPWriteXPM, FPWritePNG, FPWriteBMP,
uses FPWriteXPM, FPWritePNG, FPWriteBMP,fpreadgif,fptiffcmn,
FPReadXPM, FPReadPNG, FPReadBMP, fpreadjpeg,fpwritejpeg,
fpreadtga,fpwritetga,fpreadpnm,fpwritepnm, fpreadtiff, fpwritetiff,
{$ifndef UseFile}classes,{$endif}
@ -40,6 +40,8 @@ begin
Reader := TFPReaderBMP.Create
else if T = 'J' then
Reader := TFPReaderJPEG.Create
else if T = 'G' then
Reader := TFPReaderGif.Create
else if T = 'P' then
Reader := TFPReaderPNG.Create
else if T = 'T' then
@ -130,6 +132,19 @@ begin
writeln ('Grayscale ',Grayscale, ' - Indexed ',Indexed,
' - WordSized ',WordSized,' - UseAlpha ',UseAlpha);
end
else if (t[1] = 'F') then
with (Writer as TFPWriterTiff) do
begin
if pos ('G', t) > 0 then
begin
Img.Extra[TiffPhotoMetric]:='0';
if Pos('8',T)>0 then
Img.Extra[TiffGrayBits]:='8'
else if Pos('16',T)>0 then
Img.Extra[TiffGrayBits]:='16';
Writeln(TiffPhotoMetric,': 0 ',TiffGrayBits,': ',Img.Extra[TiffGrayBits]);
end;
end
else if (t[1] = 'X') then
begin
if length(t) > 1 then
@ -154,12 +169,14 @@ begin
begin
writeln ('Give filename to read and to write, preceded by filetype:');
writeln ('X for XPM, P for PNG, B for BMP, J for JPEG, T for TGA,');
writeln ('N for PNM (read only), F for TIFF');
writeln ('N for PNM (read only), F for TIFF, G for gif (read only)');
writeln ('example: imgconv X hello.xpm P hello.png');
writeln ('example: imgconv hello.xpm P hello.png');
writeln ('Options for');
writeln (' PNG : G : grayscale, A : use alpha, ');
writeln (' I : Indexed in palette, W : Word sized.');
writeln (' TIFF : G16 write grayscale 16 bits/pixel');
writeln (' G8 write grayscale 16 bits/pixel');
writeln (' XPM : Number of chars to use for 1 pixel');
writeln (' The color size of an XPM can be set after the X as 1,2,3 or 4');
writeln ('example: imgconv hello.xpm PIA hello.png');

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

@ -87,7 +87,7 @@ begin
y1 := top;
if ( y2 > bottom ) then // bottom side needs to be clipped
y2 := bottom;
if (x1 > x2) or (y1 < y2) then
if (x1 > x2) or (y1 > y2) then
ClearRect;
end;
end;

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

@ -19,11 +19,11 @@ interface
uses classes, FPImage, FPCanvas;
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Width:integer; c:TFPColor);
procedure DrawPatternEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TPenPattern; c:TFPColor);
procedure FillEllipseColor (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; c:TFPColor);
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; const c:TFPColor);
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Width:integer; const c:TFPColor);
procedure DrawPatternEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TPenPattern; const c:TFPColor);
procedure FillEllipseColor (Canv:TFPCustomCanvas; const Bounds:TRect; const c:TFPColor);
procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; const c:TFPColor);
procedure FillEllipseHashHorizontal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
procedure FillEllipseHashVertical (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
procedure FillEllipseHashDiagonal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
@ -317,7 +317,7 @@ end;
{ The drawing routines }
type
TPutPixelProc = procedure (Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
TPutPixelProc = procedure (Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
TLinePoints = array[0..PatternBitCount-1] of boolean;
PLinePoints = ^TLinePoints;
@ -334,31 +334,31 @@ begin
LinePoints^[0] := (APattern and i) <> 0;
end;
procedure PutPixelCopy(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
procedure PutPixelCopy(Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
begin
with Canv do
Colors[x,y] := color;
DrawPixel(x,y,color);
end;
procedure PutPixelXor(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
procedure PutPixelXor(Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
begin
with Canv do
Colors[x,y] := Colors[x,y] xor color;
end;
procedure PutPixelOr(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
procedure PutPixelOr(Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
begin
with Canv do
Colors[x,y] := Colors[x,y] or color;
end;
procedure PutPixelAnd(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
procedure PutPixelAnd(Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
begin
with Canv do
Colors[x,y] := Colors[x,y] and color;
end;
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; const c:TFPColor);
var info : TEllipseInfo;
r, y : integer;
MyPutPix : TPutPixelProc;
@ -387,7 +387,7 @@ begin
end;
end;
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Width:integer; c:TFPColor);
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Width:integer; const c:TFPColor);
var infoOut, infoIn : TEllipseInfo;
r, y : integer;
id : PEllipseInfoData;
@ -430,7 +430,7 @@ begin
end;
end;
procedure DrawPatternEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TPenPattern; c:TFPColor);
procedure DrawPatternEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TPenPattern; const c:TFPColor);
var info : TEllipseInfo;
xx, y : integer;
LinePoints : TLinePoints;
@ -496,7 +496,7 @@ begin
end;
end;
procedure FillEllipseColor (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
procedure FillEllipseColor (Canv:TFPCustomCanvas; const Bounds:TRect; const c:TFPColor);
var info : TEllipseInfo;
r, y : integer;
id : PEllipseInfoData;
@ -508,13 +508,13 @@ 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;
end;
procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; c:TFPColor);
procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; const c:TFPColor);
begin
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)

2
packages/fcl-image/src/fpcolcnv.inc
View File

@ -296,7 +296,7 @@ begin
end;
*)
function AlphaBlend(color1, color2: TFPColor): TFPColor;
function AlphaBlend(const color1, color2: TFPColor): TFPColor;
var
factor1, factor2: single;
begin

10
packages/fcl-image/src/fpimage.pp
View File

@ -286,7 +286,7 @@ function ConvertColor (const From : TFPColor; Fmt : TColorFormat) : TDeviceColor
function ConvertColor (const From : TDeviceColor; Fmt : TColorFormat) : TDeviceColor;
*)
function AlphaBlend(color1, color2: TFPColor): TFPColor;
function AlphaBlend(const color1, color2: TFPColor): TFPColor;
function FPColor (r,g,b,a:word) : TFPColor;
function FPColor (r,g,b:word) : TFPColor;
@ -561,7 +561,7 @@ FuzzyDepth: word = 4): TFPCustomImage;
{ HTML Color support. RRGGBB or color name. Only W3 color names s are supported}
function TryHtmlToFPColor(const S: String; out FPColor: TFPColor): Boolean;
function HtmlToFPColorDef(const S: String; out FPColor: TFpColor; Def: TFPColor): TFPColor;
function HtmlToFPColorDef(const S: String; out FPColor: TFpColor; const Def: TFPColor): TFPColor;
function HtmlToFPColor(const S: String): TFPColor;
@ -613,12 +613,12 @@ begin
(c.Alpha = d.Alpha);
end;
function GetFullColorData (color:TFPColor) : TColorData;
function GetFullColorData (const color:TFPColor) : TColorData;
begin
result := PColorData(@color)^;
end;
function SetFullColorData (color:TColorData) : TFPColor;
function SetFullColorData (const color:TColorData) : TFPColor;
begin
result := PFPColor (@color)^;
end;
@ -760,7 +760,7 @@ begin
end;
end;
function HtmlToFPColorDef(const S: String; out FPColor: TFpColor; Def: TFPColor): TFPColor;
function HtmlToFPColorDef(const S: String; out FPColor: TFpColor; const Def: TFPColor): TFPColor;
begin
if not TryHtmlToFPColor(S, Result) then
Result := Def;

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

16
packages/fcl-image/src/fpreadgif.pas
View File

@ -211,7 +211,10 @@ begin
// skip extensions
Repeat
Introducer:=SkipBlock(Stream);
until (Introducer = $2C) or (Introducer = $3B);
until (Introducer = $2C) or (Introducer = $3B) or (Stream.Position>=Stream.Size);
if Stream.Position>=Stream.Size then
Exit;
// descriptor
Stream.Read(FDescriptor, SizeOf(FDescriptor));
@ -298,7 +301,10 @@ begin
Stream.Seek(B, soFromCurrent);
CodeMask := (1 shl CodeSize) - 1;
end;
until B = 0;
until (B = 0) or (Stream.Position>=Stream.Size);
{ if Stream.Position>=Stream.Size then
Exit(False); }
Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)),
False, Rect(0,0,0,0), '', ContProgress);
@ -315,7 +321,11 @@ begin
Stream.ReadBuffer(SourcePtr^, B);
Inc(SourcePtr,B);
end;
until B = 0;
until (B = 0) or (Stream.Position>=Stream.Size);
{ if Stream.Position>=Stream.Size then
Exit(False); }
Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)),
False, Rect(0,0,0,0), '', ContProgress);

4
packages/fcl-image/src/fpwritexpm.pp
View File

@ -28,7 +28,7 @@ type
FColorShift : word;
FColorSize : byte;
procedure SetColorSize (AValue : byte);
function ColorToHex (c:TFPColor) : string;
function ColorToHex (const c:TFPColor) : string;
protected
procedure InternalWrite (Str:TStream; Img:TFPCustomImage); override;
public
@ -61,7 +61,7 @@ begin
FColorSize := AValue;
end;
function TFPWriterXPM.ColorToHex (c:TFPColor) : string;
function TFPWriterXPM.ColorToHex (const c:TFPColor) : string;
var r,g,b : word;
begin
with c do

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

@ -349,12 +349,20 @@ const
procedure TFreeTypeFont.DrawChar (x,y:integer; data:PByteArray; pitch, width, height:integer);
procedure Combine (canv:TFPCustomCanvas; x,y:integer; c : TFPColor; t:longword);
procedure Combine (canv:TFPCustomCanvas; x,y:integer; const c : TFPColor; t:longword);
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;