unit TgaPng;

{
Динамические библиотеки не позволяют использовать объявления типов и
классов. Preview в OpenPictureDialog реализуется при посредстве
RegisterFileFormat. Поскольку для работы последнего необходим класс
(используется метод LoadFromStream класса), подключение данного модуля
в виде DLL представляется невозможным.
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Zlib, ExtCtrls, Buttons;

type
  TfmInfo = class(TForm)
    imStamp: TImage;
    laVersion: TLabel;
    boxVersion: TComboBox;
    cbStamp: TCheckBox;
    edAuthor: TEdit;
    Label1: TLabel;
    Edit1: TEdit;
    Label2: TLabel;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    edJobName: TEdit;
    Label3: TLabel;
    meInfo: TMemo;
    btOkDialog: TBitBtn;
    btCancel: TBitBtn;
    procedure FormDeactivate(Sender: TObject);
    procedure btCancelClick(Sender: TObject);
    procedure btOkDialogClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fmInfo: TfmInfo;
  View:boolean;

  const
   Adam7tab:array[0..7,0..7]of byte=
   ((1,6,4,6,2,6,4,6),
    (7,7,7,7,7,7,7,7),
    (5,6,5,6,5,6,5,6),
    (7,7,7,7,7,7,7,7),
    (3,6,4,6,3,6,4,6),
    (7,7,7,7,7,7,7,7),
    (5,6,5,6,5,6,5,6),
    (7,7,7,7,7,7,7,7));
//                y     pass
   Adam7lin:array[0..7,1..7]of byte=
    ((1,1,0,1,0,1,0),
     (0,0,0,0,0,0,1),
     (0,0,0,0,1,1,0),
     (0,0,0,0,0,0,1),
     (0,0,1,1,0,1,0),
     (0,0,0,0,0,0,1),
     (0,0,0,0,1,1,0),
     (0,0,0,0,0,0,1));

  type
  TTgaExtension=record
    ExtensionSize:Word;
    AuthorName:array[0..40]of Char;
    AuthorComments:array[0..3,0..80]of Char;
    Month:Word;
    Day:Word;
    Year:Word;
    Hour:Word;
    Minute:Word;
    Second:Word;
    JobName:array[0..40]of Char;
    JobHours:Word;
    JobMinutes:Word;
    JobSeconds:Word;
    SoftwareID:array[0..40]of Char;
    SoftVersionNumber:Word;
    SoftVersionLetter:Char;
    KeyColor:DWORD;
    PixelRatioNumerator:Word;
    PixelRatioDenominator:Word;
    GammaNumerator:Word;
    GammaDenominator:Word;
    ColorCorrectionOffset:DWORD;
    PostageStampOffset:DWORD;
    ScanLineOffset:DWORD;
    AttributesType:Byte;
  end;

    TArray=array of byte;
    PDWArray=array of DWORD;
    TChunkTypeString=string[4];
    TFilterRaw=array of byte;
    TChunkType=array[1..4]of char;
    TChunkBegin=record
      DataLength:DWORD;
      ChunkType:TChunkType;
    end;

    TIHDRChunkData=record {13B}
      Width:DWORD; { Ширина изображения в пикселах 4B}
      Height:DWORD ; { Высота изображения в пикселах 4B}
      BitDepth:BYTE; { Бит на пиксел или на выборку 1B}
      ColorType:BYTE; { Индикатор интерпретации цвета 1B}
      Compression:BYTE; { индикатор типа сжатия 1B}
      tFilter:BYTE; { индикатор типа Фильтра 1B}
      Interlace:BYTE; { Тип используемой чередующейся схемы 1B}
    end;
    TIHDRChunk=record
      DataLength:DWORD;   {4B}
      ChunkType:TChunkType; {4B}
      Data:TIHDRchunkData;
      CRC:DWORD;            {4B}
    end;

    TPLTEChunkEntry=record
      Red,Green,Blue:BYTE;
    end;
    TPLTEChunkData=array of TPLTEChunkEntry;
    TPLTEChunk=record
      DataLength:DWORD;
      ChunkType:TChunkType;
      Data:TPLTEChunkData;
      CRC:DWORD;
    end;

    WordPLTEEntry=record
      Red,Green,Blue:Word;
    end;

    TbKGDChunkData=record
      Index:Byte;
      Value:Word;
      Color:WordPLTEEntry;
    end;
    TbKGDChunk=record
      DataLength:DWORD;
      ChunkType:TChunkType;
      Data:TbKGDChunkData;
      CRC:DWORD;
    end;

    TIDATChunkData=array of byte;

    TIDATChunk=record
      DataLength:DWORD;
      ChunkType:TChunkType;
      Data:TIDATChunkData;
      CRC:DWORD;
    end;

    TImageData=pbytearray;
    TPNGSignature=array[1..8]of char;
    TFilterTypes=set of 0..255;

     TPNG=class (TBitmap)
       private
        FInfo:TStringList; //Содержит информацию о файле
        ds:TDecompressionStream; //Поток распаковки (used library ZLib)
        fs:TMemoryStream; //поток для буферизации
        fstr:TFileStream; //Файловый поток
        ms:TMemoryStream; //Поток памяти
        IHDRData:TIHDRChunkData;
        FilterTypes:TFilterTypes;//Типы используемых фильтров
        ExtArea:TTgaExtension;
       protected
        BPP:DWORD;//bytes per pixel
        bp:DWORD;//bytes per цветовую составлящую, либо pixels per byte
        function ProcessHeader:TArray;//Обработка заголовка
        function ProcessPalette(dataLength:DWORD):TArray;// обработка палитры
        function ProcessEnd:TArray; //Обработка куска IEND
        function ProcessTxt(DataLength:longint):TArray;//Обработка куска tEXt
        function ProcessData(dataLength:DWORD):TArray;//Обработка куска IDAT: распаковка
        procedure Drawing(count:DWORD);//Рисование
//Фильтрация байта из строки
        procedure Filter(FilterType:byte; i, k:DWORD; var Prior, Raw:TFilterRaw);
//Вспомогательная функция для фильтра Paeth
        function PaethPredictor(a,b,c:BYTE):byte;

        function LoadFromFil:boolean;

       public
        constructor Create; override;
        destructor Destroy; override;

//Запись PNG-файла. Записывается 8 bit indexed, 24 bit RGB или 32 bit RGBA
//paeth filtered
        procedure SaveToFile(const fileName:string);// override;
//запись куска chnk с данными из P (длиной len)
        procedure savechunk(fs:TFileStream;P:pointer;len:DWORD;chnk:TChunkType);
        procedure savetext(fs:TFileStream;keyw:string;txt:string);
//подсчет CRC-32 куска chnk и его данных P (длиной len)
        function findCRC(P:pointer;len:DWORD;chnk:TChunkType):DWORD;

//Загрузка изображения из файла. Возникает битмап pf8bit (+palette),
//pf24bit (no alpha channel), или pf32bit (+alpha channel):
        function LoadFromFile(const fileName:string):boolean;
        procedure LoadFromStream(Stream: TStream); override;

        property Info:TStringList read FInfo;//Содержит информацию о файле
     end; //TPng


const
//поддерживаемые типы кусков
  PalChunk:TChunkType=('P','L','T','E');
  TxtChunk:TChunkType=('t','E','X','t');
  DatChunk:TChunkType=('I','D','A','T');
  EndChunk:TChunkType=('I','E','N','D');
  HdrChunk:TChunkType=('I','H','D','R');
//последовательность байт в заголовке PNG-файла
  _PNGSignature:TPNGSignature=(#137,#80,#78,#71,#13,#10,#26,#10);

  procedure Reverse(var Number:WORD);overload;//HSB<->LSB
  procedure Reverse(var Number:DWORD);overload;//аналогично для 32-битного числа
  function RGBAToLW(R,G,B,A:byte):DWORD;//преобразование для записи в 32bit Bitmap

var
 ImageData:TImageData; //массив данных о пикселях (после распаковки)

type
  TBuffer=class
   private
    Index,Size:DWORD;
    Buf:Pointer;
    p:^byte;
    F:^file;
   public
    Constructor Create(var F1:file;S:DWORD);
    procedure PutByte(C:byte);
    procedure SaveToFile;
    procedure Flush;
    Destructor Destroy; override;
  end;

  TTgaFooter=record
    ExtensionAreaOffset:LongInt;
    DeveloperDirectoryOffset:LongInt;
    Signature_:array[0..17]of Char;
  end;

  TTgaHeader=record
    IDLength:byte;
    ColorMapType:byte;
    ImageType:byte;
// Color Map Specification
    FirstEntryIndex:Word;
    ColorMapLength:Word;
    ColorMapEntrySize:byte;
// Image Specification
    XOrigin:Word;
    YOrigin:Word;
    Width:Word;
    Height:Word;
    PixelDepth:byte;
    ImageDescriptor:byte;
  end;

  TTga=class(TBitmap)
    private
      FInfo:TStringList; //Содержит информацию о файле
    public
      ColorMapOffset:Word;
      ImageOffset:Word;
      ImageSize:DWORD;
      Version:Integer; //1=TGAv1, 2=TGAv2, 3=TGAv2+ExtensionArea
//(Используется при сохранении озображения. ExtArea заполняется в конструкторе)
      Header:TTgaHeader;
      Footer:TTgaFooter;
      ExtArea:TTgaExtension;
      ImageID:array of Char;
      Buffer:TBuffer;

      psWidth:Byte;
      psHeight:Byte;
      psData:TBitmap;

      Constructor Create; override;
      Destructor Destroy; override;

      function ReadInfo(fs:TMemoryStream):Boolean;
      procedure ReadPalette(fs:TMemoryStream);
      procedure ReadPostageStamp(fs:TMemoryStream);
      procedure SaveToFile(FN:string);
      procedure SaveImage(var F:file);
      procedure SavePostageStamp(var F:File);
      function GetColor(fs:TMemoryStream):TColor;

      function LoadFromFile(FN:string):boolean;
      procedure LoadFromStream(Stream: TStream); override;
      function LoadFromFil(fs:TMemoryStream):boolean;

      property Info:TStringList read FInfo;//Содержит информацию о файле
  end;

implementation

function ArrayToString(p:pchar):String;
begin
  Result:='';
  if p<>nil then
  while(p^<>#0) do
  begin
    Result:=Result+p^;
    inc(p);
  end;
end;

procedure StringToArray(S:String; p:pchar);
var
  i:Word;
begin
  for i:=1 to Length(S) do
  begin
    p^:=S[i];
    inc(p);
  end;
  p^:=#0;
end;

procedure StrToFixArray(S:String; p:pchar; Len:Word);
var
  i:Word;
begin
  i:=1;
  while((i<=Length(S))and(i<Len))do
  begin
    p^:=S[i];
    inc(i);
    inc(p);
  end;
  while(i<=Len) do
  begin
    p^:=#0;
    inc(i);
    inc(p);
  end;
end;

function RGBAToLW(R,G,B,A:byte):DWORD;
begin
 Result:=R shl 16+G shl 8+B+A shl 24;
end;

procedure Reverse(var Number:WORD);
 begin
  Number:=Number shr 8+Number shl 8;
 end;

procedure Reverse(var Number:DWORD);
 begin
  Number:=Number shr 24+(Number and $ff0000)shr 8+
    (Number and $ff00)shl 8+Number shl 24;
 end;

constructor TPNG.Create;
var m:integer;
begin
  inherited;
  FInfo:=TStringList.Create;
  view:=false{true};//глючит :-\
  With ExtArea do
  begin
    StrToFixArray('',@AuthorName,41);
    for m:=0 to 3 do
     StrToFixArray('',@(AuthorComments[m]),81);
    StrToFixArray('',@JobName,41);
  end;
end;

destructor TPNG.Destroy;
begin
  FInfo.Free;
  inherited;
end;

procedure TPNG.SaveToFile(const fileName:string);
var
  IHDRdata:TIHDRChunkData;
  buf:TArray;
  i,j,j2,j3,jx,k,razmer,hgt,wid,prohod:DWORD;
  paly:array[0..768]of byte;
  p,q,p2:pbytearray;
  c:byte;
  col:TColor;
  pt:pointer;
  zs:integer;
begin
  if view
  then begin
   fmInfo.boxVersion.Visible:=false;
   fmInfo.laVersion.Visible:=false;
   fmInfo.imStamp.Visible:=false;
   fmInfo.meInfo.Visible:=false;
   fmInfo.cbStamp.Caption:='Постепенная развертка';
   fmInfo.ShowModal;
   fmInfo.cbStamp.Caption:='Этикетка';
   fmInfo.meInfo.Visible:=true;
   fmInfo.boxVersion.Visible:=true;
   fmInfo.laVersion.Visible:=true;
   if fmInfo.modalresult=mrCancel then exit;
 end;
  FInfo.Clear;
  hgt:=Height;reverse(hgt);
  wid:=Width;reverse(wid);
 with IHDRdata do
 begin
  height:=hgt;width:=wid;
  bitdepth:=8;
  case pixelformat of
   pf8bit:begin colortype:=3;bpp:=1 end;
   pf24bit:begin colortype:=2;bpp:=3 end;
   pf32bit:begin colortype:=6;bpp:=4 end;
  end; //case
  compression:=0;
  tfilter:=0;
  interlace:=ord(fmInfo.cbStamp.Checked);
 end; //with
  closehandle(FileCreate(fileName));
  fstr:=TFileStream.Create(fileName,fmOpenWrite);
  try //finally
   fstr.Write(_PNGsignature,8);
   savechunk(fstr,@IHDRdata,13,HdrChunk);
   if IHDRdata.colortype=3
   then begin
     p:=scanline[0];
     c:=p[0];
     for i:=0 to 255 do
     begin
       p[0]:=byte(i);
       col:=canvas.pixels[0,0];
       PDWArray(@paly[i*3])[0]:=col;
     end; //хитрый способ добывания палитры
     p[0]:=c;
     savechunk(fstr,@paly,768,PalChunk);
   end;

   hgt:=Height;
   wid:=Width;
   with IHDRData do
    if Interlace=0
    then razmer:=(wid*bpp+1)*hgt
    else razmer:=(wid+3)*hgt*bpp;
   getmem(ImageData,razmer);
   getmem(q,wid*bpp);
   getmem(p,wid*bpp);
   k:=0;
   for i:=0 to wid*bpp-1 do p[i]:=0;
if IHDRData.interlace=0
then
  for i:=0 to hgt-1 do
  begin
   q:=p;
   p:=scanline[i];
   ImageData[k]:=4; //Paeth
   inc(k);
   j:=0;
   if pixelformat=pf8bit
   then
    for j:=0 to wid*bpp-1 do
    begin
     ImageData[k]:=p[j];
     if j>=bpp
     then dec(ImageData[k],PaethPredictor(p[j-bpp],q[j],q[j-bpp]))
     else dec(ImageData[k],PaethPredictor(0,q[j],0));
     inc(k);
    end
   else
    while j<wid*bpp do
    begin
     inc(j,3);
     for j2:=1 to 3 do
     begin
      dec(j);
      ImageData[k]:=p[j];
      if j>=bpp
      then dec(ImageData[k],PaethPredictor(p[j-bpp],q[j],q[j-bpp]))
      else dec(ImageData[k],PaethPredictor(0,q[j],0));
      inc(k);
     end;
     inc(j,bpp);
     if bpp=4 then
     begin
      ImageData[k]:=p[j-1];
      if j>bpp
      then dec(ImageData[k],PaethPredictor(p[j-5],q[j-1],q[j-5]))
      else dec(ImageData[k],PaethPredictor(0,q[j-1],0));
      inc(k);
     end;
    end; //while
  end //for, interlace=0
else //interlace=1
 for prohod:=1 to 7 do
 begin
  for i:=0 to wid*bpp-1 do p[i]:=0;
  for i:=0 to hgt-1 do
  if Adam7lin[i mod 8,prohod]=1
  then begin
   tarray(q):=copy(tarray(p),0,wid*bpp);
   p2:=scanline[i];
   ImageData[k]:=4; //Paeth
   inc(k);
   j2:=0;
   if pixelformat=pf8bit
   then
    for j:=0 to wid-1 do
    begin if Adam7tab[i mod 8,j mod 8]=prohod
    then begin
     ImageData[k]:=p2[j];
     p[j2]:=p2[j];
     if j2>=bpp
     then dec(ImageData[k],PaethPredictor(p[j2-bpp],q[j2],q[j2-bpp]))
     else dec(ImageData[k],PaethPredictor(0,q[j2],0));
     inc(j2);
     inc(k);
    end end
   else //<>pf8bit
   for j:=0 to wid-1 do
    if Adam7tab[i mod 8,j mod 8]=prohod
    then begin
     jx:=j*bpp+3;
     inc(j2,3);
     for j3:=1 to 3 do
     begin
      dec(jx);
      ImageData[k]:=p2[jx];
      dec(j2);
      p[j2]:=p2[jx];
      if j2>=bpp
      then dec(ImageData[k],PaethPredictor(p[j2-bpp],q[j2],q[j2-bpp]))
      else dec(ImageData[k],PaethPredictor(0,q[j2],0));
      inc(k);
     end;
     inc(j2,bpp);
     if bpp=4 then
     begin
      ImageData[k]:=p2[jx+3];
      p[j2-1]:=p2[jx+3];
      if j2>bpp
      then dec(ImageData[k],PaethPredictor(p[j2-5],q[j2-1],q[j2-5]))
      else dec(ImageData[k],PaethPredictor(0,q[j2-1],0));
      inc(k);
     end;
    end; //for j, if
  end; //for i, if
 end; //for prohod
   compressbuf(ImageData,k,pt,zs);
   FInfo.Add('packed '+inttostr(k));
   savechunk(fstr,pt,zs,DatChunk);
   dispose(pt);
   dispose(ImageData);

   savetext(fstr,'Title',fmInfo.edJobName.Text);
   savetext(fstr,'Author',fmInfo.edAuthor.Text);
   savetext(fstr,'',fmInfo.Edit1.Text);
   savetext(fstr,'',fmInfo.Edit2.Text);
   savetext(fstr,'',fmInfo.Edit3.Text);
   savetext(fstr,'',fmInfo.Edit4.Text);

   savechunk(fstr,@IHDRdata,0,EndChunk);
  finally
   fstr.Free;
   SetLength(buf,0);
  end;
end;

procedure TPNG.savetext(fs:TFileStream;keyw:string;txt:string);
var
  i:DWORD;
  len:DWORD;
  str:pchar;
begin
  if(txt='')then exit;
  len:=length(keyw)+1+length(txt);
  getmem(str,len);
  for i:=1 to length(keyw)do
   str[i-1]:=keyw[i];
  str[length(keyw)]:=#0;
  for i:=1 to length(txt)do
   str[i+length(keyw)]:=txt[i];
  i:=len;reverse(i);
  fs.Write(i,4);
  fs.Write(TxtChunk,4);
  fs.Write(str^,len);
  i:=findCRC(str,len,TxtChunk);reverse(i);
  fs.Write(i,4);
  freemem(str);
end;

procedure TPNG.savechunk(fs:TFileStream;P:pointer;len:DWORD;chnk:TChunkType);
var
  i:DWORD;
begin
   i:=len;reverse(i);
   fs.Write(i,4);
   fs.Write(chnk,4);
   fs.Write(P^,len);
   i:=findCRC(P,len,chnk);reverse(i);
   fs.Write(i,4);
end;

function TPNG.findCRC(P:pointer;len:DWORD;chnk:TChunkType):DWORD;
type
  pbyte=^byte;
var
  CRC_table:array[0..255]of DWORD;
  c:DWORD;
  n,k:integer;
begin
  for n:=0 to 255 do
  begin
    c:=n;
    for k:=0 to 7 do
      if odd(c)
      then c:=$edb88320 xor(c shr 1)
      else c:=c shr 1;
    CRC_table[n]:=c;
  end;
  c:=$ffffffff;
  for n:=1 to 4 do
    c:=CRC_table[(c xor ord(chnk[n]))and $ff]xor(c shr 8);
  for n:=0 to len-1 do
    c:=CRC_table[(c xor pbytearray(P)[n])and $ff]xor(c shr 8);
  findCRC:=c xor $ffffffff;
end;

function TPNG.LoadFromFil:boolean;
var
  chunkBegin:TChunkBegin;
  CRC:DWORD;
  buf:TArray;
  PNGSign:TPNGSignature;
begin
  ms:=TMemoryStream.Create;
  try //finally
   FInfo.Clear;
   fs.Read(PNGsign,8);
   result:=true;
   if PNGsign<>_PNGSignature
   then begin
    FInfo.Add('Это не PNG!');
    result:=false;
   end
   else
   repeat
    fs.Read(chunkbegin,8);
    with chunkBegin do begin
     Reverse(DataLength);
//     FInfo.Add(string(ChunkType)+' ('+IntToStr(DataLength)+')');
     if ChunkType=HdrChunk then buf:=ProcessHeader
     else if ChunkType=PalChunk then buf:=ProcessPalette(DataLength)
     else if ChunkType=DatChunk then buf:=ProcessData(DataLength)
     else if ChunkType=EndChunk then buf:=ProcessEnd
     else if ChunkType=TxtChunk then buf:=ProcessTxt(DataLength)
     else begin //обрабатываем неизвестный тип куска
       SetLength(buf,DataLength);
       fs.Read(buf[0],DataLength);
     end;
     fs.Read(CRC,4);Reverse(CRC);
     if(CRC<>findCRC(buf,DataLength,chunkBegin.ChunkType))
     then FInfo.Add('CRC error');
    end;
    SetLength(buf,0);
   until not((fs.Position<=fs.Size)and(chunkBegin.ChunkType<>EndChunk));
  finally
   fs.Free;
   ms.Free;
   SetLength(buf,0);
  end;
end;

function TPNG.LoadFromFile(const fileName:string):boolean;
begin
  fstr:=TFileStream.Create(fileName,fmOpenRead);
  fs:=TMemoryStream.Create;
  fs.Size:=fstr.Size;
  fstr.Read(fs.Memory^,fstr.Size);
  result:=LoadFromFil;
  fstr.Free;
  if view
  then begin
   fmInfo.edJobName.Text:=ArrayToString(@(ExtArea.JobName));
   fmInfo.edAuthor.Text:=ArrayToString(@(ExtArea.AuthorName));
   fmInfo.Edit1.Text:=ArrayToString(@(ExtArea.AuthorComments[0]));
   fmInfo.Edit2.Text:=ArrayToString(@(ExtArea.AuthorComments[1]));
   fmInfo.Edit3.Text:=ArrayToString(@(ExtArea.AuthorComments[2]));
   fmInfo.Edit4.Text:=ArrayToString(@(ExtArea.AuthorComments[3]));
   fmInfo.meInfo.Lines:=FInfo;
   fmInfo.imStamp.Visible:=false;
   fmInfo.Show;
  end;
end;

procedure TPNG.LoadFromStream(Stream: TStream);
begin
  fs:=TMemoryStream.Create;
  fs.Size:=Stream.Size;
  Stream.Read(fs.Memory^,Stream.Size);
  LoadFromFil;
end;

function TPNG.ProcessHeader:TArray;
const
 IntToYes:array[0..1]of string[3]=('No','Yes');
 IntToCvet:array[0..6]of string=('Grayscale','','RGB','Indexed color',
  'Grayscale+Alpha','','RGB+Alpha');
begin
  fs.Read(IHDRData,13);
  SetLength(result,13);
  result:=copy(TArray(@IHDRData),0,13);
  Reverse(IHDRData.Width); Reverse(IHDRData.Height);
  Width:=IHDRData.Width; Height:=IHDRData.Height;
  with IHDRData do begin
    FInfo.Add('Высота '+IntToStr(Height));
    FInfo.Add('Ширина '+IntToStr(Width));
    FInfo.Add('Бит на пиксел '+IntToStr(BitDepth));
    FInfo.Add('Тип цвета '+IntToCvet[ColorType]);
    FInfo.Add('Adam7 interlace '+IntToYes[InterLace]);
    bp:=BitDepth shr 3;
    case ColorType of
     0:begin //Grayscale
        pixelformat:=pf24bit;
        if bp=2
        then bpp:=2
        else begin
         bpp:=1;
         bp:=8 div BitDepth;
        end;
       end;
     4:begin //Grayscale+alpha
        pixelformat:=pf32bit;
        Bpp:=bp*2;
       end;
     2:begin //RGB
        pixelformat:=pf24bit;
        Bpp:=bp*3;
       end;
     6:begin //RGB+alpha
        pixelformat:=pf32bit;
        Bpp:=bp*4;
       end;
     3:begin //indexed
        pixelformat:=pf8bit;
        Bpp:=1;
        bp:=8 div BitDepth;
       end;
    end; //Case
  end; //with
end;

function TPNG.ProcessTxt(DataLength:longint):TArray;
var
  str:pchar;
  str2:string;
  i:longint;
begin
  Getmem(str,DataLength);
  Setlength(result,DataLength);
  fs.Read(str[0],DataLength);
  str2:='';
  for i:=0 to DataLength-1 do
   if str[i]=#0
   then str2:=str2+' '
   else str2:=str2+str[i];
  FInfo.Add(str2);
  if pos('Author',str2)=1
  then begin
   delete(str2,1,7);
   StrToFixArray(str2,ExtArea.AuthorName,40)
  end
  else if pos('Title',str2)=1
  then begin
   delete(str2,1,6);
   StrToFixArray(str2,ExtArea.JobName,40)
  end
  else begin
   delete(str2,1,1);
   for i:=0 to 3 do
    if ExtArea.AuthorComments[i,0]=#0
    then begin
     StrToFixArray(str2,ExtArea.AuthorComments[i],80);
     break;
    end;
  end;
  for i:=0 to DataLength-1 do
   result[i]:=ord(str[i]);
  freemem(str);
end;

function TPNG.ProcessPalette(datalength:DWORD):TArray;
var
 k:longint;
 PLTEData:TPLTEChunkData;
 hpal:HPALETTE;
 pal:PLogPalette;
begin
 SetLength(PLTEData,DataLength div 3);
 SetLength(Result,DataLength);
 k:=fs.Position;
 fs.Read(PLTEData[0],DataLength);
 fs.Seek(k,soFromBeginning);
 fs.Read(result[0],DataLength);
 pal:=nil;
 try
   GetMem(pal,sizeof(TLogPalette)+sizeof(TPaletteEntry)*255);
   pal.palVersion:=$300;
   pal.palNumEntries:=256;
   for k:=0 to DataLength div 3-1 do with pal.palPalEntry[k]do
   begin
    peRed:=PLTEData[k].Red;
    peGreen:=PLTEData[k].Green;
    peBlue:=PLTEData[k].Blue;
    peFlags:=PC_NOCOLLAPSE; //используем все 256 цветов
   end;
   hpal:=CreatePalette(pal^);
   if hpal<>0 then Palette:=hpal;
 finally
   FreeMem(pal);
   SetLength(PLTEData,0);
  end;
end;

function TPNG.ProcessEnd:TArray;
const
 IntToFilter:array[0..4]of string=('None','Sub','Up','Average','Paeth');
var
  i:DWORD;
  razmer:integer;
begin
  SetLength(Result,4);
  ms.Position:=0;
  ds:=TDecompressionStream.Create(ms);
  with IHDRData do
    razmer:=(width+3)*height*bpp;
  getmem(ImageData,razmer);
  i:=ds.Read(ImageData[0],razmer);
//  FInfo.Add('decompressed '+IntToStr(i));
  Drawing(i);
  for i:=0 to 255 do
   if i in FilterTypes then FInfo.Add('Фильтр '+IntToStr(i)+
    ' ('+IntToFilter[i]+')');
  dispose(ImageData);
  ds.Free;
end;

function TPNG.ProcessData(dataLength:DWORD):TArray;
begin
  SetLength(Result,dataLength);
  fs.Read(Result[0],DataLength);
  ms.Write(Result[0],DataLength);
end;

procedure TPNG.Drawing(count:DWORD);
type
  p3array=array of array[0..2]of byte;
var
 FilterType,ipass:Byte; // тип фильтра
 Prior,Raw:TfilterRaw;
 // Prior- предыдущая строка байтов изображения
 // Raw- расфильтрованная строка байтов изображения
 j:byte;
 x,y,nr:word;
 i,k,RawLen:DWORD;
 // i- позиция в массиве данных изображения
 // k- позиция в текущей строке байтов
 p:Pbytearray;
begin
 x:=0;y:=0;nr:=0;
 ipass:=1;
 // инициализация массивов
 if bpp=1
 then RawLen:=IHDRData.Width div bp+1
 else RawLen:=IHDRData.Width*bpp+1;
 SetLength(Raw,RawLen);
 SetLength(Prior,RawLen);
 for i:=0 to RawLen-1 do Prior[i]:=0;
 i:=0;k:=0;
 // чтение
 while i<Count do begin
  if(x=0)and((IHDRData.InterLace=0)or(Adam7lin[y mod 8,ipass]=1))then
  begin
   // определяем тип фильтра
   FilterType:=ImageData[i];
   if not(FilterType in FilterTypes)then FilterTypes:=FilterTypes+[FilterType];
   inc(i);
  end;
  // вывод пиксела
  p:=scanline[y];
 with IHDRData do
 if(InterLace=0)or(ipass=Adam7tab[y mod 8,x mod 8])
 then begin
  case ColorType of
  3:begin // Индексированные цвета
    if nr mod bp=0
    then Filter(FilterType,i,k,Prior,Raw);
    P[x]:=(ImageData[i]shr(BitDepth*(bp-1-nr mod bp)))and((1 shl BitDepth)-1);
    if(nr+1)mod bp=0
    then begin inc(i);inc(k)end;
   end; //3
  4:begin //Grayscale+alpha
    Filter(FilterType,i,k,Prior,Raw);
    Filter(FilterType,i+bp,k+bp,Prior,Raw);
    j:=ImageData[i];
    PDWArray(P)[x]:=RGBAToLW(j,j,j,ImageData[i+bp]);
    inc(i,bpp);inc(k,bpp);
   end; //4
  0:if bpp=1
   then begin //Grayscale not 16 bit
    if nr mod bp=0
    then Filter(FilterType,i,k,Prior,Raw);
    j:=(ImageData[i]shr(BitDepth*(bp-1-nr mod bp)))and((1 shl BitDepth)-1);
    j:=(j and(1 shl BitDepth-1))*255 div(1 shl BitDepth-1);
    p3array(P)[x][0]:=j;
    p3array(P)[x][1]:=j;
    p3array(P)[x][2]:=j;
    if(nr+1)mod bp=0
    then begin inc(i);inc(k)end;
   end
   else begin //Grayscale 16 bit
    Filter(FilterType,i,k,Prior,Raw);
    j:=ImageData[i];
    p3array(P)[x][0]:=j;
    p3array(P)[x][1]:=j;
    p3array(P)[x][2]:=j;
    inc(i,bpp);inc(k,bpp);
   end; //0
else{2,6:}begin   // TrueColor & TrueColor с альфой
   Filter(FilterType,i,k,Prior,Raw);
   Filter(FilterType,i+bp,k+bp,Prior,Raw);
   Filter(FilterType,i+bp+bp,k+bp+bp,Prior,Raw);
   if ColorType=6 //RGBA
   then begin
    Filter(FilterType,i+bpp-bp,k+bpp-bp,Prior,Raw);
    PDWArray(P)[x]:=RGBAToLW(ImageData[i],ImageData[i+bp],
      ImageData[i+bp+bp],ImageData[i+bpp-bp]);
   end
   else begin
    p3array(P)[x][0]:=ImageData[i+bp+bp];
    p3array(P)[x][1]:=ImageData[i+bp];
    p3array(P)[x][2]:=ImageData[i];
   end;
   inc(i,bpp);inc(k,bpp);
  end; //2,6
 end; //case
 inc(nr);
end;
  inc(x);
  if x=IHDRData.Width then
  begin
   if(bpp=1)and(nr mod bp>0)then inc(i);
   // Следующая строка растра
   if(IHDRData.InterLace=0)or(Adam7lin[y mod 8,ipass]=1)
   then Prior:=copy(Raw,0,RawLen);
   inc(y);  // перевод строки
   if y=IHDRData.Height then
   begin
    y:=0;
    for k:=0 to RawLen-1 do Prior[k]:=0;
    inc(ipass);
   end;
   x:=0;nr:=0;    // возврат каретки
   k:=0;
  end;
 end;
 SetLength(Prior,0);
 SetLength(Raw,0);
end;

procedure TPNG.Filter(FilterType:byte;i,k:DWORD;var Prior,Raw:TFilterRaw);
// дефильтрация
// FilterType- тип фильтра
// i- позиция в массиве данных изображения
// k- позиция в текущей строке байтов
// Prior- предыдущая строка байтов изображения
// Raw- дефильтрованная строка байтов изображения
 begin
  case FilterType of
   1: // Sub-фильтр
      if k>=bpp
      then inc(ImageData[i],Raw[k-Bpp]);
   2: // Up-фильтр
      inc(ImageData[i],Prior[k]);
   3: // Average-фильтр
      if k>=bpp
      then inc(ImageData[i],(Raw[k-bpp]+Prior[k])div 2)
      else inc(ImageData[i],Prior[k]div 2);
   4: // Paeth-фильтр
      if k>=bpp
      then inc(ImageData[i],PaethPredictor(Raw[k-bpp],Prior[k],Prior[k-bpp]))
      else inc(ImageData[i],PaethPredictor(0,Prior[k],0));
  end;
  Raw[k]:=ImageData[i];
 end;

function TPNG.PaethPredictor(a,b,c:BYTE):byte;
  // вспомогательная функция для фильтра Paeth
 var
   pa,pb,pc:integer;
 begin {PaethPredictor}
   pc:=a+b-c;
   pa:=abs(pc-a); pb:=abs(pc-b); pc:=abs(pc-c);
   if(pa<=pb)and(pa<=pc)
   then Result:=a
   else
    if pb>pc
    then Result:=c
    else Result:=b;
 end; {PaethPredictor}

{ -----------------------------------------------------------------------------}
{ Описание процедур класса TTgaFile }
Constructor TTga.Create;
var
 da:TDateTime;
 m:word;
begin
  inherited Create;
  FInfo:=TStringList.Create;
  psWidth:=0;
  psHeight:=0;
  Version:=3;
  View:=false{true};//глючит :-\
  With ExtArea do
  begin
    ExtensionSize:=495;
    StrToFixArray('',@AuthorName,41);
    for m:=0 to 3 do
     StrToFixArray('',@(AuthorComments[m]),81);
    da:=Now;
    DecodeDate(da,Year,Month,Day);
    DecodeTime(da,Hour,Minute,Second,m);
    StrToFixArray('',@JobName,41);
    JobHours:=0;
    JobMinutes:=0;
    JobSeconds:=0;
    StrToFixArray('TGA module of P!NGU!N ^ FreePainter',@SoftwareID,41);
    SoftVersionNumber:=100;
    SoftVersionLetter:=' ';
    KeyColor:=0;
    PixelRatioNumerator:=1;
    PixelRatioDenominator:=1;
    GammaNumerator:=1;
    GammaDenominator:=1;
    ColorCorrectionOffset:=0;
    PostageStampOffset:=0;
    ScanLineOffset:=0;
    AttributesType:=1;
  end;
end;

Destructor TTga.Destroy;
begin
  SetLength(ImageID,0);
  FInfo.Free;
  inherited;
end;

procedure TTga.LoadFromStream(Stream: TStream);
var
 fs:TMemoryStream;
begin
  fs:=TMemoryStream.Create;
  fs.Size:=Stream.Size;
  Stream.Read(fs.Memory^,Stream.Size);
  LoadFromFil(fs);
end;

function TTga.LoadFromFile(FN:string):boolean;
var
 fstr:TFileStream;
 fs:TMemoryStream;
begin
 fstr:=TFileStream.Create(FN,fmOpenRead);
 fs:=TMemoryStream.Create;
 fs.Size:=fstr.Size;
 fstr.Read(fs.Memory^,fstr.Size);
 result:=LoadFromFil(fs);
 fstr.Free;
 if view
 then begin
  fmInfo.edJobName.Text:=ArrayToString(@(ExtArea.JobName));
  fmInfo.edAuthor.Text:=ArrayToString(@(ExtArea.AuthorName));
  fmInfo.Edit1.Text:=ArrayToString(@(ExtArea.AuthorComments[0]));
  fmInfo.Edit2.Text:=ArrayToString(@(ExtArea.AuthorComments[1]));
  fmInfo.Edit3.Text:=ArrayToString(@(ExtArea.AuthorComments[2]));
  fmInfo.Edit4.Text:=ArrayToString(@(ExtArea.AuthorComments[3]));
  fmInfo.imStamp.Visible:=(psWidth*psHeight>0);
  if(psWidth*psHeight>0)
  then fmInfo.imStamp.Picture.Assign(psData);
  fmInfo.meInfo.Lines:=FInfo;
  fmInfo.Show;
 end;
end;

function TTga.LoadFromFil(fs:TMemoryStream):boolean;
var
  a,b:Integer; { Координаты начальной точки развертки}
  x,y:Integer;
  hdir,vdir:Integer;{ Направление развертки }
  i,j:Word;
  Color:TColor;
  RepCount,bpp:Byte;
  p:pbytearray;
begin
  result:=True;
  if not(ReadInfo(fs))
  then begin
    result:=False;
    Exit;
  end;
  FInfo.add('Высота '+IntToStr(Header.Height));
  FInfo.add('Ширина '+IntToStr(Header.Width));
// Выделить память под картинку
  case Header.PixelDepth of
    8:begin PixelFormat:=pf8bit; bpp:=1 end;
    32:begin PixelFormat:=pf32bit; bpp:=4 end;
    else begin PixelFormat:=pf24bit; bpp:=3 end;
  end;
  Height:=Header.Height;
  Width:=Header.Width;
  if(Header.ImageType and 7)=3
  then FInfo.add('Grayscale')
  else
    case Header.PixelDepth of
      8:FInfo.add('256 цветов');
      15,16:FInfo.add('32K цветов');
      24:FInfo.add('16M цветов');
      32:FInfo.add('16M цветов + Alpha channel');
      else FInfo.add('Неизвестный формат');
    end;
  fs.Seek(Header.IDLength+18,soFromBeginning);
  ReadPalette(fs);
  ImageOffset:=fs.Position;
// Определить начальную точку и направление развертки
  a:=(Header.Width-1)*bpp; hdir:=-bpp;
  b:=0; vdir:=1;
  if(Header.ImageDescriptor and $10)=0
  then begin
    a:=0; hdir:=bpp;
  end;
  if(Header.ImageDescriptor and $20)=0
  then begin
    b:=Header.Height-1; vdir:=-1;
  end;
// Расшифровать изображение
y:=b;
for i:=0 to Header.Height-1 do
begin
 p:=ScanLine[y];
 x:=a;
 case Header.ImageType of
9,10,11:repeat //Сжатое
        fs.Read(RepCount,1);
        if(RepCount and $80)=0
        then
        for j:=0 to RepCount do
        begin
          Color:=GetColor(fs);
          p[x]:=Color;
          if bpp>1
          then begin
            pword(@p[x+1])^:=Color shr 8;
            if bpp=4 then p[x+3]:=Color shr 24;
          end;
          inc(x,hdir);
        end
        else begin
          Color:=GetColor(fs);
          RepCount:=RepCount and $7F;
          for j:=0 to RepCount do
          begin
            p[x]:=Color;
            if bpp>1
            then begin
              pword(@p[x+1])^:=Color shr 8;
              if bpp=4 then p[x+3]:=Color shr 24;
            end;
            inc(x,hdir);
          end;
        end;
      until(abs(x-a)=Header.Width*bpp);
 else for j:=0 to Header.Width-1 do
      begin
        Color:=GetColor(fs);
        p[x]:=Color;
        if bpp>1
        then begin
          pword(@p[x+1])^:=Color shr 8;
          if bpp=4 then p[x+3]:=Color shr 24;
        end;
        inc(x,hdir);
      end;
 end; //case
 y:=y+vdir;
end;
 if(Version=3)and(ExtArea.PostageStampOffset<>0)
 then begin
   fs.Seek(ExtArea.PostageStampOffset,soFromBeginning);
   ReadPostageStamp(fs);
 end;
 fs.Free;
end;

function TTga.ReadInfo(fs:TMemoryStream):Boolean;
var i:integer;
begin
  Result:=true;
 try
  fs.Seek(fs.Size-26,soFromBeginning);
  fs.Read(Footer,26);
  if ArrayToString(@(Footer.Signature_[0]))='TRUEVISION-XFILE.'
  then
    if(Footer.ExtensionAreaOffset<>0)
    then begin
      fs.Seek(Footer.ExtensionAreaOffset,soFromBeginning);
      fs.Read(ExtArea,495);
      if(ExtArea.ExtensionSize=495)
      then with ExtArea do begin
        Version:=3;
        FInfo.Add('Date: '+IntToStr(Day)+'/'+IntToStr(Month)+'/'+IntToStr(Year));
        FInfo.Add('Time: '+IntToStr(Hour)+':'+IntToStr(Minute)+':'+IntToStr(Second));
        FInfo.Add('JobName: '+ArrayToString(@JobName));
        FInfo.Add('Author: '+ArrayToString(@AuthorName));
        for i:=0 to 3 do
         FInfo.Add(ArrayToString(@(AuthorComments[i])));
      end
      else Version:=1;
    end
    else Version:=2
  else Version:=1;
  if Version=1
  then FInfo.Add('TGA v.1')
  else FInfo.Add('TGA v.2');
  fs.Seek(0,soFromBeginning);
  fs.Read(Header,18); { Заголовок }
  SetLength(ImageID,Header.IDLength+1);
  if(Header.IDLength>0)
  then fs.Read(ImageID[0],Header.IDLength);
  ImageID[Header.IDLength]:=#0;
  ColorMapOffset:=fs.Position;
  ImageOffset:=ColorMapOffset+
    ((Header.ColorMapEntrySize+1)shr 3)*Header.ColorMapLength;
  if Version=2
  then ImageSize:=fs.Size-ImageOffset
  else
    if(Footer.DeveloperDirectoryOffset<>0)
    then ImageSize:=Footer.DeveloperDirectoryOffset-ImageOffset
    else
      if(Footer.ExtensionAreaOffset<>0)
      then ImageSize:=Footer.ExtensionAreaOffset-ImageOffset
      else ImageSize:=fs.Size-ImageOffset-26;
  except on EInOutError do
     Result:=False;
 end; //try
end;

procedure TTga.ReadPalette(fs:TMemoryStream);
var
 k,w:word;
 P:pbytearray;
 hpal:HPALETTE;
 pal:PLogPalette;
begin
  w:=(Header.ColorMapEntrySize+1)shr 3;
  k:=w*Header.ColorMapLength;
  GetMem(p,k);
  fs.Seek(18+Header.IDLength,soFromBeginning);{ Пропустить заголовок и Image ID}
  if(Header.ColorMapType=1)
  then fs.Read(p[0],k)
  else if not(Header.ImageType in[3,11])then exit;
  pal:=nil;
  try
   GetMem(pal,sizeof(TLogPalette)+sizeof(TPaletteEntry)*255);
   pal.palVersion:=$300;
   pal.palNumEntries:=256;
   if Header.ImageType in[3,11] //Grayscale
   then
    for k:=0 to 255 do with pal.palPalEntry[k]do
    begin
     peRed:=k; peGreen:=k; peBlue:=k;
     peFlags:=PC_NOCOLLAPSE; //используем все 256 цветов
    end
   else if w>2
   then
    for k:=0 to Header.ColorMapLength-1 do with pal.palPalEntry[k]do
    begin
     peRed:=p[k*w+2];
     peGreen:=p[k*w+1];
     peBlue:=p[k*w];
     peFlags:=PC_NOCOLLAPSE;
    end
   else
    for k:=0 to Header.ColorMapLength-1 do with pal.palPalEntry[k]do
    begin
     w:=pwordarray(p)[k];
     peRed:=(w and $fc00)shr 8;
     peGreen:=(w and $07e0)shr 3;
     peBlue:=(w and $3e)shl 2;
     peFlags:=PC_NOCOLLAPSE;
    end;
   hpal:=CreatePalette(pal^);
   if hpal<>0 then Palette:=hpal;
  finally
   FreeMem(pal);
   FreeMem(p);
  end;
end;

function TTga.GetColor(fs:TMemoryStream):TColor;
var
  C:Word;
  R,G,B,A:DWORD;
begin
  Case Header.PixelDepth of
    8: fs.Read(Result,1);
 15,16:begin
        fs.Read(C,2);
        Result:=RGB((C and $001F)shl 3,(C and $03E0)shr 2,(C and $7C00)shr 7);
      end;
    24:begin
        fs.Read(R,1);
        fs.Read(G,1);
        fs.Read(B,1);
        Result:=RGB(R,G,B);
      end;
    32:begin
        fs.Read(R,1);
        fs.Read(G,1);
        fs.Read(B,1);
        fs.Read(A,1);
        Result:=RGB(R,G,B)+(A shl 24);
      end;
    else Result:=0;
  end;
end;

procedure TTga.ReadPostageStamp(fs:TMemoryStream);
Var
  i,j,hdir,vdir,y,a:Integer;
  p:^TColor;
  p8:Pbyte;
begin
  fs.Seek(ExtArea.PostageStampOffset,soFromBeginning);
  fs.Read(psWidth,1);
  fs.Read(psHeight,1);
  psData:=TBitmap.Create;
  psData.PixelFormat:=pixelformat;
  psData.Palette:=Palette;
  psData.Height:=psHeight;
  psData.Width:=psWidth;
  a:=psWidth-1;hdir:=-1;
  if(Header.ImageDescriptor and $10)=0
  then begin
    a:=0;hdir:=1;
  end;
  y:=0;vdir:=1;
  if(Header.ImageDescriptor and $20)=0
  then begin
    y:=psHeight-1;vdir:=-1;
  end;
 if pixelformat=pf8bit
 then
  for i:=0 to psHeight-1 do
  begin
    p8:=psData.ScanLine[y];
    inc(p8,a);
    for j:=0 to psWidth-1 do
    begin
      p8^:=GetColor(fs);
      inc(p8,hdir);
    end;
    y:=y+vdir;
  end
 else
  for i:=0 to psHeight-1 do
  begin
    p:=psData.ScanLine[y];
    inc(p,a);
    for j:=0 to psWidth-1 do
    begin
      p^:=GetColor(fs);
      inc(p,hdir);
    end;
    y:=y+vdir;
  end;
end;

procedure TTga.SaveToFile(FN:string);
var
  New_F:file;
  da:TDateTime;
  m:word;
begin
  if view
  then begin
   fmInfo.imStamp.Visible:=false;
   fmInfo.meInfo.Visible:=false;
   fmInfo.ShowModal;
   fmInfo.meInfo.Visible:=true;
   With ExtArea do
   begin
    StrToFixArray(fmInfo.edAuthor.Text,@AuthorName,41);
    StrToFixArray(fmInfo.Edit1.Text,@(AuthorComments[0]),81);
    StrToFixArray(fmInfo.Edit2.Text,@(AuthorComments[1]),81);
    StrToFixArray(fmInfo.Edit3.Text,@(AuthorComments[2]),81);
    StrToFixArray(fmInfo.Edit4.Text,@(AuthorComments[3]),81);
    da:=Now;
    DecodeDate(da,Year,Month,Day);
    DecodeTime(da,Hour,Minute,Second,m);
    StrToFixArray(fmInfo.edJobName.Text,@JobName,41);
   end;
   Version:=StrToInt(fmInfo.boxVersion.Text)*2-1;
   psWidth:=ord(fmInfo.cbStamp.Checked);
   psHeight:=psWidth;
   if fmInfo.modalresult=mrCancel then exit;
  end;
  AssignFile(New_F,'$$$.tga');
  Rewrite(New_F,1);
  //Новый заголовок
  with Header do
  begin
    IDLength:=0;
    if pixelformat=pf8bit
    then ColorMapType:=1
    else ColorMapType:=0;
    ImageType:=2-ColorMapType;
// Color Map Specification
    FirstEntryIndex:=0;
    ColorMapLength:=256*ColorMapType;
    ColorMapEntrySize:=24*ColorMapType;
// Image Specification
    XOrigin:=0;
    YOrigin:=0;
    case pixelformat of
     pf8bit:PixelDepth:=8;
     pf24bit:PixelDepth:=24;
     else PixelDepth:=32;
    end;
    ImageDescriptor:=0;
  end;
  Header.Height:=Height;
  Header.Width:=Width;
  BlockWrite(New_F,Header,18);
  SaveImage(New_F);

  Footer.ExtensionAreaOffset:=0;
  if version=3
  then begin
   if psWidth>0
   then begin
    ExtArea.PostageStampOffset:=FilePos(New_F);
    SavePostageStamp(New_F);
   end;
   Footer.ExtensionAreaOffset:=FilePos(New_F);
   BlockWrite(New_F,ExtArea,495);
  end;
  Footer.DeveloperDirectoryOffset:=0;
  Footer.Signature_:='TRUEVISION-XFILE.';
  Footer.Signature_[17]:=#0;
  if version>1 then BlockWrite(New_F,Footer,26);
  CloseFile(New_F);
  DeleteFile(FN);
  Rename(New_F,FN);
end;

procedure TTga.SaveImage(var F:File);
var
  p:pbyte;
  i,j:Word;
  pal:Pointer;
begin //SaveImage
  Buffer:=TBuffer.Create(F,$400);
  if Header.ImageType and 7=1
  then begin
      //Сохранить палитру
      PixelFormat:=pf8bit;
      GetMem(pal,sizeof(TPaletteEntry)*256);
      GetPaletteEntries(Palette,0,256,pal^);
      p:=pal;
      for i:=0 to 255 do
      begin
        Buffer.PutByte(pbytearray(p)[2]); //blue
        Buffer.PutByte(pbytearray(p)[1]); //green
        Buffer.PutByte(p^); //red
        inc(p,4);
      end;
      FreeMem(pal);
    end;
  for i:=Height-1 downto 0 do
  begin
    p:=ScanLine[i];
    if Header.ImageType=1
    then//Color Mapped
      for j:=0 to Width-1 do
        Buffer.PutByte(pbytearray(p)[j])
    else
      for j:=0 to Width-1 do
      begin
        Buffer.PutByte(p^);//Alfa Channel
        Buffer.PutByte(pbytearray(p)[1]);//Blue
        Buffer.PutByte(pbytearray(p)[2]); inc(p,3);//Green
        if pixelformat=pf32bit
          then begin
            Buffer.PutByte(p^);inc(p);
          end;
      end; //for j
  end; //for i
  Buffer.Flush;
  Buffer.Free;
end;

procedure TTga.SavePostageStamp(var F:File);
var
  p:pbyte;
  i,j,x:Word;
begin //SaveImage
  Buffer:=TBuffer.Create(F,$400);
  psWidth:=64;
  psHeight:=64;
  psData:=TBitmap.Create;
  psData.Width:=64;
  psData.Height:=64;
  psData.PixelFormat:=pixelformat;
  psData.Palette:=Palette;
  for i:=0 to 63 do
  begin
   x:=(i*Width)div 64;
   for j:=0 to 63 do
     psData.Canvas.Pixels[i,j]:=Canvas.Pixels[x,(j*Height)div 64]
  end;
  Buffer.PutByte(psWidth);
  Buffer.PutByte(psHeight);
  for i:=psHeight-1 downto 0 do
  begin
    p:=psData.ScanLine[i];
    if Header.ImageType=1
    then//Color Mapped
      for j:=0 to psWidth-1 do
        Buffer.PutByte(pbytearray(p)[j])
    else
      for j:=0 to psWidth-1 do
      begin
        Buffer.PutByte(p^);//Alfa Channel
        Buffer.PutByte(pbytearray(p)[1]);//Blue
        Buffer.PutByte(pbytearray(p)[2]); inc(p,3);//Green
        if pixelformat=pf32bit
          then begin
            Buffer.PutByte(p^);inc(p);
          end;
      end; //for j
  end; //for i
  Buffer.Flush;
  Buffer.Free;
end;

{-- Методы класса TBuffer ----------------------}
Constructor TBuffer.Create(var F1:file; S:DWORD);
begin
  Size:=S;
  F:=@F1;
  GetMem(Buf,Size);
  Index:=1;
  p:=Buf;
end;

procedure TBuffer.PutByte(C:Byte);
begin
  p^:=C;
  inc(p);
  if(Index=Size)then SaveToFile
  else inc(Index);
end;

procedure TBuffer.SaveToFile;
begin
  BlockWrite(F^,Buf^,Index);
  Index:=1;
  p:=Buf;
end;

procedure TBuffer.Flush;
begin
  BlockWrite(F^,Buf^,Index-1);
  Index:=1;
  p:=Buf;
end;

Destructor TBuffer.Destroy;
begin
  FreeMem(Buf);
  inherited;
end;


{$R *.DFM}

procedure TfmInfo.FormDeactivate(Sender: TObject);
begin
 if meInfo.Visible then Close;
end;

procedure TfmInfo.btCancelClick(Sender: TObject);
begin
 modalresult:=mrCancel;
 if meInfo.Visible then Close;
end;

procedure TfmInfo.btOkDialogClick(Sender: TObject);
begin
 modalresult:=mrOk;
 if meInfo.Visible then Close;
end;

initialization
  {Регистрация расширений формата PNG}
  TPicture.RegisterFileFormat('PNG', 'PNG Image File', TPNG);
  {Регистрация расширений формата Targa}
  TPicture.RegisterFileFormat('TGA', 'Targa Image File', TTga);
  TPicture.RegisterFileFormat('WIN', 'Targa Image File', TTga);
  TPicture.RegisterFileFormat('VST', 'Targa Image File', TTga);
  TPicture.RegisterFileFormat('VDA', 'Targa Image File', TTga);
  TPicture.RegisterFileFormat('ICB', 'Targa Image File', TTga);
finalization
  {Снятие регистрации расширений формата PNG}
  TPicture.UnRegisterGraphicClass(TPNG);
  {Снятие регистрации расширений формата Targa}
  TPicture.UnRegisterGraphicClass(TTga);
end.
