{***************************************************************************}
{* NicePCX * Fast (and correct) Load&Save 320*200/256 PCXs by Nikola Injac *}
{***************************************************************************}
{* No filelength (65535) Restrictions * GraphInit * BGI Drivers not needed *}
{***************************************************************************}

UNIT NICEPCX;
INTERFACE
TYPE TPal= ARRAY[0..768] OF Byte;

VAR  Pal        : TPal;
     Head       : ARRAY[0..127] OF Byte;
     SwapPicPtr : Pointer;

PROCEDURE LoadPCX(Filename: String);
PROCEDURE SavePCX(FileName: String);
{-----------------------------------}
PROCEDURE LoadPCXTo(Filename: String; Where:Word);
PROCEDURE SetColor(Nr,R,G,B:Byte);
PROCEDURE GetColor(Nr:Byte; VAR R,G,B:Byte);
PROCEDURE SetPCXPal(Pal: TPal);
PROCEDURE SetPal(Pal: TPal);
PROCEDURE GetPic;
PROCEDURE PutPic;
PROCEDURE Fault(Out:String);

IMPLEMENTATION
{---------------------------------------------------------------------------}
PROCEDURE Fault(Out:String);
BEGIN
  ASM mov ax,3;int 10h; END;
  WriteLn('Error! '+Out);
  Halt;
end;
{---------------------------------------------------------------------------}
PROCEDURE SetColor(Nr,R,G,B:Byte);
BEGIN
  Port[$3C8]:=Nr;
  Port[$3C9]:=R;
  Port[$3C9]:=G;
  Port[$3C9]:=B;
END;
{---------------------------------------------------------------------------}
PROCEDURE GetColor(Nr:Byte; VAR R,G,B:Byte);
BEGIN
  Port[$3C7]:=Nr;
  R:=Port[$3C9];
  G:=Port[$3C9];
  B:=Port[$3C9];
END;
{---------------------------------------------------------------------------}
PROCEDURE SetPCXPal;
var i: Integer;
BEGIN
  FOR i:=0 TO 255 DO
    SetColor(i,pal[i*3] SHR 2,pal[i*3+1] SHR 2,pal[i*3+2] SHR 2);
END;
{---------------------------------------------------------------------------}
PROCEDURE SetPal;
var i: Integer;
BEGIN
  FOR i:=0 TO 255 DO
    SetColor(i,pal[i*3],pal[i*3+1],pal[i*3+2]);
END;

PROCEDURE GetPic;
BEGIN
  IF SwapPicPtr=NIL THEN
    GetMem (SwapPicPtr,65535);
  Move(Ptr($a000,0)^,SwapPicPtr^,64000);
  Move(Pal,Ptr(Seg(SwapPicPtr^),64000)^,768);
END;

PROCEDURE PutPic;
BEGIN
  IF SwapPicPtr<>NIL THEN BEGIN
    Move(SwapPicPtr^,Ptr($a000,0)^,64000);
    Move(Ptr(Seg(SwapPicPtr^),64000)^,Pal,768);
    SetPal(Pal);
  END;
END;

