605 lines
18 KiB
Plaintext
605 lines
18 KiB
Plaintext
{
|
|
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 image format loader/saver for Targa images.}
|
|
unit ImagingTarga;
|
|
|
|
{$I ImagingOptions.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
|
|
|
|
type
|
|
{ Class for loading and saving Truevision Targa images.
|
|
It can load/save 8bit indexed or grayscale, 16 bit RGB or grayscale,
|
|
24 bit RGB and 32 bit ARGB images with or without RLE compression.}
|
|
TTargaFileFormat = class(TImageFileFormat)
|
|
protected
|
|
FUseRLE: LongBool;
|
|
procedure Define; override;
|
|
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
|
|
OnlyFirstLevel: Boolean): Boolean; override;
|
|
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
|
|
Index: LongInt): Boolean; override;
|
|
procedure ConvertToSupported(var Image: TImageData;
|
|
const Info: TImageFormatInfo); override;
|
|
public
|
|
function TestFormat(Handle: TImagingHandle): Boolean; override;
|
|
published
|
|
{ Controls that RLE compression is used during saving. Accessible trough
|
|
ImagingTargaRLE option.}
|
|
property UseRLE: LongBool read FUseRLE write FUseRLE;
|
|
end;
|
|
|
|
implementation
|
|
|
|
const
|
|
STargaFormatName = 'Truevision Targa Image';
|
|
STargaMasks = '*.tga';
|
|
TargaSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA1R5G5B5,
|
|
ifR8G8B8, ifA8R8G8B8];
|
|
TargaDefaultRLE = False;
|
|
|
|
const
|
|
STargaSignature = 'TRUEVISION-XFILE';
|
|
|
|
type
|
|
{ Targa file header.}
|
|
TTargaHeader = packed record
|
|
IDLength: Byte;
|
|
ColorMapType: Byte;
|
|
ImageType: Byte;
|
|
ColorMapOff: Word;
|
|
ColorMapLength: Word;
|
|
ColorEntrySize: Byte;
|
|
XOrg: SmallInt;
|
|
YOrg: SmallInt;
|
|
Width: SmallInt;
|
|
Height: SmallInt;
|
|
PixelSize: Byte;
|
|
Desc: Byte;
|
|
end;
|
|
|
|
{ Footer at the end of TGA file.}
|
|
TTargaFooter = packed record
|
|
ExtOff: UInt32; // Extension Area Offset
|
|
DevDirOff: UInt32; // Developer Directory Offset
|
|
Signature: TChar16; // TRUEVISION-XFILE
|
|
Reserved: Byte; // ASCII period '.'
|
|
NullChar: Byte; // 0
|
|
end;
|
|
|
|
|
|
{ TTargaFileFormat class implementation }
|
|
|
|
procedure TTargaFileFormat.Define;
|
|
begin
|
|
inherited;
|
|
FName := STargaFormatName;
|
|
FFeatures := [ffLoad, ffSave];
|
|
FSupportedFormats := TargaSupportedFormats;
|
|
|
|
FUseRLE := TargaDefaultRLE;
|
|
|
|
AddMasks(STargaMasks);
|
|
RegisterOption(ImagingTargaRLE, @FUseRLE);
|
|
end;
|
|
|
|
function TTargaFileFormat.LoadData(Handle: TImagingHandle;
|
|
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
|
|
var
|
|
Hdr: TTargaHeader;
|
|
Foo: TTargaFooter;
|
|
FooterFound, ExtFound: Boolean;
|
|
I, PSize, PalSize: Integer;
|
|
Pal: Pointer;
|
|
FmtInfo: TImageFormatInfo;
|
|
WordValue: Word;
|
|
|
|
procedure LoadRLE;
|
|
var
|
|
I, CPixel, Cnt: LongInt;
|
|
Bpp, Rle: Byte;
|
|
Buffer, Dest, Src: PByte;
|
|
BufSize: LongInt;
|
|
begin
|
|
with GetIO, Images[0] do
|
|
begin
|
|
// Allocates buffer large enough to hold the worst case
|
|
// RLE compressed data and reads then from input
|
|
BufSize := Width * Height * FmtInfo.BytesPerPixel;
|
|
BufSize := BufSize + BufSize div 2 + 1;
|
|
GetMem(Buffer, BufSize);
|
|
Src := Buffer;
|
|
Dest := Bits;
|
|
BufSize := Read(Handle, Buffer, BufSize);
|
|
|
|
Cnt := Width * Height;
|
|
Bpp := FmtInfo.BytesPerPixel;
|
|
CPixel := 0;
|
|
while CPixel < Cnt do
|
|
begin
|
|
Rle := Src^;
|
|
Inc(Src);
|
|
if Rle < 128 then
|
|
begin
|
|
// Process uncompressed pixel
|
|
Rle := Rle + 1;
|
|
CPixel := CPixel + Rle;
|
|
for I := 0 to Rle - 1 do
|
|
begin
|
|
// Copy pixel from src to dest
|
|
case Bpp of
|
|
1: Dest^ := Src^;
|
|
2: PWord(Dest)^ := PWord(Src)^;
|
|
3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
|
|
4: PUInt32(Dest)^ := PUInt32(Src)^;
|
|
end;
|
|
Inc(Src, Bpp);
|
|
Inc(Dest, Bpp);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
// Process compressed pixels
|
|
Rle := Rle - 127;
|
|
CPixel := CPixel + Rle;
|
|
// Copy one pixel from src to dest (many times there)
|
|
for I := 0 to Rle - 1 do
|
|
begin
|
|
case Bpp of
|
|
1: Dest^ := Src^;
|
|
2: PWord(Dest)^ := PWord(Src)^;
|
|
3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
|
|
4: PUInt32(Dest)^ := PUInt32(Src)^;
|
|
end;
|
|
Inc(Dest, Bpp);
|
|
end;
|
|
Inc(Src, Bpp);
|
|
end;
|
|
end;
|
|
// set position in source to real end of compressed data
|
|
Seek(Handle, -(BufSize - (PtrUInt(Src) - PtrUInt(Buffer))),
|
|
smFromCurrent);
|
|
FreeMem(Buffer);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
SetLength(Images, 1);
|
|
with GetIO, Images[0] do
|
|
begin
|
|
// Read targa header
|
|
Read(Handle, @Hdr, SizeOf(Hdr));
|
|
// Skip image ID info
|
|
Seek(Handle, Hdr.IDLength, smFromCurrent);
|
|
// Determine image format
|
|
Format := ifUnknown;
|
|
case Hdr.ImageType of
|
|
1, 9: Format := ifIndex8;
|
|
2, 10: case Hdr.PixelSize of
|
|
15: Format := ifX1R5G5B5;
|
|
16: Format := ifA1R5G5B5;
|
|
24: Format := ifR8G8B8;
|
|
32: Format := ifA8R8G8B8;
|
|
end;
|
|
3, 11: Format := ifGray8;
|
|
end;
|
|
// Format was not assigned by previous testing (it should be in
|
|
// well formed targas), so formats which reflects bit dept are selected
|
|
if Format = ifUnknown then
|
|
case Hdr.PixelSize of
|
|
8: Format := ifGray8;
|
|
15: Format := ifX1R5G5B5;
|
|
16: Format := ifA1R5G5B5;
|
|
24: Format := ifR8G8B8;
|
|
32: Format := ifA8R8G8B8;
|
|
end;
|
|
NewImage(Hdr.Width, Hdr.Height, Format, Images[0]);
|
|
FmtInfo := GetFormatInfo(Format);
|
|
|
|
if (Hdr.ColorMapType = 1) and (Hdr.ImageType in [1, 9]) then
|
|
begin
|
|
// Read palette
|
|
PSize := Hdr.ColorMapLength * (Hdr.ColorEntrySize shr 3);
|
|
GetMem(Pal, PSize);
|
|
try
|
|
Read(Handle, Pal, PSize);
|
|
// Process palette
|
|
PalSize := Iff(Hdr.ColorMapLength > FmtInfo.PaletteEntries,
|
|
FmtInfo.PaletteEntries, Hdr.ColorMapLength);
|
|
for I := 0 to PalSize - 1 do
|
|
case Hdr.ColorEntrySize of
|
|
24:
|
|
with Palette[I] do
|
|
begin
|
|
A := $FF;
|
|
R := PPalette24(Pal)[I].R;
|
|
G := PPalette24(Pal)[I].G;
|
|
B := PPalette24(Pal)[I].B;
|
|
end;
|
|
// I've never seen tga with these palettes so they are untested
|
|
16:
|
|
with Palette[I] do
|
|
begin
|
|
A := (PWordArray(Pal)[I] and $8000) shr 12;
|
|
R := (PWordArray(Pal)[I] and $FC00) shr 7;
|
|
G := (PWordArray(Pal)[I] and $03E0) shr 2;
|
|
B := (PWordArray(Pal)[I] and $001F) shl 3;
|
|
end;
|
|
32:
|
|
with Palette[I] do
|
|
begin
|
|
A := PPalette32(Pal)[I].A;
|
|
R := PPalette32(Pal)[I].R;
|
|
G := PPalette32(Pal)[I].G;
|
|
B := PPalette32(Pal)[I].B;
|
|
end;
|
|
end;
|
|
finally
|
|
FreeMemNil(Pal);
|
|
end;
|
|
end;
|
|
|
|
case Hdr.ImageType of
|
|
0, 1, 2, 3:
|
|
// Load uncompressed mode images
|
|
Read(Handle, Bits, Size);
|
|
9, 10, 11:
|
|
// Load RLE compressed mode images
|
|
LoadRLE;
|
|
end;
|
|
|
|
// Check if there is alpha channel present in A1R5GB5 images, if it is not
|
|
// change format to X1R5G5B5
|
|
if Format = ifA1R5G5B5 then
|
|
begin
|
|
if not Has16BitImageAlpha(Width * Height, Bits) then
|
|
Format := ifX1R5G5B5;
|
|
end;
|
|
|
|
// We must find true end of file and set input' position to it
|
|
// paint programs appends extra info at the end of Targas
|
|
// some of them multiple times (PSP Pro 8)
|
|
repeat
|
|
ExtFound := False;
|
|
FooterFound := False;
|
|
|
|
if Read(Handle, @WordValue, 2) = 2 then
|
|
begin
|
|
// 495 = size of Extension Area
|
|
if WordValue = 495 then
|
|
begin
|
|
Seek(Handle, 493, smFromCurrent);
|
|
ExtFound := True;
|
|
end
|
|
else
|
|
Seek(Handle, -2, smFromCurrent);
|
|
end;
|
|
|
|
if Read(Handle, @Foo, SizeOf(Foo)) = SizeOf(Foo) then
|
|
begin
|
|
if Foo.Signature = STargaSignature then
|
|
FooterFound := True
|
|
else
|
|
Seek(Handle, -SizeOf(Foo), smFromCurrent);
|
|
end;
|
|
until (not ExtFound) and (not FooterFound);
|
|
|
|
// Some editors save targas flipped
|
|
if Hdr.Desc < 31 then
|
|
FlipImage(Images[0]);
|
|
|
|
Result := True;
|
|
end;
|
|
end;
|
|
|
|
function TTargaFileFormat.SaveData(Handle: TImagingHandle;
|
|
const Images: TDynImageDataArray; Index: LongInt): Boolean;
|
|
var
|
|
I: LongInt;
|
|
Hdr: TTargaHeader;
|
|
FmtInfo: TImageFormatInfo;
|
|
Pal: PPalette24;
|
|
ImageToSave: TImageData;
|
|
MustBeFreed: Boolean;
|
|
|
|
procedure SaveRLE;
|
|
var
|
|
Dest: PByte;
|
|
WidthBytes, Written, I, Total, DestSize: LongInt;
|
|
|
|
function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt;
|
|
var
|
|
Pixel: UInt32;
|
|
NextPixel: UInt32;
|
|
N: LongInt;
|
|
begin
|
|
N := 0;
|
|
Pixel := 0;
|
|
NextPixel := 0;
|
|
if PixelCount = 1 then
|
|
begin
|
|
Result := PixelCount;
|
|
Exit;
|
|
end;
|
|
case Bpp of
|
|
1: Pixel := Data^;
|
|
2: Pixel := PWord(Data)^;
|
|
3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
|
|
4: Pixel := PUInt32(Data)^;
|
|
end;
|
|
while PixelCount > 1 do
|
|
begin
|
|
Inc(Data, Bpp);
|
|
case Bpp of
|
|
1: NextPixel := Data^;
|
|
2: NextPixel := PWord(Data)^;
|
|
3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
|
|
4: NextPixel := PUInt32(Data)^;
|
|
end;
|
|
if NextPixel = Pixel then
|
|
Break;
|
|
Pixel := NextPixel;
|
|
N := N + 1;
|
|
PixelCount := PixelCount - 1;
|
|
end;
|
|
if NextPixel = Pixel then
|
|
Result := N
|
|
else
|
|
Result := N + 1;
|
|
end;
|
|
|
|
function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt;
|
|
var
|
|
Pixel: UInt32;
|
|
NextPixel: UInt32;
|
|
N: LongInt;
|
|
begin
|
|
N := 1;
|
|
Pixel := 0;
|
|
NextPixel := 0;
|
|
case Bpp of
|
|
1: Pixel := Data^;
|
|
2: Pixel := PWord(Data)^;
|
|
3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
|
|
4: Pixel := PUInt32(Data)^;
|
|
end;
|
|
PixelCount := PixelCount - 1;
|
|
while PixelCount > 0 do
|
|
begin
|
|
Inc(Data, Bpp);
|
|
case Bpp of
|
|
1: NextPixel := Data^;
|
|
2: NextPixel := PWord(Data)^;
|
|
3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
|
|
4: NextPixel := PUInt32(Data)^;
|
|
end;
|
|
if NextPixel <> Pixel then
|
|
Break;
|
|
N := N + 1;
|
|
PixelCount := PixelCount - 1;
|
|
end;
|
|
Result := N;
|
|
end;
|
|
|
|
procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest:
|
|
PByte; out Written: LongInt);
|
|
const
|
|
MaxRun = 128;
|
|
var
|
|
DiffCount: LongInt;
|
|
SameCount: LongInt;
|
|
RleBufSize: LongInt;
|
|
begin
|
|
RleBufSize := 0;
|
|
while PixelCount > 0 do
|
|
begin
|
|
DiffCount := CountDiff(Data, Bpp, PixelCount);
|
|
SameCount := CountSame(Data, Bpp, PixelCount);
|
|
if (DiffCount > MaxRun) then
|
|
DiffCount := MaxRun;
|
|
if (SameCount > MaxRun) then
|
|
SameCount := MaxRun;
|
|
if (DiffCount > 0) then
|
|
begin
|
|
Dest^ := Byte(DiffCount - 1);
|
|
Inc(Dest);
|
|
PixelCount := PixelCount - DiffCount;
|
|
RleBufSize := RleBufSize + (DiffCount * Bpp) + 1;
|
|
Move(Data^, Dest^, DiffCount * Bpp);
|
|
Inc(Data, DiffCount * Bpp);
|
|
Inc(Dest, DiffCount * Bpp);
|
|
end;
|
|
if SameCount > 1 then
|
|
begin
|
|
Dest^ := Byte((SameCount - 1) or $80);
|
|
Inc(Dest);
|
|
PixelCount := PixelCount - SameCount;
|
|
RleBufSize := RleBufSize + Bpp + 1;
|
|
Inc(Data, (SameCount - 1) * Bpp);
|
|
case Bpp of
|
|
1: Dest^ := Data^;
|
|
2: PWord(Dest)^ := PWord(Data)^;
|
|
3: PColor24Rec(Dest)^ := PColor24Rec(Data)^;
|
|
4: PUInt32(Dest)^ := PUInt32(Data)^;
|
|
end;
|
|
Inc(Data, Bpp);
|
|
Inc(Dest, Bpp);
|
|
end;
|
|
end;
|
|
Written := RleBufSize;
|
|
end;
|
|
|
|
begin
|
|
with ImageToSave do
|
|
begin
|
|
// Allocate enough space to hold the worst case compression
|
|
// result and then compress source's scanlines
|
|
WidthBytes := Width * FmtInfo.BytesPerPixel;
|
|
DestSize := WidthBytes * Height;
|
|
DestSize := DestSize + DestSize div 2 + 1;
|
|
GetMem(Dest, DestSize);
|
|
Total := 0;
|
|
try
|
|
for I := 0 to Height - 1 do
|
|
begin
|
|
RleCompressLine(@PByteArray(Bits)[I * WidthBytes], Width,
|
|
FmtInfo.BytesPerPixel, @PByteArray(Dest)[Total], Written);
|
|
Total := Total + Written;
|
|
end;
|
|
GetIO.Write(Handle, Dest, Total);
|
|
finally
|
|
FreeMem(Dest);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Result := False;
|
|
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
|
|
with GetIO, ImageToSave do
|
|
try
|
|
FmtInfo := GetFormatInfo(Format);
|
|
// Fill targa header
|
|
FillChar(Hdr, SizeOf(Hdr), 0);
|
|
Hdr.IDLength := 0;
|
|
Hdr.ColorMapType := Iff(FmtInfo.PaletteEntries > 0, 1, 0);
|
|
Hdr.Width := Width;
|
|
Hdr.Height := Height;
|
|
Hdr.PixelSize := FmtInfo.BytesPerPixel * 8;
|
|
Hdr.ColorMapLength := FmtInfo.PaletteEntries;
|
|
Hdr.ColorEntrySize := Iff(FmtInfo.PaletteEntries > 0, 24, 0);
|
|
Hdr.ColorMapOff := 0;
|
|
// This indicates that targa is stored in top-left format
|
|
// as our images -> no flipping is needed.
|
|
Hdr.Desc := 32;
|
|
// Set alpha channel size in descriptor (mostly ignored by other software though)
|
|
if Format = ifA8R8G8B8 then
|
|
Hdr.Desc := Hdr.Desc or 8
|
|
else if Format = ifA1R5G5B5 then
|
|
Hdr.Desc := Hdr.Desc or 1;
|
|
|
|
// Choose image type
|
|
if FmtInfo.IsIndexed then
|
|
Hdr.ImageType := Iff(FUseRLE, 9, 1)
|
|
else
|
|
if FmtInfo.HasGrayChannel then
|
|
Hdr.ImageType := Iff(FUseRLE, 11, 3)
|
|
else
|
|
Hdr.ImageType := Iff(FUseRLE, 10, 2);
|
|
|
|
Write(Handle, @Hdr, SizeOf(Hdr));
|
|
|
|
// Write palette
|
|
if FmtInfo.PaletteEntries > 0 then
|
|
begin
|
|
GetMem(Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
|
|
try
|
|
for I := 0 to FmtInfo.PaletteEntries - 1 do
|
|
with Pal[I] do
|
|
begin
|
|
R := Palette[I].R;
|
|
G := Palette[I].G;
|
|
B := Palette[I].B;
|
|
end;
|
|
Write(Handle, Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
|
|
finally
|
|
FreeMemNil(Pal);
|
|
end;
|
|
end;
|
|
|
|
if FUseRLE then
|
|
// Save rle compressed mode images
|
|
SaveRLE
|
|
else
|
|
// Save uncompressed mode images
|
|
Write(Handle, Bits, Size);
|
|
|
|
Result := True;
|
|
finally
|
|
if MustBeFreed then
|
|
FreeImage(ImageToSave);
|
|
end;
|
|
end;
|
|
|
|
procedure TTargaFileFormat.ConvertToSupported(var Image: TImageData;
|
|
const Info: TImageFormatInfo);
|
|
var
|
|
ConvFormat: TImageFormat;
|
|
begin
|
|
if Info.HasGrayChannel then
|
|
// Convert all grayscale images to Gray8 (preserve alpha of AxGrayx formats)
|
|
ConvFormat := IffFormat(not Info.HasAlphaChannel, ifGray8, ifA8R8G8B8)
|
|
else if Info.IsIndexed then
|
|
// Convert all indexed images to Index8
|
|
ConvFormat := ifIndex8
|
|
else if Info.HasAlphaChannel then
|
|
// Convert images with alpha channel to A8R8G8B8
|
|
ConvFormat := ifA8R8G8B8
|
|
else if Info.UsePixelFormat then
|
|
// Convert 16bit images (without alpha channel) to A1R5G5B5
|
|
ConvFormat := ifA1R5G5B5
|
|
else
|
|
// Convert all other formats to R8G8B8
|
|
ConvFormat := ifR8G8B8;
|
|
|
|
ConvertImage(Image, ConvFormat);
|
|
end;
|
|
|
|
function TTargaFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
|
|
var
|
|
Hdr: TTargaHeader;
|
|
ReadCount: LongInt;
|
|
begin
|
|
Result := False;
|
|
if Handle <> nil then
|
|
begin
|
|
ReadCount := GetIO.Read(Handle, @Hdr, SizeOf(Hdr));
|
|
GetIO.Seek(Handle, -ReadCount, smFromCurrent);
|
|
Result := (ReadCount >= SizeOf(Hdr)) and
|
|
(Hdr.ImageType in [0, 1, 2, 3, 9, 10, 11]) and
|
|
(Hdr.PixelSize in [1, 8, 15, 16, 24, 32]) and
|
|
(Hdr.ColorEntrySize in [0, 16, 24, 32]);
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
RegisterImageFileFormat(TTargaFileFormat);
|
|
|
|
{
|
|
File Notes:
|
|
|
|
-- TODOS ----------------------------------------------------
|
|
- nothing now
|
|
|
|
-- 0.21 Changes/Bug Fixes -----------------------------------
|
|
- MakeCompatible method moved to base class, put ConvertToSupported here.
|
|
GetSupportedFormats removed, it is now set in constructor.
|
|
- Made public properties for options registered to SetOption/GetOption
|
|
functions.
|
|
- Changed extensions to filename masks.
|
|
- Changed SaveData, LoadData, and MakeCompatible methods according
|
|
to changes in base class in Imaging unit.
|
|
|
|
-- 0.17 Changes/Bug Fixes -----------------------------------
|
|
- 16 bit images are usually without alpha but some has alpha
|
|
channel and there is no indication of it - so I have added
|
|
a check: if all pixels of image are with alpha = 0 image is treated
|
|
as X1R5G5B5 otherwise as A1R5G5B5
|
|
- fixed problems with some nonstandard 15 bit images
|
|
}
|
|
|
|
end.
|
|
|