aksdb
/
CentrED
1
0
Fork 0
Code Issues 2 Pull Requests Releases Wiki Activity
CentrED/Imaging/ImagingTarga.pas

605 lines
18 KiB
Plaintext
Raw Permalink Blame History

{
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.
Reference in New Issue View Git Blame Copy Permalink