{***************************************************************************}
{* LOAD PART
{***************************************************************************}

FUNCTION DecodeBody(Body:Pointer;Where,Length,Offse:Word):WORD;
VAR Result:WORD;
BEGIN
ASM
    push ds
    mov  dx,Length
    mov  ax,Where
    mov  es,ax
    mov  di,[Offse]
    xor  cx,cx
    lds  si,Body
    add  dx,si
    mov  bx,0c0h*256+03fh
  @GetNextByte:
    lodsb
    mov     ah,al
    and     al,bh
    cmp     al,bh
    mov     al,ah
    jnz     @SinglePixel
    and     ah,bl
    mov     cl,ah
    lodsb
    jmp     @Encoded
  @SinglePixel:
    inc     cl
  @Encoded:
    rep     stosb
    cmp     di,64000
    jae      @Exit
    cmp     si,dx
    jne     @GetNextByte
  @Exit:
    pop  ds
    mov     Result,di
  END;
  DecodeBody:=Result;
END;
{---------------------------------------------------------------------------}

PROCEDURE LoadPCXTo(Filename:String; Where:Word);
VAR F     : File;
    Res,i : Word;
    Temp  : Pointer;
    Offs  : Word;
BEGIN
  Assign (f,Filename);
  {$I-} Reset (f,1); {$I+}
  IF IOResult<>0 THEN Fault('"'+Filename+'" not found.');
  BlockRead(f,Head,128);
  IF (Head[0]<>10) OR (Head[3]<>8) OR (Head[65]<>1)
    THEN Fault('Only 320x200/256 PCX Files.');
  Seek(f,FileSize(f)-768);
  BlockRead(f,Pal,768);
  FOR i:=0 TO 767 DO Pal[i]:=Pal[i] SHR 2;
  SetPal(Pal);
  Seek(f,128);
  GetMem (Temp,65535);
  FillChar(Temp^, 50000, #0);
  BlockRead (f,Temp^,50000,Res);
  i:=49999; {This is the dirty part. PCX is a VERY funny format!!!}
  WHILE (Mem[Seg(Temp^):i] AND 192=192) DO BEGIN
    DEC(Res);
    DEC(i);
  END;
  Offs:=DecodeBody(Temp,$a000,Res,0);
  IF Offs<64000 THEN BEGIN
    Seek(f,128+Res);
    BlockRead (f,Temp^,65535,Res);
    Offs:=DecodeBody(Temp,$a000,Res,Offs);
  END;
  FreeMem (Temp,65535); {End of the DIRTY part.}
  Close (f);
end;

PROCEDURE LoadPCX(Filename:String);
Begin
  asm mov ax,$13;int 10h; end;
  LoadPCXTo(Filename,$0a000);
End;

{***************************************************************************}
{* SAVE PART
{***************************************************************************}

Procedure SavePCX(FileName : String);
Var F : File;

Procedure WriteHeader;
CONST
  HPart1: Array [1..16] of Byte=(10,5,1,8,1,0,1,0,64,1,200,0,187,4,187,4);
  HPart2: Array [1..4]  of Byte=(1,64,1,1);
VAR i : Integer;
Begin
  FillChar(Head, 128, #0);
  Move(HPart1,Head,16);
  Move(HPart2,Head[65],4);
  BlockWrite(F,Head,128);
End;

{---------------------------------------------------------------------------}
PROCEDURE EncodeBody;
VAR i:Word;

Procedure EncodeLine(LineNr:Word);
VAR
  RepCnt   : Word;
  PixOffs  : Word;
  LineEnd  : Word;
  WrCnt    : Word;
  WrByte   : Byte;
  PixNow   : Byte;
  Wr       : ARRAY[0..640] OF Byte;

BEGIN
  PixOffs:=LineNr*320;
  LineEnd:=PixOffs+320;
  WrCnt:=0;
  WHILE PixOffs < LineEnd DO
  BEGIN
    RepCnt:=1;
    PixNow:=Mem[$a000:PixOffs];
    WHILE (Mem[$a000:PixOffs+RepCnt]=PixNow) AND
          ((PixOffs+RepCnt)<LineEnd) AND (RepCnt<63) DO INC(RepCnt);
    IF RepCnt>1 THEN
    BEGIN
      WrByte    := RepCnt OR 192;
      Wr[WrCnt] := WrByte; Inc(WrCnt);
      Wr[WrCnt] := PixNow; Inc(WrCnt);
      Inc(PixOffs,RepCnt);
    END
    ELSE BEGIN
      IF (PixNow AND 192)=192 THEN
      BEGIN
        WrByte    := 193;
        Wr[WrCnt] := WrByte; Inc(WrCnt);
      END;
      Wr[WrCnt]:= PixNow; Inc(WrCnt);
      INC(PixOffs);
    END;
  END;
  BlockWrite(F,Wr,WrCnt);
END;

BEGIN
  For i:= 0 to 199 Do EncodeLine(i);
END;
{---------------------------------------------------------------------------}
PROCEDURE WritePal;
Var i,R,G,B : Byte;
Begin
  Pal[0]:=12;
  For i:=0 TO 255 DO
  Begin
    GetColor(i,R,G,B);
    Pal[i*3+1] :=R SHL 2;
    Pal[i*3+2] :=G SHL 2;
    Pal[i*3+3] :=B SHL 2;
  End;
  BlockWrite(F,Pal,769);
End;
{---------------------------------------------------------------------------}
BEGIN
  Assign(F,FileName);
  {$I-} Rewrite (F,1); {$I+}
  IF IOResult<>0 THEN Fault('"'+Filename+'" could not be written.');
  WriteHeader;
  EncodeBody;
  WritePal;
  Close(F);
End;
{---------------------------------------------------------------------------}
BEGIN
  SwapPicPtr:=NIL;
END.