diff --git a/applications/pyramidtiff/pyramidtiff.lpi b/applications/pyramidtiff/pyramidtiff.lpi index cc2d80229..c190747a0 100644 --- a/applications/pyramidtiff/pyramidtiff.lpi +++ b/applications/pyramidtiff/pyramidtiff.lpi @@ -1,4 +1,4 @@ - + @@ -29,19 +29,23 @@ - - + - + + + + + + + - @@ -59,12 +63,6 @@ - - - - - - diff --git a/applications/pyramidtiff/pyramidtiff.lpr b/applications/pyramidtiff/pyramidtiff.lpr index fca7c3c75..ba8caf2bc 100644 --- a/applications/pyramidtiff/pyramidtiff.lpr +++ b/applications/pyramidtiff/pyramidtiff.lpr @@ -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 Size1DWord(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+1Img 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 '); - writeln(' Check if file is a pyramid, tiled tif. 0 = yes, 1 = no.'); writeln('-i '); 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 '); - 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 '); + writeln(' Check if file is a pyramid, tiled tif. 0 = yes, 1 = no.'); + writeln(' You can not use both -c and -i'); writeln('--width='); writeln(' In pixel. Default=',TileWidth); writeln('--height='); diff --git a/applications/pyramidtiff/pytigraphics.pas b/applications/pyramidtiff/pytigraphics.pas index 1a506075e..a4825015e 100644 --- a/applications/pyramidtiff/pytigraphics.pas +++ b/applications/pyramidtiff/pytigraphics.pas @@ -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;