You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
977 lines
31 KiB
977 lines
31 KiB
{
|
|
Vampyre Imaging Library
|
|
by Marek Mauder
|
|
http://imaginglib.sourceforge.net
|
|
|
|
The contents of this file are used with permission, subject to the Mozilla
|
|
Public License Version 1.1 (the "License"); you may not use this file except
|
|
in compliance with the License. You may obtain a copy of the License at
|
|
http://www.mozilla.org/MPL/MPL-1.1.html
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
|
|
the specific language governing rights and limitations under the License.
|
|
|
|
Alternatively, the contents of this file may be used under the terms of the
|
|
GNU Lesser General Public License (the "LGPL License"), in which case the
|
|
provisions of the LGPL License are applicable instead of those above.
|
|
If you wish to allow use of your version of this file only under the terms
|
|
of the LGPL License and not to allow others to use your version of this file
|
|
under the MPL, indicate your decision by deleting the provisions above and
|
|
replace them with the notice and other provisions required by the LGPL
|
|
License. If you do not delete the provisions above, a recipient may use
|
|
your version of this file under either the MPL or the LGPL License.
|
|
|
|
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
|
|
}
|
|
|
|
{ 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 begining 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 linenreaks 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
|
|
SwapEndianLongWord(PLongWord(Dest), Size div SizeOf(LongWord));
|
|
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: Integer; 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: Integer): 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: Integer): 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: Integer): 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: Integer): 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.
|