PC Media 23/PC MEDIA CD23.iso/share/prog/dclib500/pcxunit.pas

Pascal/Delphi Source File | 1993-12-20 | 10.6 KB | 627 lines

{$R-}    {Range checking off}
{$B-}    {Boolean complete evaluation off}
{$S-}    {Stack checking off}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}

unit PCXUNIT;

INTERFACE

uses
  Crt, Dos;

const
   MAX_WIDTH = 4000;
   COMPRESION_NUM = $C0;
   MAX_BLOCK = 4096;

   RED = 0;
   GREEN = 1;
   BLUE = 2;

   CGA4 = $04;
   CGA2 = $06;
   EGA  = $10;
   VGA  = $12;
   MCGA = $13;

type
   str80 = string [80];
   file_buffer = array [0..127] of byte;
   block_array = array [0..MAX_BLOCK] of byte;
   pal_array = array [0..255, RED..BLUE] of byte;
   ega_array = array [0..16] of byte;
   line_array = array [0..MAX_WIDTH] of byte;

   pcx_cabeza = record
        Manufacturer: byte;

        Version: byte;

        Encoding: byte;

        Bits_per_pixel: byte;

        Xmin: integer;
        Ymin: integer;
        Xmax: integer;
        Ymax: integer;

        Hdpi: integer;
        Vdpi: integer;

        ColorMap: array [0..15, RED..BLUE] of byte;

        Reserved: byte;

        Nplanes: byte;

        Bytes_per_line_per_plane: integer;

        PaletteInfo: integer;

        HscreenSize: integer;
        VscreenSize: integer;

        Filler: array [74..127] of byte;
        end;

var
   Name: str80;
   ImageName: str80;
   BlockFile: file;
   BlockData: block_array;

   Cabeza: pcx_cabeza;
   Palette256: pal_array;
   PaletteEGA: ega_array;
   PCXline: line_array;

   Ymax: integer;
   NextByte: integer;
   Index: integer;
   Data: byte;

   PictureMode: integer;
   Reg: Registers;


   PROCEDURE ERROR (S:STR80);
   PROCEDURE READERROR(MSG:INTEGER);
   PROCEDURE VIDEOMODE(N:INTEGER);
   PROCEDURE EGAPALETTE(N,R,G,B:INTEGER);
   PROCEDURE VGAPALETTE(N,R,G,B:INTEGER);
   PROCEDURE EGA16PALETTE;
   PROCEDURE VGA16PALETTE;
   PROCEDURE ENTIREVGAPALETTE;
   PROCEDURE SETPALETTE;
   PROCEDURE SHOWCGA(Y:INTEGER);
   PROCEDURE SHOWEGA(Y:INTEGER);
   PROCEDURE SHOWMCGA(Y:INTEGER);
   PROCEDURE READ256PALETTE;
   PROCEDURE READHEADER;
   PROCEDURE READBYTE;
   PROCEDURE READ_PCX_LINE;
   PROCEDURE READ_PCX (NAME:STR80);
   PROCEDURE DISPLAY_PCX(NAME:STR80);
   PROCEDURE VERPCX(NAME:STR80);

IMPLEMENTATION

procedure Error (s: str80 );

var c: char;
    i: integer;

begin
TextMode (C80);
writeln ('ERROR');
writeln (s);
halt;
end;


procedure ReadError (msg: integer);

begin
if IOresult <> 0 then
   case msg of
   1: Error ('No puedo abrir el fichero - ' + ImageName);
   2: Error ('Error cerrando fichero - ' + ImageName + ' - el disco debe de estar lleno');
   3: Error ('Error leyendo fichero - ' + ImageName);

   else
      Error ('Error haciendo I/O en fichero - ' + ImageName);
   end;
end;


procedure VideoMode (n: integer);


begin
Reg.ah := $00;
Reg.al := n;
intr ($10, Reg);
end;



procedure EGApalette (n, R, G, B: integer);

var i: integer;

begin
R := R shr 6;
G := G shr 6;
B := B shr 6;
i := (R shl 4) + (G shl 2) + B;

Reg.ah := $10;
Reg.al := 0;
Reg.bh := i;
Reg.bl := n;
intr ($10, Reg);
end;  { EGApalette }


procedure VGApalette (n, R, G, B: integer);

begin
R := R shr 2;
G := G shr 2;
B := B shr 2;

Reg.ah := $10;
Reg.al := $0;
Reg.bl := n;
Reg.bh := n;
intr ($10, Reg);

Reg.ah := $10;
Reg.al := $10;
Reg.bx := n;
Reg.dh := R;
Reg.ch := G;
Reg.cl := B;
intr ($10, Reg);
end;


procedure EGA16palette;

var
   i, r, g, b: integer;

