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.