CentrED/Imaging/ImagingTarga.pas

624 lines
19 KiB
Plaintext

{
$Id: ImagingTarga.pas 84 2007-05-27 13:54:27Z galfar $
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 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;
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
constructor Create; override;
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: LongWord; // Extension Area Offset
DevDirOff: LongWord; // Developer Directory Offset
Signature: array[0..15] of Char; // TRUEVISION-XFILE
Reserved: Byte; // ASCII period '.'
NullChar: Byte; // 0
end;
{ TTargaFileFormat class implementation }
constructor TTargaFileFormat.Create;
begin
inherited Create;
FName := STargaFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := False;
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: LongWord;
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
// Alocates 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: PLongWord(Dest)^ := PLongWord(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: PLongWord(Dest)^ := PLongWord(Src)^;
end;
Inc(Dest, Bpp);
end;
Inc(Src, Bpp);
end;
end;
// set position in source to real end of compressed data
Seek(Handle, -(BufSize - LongInt(LongWord(Src) - LongWord(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: LongWord;
NextPixel: LongWord;
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 := PLongWord(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 := PLongWord(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: LongWord;
NextPixel: LongWord;
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 := PLongWord(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 := PLongWord(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; var 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: PLongWord(Dest)^ := PLongWord(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.