begin
for i := 0 to 15 do
   begin
   r := Cabeza.ColorMap [i, RED]   shr 6;
   g := Cabeza.ColorMap [i, GREEN] shr 6;
   b := Cabeza.ColorMap [i, BLUE]  shr 6;
   PaletteEGA [i] := (r shl 4) + (g shl 2) + b;
   end;
PaletteEGA [16] := 0;

Reg.ah := $10;
Reg.al := $02;
Reg.dx := ofs (PaletteEGA);
Reg.es := seg (PaletteEGA);
intr ($10, Reg);

end;


procedure VGA16palette;

var
   i: integer;

begin
for i := 0 to 15 do
   PaletteEGA [i] := i;
PaletteEGA [16] := 0;

Reg.ah := $10;
Reg.al := $02;
Reg.dx := ofs (PaletteEGA);
Reg.es := seg (PaletteEGA);
intr ($10, Reg);

for i := 0 to 15 do
   begin
   Palette256 [i, RED]   := Cabeza.ColorMap [i, RED]   shr 2;
   Palette256 [i, GREEN] := Cabeza.ColorMap [i, GREEN] shr 2;
   Palette256 [i, BLUE]  := Cabeza.ColorMap [i, BLUE]  shr 2;
   end;

Reg.ah := $10;
Reg.al := $12;
Reg.bx := 0;
Reg.cx := 255;
Reg.dx := ofs (Palette256);
Reg.es := seg (Palette256);
intr ($10, Reg);

end;


procedure EntireVGApalette;

var
   i: integer;

begin
for i := 0 to 255 do
   begin
   Palette256 [i, RED]   := Palette256 [i, RED]   shr 2;
   Palette256 [i, GREEN] := Palette256 [i, GREEN] shr 2;
   Palette256 [i, BLUE]  := Palette256 [i, BLUE]  shr 2;
   end;

Reg.ah := $10;
Reg.al := $12;
Reg.bx := 0;
Reg.cx := 255;
Reg.dx := ofs (Palette256);
Reg.es := seg (Palette256);
intr ($10, Reg);

end;


procedure SetPalette;

var i: integer;

begin
if PictureMode = MCGA then
   EntireVGApalette
else if PictureMode = VGA then
   VGA16palette
else
   EGA16palette;
end;


procedure ShowCGA (Y: integer);

var
   i, j, l, m, t: integer;
   Yoffset: integer;
   CGAScreen: array [0..32000] of byte absolute $B800:$0000;

begin
i := 8 div Cabeza.Bits_per_pixel;

if (i = 8) then
   j := 7
else
   j := 3;

t := (Cabeza.Xmax - Cabeza.Xmin + 1);
m := t and j;

l := (t + j) div i;
if l > 80 then
   begin
   l := 80;
   m := 0;
   end;

if (m <> 0) then
   begin
   m := $FF shl (8 - (m * Cabeza.Bits_per_pixel));
   t := l - 1;
   PCXline [t] := PCXline [t] and m;
   end;

Yoffset := 8192 * (Y and 1);
Move (PCXline [0], CGAScreen [((Y shr 1) * 80) + Yoffset], l);

end;


procedure ShowEGA (Y: integer);


var
   i, j, l, m, t: integer;
   EGAplane: integer;
   EGAscreen: array [0..32000] of byte absolute $A000:$0000;

begin
EGAplane := $0100;
PortW [$3CE] := $0005;


t := (Cabeza.Xmax - Cabeza.Xmin + 1);
m := t and 7;

l := (t + 7) shr 3;
if (l >= 80) then
   begin
   l := 80;
   m := 0;
   end;

if (m <> 0) then
   m := $FF shl (8 - m)
else
   m := $FF;

for i := 0 to Cabeza.Nplanes-1 do
   begin
   j := i * Cabeza.Bytes_per_line_per_plane;
   t := j + l - 1;
   PCXline [t] := PCXline [t] and m;

   PortW [$3C4] := EGAplane + 2;
   Move (PCXline [j], EGAscreen [Y * 80], l);
   EGAplane := EGAplane shl 1;
   end;

PortW [$3C4] := $0F02;
end;


procedure ShowMCGA (Y: integer);


var
   l: integer;
   MCGAscreen: array [0..64000] of byte absolute $A000:$0000;

begin
l := Cabeza.XMax - Cabeza.Xmin;
if l > 320 then
   l := 320;

Move (PCXline [0], MCGAScreen [Y * 320], l);

end;


procedure Read256palette;


var
   i: integer;
   b: byte;

begin
seek (BlockFile, FileSize (BlockFile) - 769);
BlockRead (BlockFile, b, 1);
ReadError (3);

if b <> 12 then
   exit;

BlockRead (BlockFile, Palette256, 3*256);
ReadError (3);

