[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]

    {
    As I follow this forum, many requests are made for PCX graphics
    file routines. Those that are looking for Read_PCX info can
    find it on the ZSoft BBS in a wonderful Pascal example: ShowPCX.

    On the other hand, there is next to zilch out there on how to
    Write_PCX files. I know.... I searched and searched and couldn't
    find a thing! So with a little brute force  and a few ZSoft
    C language snippets <groan>, I got this together:

    PCX_W.Write_PCX (Name:Str80);
    given to the public domain and commonweal.
    pseudocode:
               set 640x480x16 VGAhi graphics mode only for now
               getimage 1 row at a time
               reorganize the BGI color planes into PCX format order
               encode the raw PCX line into a run length limited
                 compressed PCX line
               blockwrite the compressed PCX line to your.PCX file
    }

    {$R-}    {Range checking, turn off when debugged}

    unit PCX_W;

    { --------------------- Interface ----------------- }

    interface

    type
        Str80 = string [80];

    procedure Write_PCX  (Name:Str80);

    { ===================== Implementation ============ }

    implementation

    uses
        Graph;

    {-------------- Write_PCX --------------}

    procedure Write_PCX (Name:Str80);

    const
         RED1   = 0;
         GREEN1 = 1;
         BLUE1  = 2;

    type
        ArrayPal   = array [0..15, RED1..BLUE1] of byte;

    const
         MAX_WIDTH  = 4000;    { arbitrary - maximum width (in bytes) of
                                 a PCX image }
         INTENSTART =   $5;
         BLUESTART  =  $55;
         GREENSTART =  $A5;
         REDSTART   =  $F5;

    type
        Pcx_Header = record
        {comments from ZSoft ShowPCX pascal example}

            Manufacturer: byte;     { Always 10 for PCX file }

            Version: byte;          { 2 - old PCX - no palette (not used
                                          anymore),
                                      3 - no palette,
                                      4 - Microsoft Windows - no palette
                                          (only in old files, new Windows
                                          version uses 3),
                                      5 - with palette }

            Encoding: byte;         { 1 is PCX, it is possible that we may
                                      add additional encoding methods in the
                                      future }

            Bits_per_pixel: byte;   { Number of bits to represent a pixel
                                      (per plane) - 1, 2, 4, or 8 }

            Xmin: integer;          { Image window dimensions (inclusive) }
            Ymin: integer;          { Xmin, Ymin are usually zero (not always)}
            Xmax: integer;
            Ymax: integer;

            Hdpi: integer;          { Resolution of image (dots per inch) }
            Vdpi: integer;          { Set to scanner resolution - 300 is
                                      default }

            ColorMap: ArrayPal;
                                    { RGB palette data (16 colors or less)
                                      256 color palette is appended to end
                                      of file }

            Reserved: byte;         { (used to contain video mode)
                                      now it is ignored - just set to zero }

            Nplanes: byte;          { Number of planes }

            Bytes_per_line_per_plane: integer;   { Number of bytes to
                                                   allocate for a scanline
                                                   plane. MUST be an an EVEN
                                                   number! Do NOT calculate
                                                   from Xmax-Xmin! }

            PaletteInfo: integer;   { 1 = black & white or color image,
                                      2 = grayscale image - ignored in PB4,
                                          PB4+ palette must also be set to
                                          shades of gray! }

            HscreenSize: integer;   { added for PC Paintbrush IV Plus
                                      ver 1.0,  }
            VscreenSize: integer;   { PC Paintbrush IV ver 1.02 (and later)}
                                    { I know it is tempting to use these
                                      fields to determine what video mode
                                      should be used to display the image
                                      - but it is NOT recommended since the
                                      fields will probably just contain
                                      garbage. It is better to have the
                                      user install for the graphics mode he
                                      wants to use... }

            Filler: array [74..127] of byte;     { Just set to zeros }
        end;

        Array80    = array [1..80]        of byte;
        ArrayLnImg = array [1..326]       of byte; { 6 extra bytes at
         beginng of line that BGI uses for size info}
        Line_Array = array [0..MAX_WIDTH] of byte;
        ArrayLnPCX = array [1..4]         of Array80;

    var
       PCXName   : File;
       Header    : Pcx_Header;                 { PCX file header }
       ImgLn     : ArrayLnImg;
       PCXLn     : ArrayLnPCX;
       RedLn,
       BlueLn,
       GreenLn,
       IntenLn   : Array80;
       Img       : pointer;

    {-------------- BuildHeader- -----------}

    procedure BuildHeader;

    const
         PALETTEMAP: ArrayPal=
                     {  R    G    B                    }
                    (($00, $00, $00),  {  black        }
                     ($00, $00, $AA),  {  blue         }
                     ($00, $AA, $00),  {  green        }
                     ($00, $AA, $AA),  {  cyan         }
                     ($AA, $00, $00),  {  red          }
                     ($AA, $00, $AA),  {  magenta      }
                     ($AA, $55, $00),  {  brown        }
                     ($AA, $AA, $AA),  {  lightgray    }
                     ($55, $55, $55),  {  darkgray     }
                     ($55, $55, $FF),  {  lightblue    }
                     ($55, $FF, $55),  {  lightgreen   }
                     ($55, $FF, $FF),  {  lightcyan    }
                     ($FF, $55, $55),  {  lightred     }
                     ($FF, $55, $FF),  {  lightmagenta }
                     ($FF, $FF, $55),  {  yellow       }
                     ($FF, $FF, $FF) );{  white        }

    var
       i : word;

    begin
         with Header do
              begin
                   Manufacturer  := 10;
                   Version  := 5;
                   Encoding := 1;
                   Bits_per_pixel := 1;
                   Xmin := 0;
                   Ymin := 0;
                   Xmax := 639;
                   Ymax := 479;
                   Hdpi := 640;
                   Vdpi := 480;
                   ColorMap := PALETTEMAP;
                   Reserved := 0;
                   Nplanes  := 4; { Red, Green, Blue, Intensity }
                   Bytes_per_line_per_plane := 80;
                   PaletteInfo := 1;
                   HscreenSize := 0;
                   VscreenSize := 0;
                   for i := 74 to 127 do
                       Filler [i] := 0;
              end;
    end;

    {-------------- GetBGIPlane ------------}

    procedure GetBGIPlane (Start:word; var Plane:Array80);

    var
       i : word;

    begin
         for i:= 1 to Header.Bytes_per_line_per_plane do
             Plane [i] := ImgLn [Start +i -1]
    end;

    {-------------- BuildPCXPlane ----------}

    procedure BuildPCXPlane (Start:word; Plane:Array80);

    var
       i : word;

    begin
         for i := 1 to Header.Bytes_per_line_per_plane do
             PCXLn [Start] [i] := Plane [i];
    end;

    {-------------- EncPCXLine -------------}

    procedure EncPCXLine (PlaneLine : word); { Encode a PCX line }

    var
       This,
       Last,
       RunCount : byte;
       i,
       j        : word;

      {-------------- EncPut -----------------}

      procedure EncPut (Byt, Cnt :byte);

      const
           COMPRESS_NUM = $C0;  { this is the upper two bits that
                                  indicate a count }

      var
         Holder : byte;

      begin
      {$I-}
           if (Cnt = 1) and (COMPRESS_NUM <> (COMPRESS_NUM and Byt)) then
              blockwrite (PCXName, Byt,1)          { single occurance }
              {good place for file error handler!}
           else
               begin
                    Holder := (COMPRESS_NUM or Cnt);
                    blockwrite (PCXName, Holder, 1); { number of times the
                                                       following color
                                                       occurs }
                    blockwrite (PCXName, Byt, 1);
               end;
      {$I+}
      end;

    begin
         i := 1;         { used in PCXLn }
         RunCount := 1;
         Last := PCXLn [PlaneLine][i];
         for j := 1 to Header.Bytes_per_line_per_plane -1 do
             begin
                  inc (i);
                  This := PCXLn [PlaneLine][i];
                  if This = Last then
                     begin
                          inc (RunCount);
                          if RunCount = 63 then   { reached PCX run length
                                                    limited max yet? }
                             begin
                                  EncPut (Last, RunCount);
                                  RunCount := 0;
                             end;
                     end
                  else
                      begin
                           if RunCount >= 1 then
                              Encput (Last, RunCount);
                           Last := This;
                           RunCount := 1;
                      end;
             end;
         if RunCount >= 1 then  { any left over ? }
            Encput (Last, RunCount);
    end;

                { - - -W-R-I-T-E-_-P-C-X- - - - - - - - }

    const
         XMAX = 639;
         YMAX = 479;

    var
       i, j, Size : word;

    begin
         BuildHeader;
         assign     (PCXName,Name);
    {$I-}
         rewrite    (PCXName,1);
         blockwrite (PCXName,Header,sizeof (Header));
         {good place for file error handler!}
    {$I+}
         setviewport (0,0,XMAX,YMAX, ClipOn);
         Size := imagesize (0,0,XMAX,0); { size of a single row }
         getmem (Img,Size);

         for i := 0 to YMAX do
             begin
                  getimage (0,i,XMAX,i,Img^);  { Grab 1 line from the
                                                 screen store in Img
                                                 buffer  }
                  move (Img^,ImgLn,Size {326});

                  GetBGIPlane (INTENSTART, IntenLn);
                  GetBGIPlane (BLUESTART,  BlueLn );
                  GetBGIPlane (GREENSTART, GreenLn);
                  GetBGIPlane (REDSTART,   RedLn  );
                  BuildPCXPlane (1, RedLn  );
                  BuildPCXPlane (2, GreenLn);
                  BuildPCXPlane (3, BlueLn );
                  BuildPCXPlane (4, IntenLn); { 320 bytes/line
                                                uncompressed }
                  for j := 1 to Header.NPlanes do

                      EncPCXLine (j);
             end;
         freemem (Img,Size);           (* Release the memory        *)
    {$I-}
         close (PCXName);              (* Save the Image            *)
    {$I+}
    end;

    end {PCX.TPU} .

    { -----------------------Test Program -------------------------- }

    program WritePCX;

    uses
        Graph, PCX_W;

    {-------------- DrawHorizBars ----------}

    procedure DrawHorizBars;

    var
       i, Color : word;

    begin
         cleardevice;
         Color := 15;
         for i := 0 to 15 do
             begin
                  setfillstyle (solidfill,Color);
                  bar (0,i*30,639,i*30+30);       { 16*30 = 480 }
                  dec (Color);
             end;
    end;

    {-------------- Main -------------------}

    var
       NameW : Str80;
       Gd,
       Gm    : integer;

    begin
         writeln;
         if (ParamCount = 0) then           { no DOS command line
                                              parameters }
            begin
                 write ('Enter name of PCX picture file to write: ');
                 readln (NameW);
                 writeln;
            end
         else
             begin
                  NameW := paramstr (1);  { get filename from DOS
                                            command line }
             end;

         if (Pos ('.', NameW) = 0) then   { make sure the filename
                                            has PCX extension }
            NameW := Concat (NameW, '.pcx');

         Gd:=VGA;
         Gm:=VGAhi; {640x480, 16 colors}
         initgraph (Gd,Gm,'..\bgi');  { path to your EGAVGA.BGI }

         DrawHorizBars;

         readln;
         Write_PCX (NameW); { PCX_W.TPU }
         closegraph;                    { Close graphics    }
         textmode (co80);               { back to text mode }
    end.  { Write_PCX }

    {
    OK, everybody, I hope this gets you started. I had a lot of
    fun setting it up. There are some obvious places that need
    optimization... especially the disk intensive blockwrites. If
    someone could please figure out holding about 4k or so in pointers
    of the encoded PCX file before writing, I'd sure appreciate it!.
    (please post for everyone, if you do.)

    }

[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]