Pascal pcx256 Code Library

unit PCX256; { PCX256.PAS unit version 1.0 Reinout Raymakers 1997 }

{
  When I was looking for a screen-export routine in TP 7.0 that writes
  the picture in a wide-spread file format such as PCX, BMP or GIF, I could
  not find anything that was both understandably and bugfree...
  The only working routines contained assembler code, so that i could not
  change the routines to fit my purpose. I then decided to do it from scratch
  and here's the result (completely assembler-free and still quite fast):

  This unit reads and writes 256 color .PCX files. Keep the following things
  in mind:
           - Files are only written correctly if the computer is in 256 color
             mode using a .BGI file (e.g. SVGA256.BGI), because this unit
             uses the graph unit to read and write pixels.
             The routines also work in 16 color mode, but unless you carefully
             define your colors (SetRGBPalette procedure), the colors of
             the picture can turn out the wrong way......
           - The procedures do not check if files exist, or if the files you
             specify are indeed correct PCX files. You have to do that in
             the main program yourself. (You can use CheckPCX256 to do that.)
           - 'FileName' should always contain the extension of the file.

  You are free to use or change this unit in any way you like, but I would
  appreciate it, if you mailed me your suggestions / changes / bugs or
  anything else you want changed....

  P.S. Except for the SetVGAPalette, GetVGAPalette & FileExists routines, all
       the code is written by me. The FileExists routine is from the Help
       of Turbo Pascal. I don't remember where I got the other two routines,
       but hereby I want to thank the authors, because I'm really bad
       at low-level memory coding....

  Reinout Raymakers
  Nolensstraat 12
  5344 SK Oss
  The Netherlands
  reinoutr@sci.kun.nl

  RR, 18 May 1997

  Projects that I'm still working on: - True color (24 bit) PCX files unit
                                      - Export routines for GIF / BMP formats

}

interface

type Colorvalue     = Record
                        Rvalue,
                        Gvalue,
                        Bvalue : byte;
                      end;
     Palette16      = Array [0..15]  of Colorvalue;
     Palette256     = Array [0..255] of Colorvalue;

     PCXType = Object          { Header definition of .PCX file }
        ID,                    { Manufacturer, 10 = ZSoft }
        Version,               { Version, 5 = latest }
        Encoding,              { Compression, 1 = RLE }
        BPP           : Byte;  { Bits per pixel, 8 for 256 colors }
        Window        : Record { Original position and size of picture }
                          Left,               { X1 }
                          Top,                { Y1 }
                          Right,              { X2 }
                          Bottom   : Word     { Y2 }
                        End;
        HorRes,
        VerRes        : Word;  { Physical properties of picture, in DPI }
        Colors        : Palette16; { 16 color palette, unused at 256 colors }
        Reserved,             { Reserved Byte }
        NPlanes       : Byte; { Number of planes, 1 for 256 colors }
        BPL,                  { Bytes per horizontal line }
        Palette       : Word; { Greyscale or Color, 1 for Color (2 for Grayscale) }
        Filler        : Array[1..58] of Byte; { Reserved space }
      End;

procedure WritePCX256(FileName : String; X1, Y1, X2, Y2 : Word);

{ FileName is the name of the file you want to write the data to, X1, Y1, X2
  and X2 are the coordinates of the window your want to write to disk. }

procedure ReadPCX256(FileName : String; X, Y : Word);

{ FileName is the name of the file you want to read the data from. X and Y
  are the coordinates at which position you want the upper left corner of the
  picture.}

procedure InfoPCX(FileName : String; var Header : PCXType);

{ FileName is the name of the file you want info about. This procedure does
  nothing but give the header of the .PCX file in the variable Header. }

function CheckPCX256(FileName : String; var Error : Byte) : Boolean;

{ FileName is the name of the file of which you want to be sure that it is
  a correct 256 color .PCX file. CheckPCX256 returns TRUE if the file is
  indeed such a file. If NOT, it returns FALSE.
  'Error' contains more detailed information on what the problem is:

   0 - file is ok
   1 - file does not exist
   2 - file is not a PCX file
   3 - file is PCX, but not a 256 color file
   4 - file is 256 color PCX, but the data compression type is unknown
       (you can always try to read it anyway, it might be an error in the
        header, because for PCX only RLE is documented!)
}

implementation

uses Dos, MyUnit;

const BufferSize = 4096; { Size of the buffer for reading and writing files }

procedure GetVGAPalette(var Pal : Palette256);
var ColorNo : Byte;