seek (BlockFile, 128);

end;


procedure ReadHeader;

label WrongFormat;

begin
{$I-}
BlockRead (BlockFile, Cabeza, 128);
ReadError (3);


if (Cabeza.Manufacturer <> 10) or (Cabeza.Encoding <> 1) then
   begin
   close (BlockFile);
   Error ('Este fichero no es una imagen PCX válida.');
   end;

if (Cabeza.Nplanes = 4) and (Cabeza.Bits_per_pixel = 1) then
   begin
   if (Cabeza.Ymax - Cabeza.Ymin) <= 349 then
      begin
      PictureMode := EGA;
      Ymax := 349;
      end
   else
      begin
      PictureMode := VGA;
      Ymax := 479;
      end;
   end
else if (Cabeza.Nplanes = 1) then
   begin
   Ymax := 199;

   if (Cabeza.Bits_per_pixel = 1) then
      PictureMode := CGA2
   else if (Cabeza.Bits_per_pixel = 2) then
      PictureMode := CGA4
   else if (Cabeza.Bits_per_pixel = 8) then
      begin
      PictureMode := MCGA;
      if Cabeza.Version = 5 then
         Read256palette;
      end
   else
      goto WrongFormat;
   end
else
   begin
WrongFormat:
   close (BlockFile);
   Error ('Fichero PCX esta en un formato incorrecto - Requiere CGA, EGA, VGA, o MCGA');
   end;

Index := 0;
NextByte := MAX_BLOCK;

end;



procedure ReadByte;


var
   NumBlocksRead: integer;

begin
if NextByte = MAX_BLOCK then
   begin
   BlockRead (BlockFile, BlockData, MAX_BLOCK, NumBlocksRead);
   NextByte := 0;
   end;

data := BlockData [NextByte];
inc (NextByte);
end;  { ReadByte }



procedure Read_PCX_Line;

var
   count: integer;
   bytes_per_line: integer;

begin
{$I-}

bytes_per_line := Cabeza.Bytes_per_line_per_plane * Cabeza.Nplanes;

if Index <> 0 then
   FillChar (PCXline [0], Index, data);

while (Index < bytes_per_line) do
   begin
   ReadByte;

   if (data and $C0) = COMPRESION_NUM then
      begin
      count := data and $3F;
      ReadByte;
      FillChar (PCXline [Index], count, data);
      inc (Index, count);
      end
   else
      begin
      PCXline [Index] := data;
      inc (Index);
      end;
   end;

ReadError (3);

Index := Index - bytes_per_line;

{$I+}
end;


procedure Read_PCX (name: str80);

var
   k, kmax: integer;

begin
{$I-}
ImageName := name;

assign (BlockFile, name);
reset (BlockFile, 1);
ReadError (1);

ReadHeader;


VideoMode (PictureMode);
if Cabeza.Version = 5 then
   SetPalette;


kmax := Cabeza.Ymin + Ymax;
if Cabeza.Ymax < kmax then
   kmax := Cabeza.ymax;

if (PictureMode = EGA) or (PictureMode = VGA) then
   begin
   for k := Cabeza.Ymin to kmax do
      begin
      Read_PCX_Line;
      ShowEGA (k);
      end;
   end
else if (PictureMode = MCGA) then
   begin
   for k := Cabeza.Ymin to kmax do
      begin
      Read_PCX_Line;
      ShowMCGA (k);
      end;
   end
else
   begin
   for k := Cabeza.Ymin to kmax do
      begin
      Read_PCX_Line;
      ShowCGA (k);
      end;
    end;

close (BlockFile);
ReadError (2);
{$I+}
end;


procedure display_pcx (name: str80);

var
   c: char;

begin
Read_PCX (name);

while (not KeyPressed) do
   { nothing };

c := ReadKey;
if c = #0 then
   c := ReadKey;

end;


PROCEDURE VERPCX(NAME:STR80);
BEGIN
{ClrScr;
writeln ('   PCXUNIT - Adaptación de SHOW_PCX al formato Unit por David Carrero F-B.');
writeln ('         SHOW_PCX - leer y visualizar gráficos PC Paintbrush (R) ');
writeln;
writeln ('                            PERMISSION TO COPY:');
writeln ('            SHOW_PCX -- (C) Copyright 1989 ZSoft, Corporation.');
writeln;
writeln;
writeln (' Resevados todos los derechos por ZSoft Corporation de SHOW_PCX. ');
writeln (' ZSoft Corporation,  450 Franklin Road, Suite 100,  Marietta, GA 30067');
writeln (' [phone]');
writeln;}


if (Pos ('.', Name) = 0) then
   Name := Concat (Name, '.pcx');

display_pcx (Name);

TextMode (co80);

end;
END.