[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]