begin
for ColorNo := 0 to 255 do
  begin
  Port [$3c7]         := ColorNo;
  Pal[ColorNo].RValue := Port [$3c9];
  Pal[ColorNo].GValue := Port [$3c9];
  Pal[ColorNo].BValue := Port [$3c9];
  end;
end; { GetVGAPalette }

procedure SetVGAPalette(var Pal : Palette256);
var Regs : Registers;

begin
with Regs do
  begin
  AX:=$1012;
  BX:=0;
  CX:=256;
  ES:=Seg(Pal); DX:=Ofs(Pal);
  end;
Intr($10,Regs);
end; { SetVGAPalette }

function FileExists(FileName: String): Boolean;
var
  F: File;

begin
{$I-}
Assign(F, FileName);
Reset(F);
Close(F);
{$I+}
FileExists := (IOResult = 0) and (FileName <> '');
end;  { FileExists }

procedure WritePCX256;
var Header  : PCXType;
    PCXFile : File;
    Pal256  : Palette256;

procedure OpenFile;
begin
Assign(PCXFile,FileName);
ReWrite(PCXFile,1);
end;

procedure WriteHeader;
begin
with Header do
  begin
  ID       := 10;
  Version  := 5;
  Encoding := 1;
  BPP      := 8;
  with Window do
    begin
    Left   := X1;
    Top    := Y1;
    Right  := X2;
    Bottom := Y2;
    end;
  HorRes   := 300; { Since a picture that is written from the screen has no  }
  VerRes   := 300; { physical size, 300 DPI is just a random chosen value... }
  NPlanes  := 1;
  BPL      := X2-X1+1;
{ If Odd(BPL) then Inc(BPL); } { Officially BPL should always be even, but
                                 after implementation, a lot of programs
                                 could not read the files anymore, and
                                 this solution does not seem to give any
                                 problems..... }
  Palette  := 1;
  end;
BlockWrite(PCXFile,Header,SizeOf(Header));
end;

procedure WriteData; { This procedure writes a RLE compressed picture. }
var X, Y    : Word;
    Buffer  : Array[0..BufferSize] of Byte;
    Count   : Word;
    CurColor,
    ByteCnt,
    Color   : Byte;

begin
For Y := Y1 to Y2 do
    begin
    Count := 0;
    ByteCnt := 0;
    For X := X1 to X2 do
      begin
      Color := GetPixel(X,Y);
      If X = X1 then           { just remember the first byte }
        begin
        CurColor := Color;
        ByteCnt  := 1;
        end
      else
        begin
        If (Color <> CurColor) OR (ByteCnt = 63) then  { write data if new color or more than 63 the same }
          begin
          If (ByteCnt <> 1) or (CurColor AND $C0 = $C0) then { write RLE code if necessary }
            begin
            Buffer[Count] := ByteCnt OR $C0;
            Inc(Count);
            end;
          Buffer[Count] := CurColor; { write color }
          Inc(Count);
          CurColor := Color;
          ByteCnt  := 1;
          end
        else
          begin
          Inc(ByteCnt);
          end;
        end;
      If X = X2 then { write buffer to file after last byte }
        begin
          Buffer[Count] := ByteCnt OR $C0;
          Inc(Count);
          Buffer[Count] := CurColor;
          Inc(Count);
          BlockWrite(PCXFile,Buffer,Count);
        end;
      end;
    end;
end;

procedure WritePalette;
Var Marker,
    Count   : Byte;
begin
Marker := 12;
GetVGAPalette(Pal256);
For Count := 0 to 255 do
    begin
    Pal256[Count].RValue := Pal256[Count].RValue * 4;
    Pal256[Count].BValue := Pal256[Count].BValue * 4;
    Pal256[Count].GValue := Pal256[Count].GValue * 4;
    end;
BlockWrite(PCXFile,Marker,SizeOf(Marker));
Blockwrite(PCXFile,Pal256,SizeOf(Pal256));
end;

procedure CloseFile;
begin
Close(PCXFile);
end;

begin
OpenFile;        { Create the new file }
WriteHeader;     { Create a correct header and write it to file }
WriteData;       { Compress data using RLE and write data to file }
WritePalette;    { Get current standard VGA palette, convert it to
                   a 16.7 Million color palette and write it to file }
CloseFile;       { And ready is your PCX! }
end; { WritePCX256 }

procedure ReadPCX256;
var Header  : PCXType;
    PCXFile : File;
    Pal256  : Palette256;
    X1, Y1  : Word;

procedure OpenFile;
begin
Assign(PCXFile,FileName);
Reset(PCXFile,1);
end;

