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

    {
    From: WILLIAM PLANKE
    Subj: Write PCX example 1/4

    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:
    }

    { =================== TPv6.0  P C X _ W ======================== }

    {$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 }

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