unit tga; {TGA file betolto unit}
{$S+,I+,R+,Q+}
{_$mode delphi}
interface
{ Belepiszkalva, hogy leforduljon Delphi alatt
- dword ertelmezve
- uj tipus: byteFile = file of byte -- valami zavarta
+ valamiert a hibakat 4 sorral elobb irta ki, mint ahol voltak -- miert ???
hogy lazarus alatt fusson, $S- -al kell forditani :(
- valamiert runtime 202-t ir ki fuggvenyhivaskor. valami stack algnment
problema lehet
}
uses Dialogs;
{ Megy Uncompressed TGA-ra es RLE encoded TGA-ra is! }
{ Es nem megy az en FPC-mre !!! :(((((((( }
type pTgaImage=^TgaImage; {Struktura a kepunknek }
TgaImage=packed record
Width,Height:word;
Bpp,Something,BytesPerPixel:byte;
imagesize,pixels:longint;
imagedata:pointer { tt lesz maga a kep! }
end;
procedure LoadTgaImage(var image:TgaImage; filename:string);
{ Betolt egy TGA kepet }
procedure FreeImage(var image:TgaImage); { Free-eli az ImageData-t }
implementation
procedure throwError(s : string);
begin
ShowMessage('tga: '+s);
end;
type TgaHeader = array[1..12] of byte; { Header tipus- a file elso 12 byte-ja }
{ Helyes TGA Header-ok }
const UncompressedH : TgaHeader=(0,0, 2,0,0,0,0,0,0,0,0,0);
CompressedH : TgaHeader=(0,0,10,0,0,0,0,0,0,0,0,0);
type byteFile = file of byte;
{ dword = 0..4294967295; !!! ez nem mefelelo }
function InitImage(var image:TgaImage; var f:byteFile; filename:string):boolean;
{ Ez a fuggveny beolvassa a file azon reszet ami azonos mind az RLEs, es
Tomoritetlen TGA-knal. Ezek utan beallit meg nehany valtozot }
begin
InitImage:=true;
Blockread(f,image,6); { Ez a beolvasas, a TGAImage-nek csak az
elso 6 byte-ja van benne a file-ban. A tobbit kiszamoljuk. }
if ioresult<>0 then
begin
ThrowError('Kep Parametereinek kiolvasasa sikertelen: "'+filename+'"!');
InitImage:=false;
exit
end;
if not (image.bpp in [24,32]) then
begin
ThrowError('Csak 24 es 32 bites TGA-kat lehet hasznalni: "'+filename+'"!');
InitImage:=false; exit
end;
image.BytesPerPixel:=image.Bpp shr 3; {div 8}
image.pixels:=image.width*image.height;
image.imagesize:=image.pixels*image.bytesperpixel;
getmem(image.imagedata,image.imagesize);
{ Lefoglaljuk a szukseges memoriateruletet, amit a kepunk el fog foglalni
(RLE eseteben a decompressalas utan) }
end;
{ Ez a procedure arra jo, hogy felcserelje az osszes pixel Red es Blue
Komponenset, mert a TGA file-okban RGBA helyett BGRA a pixelformat. }
procedure FlipRB(var image:tgaimage);
var p,np:^byte; t:byte; i:longint;
begin
p:=image.imagedata;
for i:=1 to image.pixels do begin
dword(np):=dword(p)+2; { np es p mutat a piros es kek komponensekre }
t:=p^; p^:=np^; np^:=t; { itt tortenik a csere }
dword(p):=dword(p)+image.BytesPerPixel { tovabb a kovetkezo pixelre }
end
end;
{ Ez a procedure betolti a tomoritetlen TGA -bol a kepet. }
procedure LoadUncompressedTga(var image:TgaImage; var f:bytefile; filename:string);
begin
blockread(f,image.imagedata^,image.imagesize);
{ Az egesz csak egy sima blockread }
{ Mivel a pixelformat BGRA, vagy BGR, kesobb ki kell cserelni!! Ezt vegzi el a FlipRB(); }
if ioresult<>0 then begin ThrowError('Kep Tartalmanak a betoltese sikertelen: "'+filename+'"!'); exit end
end;
procedure LoadCompressedTga(var image:TgaImage; var f:bytefile; filename:string);
var p:pointer;
c,i:byte; r:boolean; currentpixel:longint;
begin
currentpixel:=0; p:=image.imagedata;
{ p mutat az eppen irott pixel-re a memoriaban
currentpixel jeloli az eppen irott pixel szamat, hogy tudjuk mikor
kell kilepni. }
while currentpixel<image.pixels do begin
blockread(f,c,1); r:=((c shr 7)=1); c:=(c and $7F)+1; { $7F=0111 1111b
//beolvassuk a chunk header-t ami 1 byte hosszu.
//legfontosabb bit (8-adik bit) jeloli ha a kovetkezo resz
//RLE resz, vagy RAW Tomoritetlen adat. ha ez=1 akkor az
//(also 7 bit)+1 jeloli hogy a kovetkezo szin-t hanyszor kell
//ismetelni.Egyebkent az also7bit+1 jeloli hogy hany tomoritetlen
//pixel kovetkezik a file-ban
//r=MSB(most significant bit), c=(az also 7 bit) +1 }
if r then begin
blockread(f,p^,image.bytesperpixel); //beolvassuk az ismetelendo pixelt.
for i:=1 to c-1 do move(p^,pointer(dword(p)+dword(i*(image.bytesperpixel)))^,image.bytesperpixel)
{^^itten beirjuk c-szer a memoriaba! }
{ //if c>1 then move(p^,pointer(dword(p)+image.bytesperpixel)^,image.bytesperpixel*(c-1));
//^^igaz hogy nem ortodox modszer, de miert nem megy igy? miert kell a move() masolatot csinaljon
// az adatokrol, mielott masol?}
end else blockread(f,p^,c*image.bytesperpixel);
{ ha tomoritetlen resz, akkor csak egyszeruen beolvassuk }
if ioresult<>0 then begin ThrowError('RLE Kep Tartalmanak a betoltese sikertelen: "'+filename+'"!'); exit end;
dword(p):=dword(p)+(c*image.bytesperpixel); { tovabb }
currentpixel:=currentpixel+c { tovabb }
end
end;
procedure LoadTgaImage(var image:TgaImage; filename:string);
var f:bytefile;
header:TgaHeader;
i:word;
b:byte;
begin
assign(f,filename);{$I-}reset(f);{$I+} {//Megnyitjuk a file-t }
if ioresult<>0 then begin ThrowError('Nem sikerult megnyitni a "'+filename+'" file-t'); exit end;
BlockRead(f,header,sizeof(TgaHeader)); {//Kiolvassuk az elso 12 byte-ot }
if ioresult<>0 then begin ThrowError('Hiba a Header Olvasasa kozben: "'+filename+'"'); close(f); exit end;
b:=0;
{ osszehasonlitjuk a helyes Uncompressed es RunLength Encoded headerekkel. }
for i:=1 to 12 do if header[i]<>UncompressedH[i] then b:=b or 1;
for i:=1 to 12 do if header[i]<>CompressedH[i] then b:=b or 2;
{// ezek utan b=3 ha a file hibas, b=1 ha a file Tomoritett, es b=2 ha nem}
if b=3 then ThrowError('Nem Helyes File Formatum: "'+filename+'"!') else begin
{//Ha helyes a header, akkor beolvassuk a file elso reszet, ami azonos mind
//a compressed es RLE encoded fileokhoz}
if InitImage(image,f,filename) then
if b and 1=0 then
LoadUncompressedTga(image,f,filename) {//Folytatjuk a tomoritetlen file beolvasasat}
else
LoadCompressedTga(image,f,filename) {//Folytatjuk a tomoritett file beolvasasat}
end;
{// FlipRB(image); //Ki kell cserelni a Piros es Kek komponenseket }
close(f) {//Kesz, bezarjuk a file-t}
end;
{// Itten felszabaditjuk a kep altal lefoglalt memoriat
// Vigyazat: nem az egesz record-ot szabaditjuk fel, csak belole a kepet! }
procedure FreeImage(var image:TgaImage);
begin
if image.imagedata<>nil then freemem(image.imagedata,image.imagesize)
end;
end.