unit pcx;

                               interface

uses vesatype,vesa256,err,xmslib;

type
{+ обозначено - то что в ПРИНЦИПЕ можно проверять}

THeadPCX=record
 Manufact    : byte;{+}{0A}
 Version     : byte;{+}{5 - наш случай}
 Encoding    : byte;{+}{зашифрована или нет}
 BPP         : byte;{+}{Bit Per Pixel - мне лично не надо}
 Xmin,Ymin,
 Xmax,Ymax   : word;{+}{Размеры картинки}
 HDPI,VDPI   : word;   {Оригинальные размеры картинки, например до сканирования}
 ColorMap    : array[0..47] of byte;{палитра для 16ц режимов}
 Reserved    : byte;{пустота}
 NPlanes     : Byte;{+}{количество плоскостей - для 256ц =1, для 24bц = 3}
 BPL         : WORD;{+}{Bytes Per Line - сколько идет на одну линию, НЕ ВЫЧИСЛЯЕТСЯ (по документации) из Xmax-Xmin}
 PalInfo     : word;{+}{1 - цветная 2-grayscale}
 ResARR      : array[1..58] of byte;{пустота}
end;

PTPict=^TPict;
TPict=record
 header:THeadPCX;
 img:^TArray64k;
 pal:array[0..767] of byte;
end;


Function LoadPcx(filename:string):pointer;
Procedure DrawPict(pict:PTPict; xs,ys:word;ChangePal:boolean);


implementation

function LoadPcx(filename:string):pointer;
var
   f:file;
   buf:^Tarray64k;{нерасшифрованный буфер}
   i:word;{счетчик}
   res:word;{сколько прочитано}
   fsize:longint;{какой говорите размерчик?}
   pict:PTPict;

procedure decodebuf;
 var
    count:word;{счетчик позиции в расшифрованной картинке}
    m:word;{счетчик позиции в расшифрованной картинке}
    c:byte;{сколько копировать}
    l:word;{счетчик}

  begin
     m:=0;
     c:=0;
     count:=0;
  while (m<res) do
   begin

    if c<>0 then
    begin
    for l:=1 to c do
     begin
      pict^.img^[count]:=buf^[m];
      inc(count);
     end;
     c:=0;
    end else
    if (buf^[m] and $c0=$c0) then
    c:=buf^[m] and $3f else
    begin
     pict^.img^[count]:=buf^[m];
     inc(count);
    end;
    inc (m);
   end;
  end;

begin


if filename='' then begin error:=PCX_NONAME; OutErr; end;
assign(f,filename);
{$I-}
reset (f,1);
{$I+}
if IORESULT<>0 then  begin error:=PCX_InitFalse; OutErr;end;
fsize:=filesize(f);
new(pict);
blockread(f,pict^.header,128);

if pict^.header.manufact<>$A then begin writeln ('ERROR 3'); halt; end;
if pict^.header.version<5 then begin writeln ('ERROR 4'); halt; end;
if pict^.header.NPlanes<>1 then begin writeln ('ERROR 5'); halt; end;
if (pict^.header.Xmax-pict^.header.Xmin+1)*(pict^.header.Ymax-pict^.header.Ymin+1)>64000
 then begin writeln ('ERROR 6'); halt; end;

seek(f,fsize-768);
blockread(f,pict^.pal,768);

seek(f,128);
getmem(buf,65535);
getmem(pict^.img,(pict^.header.Xmax-pict^.header.Xmin+1)*(pict^.header.Ymax-pict^.header.Ymin+1));
blockread(f,buf^,fsize-128-769,res);
decodebuf;
freemem(buf,65535);
close(f);
LoadPCX:=pict;
end;

procedure DrawPict(pict:PTPict; xs,ys:word;ChangePal:boolean);
var
    x,y,ex,ey:word;
    m:word;
    i:integer;
begin
if not IsVesa then begin halt; end;
if changepal then begin
for i:=0 to 767 do pict^.pal[i]:=pict^.pal[i] shr 2;
setpal(addr(pict^.pal));
end;
   eX := pict^.header.xmax-pict^.header.xmin+1;
   ey := pict^.header.ymax-pict^.header.ymin+1;
   x:=0;y:=0;
   m:=0;
while (y<ey) do
begin
   VPutPixel(x+xs,y+ys,pict^.img^[m]);
   inc(m);
   Inc(x);
IF x >= eX THEN
  BEGIN
    x:=0;
    Inc(y)
  END
end;
end;
end.