CentrED/Imaging/ImagingPortableMaps.pas

962 lines
31 KiB
Plaintext
Raw Normal View History

2022-05-08 10:47:53 +02:00
{
Vampyre Imaging Library
by Marek Mauder
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains loader/saver for Portable Maps file format family (or PNM).
That includes PBM, PGM, PPM, PAM, and PFM formats.}
unit ImagingPortableMaps;
{$I ImagingOptions.inc}
interface
uses
SysUtils, ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
type
{ Types of pixels of PNM images.}
TTupleType = (ttInvalid, ttBlackAndWhite, ttGrayScale, ttRGB, ttBlackAndWhiteAlpha,
ttGrayScaleAlpha, ttRGBAlpha, ttGrayScaleFP, ttRGBFP);
{ Record with info about PNM image used in both loading and saving functions.}
TPortableMapInfo = record
Width: LongInt;
Height: LongInt;
FormatId: AnsiChar;
MaxVal: LongInt;
BitCount: LongInt;
Depth: LongInt;
TupleType: TTupleType;
Binary: Boolean;
HasPAMHeader: Boolean;
IsBigEndian: Boolean;
end;
{ Base class for Portable Map file formats (or Portable AnyMaps or PNM).
There are several types of PNM file formats that share common
(simple) structure. This class can actually load all supported PNM formats.
Saving is also done by this class but descendants (each for different PNM
format) control it.}
TPortableMapFileFormat = class(TImageFileFormat)
protected
FIdNumbers: TChar2;
FSaveBinary: LongBool;
FUSFormat: TFormatSettings;
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
public
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
{ If set to True images will be saved in binary format. If it is False
they will be saved in text format (which could result in 5-10x bigger file).
Default is value True. Note that PAM and PFM files are always saved in binary.}
property SaveBinary: LongBool read FSaveBinary write FSaveBinary;
end;
{ Portable Bit Map is used to store monochrome 1bit images. Raster data
can be saved as text or binary data. Either way value of 0 represents white
and 1 is black. As Imaging does not have support for 1bit data formats
PBM images can be loaded but not saved. Loaded images are returned in
ifGray8 format (witch pixel values scaled from 1bit to 8bit).}
TPBMFileFormat = class(TPortableMapFileFormat)
protected
procedure Define; override;
end;
{ Portable Gray Map is used to store grayscale 8bit or 16bit images.
Raster data can be saved as text or binary data.}
TPGMFileFormat = class(TPortableMapFileFormat)
protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
end;
{ Portable Pixel Map is used to store RGB images with 8bit or 16bit channels.
Raster data can be saved as text or binary data.}
TPPMFileFormat = class(TPortableMapFileFormat)
protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
end;
{ Portable Arbitrary Map is format that can store image data formats
of PBM, PGM, and PPM formats with optional alpha channel. Raster data
can be stored only in binary format. All data formats supported
by this format are ifGray8, ifGray16, ifA8Gray8, ifA16Gray16,
ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.}
TPAMFileFormat = class(TPortableMapFileFormat)
protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
end;
{ Portable Float Map is unofficial extension of PNM format family which
can store images with floating point pixels. Raster data is saved in
binary format as array of IEEE 32 bit floating point numbers. One channel
or RGB images are supported by PFM format (so no alpha).}
TPFMFileFormat = class(TPortableMapFileFormat)
protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
end;
implementation
const
PortableMapDefaultBinary = True;
SPBMFormatName = 'Portable Bit Map';
SPBMMasks = '*.pbm';
SPGMFormatName = 'Portable Gray Map';
SPGMMasks = '*.pgm';
PGMSupportedFormats = [ifGray8, ifGray16];
SPPMFormatName = 'Portable Pixel Map';
SPPMMasks = '*.ppm';
PPMSupportedFormats = [ifR8G8B8, ifR16G16B16];
SPAMFormatName = 'Portable Arbitrary Map';
SPAMMasks = '*.pam';
PAMSupportedFormats = [ifGray8, ifGray16, ifA8Gray8, ifA16Gray16,
ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16];
SPFMFormatName = 'Portable Float Map';
SPFMMasks = '*.pfm';
PFMSupportedFormats = [ifR32F, ifB32G32R32F];
const
{ TAB, CR, LF, and Space are used as seperators in Portable map headers and data.}
WhiteSpaces = [#9, #10, #13, #32];
SPAMWidth = 'WIDTH';
SPAMHeight = 'HEIGHT';
SPAMDepth = 'DEPTH';
SPAMMaxVal = 'MAXVAL';
SPAMTupleType = 'TUPLTYPE';
SPAMEndHdr = 'ENDHDR';
{ Size of buffer used to speed up text PNM loading/saving.}
LineBufferCapacity = 16 * 1024;
TupleTypeNames: array[TTupleType] of string = (
'INVALID', 'BLACKANDWHITE', 'GRAYSCALE', 'RGB',
'BLACKANDWHITE_ALPHA', 'GRAYSCALE_ALPHA', 'RGB_ALPHA', 'GRAYSCALEFP',
'RGBFP');
{ TPortableMapFileFormat }
procedure TPortableMapFileFormat.Define;
begin
inherited;
FFeatures := [ffLoad, ffSave];
FSaveBinary := PortableMapDefaultBinary;
FUSFormat := GetFormatSettingsForFloats;
end;
function TPortableMapFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
I, ScanLineSize, MonoSize: LongInt;
Dest: PByte;
MonoData: Pointer;
Info: TImageFormatInfo;
LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar;
LineEnd, LinePos: LongInt;
MapInfo: TPortableMapInfo;
LineBreak: string;
procedure CheckBuffer;
begin
if (LineEnd = 0) or (LinePos = LineEnd) then
begin
// Reload buffer if its is empty or its end was reached
LineEnd := GetIO.Read(Handle, @LineBuffer[0], LineBufferCapacity);
LinePos := 0;
end;
end;
procedure FixInputPos;
begin
// Sets input's position to its real pos as it would be without buffering
if LineEnd > 0 then
begin
GetIO.Seek(Handle, -LineEnd + LinePos, smFromCurrent);
LineEnd := 0;
end;
end;
function ReadString: string;
var
S: AnsiString;
C: AnsiChar;
begin
// First skip all whitespace chars
SetLength(S, 1);
repeat
CheckBuffer;
S[1] := LineBuffer[LinePos];
Inc(LinePos);
if S[1] = '#' then
repeat
// Comment detected, skip everything until next line is reached
CheckBuffer;
S[1] := LineBuffer[LinePos];
Inc(LinePos);
until S[1] = #10;
until not(S[1] in WhiteSpaces);
// Now we have reached some chars other than white space, read them until
// there is whitespace again
repeat
SetLength(S, Length(S) + 1);
CheckBuffer;
S[Length(S)] := LineBuffer[LinePos];
Inc(LinePos);
// Repeat until current char is whitespace or end of file is reached
// (Line buffer has 0 bytes which happens only on EOF)
until (S[Length(S)] in WhiteSpaces) or (LineEnd = 0);
// Get rid of last char - whitespace or null
SetLength(S, Length(S) - 1);
// Move position to the beginning of next string (skip white space - needed
// to make the loader stop at the right input position)
repeat
CheckBuffer;
C := LineBuffer[LinePos];
Inc(LinePos);
until not (C in WhiteSpaces) or (LineEnd = 0);
// Dec pos, current is the beginning of the the string
Dec(LinePos);
Result := string(S);
end;
function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
begin
Result := StrToInt(ReadString);
end;
procedure FindLineBreak;
var
C: AnsiChar;
begin
LineBreak := #10;
repeat
CheckBuffer;
C := LineBuffer[LinePos];
Inc(LinePos);
if C = #13 then
LineBreak := #13#10;
until C = #10;
end;
function ParseHeader: Boolean;
var
Id: TChar2;
I: TTupleType;
TupleTypeName: string;
Scale: Single;
begin
Result := False;
with GetIO do
begin
FillChar(MapInfo, SizeOf(MapInfo), 0);
Read(Handle, @Id, SizeOf(Id));
FindLineBreak;
if Id[1] in ['1'..'6'] then
begin
// Read header for PBM, PGM, and PPM files
MapInfo.Width := ReadIntValue;
MapInfo.Height := ReadIntValue;
if Id[1] in ['1', '4'] then
begin
MapInfo.MaxVal := 1;
MapInfo.BitCount := 1
end
else
begin
// Read channel max value, <=255 for 8bit images, >255 for 16bit images
// but some programs think its max colors so put <=256 here
MapInfo.MaxVal := ReadIntValue;
MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
end;
MapInfo.Depth := 1;
case Id[1] of
'1', '4': MapInfo.TupleType := ttBlackAndWhite;
'2', '5': MapInfo.TupleType := ttGrayScale;
'3', '6':
begin
MapInfo.TupleType := ttRGB;
MapInfo.Depth := 3;
end;
end;
end
else if Id[1] = '7' then
begin
// Read values from PAM header
// WIDTH
if (ReadString <> SPAMWidth) then Exit;
MapInfo.Width := ReadIntValue;
// HEIGHT
if (ReadString <> SPAMheight) then Exit;
MapInfo.Height := ReadIntValue;
// DEPTH
if (ReadString <> SPAMDepth) then Exit;
MapInfo.Depth := ReadIntValue;
// MAXVAL
if (ReadString <> SPAMMaxVal) then Exit;
MapInfo.MaxVal := ReadIntValue;
MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
// TUPLETYPE
if (ReadString <> SPAMTupleType) then Exit;
TupleTypeName := ReadString;
for I := Low(TTupleType) to High(TTupleType) do
if SameText(TupleTypeName, TupleTypeNames[I]) then
begin
MapInfo.TupleType := I;
Break;
end;
// ENDHDR
if (ReadString <> SPAMEndHdr) then Exit;
end
else if Id[1] in ['F', 'f'] then
begin
// Read header of PFM file
MapInfo.Width := ReadIntValue;
MapInfo.Height := ReadIntValue;
Scale := StrToFloatDef(ReadString, 0, FUSFormat);
MapInfo.IsBigEndian := Scale > 0.0;
if Id[1] = 'F' then
MapInfo.TupleType := ttRGBFP
else
MapInfo.TupleType := ttGrayScaleFP;
MapInfo.Depth := Iff(MapInfo.TupleType = ttRGBFP, 3, 1);
MapInfo.BitCount := Iff(MapInfo.TupleType = ttRGBFP, 96, 32);
end;
FixInputPos;
MapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']);
if MapInfo.Binary and not (Id[1] in ['F', 'f']) then
begin
// Mimic the behaviour of Photoshop and other editors/viewers:
// If linereaks in file are DOS CR/LF 16bit binary values are
// little endian, Unix LF only linebreak indicates big endian.
MapInfo.IsBigEndian := LineBreak = #10;
end;
// Check if values found in header are valid
Result := (MapInfo.Width > 0) and (MapInfo.Height > 0) and
(MapInfo.BitCount in [1, 8, 16, 32, 96]) and (MapInfo.TupleType <> ttInvalid);
// Now check if image has proper number of channels (PAM)
if Result then
case MapInfo.TupleType of
ttBlackAndWhite, ttGrayScale: Result := MapInfo.Depth = 1;
ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := MapInfo.Depth = 2;
ttRGB: Result := MapInfo.Depth = 3;
ttRGBAlpha: Result := MapInfo.Depth = 4;
end;
end;
end;
begin
Result := False;
LineEnd := 0;
LinePos := 0;
SetLength(Images, 1);
with GetIO, Images[0] do
begin
Format := ifUnknown;
// Try to parse file header
if not ParseHeader then Exit;
// Select appropriate data format based on values read from file header
case MapInfo.TupleType of
ttBlackAndWhite: Format := ifGray8;
ttBlackAndWhiteAlpha: Format := ifA8Gray8;
ttGrayScale: Format := IffFormat(MapInfo.BitCount = 8, ifGray8, ifGray16);
ttGrayScaleAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16);
ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
ttGrayScaleFP: Format := ifR32F;
ttRGBFP: Format := ifB32G32R32F;
end;
// Exit if no matching data format was found
if Format = ifUnknown then Exit;
NewImage(MapInfo.Width, MapInfo.Height, Format, Images[0]);
Info := GetFormatInfo(Format);
// Now read pixels from file to dest image
if not MapInfo.Binary then
begin
Dest := Bits;
for I := 0 to Width * Height - 1 do
begin
case Format of
ifGray8:
begin
Dest^ := ReadIntValue;
if MapInfo.BitCount = 1 then
// If source is 1bit mono image (where 0=white, 1=black)
// we must scale it to 8bits
Dest^ := 255 - Dest^ * 255;
end;
ifGray16: PWord(Dest)^ := ReadIntValue;
ifR8G8B8:
with PColor24Rec(Dest)^ do
begin
R := ReadIntValue;
G := ReadIntValue;
B := ReadIntValue;
end;
ifR16G16B16:
with PColor48Rec(Dest)^ do
begin
R := ReadIntValue;
G := ReadIntValue;
B := ReadIntValue;
end;
end;
Inc(Dest, Info.BytesPerPixel);
end;
end
else
begin
if MapInfo.BitCount > 1 then
begin
if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
begin
// Just copy bytes from binary Portable Maps (non 1bit, non FP)
Read(Handle, Bits, Size);
end
else
begin
Dest := Bits;
// FP images are in BGR order and endian swap maybe needed.
// Some programs store scanlines in bottom-up order but
// I will stick with Photoshops behaviour here
Read(Handle, Bits, Size);
if MapInfo.IsBigEndian then
SwapEndianUInt32(PUInt32(Dest), Size div SizeOf(UInt32));
end;
if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
begin
// Black and white PAM files must be scaled to 8bits. Note that
// in PAM files 1=white, 0=black (reverse of PBM)
for I := 0 to Width * Height * Iff(MapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do
PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255;
end
else if MapInfo.TupleType in [ttRGB, ttRGBAlpha] then
begin
// Swap channels of RGB/ARGB images. Binary RGB image files use BGR order.
SwapChannels(Images[0], ChannelBlue, ChannelRed);
end;
// Swap byte order if needed
if (MapInfo.BitCount = 16) and MapInfo.IsBigEndian then
SwapEndianWord(Bits, Width * Height * Info.BytesPerPixel div SizeOf(Word));
end
else
begin
// Handle binary PBM files (ttBlackAndWhite 1bit)
ScanLineSize := (Width + 7) div 8;
// Get total binary data size, read it from file to temp
// buffer and convert the data to Gray8
MonoSize := ScanLineSize * Height;
GetMem(MonoData, MonoSize);
try
Read(Handle, MonoData, MonoSize);
Convert1To8(MonoData, Bits, Width, Height, ScanLineSize, False);
// 1bit mono images must be scaled to 8bit, but inverted (where 0=white, 1=black)
for I := 0 to Width * Height - 1 do
PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255;
finally
FreeMem(MonoData);
end;
end;
end;
FixInputPos;
if (MapInfo.MaxVal <> Pow2Int(MapInfo.BitCount) - 1) and
(MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then
begin
Dest := Bits;
// Scale color values according to MaxVal we got from header
// if necessary.
for I := 0 to Width * Height * Info.BytesPerPixel div (MapInfo.BitCount shr 3) - 1 do
begin
if MapInfo.BitCount = 8 then
Dest^ := Dest^ * 255 div MapInfo.MaxVal
else
PWord(Dest)^ := PWord(Dest)^ * 65535 div MapInfo.MaxVal;
Inc(Dest, MapInfo.BitCount shr 3);
end;
end;
Result := True;
end;
end;
function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
const
// Use Unix linebreak, for many viewers/editors it means that
// 16bit samples are stored as big endian - so we need to swap byte order
// before saving
LineDelimiter = #10;
PixelDelimiter = #32;
var
ImageToSave: TImageData;
MustBeFreed: Boolean;
Info: TImageFormatInfo;
I, LineLength: LongInt;
Src: PByte;
Pixel32: TColor32Rec;
Pixel64: TColor64Rec;
W: Word;
procedure WriteString(S: string; Delimiter: Char = LineDelimiter);
begin
SetLength(S, Length(S) + 1);
S[Length(S)] := Delimiter;
{$IF Defined(DCC) and Defined(UNICODE)}
GetIO.Write(Handle, @AnsiString(S)[1], Length(S));
{$ELSE}
GetIO.Write(Handle, @S[1], Length(S));
{$IFEND}
Inc(LineLength, Length(S));
end;
procedure WriteHeader;
begin
WriteString('P' + MapInfo.FormatId);
if not MapInfo.HasPAMHeader then
begin
// Write header of PGM, PPM, and PFM files
WriteString(IntToStr(ImageToSave.Width));
WriteString(IntToStr(ImageToSave.Height));
case MapInfo.TupleType of
ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1));
ttGrayScaleFP, ttRGBFP:
begin
// Negative value indicates that raster data is saved in little endian
WriteString(FloatToStr(-1.0, FUSFormat));
end;
end;
end
else
begin
// Write PAM file header
WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width]));
WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height]));
WriteString(Format('%s %d', [SPAMDepth, MapInfo.Depth]));
WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(MapInfo.BitCount) - 1]));
WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[MapInfo.TupleType]]));
WriteString(SPAMEndHdr);
end;
end;
begin
Result := False;
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
with GetIO, ImageToSave do
try
Info := GetFormatInfo(Format);
// Fill values of MapInfo record that were not filled by
// descendants in their SaveData methods
MapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8;
MapInfo.Depth := Info.ChannelCount;
if MapInfo.TupleType = ttInvalid then
begin
if Info.HasGrayChannel then
begin
if Info.HasAlphaChannel then
MapInfo.TupleType := ttGrayScaleAlpha
else
MapInfo.TupleType := ttGrayScale;
end
else
begin
if Info.HasAlphaChannel then
MapInfo.TupleType := ttRGBAlpha
else
MapInfo.TupleType := ttRGB;
end;
end;
// Write file header
WriteHeader;
if not MapInfo.Binary then
begin
Src := Bits;
LineLength := 0;
// For each pixel find its text representation and write it to file
for I := 0 to Width * Height - 1 do
begin
case Format of
ifGray8: WriteString(IntToStr(Src^), PixelDelimiter);
ifGray16: WriteString(IntToStr(PWord(Src)^), PixelDelimiter);
ifR8G8B8:
with PColor24Rec(Src)^ do
WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
ifR16G16B16:
with PColor48Rec(Src)^ do
WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
end;
// Lines in text PNM images should have length <70
if LineLength > 65 then
begin
LineLength := 0;
WriteString('', LineDelimiter);
end;
Inc(Src, Info.BytesPerPixel);
end;
end
else
begin
// Write binary images
if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
begin
// Save integer binary images
if MapInfo.BitCount = 8 then
begin
if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
begin
// 8bit grayscale images can be written in one Write call
Write(Handle, Bits, Size);
end
else
begin
// 8bit RGB/ARGB images: red and blue must be swapped and
// 3 or 4 bytes must be written
Src := Bits;
for I := 0 to Width * Height - 1 do
with PColor32Rec(Src)^ do
begin
if MapInfo.TupleType = ttRGBAlpha then
Pixel32.A := A;
Pixel32.R := B;
Pixel32.G := G;
Pixel32.B := R;
Write(Handle, @Pixel32, Info.BytesPerPixel);
Inc(Src, Info.BytesPerPixel);
end;
end;
end
else
begin
// Images with 16bit channels: make sure that channel values are saved in big endian
Src := Bits;
if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
begin
// 16bit grayscale image
for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do
begin
W := SwapEndianWord(PWord(Src)^);
Write(Handle, @W, SizeOf(Word));
Inc(Src, SizeOf(Word));
end;
end
else
begin
// RGB images with 16bit channels: swap RB and endian too
for I := 0 to Width * Height - 1 do
with PColor64Rec(Src)^ do
begin
if MapInfo.TupleType = ttRGBAlpha then
Pixel64.A := SwapEndianWord(A);
Pixel64.R := SwapEndianWord(B);
Pixel64.G := SwapEndianWord(G);
Pixel64.B := SwapEndianWord(R);
Write(Handle, @Pixel64, Info.BytesPerPixel);
Inc(Src, Info.BytesPerPixel);
end;
end;
end;
end
else
begin
// Floating point images (no need to swap endian here - little
// endian is specified in file header)
Write(Handle, Bits, Size);
end;
end;
Result := True;
finally
if MustBeFreed then
FreeImage(ImageToSave);
end;
end;
function TPortableMapFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
Id: TChar4;
ReadCount: LongInt;
begin
Result := False;
if Handle <> nil then
with GetIO do
begin
ReadCount := Read(Handle, @Id, SizeOf(Id));
Seek(Handle, -ReadCount, smFromCurrent);
Result := (Id[0] = 'P') and (Id[1] in [FIdNumbers[0], FIdNumbers[1]]) and
(Id[2] in WhiteSpaces);
end;
end;
{ TPBMFileFormat }
procedure TPBMFileFormat.Define;
begin
inherited;
FName := SPBMFormatName;
FFeatures := [ffLoad];
AddMasks(SPBMMasks);
FIdNumbers := '14';
end;
{ TPGMFileFormat }
procedure TPGMFileFormat.Define;
begin
inherited;
FName := SPGMFormatName;
FSupportedFormats := PGMSupportedFormats;
AddMasks(SPGMMasks);
RegisterOption(ImagingPGMSaveBinary, @FSaveBinary);
FIdNumbers := '25';
end;
function TPGMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
MapInfo: TPortableMapInfo;
begin
FillChar(MapInfo, SizeOf(MapInfo), 0);
if FSaveBinary then
MapInfo.FormatId := FIdNumbers[1]
else
MapInfo.FormatId := FIdNumbers[0];
MapInfo.Binary := FSaveBinary;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
var
ConvFormat: TImageFormat;
begin
if Info.IsFloatingPoint then
// All FP images go to 16bit
ConvFormat := ifGray16
else if Info.HasGrayChannel then
// Grayscale will be 8 or 16 bit - depends on input's bitcount
ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1,
ifGray16, ifGray8)
else if Info.BytesPerPixel > 4 then
// Large bitcounts -> 16bit
ConvFormat := ifGray16
else
// Rest of the formats -> 8bit
ConvFormat := ifGray8;
ConvertImage(Image, ConvFormat);
end;
{ TPPMFileFormat }
procedure TPPMFileFormat.Define;
begin
inherited;
FName := SPPMFormatName;
FSupportedFormats := PPMSupportedFormats;
AddMasks(SPPMMasks);
RegisterOption(ImagingPPMSaveBinary, @FSaveBinary);
FIdNumbers := '36';
end;
function TPPMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
MapInfo: TPortableMapInfo;
begin
FillChar(MapInfo, SizeOf(MapInfo), 0);
if FSaveBinary then
MapInfo.FormatId := FIdNumbers[1]
else
MapInfo.FormatId := FIdNumbers[0];
MapInfo.Binary := FSaveBinary;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
var
ConvFormat: TImageFormat;
begin
if Info.IsFloatingPoint then
// All FP images go to 48bit RGB
ConvFormat := ifR16G16B16
else if Info.HasGrayChannel then
// Grayscale will be 24 or 48 bit RGB - depends on input's bitcount
ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1,
ifR16G16B16, ifR8G8B8)
else if Info.BytesPerPixel > 4 then
// Large bitcounts -> 48bit RGB
ConvFormat := ifR16G16B16
else
// Rest of the formats -> 24bit RGB
ConvFormat := ifR8G8B8;
ConvertImage(Image, ConvFormat);
end;
{ TPAMFileFormat }
procedure TPAMFileFormat.Define;
begin
inherited;
FName := SPAMFormatName;
FSupportedFormats := PAMSupportedFormats;
AddMasks(SPAMMasks);
FIdNumbers := '77';
end;
function TPAMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
MapInfo: TPortableMapInfo;
begin
FillChar(MapInfo, SizeOf(MapInfo), 0);
MapInfo.FormatId := FIdNumbers[0];
MapInfo.Binary := True;
MapInfo.HasPAMHeader := True;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
var
ConvFormat: TImageFormat;
begin
if Info.IsFloatingPoint then
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16)
else if Info.HasGrayChannel then
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray16)
else
begin
if Info.BytesPerPixel <= 4 then
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8)
else
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16);
end;
ConvertImage(Image, ConvFormat);
end;
{ TPFMFileFormat }
procedure TPFMFileFormat.Define;
begin
inherited;
FName := SPFMFormatName;
AddMasks(SPFMMasks);
FIdNumbers := 'Ff';
FSupportedFormats := PFMSupportedFormats;
end;
function TPFMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
Info: TImageFormatInfo;
MapInfo: TPortableMapInfo;
begin
FillChar(MapInfo, SizeOf(MapInfo), 0);
Info := GetFormatInfo(Images[Index].Format);
if (Info.ChannelCount > 1) or Info.IsIndexed then
MapInfo.TupleType := ttRGBFP
else
MapInfo.TupleType := ttGrayScaleFP;
if MapInfo.TupleType = ttGrayScaleFP then
MapInfo.FormatId := FIdNumbers[1]
else
MapInfo.FormatId := FIdNumbers[0];
MapInfo.Binary := True;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
begin
if (Info.ChannelCount > 1) or Info.IsIndexed then
ConvertImage(Image, ifB32G32R32F)
else
ConvertImage(Image, ifR32F);
end;
initialization
RegisterImageFileFormat(TPBMFileFormat);
RegisterImageFileFormat(TPGMFileFormat);
RegisterImageFileFormat(TPPMFileFormat);
RegisterImageFileFormat(TPAMFileFormat);
RegisterImageFileFormat(TPFMFileFormat);
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.77.1 Changes/Bug Fixes -----------------------------------
- Native RGB floating point format of PFM is now supported by Imaging
so we use it now for saving instead of A32B32G32B32.
- String to float formatting changes (don't change global settings).
-- 0.26.3 Changes/Bug Fixes -----------------------------------
- Fixed D2009 Unicode related bug in PNM saving.
-- 0.24.3 Changes/Bug Fixes -----------------------------------
- Improved compatibility of 16bit/component image loading.
- Changes for better thread safety.
-- 0.21 Changes/Bug Fixes -----------------------------------
- Made modifications to ASCII PNM loading to be more "stream-safe".
- Fixed bug: indexed images saved as grayscale in PFM.
- Changed converting to supported formats little bit.
- Added scaling of channel values (non-FP and non-mono images) according
to MaxVal.
- Added buffering to loading of PNM files. More than 10x faster now
for text files.
- Added saving support to PGM, PPM, PAM, and PFM format.
- Added PFM file format.
- Initial version created.
}
end.