diff --git a/applications/pyramidtiff/pyramidtiff.lpi b/applications/pyramidtiff/pyramidtiff.lpi new file mode 100644 index 000000000..cc2d80229 --- /dev/null +++ b/applications/pyramidtiff/pyramidtiff.lpi @@ -0,0 +1,82 @@ + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <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"> + <Item1> + <PackageName Value="LazUtils"/> + </Item1> + </RequiredPackages> + <Units Count="1"> + <Unit0> + <Filename Value="pyramidtiff.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="pyramidtiff"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="pyramidtiff"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <AllowLabel Value="False"/> + </SyntaxOptions> + </Parsing> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/applications/pyramidtiff/pyramidtiff.lpr b/applications/pyramidtiff/pyramidtiff.lpr new file mode 100644 index 000000000..485f314d1 --- /dev/null +++ b/applications/pyramidtiff/pyramidtiff.lpr @@ -0,0 +1,620 @@ +{ 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+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Classes, SysUtils, math, LazFileUtils, CustApp, + FPimage, FPReadJPEG, FPReadPNG, FPReadBMP, FPImgCanv, + PyTiGraphics, FPReadTiff, FPTiffCmn, FPWriteTiff; + +const + Version = '1.0'; +type + + { TPyramidTiffer } + + TPyramidTiffer = class(TCustomApplication) + private + FMinSize: Word; + FQuiet: boolean; + //FSkipCheck: boolean; + FTileHeight: Word; + FTileWidth: Word; + FVerbose: boolean; + procedure LoadTiff(out Img: TPTMemImgBase; + Reader: TFPReaderTiff; InStream: TMemoryStream; + var ErrorMsg: string); + procedure LoadOther(out Img: TPTMemImgBase; + Reader: TFPCustomImageReader; InStream: TMemoryStream); + function ShrinkImage(LastImg: TPTMemImgBase): TPTMemImgBase; + procedure TiffReaderCreateImage(Sender: TFPReaderTiff; IFD: TTiffIFD); + protected + procedure DoRun; override; + procedure ParamError(const Msg: string); + 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; + 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; + end; + +function CompareIFDForSize(i1, i2: Pointer): integer; +var + IFD1: TTiffIFD absolute i1; + IFD2: TTiffIFD absolute i2; + Size1: Int64; + Size2: Int64; +begin + Size1:=int64(IFD1.ImageWidth)*IFD1.ImageHeight; + Size2:=int64(IFD2.ImageWidth)*IFD2.ImageHeight; + if Size1>Size2 then Result:=1 + else if Size1<Size2 then Result:=-1 + else Result:=0; +end; + +function StringToList(const LongOpts: string): TStrings; +const + SepChars = ' '#10#13#9; +var + L : TStringList; + Len,I,J : Integer; +begin + l:=TStringList.Create; + I:=1; + Len:=Length(LongOpts); + while I<=Len do begin + while Isdelimiter(SepChars,LongOpts,I) do + Inc(I); + J:=I; + while (J<=Len) and Not IsDelimiter(SepChars,LongOpts,J) do + Inc(J); + if (I<=J) then + L.Add(Copy(LongOpts,I,(J-I))); + I:=J+1; + end; + Result:=l; +end; + +{ TMyApplication } + +procedure TPyramidTiffer.TiffReaderCreateImage(Sender: TFPReaderTiff; + IFD: TTiffIFD); +var + Desc: TPTMemImgDesc; +begin + // free old image + FreeAndNil(IFD.Img); + + Desc.HasAlpha:=IFD.AlphaBits>0; + Desc.Gray:=IFD.PhotoMetricInterpretation in [0,1]; + Desc.Depth:=Max(Max(Max(IFD.RedBits, + IFD.GreenBits), + IFD.BlueBits), + IFD.GrayBits); + IFD.Img:=CreateQVMemImg(Desc,IFD.ImageWidth,IFD.ImageHeight); +end; + +function TPyramidTiffer.ShrinkImage(LastImg: TPTMemImgBase): TPTMemImgBase; + + function Half(i: integer): integer; + begin + Result:=(i+1) div 2; + if Result<1 then Result:=1; + end; + +var + ImgCanvas: TFPImageCanvas; +begin + Result:=TPTMemImgBase(CreateQVMemImg(LastImg.Desc, Half(LastImg.Width), Half( + LastImg.Height))); + ImgCanvas:=TFPImageCanvas.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; + Reader: TFPReaderTiff; InStream: TMemoryStream; var ErrorMsg: string); +begin + Reader.OnCreateImage:=@TiffReaderCreateImage; + Reader.LoadFromStream(InStream); + if Reader.ImageCount=0 then begin + ErrorMsg:='tiff has no image'; + exit; + end; + Img:=Reader.GetBiggestImage.Img as TPTMemImgBase; +end; + +procedure TPyramidTiffer.LoadOther(out Img: TPTMemImgBase; + Reader: TFPCustomImageReader; InStream: TMemoryStream); +begin + Img:=TPTMemImgRGBA8Bit.Create(0, 0); + Reader.ImageRead(InStream, Img); + Img:=GetMinimumQVMemImg(Img, true) as TPTMemImgBase; +end; + +procedure TPyramidTiffer.DoRun; +var + InputFilename: String; + OutputFilename: String; + ErrorMsg: string; +begin + ReadConfig; + + if HasOption('min-size') then begin + MinSize:=StrToInt(GetOptionValue('min-size')); + if (MinSize<4) or (MinSize>32768) then + ParamError('min-size out of range (4..32768): '+IntToStr(MinSize)); + end; + if HasOption('width') then begin + TileWidth:=StrToInt(GetOptionValue('width')); + if (TileWidth<4) or (TileWidth>32768) then + ParamError('width out of range (4..32768): '+IntToStr(TileWidth)); + end; + if HasOption('height') then begin + TileHeight:=StrToInt(GetOptionValue('height')); + if (TileHeight<4) or (TileHeight>32768) then + ParamError('height out of range (4..32768): '+IntToStr(TileHeight)); + end; + + if HasOption('c') then begin + // only check + if HasOption('i') then + 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 + if not Quiet then + writeln('ok'); + end else begin + if not Quiet then + writeln('not ok: ',ErrorMsg); + ExitCode:=1; + end; + end else begin + // convert + if not HasOption('i') then + ParamError('missing parameter -i'); + 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; + end; + end; + + // stop program loop + Terminate; +end; + +procedure TPyramidTiffer.ParamError(const Msg: string); +begin + writeln('Error: ',Msg); + writeln; + WriteHelp(false); + Halt(2); +end; + +procedure TPyramidTiffer.ReadConfig; +const + ShortOpts = 'hc:i:o:qvV'; + LongOpts = 'help width height min-size quiet verbose version'; +var + LongOptions: TStrings; + + procedure CheckOpts; + var + Opts,NonOpts: TStrings; + ErrorMsg: String; + i: Integer; + begin + Opts:=TStringList.Create; + NonOpts:=TStringList.Create; + try + ErrorMsg:=CheckOptions(ShortOpts,LongOptions,Opts,NonOpts); + if ErrorMsg<>'' then begin + ShowException(Exception.Create(ErrorMsg)); + Halt; + end; + for i:=0 to NonOpts.Count-1 do + if NonOpts[i]<>'' then + ParamError('invalid parameter "'+NonOpts[i]+'"'); + finally + Opts.Free; + NonOpts.Free; + end; + Verbose:=HasOption('v','verbose'); + Quiet:=HasOption('q','quiet'); + end; + +begin + LongOptions:=StringToList(LongOpts); + try + CheckOpts; + + // parse parameters + if HasOption('h','help') then begin + WriteHelp(true); + Halt; + end; + + // parse parameters + if HasOption('V','version') then begin + writeln(Version); + Halt; + end; + finally + LongOptions.Free; + end; +end; + +function TPyramidTiffer.CheckIfFileIsPyramidTiled(Filename: string; out + ErrorMsg: string): boolean; +var + ms: TMemoryStream; +begin + Result:=false; + ErrorMsg:=''; + try + if Verbose then + writeln('Checking file "',Filename,'"'); + ms:=TMemoryStream.Create; + try + ms.LoadFromFile(Filename); + ms.Position:=0; + Result:=CheckIfStreamIsPyramidTiled(ms,ErrorMsg); + finally + ms.Free; + end; + except + on E: Exception do begin + ErrorMsg:=E.Message; + end; + end; +end; + +function TPyramidTiffer.CheckIfStreamIsPyramidTiled(s: TStream; out + ErrorMsg: string): boolean; +var + Reader: TFPReaderTiff; + i: Integer; + Img: TTiffIFD; + SmallerImg: TTiffIFD; +begin + Result:=false; + ErrorMsg:=''; + try + Reader:=TFPReaderTiff.Create; + try + ErrorMsg:='this is not a tiff file: '; + Reader.LoadHeaderFromStream(s); + ErrorMsg:='error in tiff file: '; + Reader.LoadIFDsFromStream; + if Reader.ImageCount<1 then begin + ErrorMsg:='no images found in tif'; + exit; + end; + // sort ascending + Reader.ImageList.Sort(@CompareIFDForSize); + SmallerImg:=nil; + for i:=0 to Reader.ImageCount-1 do begin + Img:=Reader.Images[i]; + if Verbose then + writeln(' ',i,'/',Reader.ImageCount,' ',Img.ImageWidth,'x',Img.ImageHeight); + if (Img.TileWidth<1) or (Img.TileLength<1) then begin + ErrorMsg:='image '+IntToStr(i)+' is not tiled'; + exit; + 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 + ErrorMsg:='missing small scale step. min-size='+IntToStr(MinSize)+'.' + +' Smallest image: '+IntToStr(Img.ImageWidth)+'x'+IntToStr(Img.ImageHeight); + exit; + end; + end else begin + if (SmallerImg.ImageWidth*2+1)<Img.ImageWidth then begin + ErrorMsg:='missing scale step between ImageWidth=' + +IntToStr(SmallerImg.ImageWidth)+' and '+IntToStr(Img.ImageWidth); + exit; + end; + if (SmallerImg.ImageHeight*2+1)<Img.ImageHeight then begin + ErrorMsg:='missing scale step between ImageHeight=' + +IntToStr(SmallerImg.ImageHeight)+' and '+IntToStr(Img.ImageHeight); + exit; + end; + end; + SmallerImg:=Img; + end; + Result:=true; + finally + Reader.Free; + end; + except + on E: Exception do begin + ErrorMsg:=ErrorMsg+E.Message; + end; + end; +end; + +function TPyramidTiffer.Convert(InputFilename, OutputFilename: string; out + ErrorMsg: string): boolean; +var + InStream: TMemoryStream; + Ext: String; + ReaderClass: TFPCustomImageReaderClass; + Reader: TFPCustomImageReader; + Img: TPTMemImgBase; + i: Integer; +begin + Result:=false; + ErrorMsg:=''; + try + if Verbose then + writeln('Reading file "',InputFilename,'"'); + InStream:=TMemoryStream.Create; + Reader:=nil; + Img:=nil; + try + // load file + InStream.LoadFromFile(InputFilename); + 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; + if ReaderClass=nil then begin + ErrorMsg:='unknown file extension "'+Ext+'"'; + exit; + end; + Reader:=ReaderClass.Create; + + // parse image + if Reader is TFPReaderTiff then begin + LoadTiff(Img, TFPReaderTiff(Reader), InStream, ErrorMsg); + end else begin + LoadOther(Img, Reader, InStream); + end; + // free memory early + FreeAndNil(InStream); + FreeAndNil(Reader); + + // convert + Result:=Convert(Img,OutputFilename,ErrorMsg); + finally + InStream.Free; + Reader.Free; + Img.Free; + end; + except + on E: Exception do begin + ErrorMsg:=E.Message; + end; + end; +end; + +function TPyramidTiffer.Convert(Img: TPTMemImgBase; OutputFilename: string; out + ErrorMsg: string): boolean; +var + OutStream: TMemoryStream; + Writer: TFPWriterTiff; + Size: Int64; + Count: Integer; + Index: Integer; + LastImg: TPTMemImgBase; + NewImg: TPTMemImgBase; +begin + Result:=false; + try + // compute the number of images + Count:=1; + Size:=Int64(Img.Width)*Img.Height; + while Size>4096 do begin + Size:=Size div 4; + inc(Count); + end; + + // create images + OutStream:=TMemoryStream.Create; + Writer:=nil; + LastImg:=nil; + NewImg:=nil; + 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); + + // 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); + // free last step + if LastImg<>Img then + FreeAndNil(LastImg); + LastImg:=NewImg; + NewImg:=nil; + end; + // free memory early + FreeAndNil(LastImg); + + // create stream + Writer.SaveToStream(OutStream); + OutStream.Position:=0; + + // save to file + OutStream.SaveToFile(OutputFilename); + Result:=true; + finally + if LastImg<>Img then + LastImg.Free; + NewImg.Free; + Writer.Free; + OutStream.Free; + end; + except + on E: Exception do begin + ErrorMsg:=E.Message; + end; + end; +end; + +constructor TPyramidTiffer.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + StopOnException:=True; + TileWidth:=256; + TileHeight:=256; + MinSize:=32; +end; + +destructor TPyramidTiffer.Destroy; +begin + inherited Destroy; +end; + +procedure TPyramidTiffer.WriteHelp(WithHeader: boolean); +var + ImgType: String; + i: Integer; +begin + writeln('Usage: ',ExeName,' -h'); + writeln; + 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; + 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 + ImgType:=ImageHandlers.TypeNames[i]; + write(' ',ImageHandlers.Extentions[ImgType]); + end; + writeln; + writeln('-o <output file>'); + writeln(' Output image file. It will always be a tif file, no matter what extension it has.'); + writeln('--width=<tilewidth>'); + writeln(' In pixel. Default=',TileWidth); + writeln('--height=<tileheight>'); + writeln(' In pixel. Default=',TileHeight); + writeln('--min-size=<min size>'); + writeln(' Create no images with a smaller width or height than this value in pixel.'); + writeln(' Default=',MinSize); + //writeln('--skip-check'); + //writeln(' Skip check if output file is already a pyramid tiled tif.'); + writeln('-h or --help'); + writeln(' Write this help'); + writeln('-q or --quiet'); + writeln(' Be less verbose'); + writeln('-v or --verbose'); + writeln(' Be more verbose'); + writeln('-V or --version'); + writeln(' Write version.'); + writeln; + writeln('Examples:'); + writeln(' Convert input.jpg into output.tif:'); + writeln(' ',ExeName,' -i input.jpg -o output.tif'); + writeln; + writeln(' Check if file.tif is already a pyramid, tiled tif:'); + writeln(' ',ExeName,' -c file.tif'); + writeln; +end; + +var + Application: TPyramidTiffer; +begin + Application:=TPyramidTiffer.Create(nil); + Application.Run; + Application.Free; +end. + diff --git a/applications/pyramidtiff/pyramidtiff.lps b/applications/pyramidtiff/pyramidtiff.lps new file mode 100644 index 000000000..8b1378917 --- /dev/null +++ b/applications/pyramidtiff/pyramidtiff.lps @@ -0,0 +1 @@ + diff --git a/applications/pyramidtiff/pytigraphics.pas b/applications/pyramidtiff/pytigraphics.pas new file mode 100644 index 000000000..7d59373b4 --- /dev/null +++ b/applications/pyramidtiff/pytigraphics.pas @@ -0,0 +1,1086 @@ +{ Graphic functions for pyramidtiff. + + Copyright (C) 2008 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. +} +unit PyTiGraphics; + +{$mode objfpc}{$H+} + +{$inline on} + +interface + +uses + Math, sysutils, Classes, FPimage, FPImgCanv, + LazLogger, FPCanvas, FPWriteTiff, FPTiffCmn; + +type + TPTMemImgDesc = record + Gray: boolean; + Depth: word; + 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; + + { TLinearInterpolation } + + TLinearInterpolation = class(TFPCustomInterpolation) + private + procedure CreatePixelWeights(OldSize, NewSize: integer; + out Entries: Pointer; out EntrySize: integer; out Support: integer); + protected + procedure Execute(x,y,w,h: integer); override; + function Filter(x: double): double; virtual; + function MaxSupport: double; virtual; + end; + +function GeTPTMemImgDesc(Gray: boolean; Depth: word; HasAlpha: boolean): TPTMemImgDesc; +function GeTPTMemImgClass(const Desc: TPTMemImgDesc): TPTMemImgBaseClass; +function CreateQVMemImg(const Desc: TPTMemImgDesc; Width, Height: integer): TFPCustomImage; +function CreateCompatibleQVMemImg(Img: TFPCustomImage; Width, Height: integer + ): TFPCustomImage; +function CreateCompatibleQVMemImgWithAlpha(Img: TFPCustomImage; + Width, Height: integer): TFPCustomImage; +function GetMinimumQVDesc(Img: TFPCustomImage): TPTMemImgDesc; +function GetMinimumQVMemImg(Img: TFPCustomImage; FreeImg: boolean): TFPCustomImage; + +procedure SetFPImgExtraTiff(const Desc: TPTMemImgDesc; Img: TFPCustomImage; + ClearTiffExtras: boolean); + +procedure SaveAsDebugTiff(Img: TFPCustomImage; Filename: string); +function dbgs(const Desc: TPTMemImgDesc): string; overload; + +implementation + +procedure SetFPImgExtraTiff(const Desc: TPTMemImgDesc; Img: TFPCustomImage; + ClearTiffExtras: boolean); +begin + if ClearTiffExtras then + FPTiffCmn.ClearTiffExtras(Img); + if Desc.Gray then begin + Img.Extra[TiffPhotoMetric]:='1'; + Img.Extra[TiffGrayBits]:=IntToStr(Desc.Depth); + end else begin + Img.Extra[TiffPhotoMetric]:='2'; + Img.Extra[TiffRedBits]:=IntToStr(Desc.Depth); + Img.Extra[TiffGreenBits]:=IntToStr(Desc.Depth); + Img.Extra[TiffBlueBits]:=IntToStr(Desc.Depth); + end; + if Desc.HasAlpha then + Img.Extra[TiffAlphaBits]:=IntToStr(Desc.Depth) + else + Img.Extra[TiffAlphaBits]:='0'; +end; + +procedure SaveAsDebugTiff(Img: TFPCustomImage; Filename: string); +var + Writer: TFPWriterTiff; + ms: TMemoryStream; +begin + ms:=nil; + Writer:=nil; + try + ms:=TMemoryStream.Create; + Writer:=TFPWriterTiff.Create; + Writer.ImageWrite(ms,Img); + ms.Position:=0; + ms.SaveToFile(Filename); + DebugLn(['SaveAsDebugTiff ',Img.ClassName,' ',Img.Width,'x',Img.Height,' ',Filename]); + finally + Writer.Free; + ms.Free; + end; +end; + +function dbgs(const Desc: TPTMemImgDesc): 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 CreateQVMemImg(const Desc: TPTMemImgDesc; Width, Height: integer + ): TFPCustomImage; +var + ImgClass: TPTMemImgBaseClass; +begin + ImgClass:=GeTPTMemImgClass(Desc); + Result:=ImgClass.Create(Width,Height); +end; + +function CreateCompatibleQVMemImg(Img: TFPCustomImage; Width, Height: integer + ): TFPCustomImage; +begin + if Img is TPTMemImgBase then + Result:=CreateQVMemImg(TPTMemImgBase(Img).Desc,Width,Height) + else + Result:=TPTMemImgRGBA16Bit.create(Width,Height); + //DebugLn(['CreateCompatibleQVMemImg '+Img.ClassName+' '+Result.ClassName]); +end; + +function CreateCompatibleQVMemImgWithAlpha(Img: TFPCustomImage; Width, + Height: integer): TFPCustomImage; +var + Desc: TPTMemImgDesc; +begin + if Img is TPTMemImgBase then begin + Desc:=TPTMemImgBase(Img).Desc; + Desc.HasAlpha:=true; + Result:=CreateQVMemImg(Desc,Width,Height) + end else + Result:=TPTMemImgRGBA16Bit.create(Width,Height); +end; + +function GetMinimumQVDesc(Img: TFPCustomImage): TPTMemImgDesc; + + function Need16Bit(c: word): boolean; inline; + var + l: Byte; + begin + l:=Lo(c); + Result:=(l<>0) and (l<>Hi(c)); + end; + +var + TestGray: Boolean; + TestAlpha: Boolean; + Test16Bit: Boolean; + BaseImg: TPTMemImgBase; + ImgDesc: TPTMemImgDesc; + y: Integer; + x: Integer; + col: TFPColor; +begin + TestGray:=true; + TestAlpha:=true; + Test16Bit:=true; + 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; + 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<>alphaOpaque) then begin + TestAlpha:=false; + Result.HasAlpha:=true; + if (not TestGray) and (not Test16Bit) then break; + end; + if TestGray + and ((col.red<>col.green) or (col.red<>col.blue)) then begin + TestGray:=false; + Result.Gray:=false; + if (not TestAlpha) and (not Test16Bit) then break; + end; + if Test16Bit then begin + if Need16Bit(col.red) + or Need16Bit(col.green) + or Need16Bit(col.blue) + or Need16Bit(col.alpha) + then begin + Test16Bit:=false; + Result.Depth:=16; + if (not TestAlpha) and (not TestGray) then break; + end; + end; + end; + end; +end; + +function GetMinimumQVMemImg(Img: TFPCustomImage; FreeImg: boolean + ): TFPCustomImage; +var + Desc: TPTMemImgDesc; + ImgClass: TPTMemImgBaseClass; + y: Integer; + x: Integer; +begin + Desc:=GetMinimumQVDesc(Img); + //debugln(['GetMinimumQVMemImg Depth=',Desc.Depth,' Gray=',Desc.Gray,' HasAlpha=',Desc.HasAlpha]); + ImgClass:=GeTPTMemImgClass(Desc); + if Img.ClassType=ImgClass then + exit(Img); + Result:=CreateQVMemImg(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 + result := $FFFF + else if c < 0.0 then + result := 0 + else + 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; + out Entries: Pointer; out EntrySize: integer; out Support: integer); +// create an array of #NewSize entries. Each entry starts with an integer +// for the StartIndex, followed by #Support singles for the pixel weights. +// The sum of weights for each entry is 1. +var + Entry: Pointer; + + procedure SetSupport(NewSupport: integer); + begin + Support:=NewSupport; + EntrySize:=SizeOf(integer)+SizeOf(Single)*Support; + Getmem(Entries,EntrySize*NewSize); + Entry:=Entries; + end; + +var + i: Integer; + Factor: double; + StartPos: Double; + StartIndex: Integer; + j: Integer; + FirstValue: Double; + //Sum: double; +begin + if NewSize=OldSize then begin + SetSupport(1); + for i:=0 to NewSize-1 do begin + // 1:1 + PInteger(Entry)^:=i; + inc(Entry,SizeOf(Integer)); + PSingle(Entry)^:=1.0; + inc(Entry,SizeOf(Single)); + end; + end else if NewSize<OldSize then begin + // shrink + SetSupport(Max(2,(OldSize+NewSize-1) div NewSize)); + Factor:=double(OldSize)/double(NewSize); + for i:=0 to NewSize-1 do begin + StartPos:=Factor*i; + StartIndex:=Floor(StartPos); + PInteger(Entry)^:=StartIndex; + inc(Entry,SizeOf(Integer)); + // first pixel + FirstValue:=(1.0-(StartPos-double(StartIndex))); + PSingle(Entry)^:=FirstValue/Factor; + inc(Entry,SizeOf(Single)); + // middle pixel + for j:=1 to Support-2 do begin + PSingle(Entry)^:=1.0/Factor; + inc(Entry,SizeOf(Single)); + end; + // last pixel + PSingle(Entry)^:=(Factor-FirstValue-(Support-2))/Factor; + inc(Entry,SizeOf(Single)); + end; + end else begin + // enlarge + if OldSize=1 then begin + SetSupport(1); + for i:=0 to NewSize-1 do begin + // nothing to interpolate + PInteger(Entry)^:=0; + inc(Entry,SizeOf(Integer)); + PSingle(Entry)^:=1.0; + inc(Entry,SizeOf(Single)); + end; + end else begin + SetSupport(2); + Factor:=double(OldSize-1)/double(NewSize); + for i:=0 to NewSize-1 do begin + StartPos:=Factor*i+Factor/2; + StartIndex:=Floor(StartPos); + PInteger(Entry)^:=StartIndex; + inc(Entry,SizeOf(Integer)); + // first pixel + FirstValue:=(1.0-(StartPos-double(StartIndex))); + // convert linear distribution + FirstValue:=Min(1.0,Max(0.0,Filter(FirstValue/MaxSupport))); + PSingle(Entry)^:=FirstValue; + inc(Entry,SizeOf(Single)); + // last pixel + PSingle(Entry)^:=1.0-FirstValue; + inc(Entry,SizeOf(Single)); + end; + end; + end; + if Entry<>Entries+EntrySize*NewSize then + raise Exception.Create('TSimpleInterpolation.Execute inconsistency'); + + {WriteLn('CreatePixelWeights Old=',OldSize,' New=',NewSize,' Support=',Support,' EntrySize=',EntrySize,' Factor=',FloatToStr(Factor)); + Entry:=Entries; + for i:=0 to NewSize-1 do begin + StartIndex:=PInteger(Entry)^; + inc(Entry,SizeOf(Integer)); + write(i,' Start=',StartIndex); + Sum:=0; + for j:=0 to Support-1 do begin + FirstValue:=PSingle(Entry)^; + inc(Entry,SizeOf(Single)); + write(' ',FloatToStr(FirstValue)); + Sum:=Sum+FirstValue; + end; + writeln(' Sum=',FloatToStr(Sum)); + end;} +end; + +procedure TLinearInterpolation.Execute(x, y, w, h: integer); +// paint Image on Canvas at x,y,w*h +var + dy: Integer; + dx: Integer; + HorzResized: PFPColor; + xEntries: Pointer; // size:integer,weight1:single,weight2:single,... + xEntrySize: integer; + xSupport: integer;// how many horizontal pixel are needed to created one new pixel + yEntries: Pointer; // size:integer,weight1:single,weight2:single,... + yEntrySize: integer; + ySupport: integer;// how many vertizontal pixel are needed to created one new pixel + NewSupportLines: LongInt; + yEntry: Pointer; + SrcStartY: LongInt; + LastSrcStartY: LongInt; + sy: Integer; + xEntry: Pointer; + sx: LongInt; + cx: Integer; + f: Single; + NewCol: TFPColor; + Col: TFPColor; + CurEntry: Pointer; + NewRed, NewGreen, NewBlue, NewAlpha: Single; +begin + //WriteLn('TSimpleInterpolation.Execute Src=',image.width,'x',image.Height,' Dest=',x,',',y,',',w,'x',h); + if (w<=0) or (h<=0) or (image.Width=0) or (image.Height=0) then exit; + + xEntries:=nil; + yEntries:=nil; + HorzResized:=nil; + try + CreatePixelWeights(image.Width,w,xEntries,xEntrySize,xSupport); + CreatePixelWeights(image.Height,h,yEntries,yEntrySize,ySupport); + //WriteLn('TSimpleInterpolation.Execute xSupport=',xSupport,' ySupport=',ySupport); + // create temporary buffer for the horizontally resized pixel for the current + // y line + GetMem(HorzResized,w*ySupport*SizeOf(TFPColor)); + + SrcStartY:=0; + for dy:=0 to h-1 do begin + if dy=0 then begin + yEntry:=yEntries; + SrcStartY:=PInteger(yEntry)^; + NewSupportLines:=ySupport; + end else begin + LastSrcStartY:=SrcStartY; + inc(yEntry,yEntrySize); + SrcStartY:=PInteger(yEntry)^; + NewSupportLines:=SrcStartY-LastSrcStartY; + //WriteLn('TSimpleInterpolation.Execute dy=',dy,' SrcStartY=',SrcStartY,' LastSrcStartY=',LastSrcStartY,' NewSupportLines=',NewSupportLines); + // move lines up + if (NewSupportLines>0) and (ySupport>NewSupportLines) then + System.Move(HorzResized[NewSupportLines*w], + HorzResized[0], + (ySupport-NewSupportLines)*w*SizeOf(TFPColor)); + end; + + // compute new horizontally resized line(s) + for sy:=ySupport-NewSupportLines to ySupport-1 do begin + xEntry:=xEntries; + for dx:=0 to w-1 do begin + sx:=PInteger(xEntry)^; + inc(xEntry,SizeOf(integer)); + NewRed:=0.0; + NewGreen:=0.0; + NewBlue:=0.0; + NewAlpha:=0.0; + for cx:=sx to sx+xSupport-1 do begin + f:=PSingle(xEntry)^; + inc(xEntry,SizeOf(Single)); + Col:=image.Colors[cx,SrcStartY+sy]; + NewRed:=NewRed+Col.red*f; + NewGreen:=NewGreen+Col.green*f; + NewBlue:=NewBlue+Col.blue*f; + NewAlpha:=NewAlpha+Col.alpha*f; + end; + NewCol.red:=Min(round(NewRed),$ffff); + NewCol.green:=Min(round(NewGreen),$ffff); + NewCol.blue:=Min(round(NewBlue),$ffff); + NewCol.alpha:=Min(round(NewAlpha),$ffff); + HorzResized[dx+sy*w]:=NewCol; + end; + end; + + // compute new vertically resized line + for dx:=0 to w-1 do begin + CurEntry:=yEntry+SizeOf(integer); + NewRed:=0.0; + NewGreen:=0.0; + NewBlue:=0.0; + NewAlpha:=0.0; + for sy:=0 to ySupport-1 do begin + f:=PSingle(CurEntry)^; + inc(CurEntry,SizeOf(Single)); + Col:=HorzResized[dx+sy*w]; + NewRed:=NewRed+Col.red*f; + NewGreen:=NewGreen+Col.green*f; + NewBlue:=NewBlue+Col.blue*f; + NewAlpha:=NewAlpha+Col.alpha*f; + end; + NewCol.red:=Min(round(NewRed),$ffff); + NewCol.green:=Min(round(NewGreen),$ffff); + NewCol.blue:=Min(round(NewBlue),$ffff); + NewCol.alpha:=Min(round(NewAlpha),$ffff); + Canvas.Colors[x+dx,y+dy]:=NewCol; + end; + end; + finally + if xEntries<>nil then FreeMem(xEntries); + if yEntries<>nil then FreeMem(yEntries); + if HorzResized<>nil then FreeMem(HorzResized); + end; +end; + +function TLinearInterpolation.Filter(x: double): double; +begin + Result:=x; +end; + +function TLinearInterpolation.MaxSupport: double; +begin + Result:=1.0; +end; + +end. +