procedure ReadHeader;
begin
BlockRead(PCXFile,Header,SizeOf(Header));
X1 := X;
Y1 := Y;
end;

procedure ReadPalette;
var Marker,
    Count  : Byte;

begin
Seek(PCXFile,FileSize(PCXFile) - 769);
BlockRead(PCXFile,Marker,SizeOf(Marker));
BlockRead(PCXFile,Pal256,SizeOf(Pal256));
For Count := 0 to 255 do
  begin
  Pal256[Count].RValue := Pal256[Count].RValue DIV 4;
  Pal256[Count].BValue := Pal256[Count].BValue DIV 4;
  Pal256[Count].GValue := Pal256[Count].GValue DIV 4;
  end;
SetVGAPalette(Pal256);
end;

procedure ReadData;
var Buffer    : Array[0..BufferSize] of Byte;
    Count,
    Count2    : Word;
    Result    : Word;
    ByteCount : Byte;
    BeginX,
    BeginY    : Word;
    Finish    : Boolean;

begin
Seek(PCXFile,SizeOf(Header));
BeginY := Y;
BeginX := X;
Finish := FALSE;
repeat
BlockRead(PCXFile,Buffer,BufferSize,Result);
If Result < BufferSize then Finish := TRUE;
If FilePos(PCXFile) > FileSize(PCXFile) - 769 then
  begin
  Result := Result - (FilePos(PCXFile) - (FileSize(PCXFile) - 769));
  Finish := TRUE;
  end;
For Count := 0 to Result - 1 do
  begin
  If Buffer[Count] AND $C0 = $C0 then { check if byte is a RLE code }
    begin
    If Count = Result - 1 then
      begin
      Seek(PCXFile,FilePos(PCXFile)-1); { check if we've got the color for that RLE }
      end
    else
      begin
      ByteCount := Buffer[Count] - $C0;
      Inc(Count);
      For Count2 := 1 to ByteCount do { write the number of pixels as stored in the RLE }
        begin
        If BeginX - X <= Header.Window.Right - Header.Window.Left { don't run of the screen }
          then PutPixel(BeginX,BeginY,Buffer[Count]);
        Inc(BeginX);
        If BeginX >= (X + Header.BPL) then { do we have to go to the next line? }
          begin
          Inc(BeginY);
          BeginX := X;
          end;
        end;
      end;
    end
  else
    begin
    If BeginX - X <= Header.Window.Right - Header.Window.Left  { identical to the above, but now we only write one pixel }
      then PutPixel(BeginX,BeginY,Buffer[Count]);
    Inc(BeginX);
    If BeginX >= (X + Header.BPL) then
      begin
      Inc(BeginY);
      BeginX := X;
      end;
    end;
  end;
until Finish;
end;

procedure CloseFile;
begin
Close(PCXFile);
end;

begin
OpenFile;      { Open the PCX file }
ReadHeader;    { Read the header from the file }
ReadPalette;   { Read the 16.7 Million color palette from the file,
                 convert it to standard VGA and apply it }
ReadData;      { Read data from file, decompress and put picture on screen }
CloseFile;     { Close the file }
end; { ReadPCX256 }

procedure InfoPCX;
var PCXFile : File;

begin
Assign(PCXFile,FileName);
Reset(PCXFile,1);
BlockRead(PCXFile,Header,SizeOf(Header));
Close(PCXFile);
end; { InfoPCX }

function CheckPCX256;
var Header  : PCXType;
    PCXFile : File;
    Result  : Word;
    Marker  : Byte;

begin
CheckPCX256 := TRUE;
Error       := 0;
If not FileExists(FileName) then
  begin
  CheckPCX256 := FALSE;
  Error       := 1;
  end
else
  begin
  Assign(PCXFile,FileName);
  Reset(PCXFile,1);
  BlockRead(PCXFile,Header,SizeOf(Header),Result);
  Seek(PCXFile,FileSize(PCXFile) - 769);
  BlockRead(PCXFile,Marker,SizeOf(Marker),Result);
  Close(PCXFile);
  If Header.ID <> 10 then
    begin
    CheckPCX256 := FALSE;
    Error       := 2;
    end
  else
    begin
    If (Marker <> 12) or (Header.BPP <> 8) or (Header.NPlanes <> 1) then
      begin
      CheckPCX256 := FALSE;
      Error       := 3;
      end;
    If (Error = 0) and (Header.Encoding <> 1) then
      begin
      CheckPCX256 := FALSE;
      Error       := 4;
      end;
    end;
  end;
end; { CheckPCX256 }

end.