pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

pyramidtiff: using fpimage copact mem image formats, converting whole directories

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3839 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
mgaertner
2014-12-14 15:42:31 +00:00
parent 3f2f88e69a
commit 02eb9245c1
3 changed files with 224 additions and 893 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
applications/pyramidtiff/pyramidtiff.lpi
View File

@ -1,4 +1,4 @@
<?xml version="1.0"?>
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
@ -29,19 +29,23 @@
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<RequiredPackages Count="3">
<Item1>
<PackageName Value="LazUtils"/>
<PackageName Value="MultiThreadProcsLaz"/>
</Item1>
<Item2>
<PackageName Value="CodeTools"/>
</Item2>
<Item3>
<PackageName Value="LazUtils"/>
</Item3>
</RequiredPackages>
<Units Count="1">
<Unit0>
<Filename Value="pyramidtiff.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="pyramidtiff"/>
</Unit0>
</Units>
</ProjectOptions>
@ -59,12 +63,6 @@
<AllowLabel Value="False"/>
</SyntaxOptions>
</Parsing>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">

324
applications/pyramidtiff/pyramidtiff.lpr
View File

@ -1,32 +1,3 @@
{ Graphic functions for pyramidtiff.
Copyright (C) 2012 Mattias Gaertner mattias@freepascal.org
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
program pyramidtiff;
{$mode objfpc}{$H+}
@ -35,30 +6,32 @@ uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, SysUtils, math, LazFileUtils, CustApp,
FPimage, FPReadJPEG, FPReadPNG, FPReadBMP, FPImgCanv,
Classes, SysUtils, math, LazFileUtils, CodeToolsStructs, CustApp,
FPimage, FPReadJPEG, FPReadPNG, FPReadBMP, FPImgCanv, FPCanvas, MTProcs,
PyTiGraphics, FPReadTiff, FPTiffCmn, FPWriteTiff;
const
Version = '1.0';
Version = '1.1';
type
{ TPyramidTiffer }
TPyramidTiffer = class(TCustomApplication)
private
FInputPath: string;
FMinSize: Word;
FOutputPath: string;
FQuiet: boolean;
//FSkipCheck: boolean;
FTileHeight: Word;
FTileWidth: Word;
FVerbose: boolean;
procedure LoadTiff(out Img: TPTMemImgBase;
procedure LoadTiff(out Img: TFPCompactImgBase;
Reader: TFPReaderTiff; InStream: TMemoryStream;
var ErrorMsg: string);
procedure LoadOther(out Img: TPTMemImgBase;
procedure LoadOther(out Img: TFPCompactImgBase;
Reader: TFPCustomImageReader; InStream: TMemoryStream);
function ShrinkImage(LastImg: TPTMemImgBase): TPTMemImgBase;
function ShrinkImage(LastImg: TFPCompactImgBase): TFPCompactImgBase;
procedure TiffReaderCreateImage(Sender: TFPReaderTiff; IFD: TTiffIFD);
protected
procedure DoRun; override;
@ -66,18 +39,33 @@ type
procedure ReadConfig;
function CheckIfFileIsPyramidTiled(Filename: string; out ErrorMsg: string): boolean;
function CheckIfStreamIsPyramidTiled(s: TStream; out ErrorMsg: string): boolean;
function Convert(InputFilename, OutputFilename: string; out ErrorMsg: string): boolean;
function Convert(Img: TPTMemImgBase; OutputFilename: string; out ErrorMsg: string): boolean;
function GetReaderClass(Filename: string): TFPCustomImageReaderClass;
function ConvertDir(InputDir, OutputDir: string; out ErrorMsg: string): boolean;
procedure ConvertFilesParallel(Index: PtrInt; Data: Pointer; {%H-}Item: TMultiThreadProcItem);
function ConvertFile(InputFilename, OutputFilename: string; out ErrorMsg: string): boolean;
function Convert(Img: TFPCompactImgBase; OutputFilename: string; out ErrorMsg: string): boolean;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure WriteHelp(WithHeader: boolean); virtual;
property TileWidth: Word read FTileWidth write FTileWidth;
property TileHeight: Word read FTileHeight write FTileHeight;
property MinSize: Word read FMinSize write FMinSize;
//property SkipCheck: boolean read FSkipCheck write FSkipCheck;
property Verbose: boolean read FVerbose write FVerbose;
property Quiet: boolean read FQuiet write FQuiet;
property InputPath: string read FInputPath write FInputPath;
property OutputPath: string read FOutputPath write FOutputPath;
end;
{ TMyCanvas }
TMyCanvas = class(TFPImageCanvas)
protected
procedure DoCopyRect({%H-}x, {%H-}y: integer; {%H-}canvas: TFPCustomCanvas;
const {%H-}SourceRect: TRect); override;
procedure DoDraw({%H-}x, {%H-}y: integer; const {%H-}anImage: TFPCustomImage); override;
end;
function CompareIFDForSize(i1, i2: Pointer): integer;
@ -87,8 +75,8 @@ var
Size1: Int64;
Size2: Int64;
begin
Size1:=int64(IFD1.ImageWidth)*IFD1.ImageHeight;
Size2:=int64(IFD2.ImageWidth)*IFD2.ImageHeight;
Size1:=IFD1.ImageWidth*IFD1.ImageHeight;
Size2:=IFD2.ImageWidth*IFD2.ImageHeight;
if Size1>Size2 then Result:=1
else if Size1<Size2 then Result:=-1
else Result:=0;
@ -117,12 +105,25 @@ begin
Result:=l;
end;
{ TMyCanvas }
procedure TMyCanvas.DoCopyRect(x, y: integer; canvas: TFPCustomCanvas;
const SourceRect: TRect);
begin
end;
procedure TMyCanvas.DoDraw(x, y: integer; const anImage: TFPCustomImage);
begin
end;
{ TMyApplication }
procedure TPyramidTiffer.TiffReaderCreateImage(Sender: TFPReaderTiff;
IFD: TTiffIFD);
var
Desc: TPTMemImgDesc;
Desc: TFPCompactImgDesc;
begin
// free old image
FreeAndNil(IFD.Img);
@ -133,10 +134,10 @@ begin
IFD.GreenBits),
IFD.BlueBits),
IFD.GrayBits);
IFD.Img:=CreatePTMemImg(Desc,IFD.ImageWidth,IFD.ImageHeight);
IFD.Img:=CreateFPCompactImg(Desc,IFD.ImageWidth,IFD.ImageHeight);
end;
function TPyramidTiffer.ShrinkImage(LastImg: TPTMemImgBase): TPTMemImgBase;
function TPyramidTiffer.ShrinkImage(LastImg: TFPCompactImgBase): TFPCompactImgBase;
function Half(i: integer): integer;
begin
@ -147,16 +148,16 @@ function TPyramidTiffer.ShrinkImage(LastImg: TPTMemImgBase): TPTMemImgBase;
var
ImgCanvas: TFPImageCanvas;
begin
Result:=TPTMemImgBase(CreatePTMemImg(LastImg.Desc, Half(LastImg.Width), Half(
Result:=TFPCompactImgBase(CreateFPCompactImg(LastImg.Desc, Half(LastImg.Width), Half(
LastImg.Height)));
ImgCanvas:=TFPImageCanvas.create(Result);
ImgCanvas:=TMyCanvas.create(Result);
ImgCanvas.Interpolation:=TLinearInterpolation.Create;
ImgCanvas.StretchDraw(0, 0, Result.Width, Result.Height, LastImg);
ImgCanvas.Interpolation.Free;
ImgCanvas.Free;
end;
procedure TPyramidTiffer.LoadTiff(out Img: TPTMemImgBase;
procedure TPyramidTiffer.LoadTiff(out Img: TFPCompactImgBase;
Reader: TFPReaderTiff; InStream: TMemoryStream; var ErrorMsg: string);
begin
Reader.OnCreateImage:=@TiffReaderCreateImage;
@ -165,23 +166,24 @@ begin
ErrorMsg:='tiff has no image';
exit;
end;
Img:=Reader.GetBiggestImage.Img as TPTMemImgBase;
Img:=Reader.GetBiggestImage.Img as TFPCompactImgBase;
end;
procedure TPyramidTiffer.LoadOther(out Img: TPTMemImgBase;
procedure TPyramidTiffer.LoadOther(out Img: TFPCompactImgBase;
Reader: TFPCustomImageReader; InStream: TMemoryStream);
begin
Img:=TPTMemImgRGBA8Bit.Create(0, 0);
Img:=TFPCompactImgRGB8Bit.Create(0, 0);
Reader.ImageRead(InStream, Img);
Img:=GetMinimumPTMemImg(Img, true) as TPTMemImgBase;
Img:=GetMinimumFPCompactImg(Img, true) as TFPCompactImgBase;
end;
procedure TPyramidTiffer.DoRun;
var
InputFilename: String;
OutputFilename: String;
ErrorMsg: string;
begin
if GetCurrentDir='' then
SetCurrentDir(GetEnvironmentVariable('PWD'));
ReadConfig;
if HasOption('min-size') then begin
@ -206,10 +208,10 @@ begin
ParamError('can not combine option -c and -i');
if HasOption('o') then
ParamError('can not combine option -c and -o');
InputFilename:=CleanAndExpandFilename(GetOptionValue('c'));
if not FileExistsUTF8(InputFilename) then
ParamError('check file not found: '+InputFilename);
if CheckIfFileIsPyramidTiled(InputFilename,ErrorMsg) then begin
InputPath:=CleanAndExpandFilename(GetOptionValue('c'));
if not FileExistsUTF8(InputPath) then
ParamError('check file not found: '+InputPath);
if CheckIfFileIsPyramidTiled(InputPath,ErrorMsg) then begin
if not Quiet then
writeln('ok');
end else begin
@ -224,17 +226,31 @@ begin
if not HasOption('o') then
ParamError('missing parameter -o');
InputFilename:=CleanAndExpandFilename(GetOptionValue('i'));
if not FileExistsUTF8(InputFilename) then
ParamError('input file not found: '+InputFilename);
OutputFilename:=CleanAndExpandFilename(GetOptionValue('o'));
if not DirectoryExistsUTF8(ExtractFilePath(OutputFilename)) then
ParamError('output directory not found: '+ExtractFilePath(OutputFilename));
if not Convert(InputFilename,OutputFilename,ErrorMsg) then begin
if not Quiet then
writeln('ERROR: ',ErrorMsg);
ExitCode:=1;
GetCurrentDirUTF8;
InputPath:=CleanAndExpandFilename(GetOptionValue('i'));
OutputPath:=CleanAndExpandFilename(GetOptionValue('o'));
if DirPathExists(InputPath) then begin
// convert whole directory
if not DirPathExists(OutputPath) then
ParamError('output directory not found: '+OutputPath);
if not ConvertDir(InputPath,OutputPath,ErrorMsg) then begin
if not Quiet then
writeln('ERROR: ',ErrorMsg);
ExitCode:=1;
end;
end else begin
// convert single file
if not FileExistsUTF8(InputPath) then
ParamError('input file not found: '+InputPath);
if not DirectoryExistsUTF8(ExtractFilePath(OutputPath)) then
ParamError('output directory not found: '+ExtractFilePath(OutputPath));
if DirPathExists(OutputPath) then
ParamError('output is a directory, but input is a file');
if not ConvertFile(InputPath,OutputPath,ErrorMsg) then begin
if not Quiet then
writeln('ERROR: ',ErrorMsg);
ExitCode:=1;
end;
end;
end;
@ -362,7 +378,8 @@ begin
end;
if SmallerImg=nil then begin
// this is the smallest image
if (Img.ImageWidth>DWord(MinSize)*2) or (Img.ImageHeight>DWord(MinSize)*2) then begin
if (Img.ImageWidth>MinSize*2)
or (Img.ImageHeight>MinSize*2) then begin
ErrorMsg:='missing small scale step. min-size='+IntToStr(MinSize)+'.'
+' Smallest image: '+IntToStr(Img.ImageWidth)+'x'+IntToStr(Img.ImageHeight);
exit;
@ -392,15 +409,101 @@ begin
end;
end;
function TPyramidTiffer.Convert(InputFilename, OutputFilename: string; out
function TPyramidTiffer.GetReaderClass(Filename: string
): TFPCustomImageReaderClass;
var
Ext: String;
i: Integer;
begin
Result:=nil;
Ext:=lowercase(ExtractFileExt(Filename));
Delete(Ext,1,1); // delete '.'
if (Ext='tif') or (Ext='tiff') then
Result:=TFPReaderTiff
else begin
for i:=0 to ImageHandlers.Count-1 do begin
if Pos(Ext,ImageHandlers.Extentions[ImageHandlers.TypeNames[i]])<1
then continue;
Result:=ImageHandlers.ImageReader[ImageHandlers.TypeNames[i]];
end;
end;
end;
function TPyramidTiffer.ConvertDir(InputDir, OutputDir: string; out
ErrorMsg: string): boolean;
var
FileInfo: TSearchRec;
Files: TFilenameToStringTree;
Item: PStringToStringTreeItem;
InputFile: String;
OutputFile: String;
FileList: TStringList;
begin
Result:=false;
ErrorMsg:='';
InputDir:=AppendPathDelim(InputDir);
OutputDir:=AppendPathDelim(OutputDir);
Files:=TFilenameToStringTree.Create(false);
FileList:=TStringList.Create;
try
if FindFirstUTF8(InputDir+AllFilesMask,faAnyFile,FileInfo)=0 then begin
repeat
// skip special files
if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') then
continue;
if GetReaderClass(FileInfo.Name)=nil then continue;
Files[FileInfo.Name]:='1';
until FindNextUTF8(FileInfo)<>0;
end;
FindCloseUTF8(FileInfo);
if CompareFilenames(InputDir,OutputDir)=0 then begin
// input and out dir are the same
// => remove output files from input list
for Item in Files do begin
InputFile:=Item^.Name;
if (CompareFileExt(InputFile,'tif',false)=0) then continue;
OutputFile:=ChangeFileExt(InputFile,'.tif');
Files.Remove(OutputFile);
end;
end;
// convert
for Item in Files do
FileList.Add(Item^.Name);
try
ProcThreadPool.DoParallel(@ConvertFilesParallel,0,FileList.Count-1,FileList);
Result:=true;
except
on E: Exception do
ErrorMsg:=E.Message;
end;
finally
FileList.Free;
Files.Free;
end;
end;
procedure TPyramidTiffer.ConvertFilesParallel(Index: PtrInt; Data: Pointer;
Item: TMultiThreadProcItem);
var
Files: TStringList;
InputFilename: String;
OutputFilename: String;
ErrorMsg: string;
begin
Files:=TStringList(Data);
InputFilename:=AppendPathDelim(InputPath)+Files[Index];
OutputFilename:=AppendPathDelim(OutputPath)+ChangeFileExt(Files[Index],'.tif');
if not ConvertFile(InputFilename,OutputFilename,ErrorMsg) then
raise Exception.Create(ErrorMsg+',input='+InputFilename+',output='+OutputFilename);
end;
function TPyramidTiffer.ConvertFile(InputFilename, OutputFilename: string; out
ErrorMsg: string): boolean;
var
InStream: TMemoryStream;
Ext: String;
ReaderClass: TFPCustomImageReaderClass;
Reader: TFPCustomImageReader;
Img: TPTMemImgBase;
i: Integer;
Img: TFPCompactImgBase;
begin
Result:=false;
ErrorMsg:='';
@ -416,21 +519,9 @@ begin
InStream.Position:=0;
// get the right image type reader
Ext:=lowercase(ExtractFileExt(InputFilename));
Delete(Ext,1,1); // delete '.'
if (Ext='tif') or (Ext='tiff') then
ReaderClass:=TFPReaderTiff
else begin
for i:=0 to ImageHandlers.Count-1 do begin
if Pos(Ext,ImageHandlers.Extentions[ImageHandlers.TypeNames[i]])<1
then continue;
ReaderClass:=ImageHandlers.ImageReader[ImageHandlers.TypeNames[i]];
if Verbose then
writeln('reading ',ImageHandlers.TypeNames[i]);
end;
end;
ReaderClass:=GetReaderClass(InputFilename);
if ReaderClass=nil then begin
ErrorMsg:='unknown file extension "'+Ext+'"';
ErrorMsg:='unknown file extension "'+ExtractFileExt(InputFilename)+'"';
exit;
end;
Reader:=ReaderClass.Create;
@ -459,16 +550,30 @@ begin
end;
end;
function TPyramidTiffer.Convert(Img: TPTMemImgBase; OutputFilename: string; out
function TPyramidTiffer.Convert(Img: TFPCompactImgBase; OutputFilename: string; out
ErrorMsg: string): boolean;
procedure AddTiff(Writer: TFPWriterTiff; Img: TFPCustomImage;
PageNumber, PageCount, TileWidth, TileHeight: integer;
Desc: TFPCompactImgDesc);
begin
Img.Extra[TiffPageNumber]:=IntToStr(PageNumber);
Img.Extra[TiffPageCount]:=IntToStr(PageCount);
Img.Extra[TiffTileWidth]:=IntToStr(TileWidth);
Img.Extra[TiffTileLength]:=IntToStr(TileHeight);
SetFPImgExtraTiff(Desc,Img,false);
Img.Extra[TiffCompression]:=IntToStr(TiffCompressionDeflateZLib);
Writer.AddImage(Img);
end;
var
OutStream: TMemoryStream;
Writer: TFPWriterTiff;
Size: Int64;
Count: Integer;
Index: Integer;
LastImg: TPTMemImgBase;
NewImg: TPTMemImgBase;
LastImg: TFPCompactImgBase;
NewImg: TFPCompactImgBase;
begin
Result:=false;
try
@ -481,6 +586,8 @@ begin
end;
// create images
if Verbose then
writeln('Creating file "',OutputFilename,'"');
OutStream:=TMemoryStream.Create;
Writer:=nil;
LastImg:=nil;
@ -488,31 +595,14 @@ begin
try
Writer:=TFPWriterTiff.Create;
Index:=0;
Img.Extra[TiffPageNumber]:=IntToStr(Index);
Img.Extra[TiffPageCount]:=IntToStr(Count);
Img.Extra[TiffTileWidth]:=IntToStr(TileWidth);
Img.Extra[TiffTileLength]:=IntToStr(TileHeight);
SetFPImgExtraTiff(Img.Desc,Img,false);
Img.Extra[TiffCompression]:=IntToStr(TiffCompressionDeflateZLib);
Writer.AddImage(Img);
AddTiff(Writer,Img,Index,Count,TileWidth,TileHeight,Img.Desc);
// add smaller images
LastImg:=Img;
while Index+1<Count do begin
Index+=1;
// create next image with half the width and height
NewImg:=ShrinkImage(LastImg);
// set tiff page number and count
NewImg.Extra[TiffPageNumber]:=IntToStr(Index);
NewImg.Extra[TiffPageCount]:=IntToStr(Count);
NewImg.Extra[TiffTileWidth]:=IntToStr(TileWidth);
NewImg.Extra[TiffTileLength]:=IntToStr(TileHeight);
SetFPImgExtraTiff(NewImg.Desc,NewImg,false);
Img.Extra[TiffCompression]:=IntToStr(TiffCompressionDeflateZLib);
// add image to tiff
if Verbose then
writeln(' adding image ',Index,'/',Count,', size=',NewImg.Width,'x',NewImg.Height);
Writer.AddImage(NewImg);
AddTiff(Writer,NewImg,Index,Count,TileWidth,TileHeight,NewImg.Desc);
// free last step
if LastImg<>Img then
FreeAndNil(LastImg);
@ -528,6 +618,8 @@ begin
// save to file
OutStream.SaveToFile(OutputFilename);
if Verbose then
writeln('Saved file "',OutputFilename,'"');
Result:=true;
finally
if LastImg<>Img then
@ -567,13 +659,13 @@ begin
if WithHeader then begin
writeln('Version ',Version);
writeln;
writeln('pyramidtiff creates a tiff containing the original image, the image');
writeln('with half the width and half the height (rounded up), the image with');
writeln('quartered width/height (rounded up), ... and so forth.');
writeln('pyramidtiff creates a tiff containing multiple images:');
writeln('the original image,');
writeln('the image with half the width and half the height (rounded up),');
writeln('the image with quartered width/height (rounded up),');
writeln('... and so forth.');
writeln;
end;
writeln('-c <input file>');
writeln(' Check if file is a pyramid, tiled tif. 0 = yes, 1 = no.');
writeln('-i <input file>');
write(' Input image file can be a:');
for i:=0 to ImageHandlers.Count-1 do begin
@ -581,8 +673,14 @@ begin
write(' ',ImageHandlers.Extentions[ImgType]);
end;
writeln;
writeln(' If input file is a directory then the -o must be a directory too.');
writeln(' All image files in the directory will be converted.');
writeln('-o <output file>');
writeln(' Output image file. It will always be a tif file, no matter what extension it has.');
writeln(' Output image file. It will always be a tif file, no matter what');
writeln(' extension it has.');
writeln('-c <input file>');
writeln(' Check if file is a pyramid, tiled tif. 0 = yes, 1 = no.');
writeln(' You can not use both -c and -i');
writeln('--width=<tilewidth>');
writeln(' In pixel. Default=',TileWidth);
writeln('--height=<tileheight>');

773
applications/pyramidtiff/pytigraphics.pas
View File

@ -40,167 +40,6 @@ uses
LazLogger, FPCanvas, FPWriteTiff, FPTiffCmn;
type
TPTMemImgDesc = record
Gray: boolean; // true = red=green=blue, false: a RGB image
Depth: word; // 8 or 16 bit
HasAlpha: boolean;
end;
{ TPTMemImgBase }
TPTMemImgBase = class(TFPCustomImage)
private
FDesc: TPTMemImgDesc;
public
property Desc: TPTMemImgDesc read FDesc;
end;
TPTMemImgBaseClass = class of TPTMemImgBase;
{ TPTMemImgGray16Bit }
TPTMemImgGray16Bit = class(TPTMemImgBase)
protected
FData: PWord;
function GetInternalColor(x, y: integer): TFPColor; override;
function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
public
constructor Create(AWidth, AHeight: integer); override;
destructor Destroy; override;
procedure SetSize(AWidth, AHeight: integer); override;
end;
TPTMemImgGrayAlpha16BitValue = packed record
g,a: word;
end;
PPTMemImgGrayAlpha16BitValue = ^TPTMemImgGrayAlpha16BitValue;
{ TPTMemImgGrayAlpha16Bit }
TPTMemImgGrayAlpha16Bit = class(TPTMemImgBase)
protected
FData: PPTMemImgGrayAlpha16BitValue;
function GetInternalColor(x, y: integer): TFPColor; override;
function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
public
constructor Create(AWidth, AHeight: integer); override;
destructor Destroy; override;
procedure SetSize(AWidth, AHeight: integer); override;
end;
{ TPTMemImgGray8Bit }
TPTMemImgGray8Bit = class(TPTMemImgBase)
protected
FData: PByte;
function GetInternalColor(x, y: integer): TFPColor; override;
function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
public
constructor Create(AWidth, AHeight: integer); override;
destructor Destroy; override;
procedure SetSize(AWidth, AHeight: integer); override;
end;
TPTMemImgGrayAlpha8BitValue = packed record
g,a: byte;
end;
PPTMemImgGrayAlpha8BitValue = ^TPTMemImgGrayAlpha8BitValue;
{ TPTMemImgGrayAlpha8Bit }
TPTMemImgGrayAlpha8Bit = class(TPTMemImgBase)
protected
FData: PPTMemImgGrayAlpha8BitValue;
function GetInternalColor(x, y: integer): TFPColor; override;
function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
public
constructor Create(AWidth, AHeight: integer); override;
destructor Destroy; override;
procedure SetSize(AWidth, AHeight: integer); override;
end;
TPTMemImgRGBA8BitValue = packed record
r,g,b,a: byte;
end;
PPTMemImgRGBA8BitValue = ^TPTMemImgRGBA8BitValue;
{ TPTMemImgRGBA8Bit }
TPTMemImgRGBA8Bit = class(TPTMemImgBase)
protected
FData: PPTMemImgRGBA8BitValue;
function GetInternalColor(x, y: integer): TFPColor; override;
function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
public
constructor Create(AWidth, AHeight: integer); override;
destructor Destroy; override;
procedure SetSize(AWidth, AHeight: integer); override;
end;
TPTMemImgRGB8BitValue = packed record
r,g,b: byte;
end;
PPTMemImgRGB8BitValue = ^TPTMemImgRGB8BitValue;
{ TPTMemImgRGB8Bit }
TPTMemImgRGB8Bit = class(TPTMemImgBase)
protected
FData: PPTMemImgRGB8BitValue;
function GetInternalColor(x, y: integer): TFPColor; override;
function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
public
constructor Create(AWidth, AHeight: integer); override;
destructor Destroy; override;
procedure SetSize(AWidth, AHeight: integer); override;
end;
TPTMemImgRGB16BitValue = packed record
r,g,b: word;
end;
PPTMemImgRGB16BitValue = ^TPTMemImgRGB16BitValue;
{ TPTMemImgRGB16Bit }
TPTMemImgRGB16Bit = class(TPTMemImgBase)
protected
FData: PPTMemImgRGB16BitValue;
function GetInternalColor(x, y: integer): TFPColor; override;
function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
public
constructor Create(AWidth, AHeight: integer); override;
destructor Destroy; override;
procedure SetSize(AWidth, AHeight: integer); override;
end;
{ TPTMemImgRGBA16Bit }
TPTMemImgRGBA16Bit = class(TPTMemImgBase)
protected
FData: PFPColor;
function GetInternalColor(x, y: integer): TFPColor; override;
function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
public
constructor Create(AWidth, AHeight: integer); override;
destructor Destroy; override;
procedure SetSize(AWidth, AHeight: integer); override;
end;
TCreateCompatibleMemImgEvent = procedure(Sender: TObject; Img: TFPCustomImage;
NewWidth, NewHeight: integer; out NewImage: TFPCustomImage) of object;
@ -216,46 +55,14 @@ type
function MaxSupport: double; virtual;
end;
{ Create a descriptor to select a memimg class }
function GetPTMemImgDesc(Gray: boolean; Depth: word; HasAlpha: boolean): TPTMemImgDesc;
{ Returns a memimg class that fits the descriptor }
function GetPTMemImgClass(const Desc: TPTMemImgDesc): TPTMemImgBaseClass;
{ Create a memimg with the descriptor }
function CreatePTMemImg(const Desc: TPTMemImgDesc; Width, Height: integer): TFPCustomImage;
{ Create a memimg with the same features as Img.
If Img is a TPTMemImgBaseClass it will create that.
Otherwise it returns a memimg that fits the Img using GetMinimumPTDesc. }
function CreateCompatiblePTMemImg(Img: TFPCustomImage; Width, Height: integer
): TFPCustomImage;
{ As CreateCompatiblePTMemImg, but the image has always an alpha channel. }
function CreateCompatiblePTMemImgWithAlpha(Img: TFPCustomImage;
Width, Height: integer): TFPCustomImage;
{ Returns the smallest descriptor that allows to store the Img.
It returns HasAlpha=false if all pixel are opaque.
It returns Gray=true if all red=green=blue.
It returns Depth=8 if all lo byte equals the hi byte or all lo bytes are 0.
To ignore rounding errors you can pass a FuzzyDepth. For example a FuzzyDepth
of 3 ignores the lower 3 bits when comparing. }
function GetMinimumPTDesc(Img: TFPCustomImage; FuzzyDepth: word = 4): TPTMemImgDesc;
{ Create a smaller memimg with the same information as Img.
Pass FreeImg=true to call Img.Free }
function GetMinimumPTMemImg(Img: TFPCustomImage; FreeImg: boolean;
FuzzyDepth: word = 4): TFPCustomImage;
procedure SetFPImgExtraTiff(const Desc: TPTMemImgDesc; Img: TFPCustomImage;
procedure SetFPImgExtraTiff(const Desc: TFPCompactImgDesc; Img: TFPCustomImage;
ClearTiffExtras: boolean);
function dbgs(const Desc: TPTMemImgDesc): string; overload;
function dbgs(const Desc: TFPCompactImgDesc): string; overload;
implementation
procedure SetFPImgExtraTiff(const Desc: TPTMemImgDesc; Img: TFPCustomImage;
procedure SetFPImgExtraTiff(const Desc: TFPCompactImgDesc; Img: TFPCustomImage;
ClearTiffExtras: boolean);
begin
if ClearTiffExtras then
@ -275,186 +82,13 @@ begin
Img.Extra[TiffAlphaBits]:='0';
end;
function dbgs(const Desc: TPTMemImgDesc): string;
function dbgs(const Desc: TFPCompactImgDesc): string;
begin
Result:='Depth='+dbgs(Desc.Depth)
+',Gray='+dbgs(Desc.Gray)
+',HasAlpha='+dbgs(Desc.HasAlpha);
end;
function GetPTMemImgDesc(Gray: boolean; Depth: word; HasAlpha: boolean
): TPTMemImgDesc;
begin
Result.Gray:=Gray;
Result.Depth:=Depth;
Result.HasAlpha:=HasAlpha;
end;
function GetPTMemImgClass(const Desc: TPTMemImgDesc): TPTMemImgBaseClass;
begin
if Desc.Gray then begin
if Desc.HasAlpha then begin
// gray, alpha
if Desc.Depth<=8 then
Result:=TPTMemImgGrayAlpha8Bit
else
Result:=TPTMemImgGrayAlpha16Bit;
end else begin
// gray, no alpha
if Desc.Depth<=8 then
Result:=TPTMemImgGray8Bit
else
Result:=TPTMemImgGray16Bit;
end;
end else begin
// RGB
if Desc.HasAlpha then begin
// RGB, alpha
if Desc.Depth<=8 then
Result:=TPTMemImgRGBA8Bit
else
Result:=TPTMemImgRGBA16Bit;
end else begin
// RGB, no alpha
if Desc.Depth<=8 then
Result:=TPTMemImgRGB8Bit
else
Result:=TPTMemImgRGB16Bit;
end;
end;
end;
function CreatePTMemImg(const Desc: TPTMemImgDesc; Width, Height: integer
): TFPCustomImage;
var
ImgClass: TPTMemImgBaseClass;
begin
ImgClass:=GetPTMemImgClass(Desc);
Result:=ImgClass.Create(Width,Height);
end;
function CreateCompatiblePTMemImg(Img: TFPCustomImage; Width, Height: integer
): TFPCustomImage;
begin
if Img is TPTMemImgBase then
Result:=CreatePTMemImg(TPTMemImgBase(Img).Desc,Width,Height)
else
Result:=CreatePTMemImg(GetMinimumPTDesc(Img),Width,Height);
//DebugLn(['CreateCompatibleQVMemImg '+Img.ClassName+' '+Result.ClassName]);
end;
function CreateCompatiblePTMemImgWithAlpha(Img: TFPCustomImage; Width,
Height: integer): TFPCustomImage;
var
Desc: TPTMemImgDesc;
begin
if Img is TPTMemImgBase then
Desc:=TPTMemImgBase(Img).Desc
else
Desc:=GetMinimumPTDesc(Img);
Desc.HasAlpha:=true;
Result:=CreatePTMemImg(Desc,Width,Height);
end;
function GetMinimumPTDesc(Img: TFPCustomImage; FuzzyDepth: word = 4): TPTMemImgDesc;
var
AllLoEqualsHi, AllLoAre0: Boolean;
FuzzyMaskLoHi: Word;
procedure Need16Bit(c: word); inline;
var
l: Byte;
begin
c:=c and FuzzyMaskLoHi;
l:=Lo(c);
AllLoAre0:=AllLoAre0 and (l=0);
AllLoEqualsHi:=AllLoEqualsHi and (l=Hi(c));
end;
var
TestGray: Boolean;
TestAlpha: Boolean;
Test16Bit: Boolean;
BaseImg: TPTMemImgBase;
ImgDesc: TPTMemImgDesc;
y: Integer;
x: Integer;
col: TFPColor;
FuzzyMaskWord: Word;
FuzzyOpaque: Word;
begin
TestGray:=true;
TestAlpha:=true;
Test16Bit:=FuzzyDepth<8;
Result.HasAlpha:=false;
Result.Gray:=true;
Result.Depth:=8;
if Img is TPTMemImgBase then begin
BaseImg:=TPTMemImgBase(Img);
ImgDesc:=BaseImg.Desc;
if ImgDesc.Depth<=8 then Test16Bit:=false;
if ImgDesc.Gray then TestGray:=false;
if not ImgDesc.HasAlpha then TestAlpha:=false;
end;
if (not TestGray) and (not TestAlpha) and (not Test16Bit) then exit;
FuzzyMaskWord:=Word($ffff) shl FuzzyDepth;
FuzzyOpaque:=alphaOpaque and FuzzyMaskWord;
FuzzyMaskLoHi:=Word(lo(FuzzyMaskWord))+(Word(lo(FuzzyMaskWord)) shl 8);
AllLoAre0:=true;
AllLoEqualsHi:=true;
for y:=0 to Img.Height-1 do begin
for x:=0 to Img.Width-1 do begin
col:=Img.Colors[x,y];
if TestAlpha and ((col.alpha and FuzzyMaskWord)<>FuzzyOpaque) then begin
TestAlpha:=false;
Result.HasAlpha:=true;
if (not TestGray) and (not Test16Bit) then break;
end;
if TestGray
and ((col.red and FuzzyMaskWord)<>(col.green and FuzzyMaskWord))
or ((col.red and FuzzyMaskWord)<>(col.blue and FuzzyMaskWord)) then begin
TestGray:=false;
Result.Gray:=false;
if (not TestAlpha) and (not Test16Bit) then break;
end;
if Test16Bit then begin
Need16Bit(col.red);
Need16Bit(col.green);
Need16Bit(col.blue);
Need16Bit(col.alpha);
if (not AllLoAre0) and (not AllLoEqualsHi) then begin
Test16Bit:=false;
Result.Depth:=16;
if (not TestAlpha) and (not TestGray) then break;
end;
end;
end;
end;
end;
function GetMinimumPTMemImg(Img: TFPCustomImage; FreeImg: boolean;
FuzzyDepth: word = 4): TFPCustomImage;
var
Desc: TPTMemImgDesc;
ImgClass: TPTMemImgBaseClass;
y: Integer;
x: Integer;
begin
Desc:=GetMinimumPTDesc(Img,FuzzyDepth);
//debugln(['GetMinimumQVMemImg Depth=',Desc.Depth,' Gray=',Desc.Gray,' HasAlpha=',Desc.HasAlpha]);
ImgClass:=GetPTMemImgClass(Desc);
if Img.ClassType=ImgClass then
exit(Img);
Result:=CreatePTMemImg(Desc,Img.Width,Img.Height);
for y:=0 to Img.Height-1 do
for x:=0 to Img.Width-1 do
Result.Colors[x,y]:=Img.Colors[x,y];
if FreeImg then
Img.Free;
end;
function ColorRound (c : double) : word;
begin
if c > $FFFF then
@ -465,405 +99,6 @@ begin
result := round(c);
end;
{ TPTMemImgGrayAlpha16Bit }
function TPTMemImgGrayAlpha16Bit.GetInternalColor(x, y: integer): TFPColor;
var
v: TPTMemImgGrayAlpha16BitValue;
begin
v:=FData[x+y*Width];
Result.red:=v.g;
Result.green:=Result.red;
Result.blue:=Result.red;
Result.alpha:=v.a;
end;
function TPTMemImgGrayAlpha16Bit.GetInternalPixel(x, y: integer): integer;
begin
Result:=0;
end;
procedure TPTMemImgGrayAlpha16Bit.SetInternalColor(x, y: integer;
const Value: TFPColor);
var
v: TPTMemImgGrayAlpha16BitValue;
begin
v.g:=Value.red;
v.a:=Value.alpha;
FData[x+y*Width]:=v;
end;
procedure TPTMemImgGrayAlpha16Bit.SetInternalPixel(x, y: integer; Value: integer
);
begin
end;
constructor TPTMemImgGrayAlpha16Bit.Create(AWidth, AHeight: integer);
begin
FDesc:=GetPTMemImgDesc(true,16,true);
inherited Create(AWidth, AHeight);
end;
destructor TPTMemImgGrayAlpha16Bit.Destroy;
begin
ReAllocMem(FData,0);
inherited Destroy;
end;
procedure TPTMemImgGrayAlpha16Bit.SetSize(AWidth, AHeight: integer);
begin
if (AWidth=Width) and (AHeight=Height) then exit;
ReAllocMem(FData,SizeOf(TPTMemImgGrayAlpha16BitValue)*AWidth*AHeight);
inherited SetSize(AWidth, AHeight);
end;
{ TPTMemImgGrayAlpha8Bit }
function TPTMemImgGrayAlpha8Bit.GetInternalColor(x, y: integer): TFPColor;
var
v: TPTMemImgGrayAlpha8BitValue;
begin
v:=FData[x+y*Width];
Result.red:=(v.g shl 8)+v.g;
Result.green:=Result.red;
Result.blue:=Result.red;
Result.alpha:=(v.a shl 8)+v.a;
end;
function TPTMemImgGrayAlpha8Bit.GetInternalPixel(x, y: integer): integer;
begin
Result:=0;
end;
procedure TPTMemImgGrayAlpha8Bit.SetInternalColor(x, y: integer;
const Value: TFPColor);
var
v: TPTMemImgGrayAlpha8BitValue;
begin
v.g:=Value.red shr 8;
v.a:=Value.alpha shr 8;
FData[x+y*Width]:=v;
end;
procedure TPTMemImgGrayAlpha8Bit.SetInternalPixel(x, y: integer; Value: integer
);
begin
end;
constructor TPTMemImgGrayAlpha8Bit.Create(AWidth, AHeight: integer);
begin
FDesc:=GetPTMemImgDesc(true,8,true);
inherited Create(AWidth, AHeight);
end;
destructor TPTMemImgGrayAlpha8Bit.Destroy;
begin
ReAllocMem(FData,0);
inherited Destroy;
end;
procedure TPTMemImgGrayAlpha8Bit.SetSize(AWidth, AHeight: integer);
begin
if (AWidth=Width) and (AHeight=Height) then exit;
ReAllocMem(FData,SizeOf(TPTMemImgGrayAlpha8BitValue)*AWidth*AHeight);
inherited SetSize(AWidth, AHeight);
end;
{ TPTMemImgGray16Bit }
function TPTMemImgGray16Bit.GetInternalColor(x, y: integer): TFPColor;
begin
Result.red:=FData[x+y*Width];
Result.green:=Result.red;
Result.blue:=Result.red;
Result.alpha:=alphaOpaque;
end;
function TPTMemImgGray16Bit.GetInternalPixel(x, y: integer): integer;
begin
Result:=0;
end;
procedure TPTMemImgGray16Bit.SetInternalColor(x, y: integer;
const Value: TFPColor);
begin
FData[x+y*Width]:=Value.red;
end;
procedure TPTMemImgGray16Bit.SetInternalPixel(x, y: integer; Value: integer);
begin
end;
constructor TPTMemImgGray16Bit.Create(AWidth, AHeight: integer);
begin
FDesc:=GetPTMemImgDesc(true,16,false);
inherited Create(AWidth, AHeight);
end;
destructor TPTMemImgGray16Bit.Destroy;
begin
ReAllocMem(FData,0);
inherited Destroy;
end;
procedure TPTMemImgGray16Bit.SetSize(AWidth, AHeight: integer);
begin
if (AWidth=Width) and (AHeight=Height) then exit;
ReAllocMem(FData,SizeOf(Word)*AWidth*AHeight);
inherited SetSize(AWidth,AHeight);
end;
{ TPTMemImgGray8Bit }
function TPTMemImgGray8Bit.GetInternalColor(x, y: integer): TFPColor;
begin
Result.red:=FData[x+y*Width];
Result.red:=(Word(Result.red) shl 8)+Result.red;
Result.green:=Result.red;
Result.blue:=Result.red;
Result.alpha:=alphaOpaque;
end;
function TPTMemImgGray8Bit.GetInternalPixel(x, y: integer): integer;
begin
Result:=0;
end;
procedure TPTMemImgGray8Bit.SetInternalColor(x, y: integer;
const Value: TFPColor);
begin
FData[x+y*Width]:=Value.red shr 8;
end;
procedure TPTMemImgGray8Bit.SetInternalPixel(x, y: integer; Value: integer);
begin
end;
constructor TPTMemImgGray8Bit.Create(AWidth, AHeight: integer);
begin
FDesc:=GetPTMemImgDesc(true,8,false);
inherited Create(AWidth, AHeight);
end;
destructor TPTMemImgGray8Bit.Destroy;
begin
ReAllocMem(FData,0);
inherited Destroy;
end;
procedure TPTMemImgGray8Bit.SetSize(AWidth, AHeight: integer);
begin
if (AWidth=Width) and (AHeight=Height) then exit;
ReAllocMem(FData,SizeOf(Byte)*AWidth*AHeight);
inherited SetSize(AWidth,AHeight);
end;
{ TPTMemImgRGBA8Bit }
function TPTMemImgRGBA8Bit.GetInternalColor(x, y: integer): TFPColor;
var
v: TPTMemImgRGBA8BitValue;
begin
v:=FData[x+y*Width];
Result.red:=(v.r shl 8)+v.r;
Result.green:=(v.g shl 8)+v.g;
Result.blue:=(v.b shl 8)+v.b;
Result.alpha:=(v.a shl 8)+v.a;
end;
function TPTMemImgRGBA8Bit.GetInternalPixel(x, y: integer): integer;
begin
Result:=0;
end;
procedure TPTMemImgRGBA8Bit.SetInternalColor(x, y: integer;
const Value: TFPColor);
var
v: TPTMemImgRGBA8BitValue;
begin
v.r:=Value.red shr 8;
v.g:=Value.green shr 8;
v.b:=Value.blue shr 8;
v.a:=Value.alpha shr 8;
FData[x+y*Width]:=v;
end;
procedure TPTMemImgRGBA8Bit.SetInternalPixel(x, y: integer; Value: integer);
begin
end;
constructor TPTMemImgRGBA8Bit.Create(AWidth, AHeight: integer);
begin
FDesc:=GetPTMemImgDesc(false,8,true);
inherited Create(AWidth, AHeight);
end;
destructor TPTMemImgRGBA8Bit.Destroy;
begin
ReAllocMem(FData,0);
inherited Destroy;
end;
procedure TPTMemImgRGBA8Bit.SetSize(AWidth, AHeight: integer);
begin
if (AWidth=Width) and (AHeight=Height) then exit;
ReAllocMem(FData,SizeOf(TPTMemImgRGBA8BitValue)*AWidth*AHeight);
inherited SetSize(AWidth,AHeight);
end;
{ TPTMemImgRGB8Bit }
function TPTMemImgRGB8Bit.GetInternalColor(x, y: integer): TFPColor;
var
v: TPTMemImgRGB8BitValue;
begin
v:=FData[x+y*Width];
Result.red:=(v.r shl 8)+v.r;
Result.green:=(v.g shl 8)+v.g;
Result.blue:=(v.b shl 8)+v.b;
Result.alpha:=alphaOpaque;
end;
function TPTMemImgRGB8Bit.GetInternalPixel(x, y: integer): integer;
begin
Result:=0;
end;
procedure TPTMemImgRGB8Bit.SetInternalColor(x, y: integer; const Value: TFPColor
);
var
v: TPTMemImgRGB8BitValue;
begin
v.r:=Value.red shr 8;
v.g:=Value.green shr 8;
v.b:=Value.blue shr 8;
FData[x+y*Width]:=v;
end;
procedure TPTMemImgRGB8Bit.SetInternalPixel(x, y: integer; Value: integer);
begin
end;
constructor TPTMemImgRGB8Bit.Create(AWidth, AHeight: integer);
begin
FDesc:=GetPTMemImgDesc(false,8,false);
inherited Create(AWidth, AHeight);
end;
destructor TPTMemImgRGB8Bit.Destroy;
begin
ReAllocMem(FData,0);
inherited Destroy;
end;
procedure TPTMemImgRGB8Bit.SetSize(AWidth, AHeight: integer);
begin
if (AWidth=Width) and (AHeight=Height) then exit;
ReAllocMem(FData,SizeOf(TPTMemImgRGB8BitValue)*AWidth*AHeight);
inherited SetSize(AWidth,AHeight);
end;
{ TPTMemImgRGB16Bit }
function TPTMemImgRGB16Bit.GetInternalColor(x, y: integer): TFPColor;
var
v: TPTMemImgRGB16BitValue;
begin
v:=FData[x+y*Width];
Result.red:=v.r;
Result.green:=v.g;
Result.blue:=v.b;
Result.alpha:=alphaOpaque;
end;
function TPTMemImgRGB16Bit.GetInternalPixel(x, y: integer): integer;
begin
Result:=0;
end;
procedure TPTMemImgRGB16Bit.SetInternalColor(x, y: integer;
const Value: TFPColor);
var
v: TPTMemImgRGB16BitValue;
begin
v.r:=Value.red;
v.g:=Value.green;
v.b:=Value.blue;
FData[x+y*Width]:=v;
end;
procedure TPTMemImgRGB16Bit.SetInternalPixel(x, y: integer; Value: integer);
begin
end;
constructor TPTMemImgRGB16Bit.Create(AWidth, AHeight: integer);
begin
FDesc:=GetPTMemImgDesc(false,16,false);
inherited Create(AWidth, AHeight);
end;
destructor TPTMemImgRGB16Bit.Destroy;
begin
ReAllocMem(FData,0);
inherited Destroy;
end;
procedure TPTMemImgRGB16Bit.SetSize(AWidth, AHeight: integer);
begin
if (AWidth=Width) and (AHeight=Height) then exit;
ReAllocMem(FData,SizeOf(TPTMemImgRGB16BitValue)*AWidth*AHeight);
inherited SetSize(AWidth,AHeight);
end;
{ TPTMemImgRGBA16Bit }
function TPTMemImgRGBA16Bit.GetInternalColor(x, y: integer): TFPColor;
begin
Result:=FData[x+y*Width];
end;
function TPTMemImgRGBA16Bit.GetInternalPixel(x, y: integer): integer;
begin
Result:=0;
end;
procedure TPTMemImgRGBA16Bit.SetInternalColor(x, y: integer;
const Value: TFPColor);
begin
FData[x+y*Width]:=Value;
end;
procedure TPTMemImgRGBA16Bit.SetInternalPixel(x, y: integer; Value: integer);
begin
end;
constructor TPTMemImgRGBA16Bit.Create(AWidth, AHeight: integer);
begin
FDesc:=GetPTMemImgDesc(false,16,true);
inherited Create(AWidth, AHeight);
end;
destructor TPTMemImgRGBA16Bit.Destroy;
begin
ReAllocMem(FData,0);
inherited Destroy;
end;
procedure TPTMemImgRGBA16Bit.SetSize(AWidth, AHeight: integer);
begin
if (AWidth=Width) and (AHeight=Height) then exit;
ReAllocMem(FData,SizeOf(TFPColor)*AWidth*AHeight);
inherited SetSize(AWidth,AHeight);
end;
{ TLinearInterpolation }
procedure TLinearInterpolation.CreatePixelWeights(OldSize, NewSize: integer;