DP Tool Club 21/CD_ASCQ_21_040595.iso/dos/prg/pas/pcxkit53/pcx.pas

Pascal/Delphi Source File | 1995-01-17 | 20KB | 681 lines

unit PCX;

(* {$DEFINE RegisteredVersion} *)

(* Requires Turbo/Borland Pascal for DOS, version 6 or later.

                                Version 5.1
                             Copyright (c) 1994
                             by Peter Donnelly
                              Skookum Software
                              1301 Ryan Street
                         Victoria BC Canada V8T 4Y8

   ╒══════════════════════════════════════════════════════════════════════╕
   │  Permission is granted for the non-commercial distribution and       │
   │  private use of this source code. This is shareware; if you use all  │
   │  or portions of it in programs you distribute, or make any other     │
   │  public use of it, you are expected to pay a modest registration     │
   │  fee. Registered users will receive the latest version of the code,  │
   │  including support for 256-color Super-VGA modes. Please see the     │
   │  READ.ME file for details.                                           │
   ╘══════════════════════════════════════════════════════════════════════╛
*)
INTERFACE

uses DOS, CRT;

CONST
        NoOptions = $0000;        { to set bits for Options }
        SaveMem =   $0001;
        HCenter =   $0002;
          VCenter =   $0004;
        BlackOut =  $0008;
        AutoSet = 0;              { can be passed to ReadIt }
        NumModes = 11;
        OurModes: array[1..NumModes] of word =
                  ($0D, $0E, $10, $12, $13, $100,
                   $101, $102, $103, $105, $107);
        ErrNoOpen = 1;
        ErrNoPal  = 2;
        ErrTooWide= 3;
        ErrColors = 4;
        ErrNoSupp = 5;


TYPE
        RGBrec = record
                   RedVal, GreenVal, BlueVal: byte;
                 end;

        RGB256Rec = array[0..255] of RGBRec;

        PCXHeaderRec = record
                         Signature: byte;
                         Version: byte;
                         Code: byte;
                         BitsPerPlane: byte;
                         XMin, YMin, XMax, YMax: word;
                         HRes, VRes: word;
                         Palette: array[0..15] of RGBRec;
                         Reserved: byte;
                         NumPlanes: byte;
                         BytesPerLine: word;
                         OtherStuff: array[69..128] of byte;
                       end;

        VESAInfoRec = record
                        Signature: array[0..3] of char;
                        Version: word;
                        OEMptr: pointer;
                        Capabilities: array[0..3] of byte;
                        ModePtr: pointer;
        { There are reports of some VESA BIOSes returning more than 256
          bytes from function 0, so this record is padded a bit. }
                        Reserved: array[0..256] of byte;
                      end;

        ModeInfoRec = record
                        Attributes: word;
                        WindowA_atts, windowB_atts: byte;
                        GranuleKb, WindowKb: word;
                        WindowAstart, WindowBstart: word;
                        FunctionAddr: pointer;
                        BytesPerLine: word;
                        XRes, YRes: word;
                        OtherStuff: array[23..256] of byte;
                      end;

VAR
        FileError: word;

FUNCTION DetectVESA(var VESAInf: VESAInfoRec): boolean;
FUNCTION DetectVGA: boolean;
FUNCTION HardwareSupports(Mode: word): boolean;
FUNCTION WeSupport(Mode: word): boolean;
FUNCTION GetMode: word;
PROCEDURE SetMode(Mode, Options: word);
PROCEDURE GetModeInfo(Mode: word; var ModeInfo: ModeInfoRec);
FUNCTION OpenFile(PicFileName: pathstr; var PicFile: file;
                  var Header: PCXHeaderRec): boolean;
PROCEDURE ReportError(Error: word; var ErrorStr: string);
FUNCTION ReadIt(PicFileName: pathstr; var Mode: word; Options: word): integer;

{========================================================================}

IMPLEMENTATION

CONST   MaxBufSize = 65024;

VAR
        BufferSize: word;
        PCXFilename: pathstr;
        PCXHeader: PCXHeaderRec;
        ModeInfo: ModeInfoRec;
        RGBpal: array[0..15] of RGBrec;
        RGB256: RGB256Rec;
        VESAInfo: VESAInfoRec;
        Regs: registers;
        WindowEnd: word;
        StartCol: word;
        ColumnCount: word;
        Plane: word;
        BytesPerLine: word;
        BytesPerScanLine: word;
        XMax: word;
        RepeatCount: byte;
        DataLength: word;
        WindowStep, WindowPos: word;
        WriteWindow: byte;
        VideoSeg, VideoOffs: word;
        Scratch, LineBuf: pointer;
        LineBufSeg, LineBufOffs: word;
        LineBufIndex: word;
        LineEnd, ScreenWidth: integer;
        Margin: integer;

{ ---------------------- Video mode routines ---------------------------- }

{$L VGAP}

PROCEDURE Decode16; far; external;

PROCEDURE Decode256; far; external;

PROCEDURE VideoOff(state: boolean);

{ Hides the image by turning off video refresh. See Ferraro p. 468. }

begin
regs.AH:= $12;
regs.BL:= $36;
regs.AL:= ord(state);
intr($10, regs);
end;

FUNCTION DetectVESA(var VESAInf: VESAInfoRec): boolean;

VAR  Signature: string[4];
     IsVESA: boolean;

begin
IsVESA:= False;
Regs.AX:= $4F00;                { VESA Get SuperVGA Info function }
Regs.ES:= seg(VESAInf);         { Info returns in VESAInfo record }
Regs.DI:= ofs(VESAInf);
intr($10, regs);
if (Regs.AH = 0) then        { Function failed if AH <> 0 }
begin
  Signature[0]:= #4;
  Move(VESAInf.Signature, Signature[1], 4);
  if Signature = 'VESA' then IsVESA:= true;
end;
DetectVESA:= IsVESA;
end;


FUNCTION DetectVGA: boolean;

begin
regs.AH:= $1A;               { See Ferraro p. 887 }
regs.AL:= 0;
intr($10, regs);
DetectVGA:= (regs.AH <> $1A);
end;


FUNCTION HardwareSupports(Mode: word): boolean;

{ VESA function $4F00 returns, among other things, a pointer to a list
  of the video modes supported. The list terminates in $FFFF. }

type  ModeList = array[0..255] of word;

VAR  Supported: boolean;
     Modes: ^ModeList;
     x: integer;

begin
Supported:= false;
if Mode >= $100 then
begin
  if DetectVESA(VESAInfo) then    { Fills info record }
  begin
    x:= 0;
    Modes:= VESAInfo.ModePtr;
    repeat
      if Modes^[x] = Mode then   { mode supported - but is window? }
      begin
        GetModeInfo(Mode, ModeInfo);
        Supported:= (ModeInfo.WindowKb > 0);
      end;
      inc(x);
    until Supported or (Modes^[x] = $FFFF) or (x = 256);
  end else Halt;        { if VESA not detected - shouldn't get this far }
end
else Supported:= true;  { assume VGA present }
HardwareSupports:= Supported;
end;


FUNCTION WeSupport(Mode: word): boolean;

{ True if requested mode is supported by PCX.PAS }

VAR  x: integer;
     InThere: boolean;

begin
InThere:= false;
for x:= 1 to NumModes do
  if Mode = OurModes[x] then InThere:= true;
WeSupport:= InThere;
end;


FUNCTION BestMode(Header: PCXHeaderRec): word;

{ Attempts to match the mode to the originating format, but goes to a
  higher resolution if the image doesn't fit the screen. }

VAR   M: word;

  PROCEDURE Try(Mode: word);

  begin
  if HardwareSupports(Mode) and WeSupport(Mode) then M:= Mode;
  end;

  FUNCTION Fits: boolean;

  begin
  Fits:= (Header.XMax < Header.HRes) and (Header.YMax < Header.VRes);
  end;

begin    { BestMode }
if Header.NumPlanes = 1 then
begin
  M:= $13;
  if (Header.HRes > 320) or (not Fits) then Try($101);
  if (Header.HRes > 640) or (not Fits) then Try($103);
  if (Header.HRes > 800) or (not Fits) then Try($105);
  if (Header.HRes > 1024) or (not Fits) then Try($107);
end
else if Header.NumPlanes = 4 then
begin
  if Header.HRes <= 320 then M:= $0D else M:= $0E;
  if (Header.VRes > 200) or (not Fits) then Try($10);
  if (Header.VRes > 350) or (not Fits) then Try($12);
  if (Header.VRes > 480) or (not Fits) then Try($102);
end
else M:= $FFFF;
BestMode:= M;
end;


FUNCTION GetMode: word;

VAR  CurrMode: word;

begin
if DetectVesa(VESAInfo) then
begin
  Regs.AX:= $4F03;
  intr($10, Regs);
  CurrMode:= Regs.BX;                  { may be inaccurate if not SVGA }
  CurrMode:= CurrMode and $3FFF;       {  - see Wilton p. 448 }
  if HardwareSupports(CurrMode) and (CurrMode >= $100) then
  begin
    GetMode:= CurrMode; exit;
  end;
end;
Regs.AH:= $0F;                         { return VGA mode }
intr($10, Regs);
GetMode:= Regs.AL;
end;


PROCEDURE SetMode(Mode, Options: word);

begin
if Mode >= $100 then
{ --- VESA Super-VGA modes }
begin
  if (Options and SaveMem) <> 0 then Mode:= Mode or $8000;
                             { Set bit 15 to preserve video memory }
  Regs.AX:= $4F02;
  Regs.BX:= Mode;
end else
{ --- Standard VGA modes }
begin
  if (Options and SaveMem) <> 0 then Mode:= Mode or $80;
                             { Set bit 7 to preserve video memory }
  Regs.AH:= 0;
  Regs.AL:= lo(Mode);
end;
intr($10, Regs);
end;  { SetMode }


PROCEDURE GetModeInfo(Mode: word; var ModeInfo: ModeInfoRec);

{ Puts information on the selected VESA mode into the ModeInfo record. }

begin
Regs.AX:= $4f01;
Regs.CX:= Mode;
Regs.ES:= seg(ModeInfo);
Regs.DI:= ofs(ModeInfo);
intr($10, Regs);
{ Early versions of VESA BIOS extensions do not return values in the
  XRes and YRes fields. We need to know the YRes for centering images. }
with ModeInfo do
case Mode of
  $100: YRes:= 400;
  $101: YRes:= 480;
  $102: YRes:= 600;
  $103: YRes:= 600;
  $105: YRes:= 768;
  $107: YRes:= 1024;
end;
end;

{ ------------------------- Palette routines ---------------------------- }

FUNCTION Get256Palette(var TheFile: file; var PaletteStart: longint): boolean;

{ TheFile must be open. }

VAR    x: integer;
       PaletteFlag: byte;

begin
PaletteStart:= filesize(TheFile) - 769;

{ The last 769 btes of the file are palette information, starting with a
   one-byte flag. Each group of three bytes represents the RGB values of
   one of the color registers. We take the 6 most significant bits
   to bring the values within the range 0-63 expected by the registers. }

seek(TheFile, PaletteStart);
blockread(TheFile, PaletteFlag, 1);
if (PaletteFlag <> 12) or (PCXHeader.Version < 5) then
begin
  FileError:= ErrNoPal;
  Get256Palette:= false;
  exit;
end;
blockread(TheFile, RGB256, 768);         { Get palette info. }
for x:= 0 to 255 do
with RGB256[x] do
begin
  RedVal:= RedVal shr 2;
  GreenVal:= GreenVal shr 2;
  BlueVal:= BlueVal shr 2;
end;
Get256Palette:= true;
end;  { Get256Palette }


PROCEDURE SetColorRegisters(var PalRec);

{ We can't use the BGI's SetRGBPalette even for the modes supported by
  the BGI, because it won't work unless the BGI initializes the mode
  itself. }

{ PalRec is a string of 768 bytes containing the RGB data. }

begin
Regs.AH:= $10;               { BIOS color register function }
Regs.AL:= $12;               { Subfunction }
Regs.ES:= seg(PalRec);       { Address of palette info }
Regs.DX:= ofs(PalRec);
Regs.BX:= 0;                 { First register to change }
Regs.CX:= $100;              { Number of registers to change }
intr($10, Regs);             { Call BIOS }
end;


PROCEDURE SetPalette(var Palette);

{ Replaces the BGI SetAllPalette procedure. Palette is a 17-byte record
  of the contents of the 16 EGA/VGA palette registers plus the overscan
  register. }

begin
Regs.AH:= $10;
Regs.AL:= 2;
Regs.ES:= seg(Palette);
Regs.DX:= ofs(Palette);
intr($10, Regs);
end;

{ ------------------------ Miscellaneous routines ------------------------ }

PROCEDURE GetMargin(ScreenWidth: word; var Margin, LineEnd: integer);

{ Calculate how many pixels have to be skipped when advancing to the
  next line, so that files of less than screen width can be displayed. }

begin
LineEnd:= PCXHeader.BytesPerLine;      { Used as counter in assembler }
Margin:= ScreenWidth - LineEnd;
if Margin < 0 then FileError:= ErrTooWide;
end;


FUNCTION SetBufferSize: word;

begin
if MaxBufSize > MaxAvail then SetBufferSize:= MaxAvail
else SetBufferSize:= MaxBufSize;
end;


PROCEDURE ReportError(Error: word; var ErrorStr: string);

begin
case Error of
  ErrNoOpen:  ErrorStr:= 'Could not open file.';
  ErrNoPal:   ErrorStr:= 'No palette information in file.';
  ErrTooWide: ErrorStr:= 'Picture is too wide for requested video mode.';
  ErrColors:  ErrorStr:= 'Number of colors in file does not match selected mode.';
  ErrNoSupp:  ErrorStr:= 'Unsupported picture format.';
end;
end;


FUNCTION OpenFile(PicFileName: pathstr; var PicFile: file;
                  var Header: PCXHeaderRec): boolean;

begin
assign(PicFile, PicFileName);
{$I-} reset(PicFile, 1);
blockread(PicFile, Header, 128);  {$I+}
OpenFile:= IOresult = 0;
end;

FUNCTION GetFirstPix(var Header: PCXHeaderRec;
                     Options, ScreenWid, ScreenHt: word): longint;

{ The image is centered if the Options call for it. Otherwise it is offset
  on the screen according to the values of XMin and YMin in the file header.
  These are usually zero. This function returns the offset in bytes from
  the start of the video buffer to where the first pixel will be written. }

VAR  FirstPix: longint;
     PicWid, PicHt: integer;

begin
FirstPix:= 0;
with Header do
begin
  PicWid:= (XMax - XMin + 1);
  if BitsPerPlane = 1 then PicWid:= PicWid div 8;
  PicHt:= YMax - YMin + 1;
  if PicHt < ScreenHt then (* INC(FIRSTPIX, 10240); *)
  begin
    if (Options and VCenter) = 0 then
      inc(FirstPix, YMin * ScreenWid)
    else inc(FirstPix, longint((ScreenHt-1-PicHt) div 2) * ScreenWid);
  end;
  if PicWid < ScreenWid then
  begin
    if (Options and HCenter) = 0 then inc(FirstPix, XMin)
    else inc(FirstPix, (ScreenWid - PicWid) div 2);
  end;
end;   { with }
GetFirstPix:= FirstPix;
end;

{ -------------------------- VGA 16-color files ------------------------- }

PROCEDURE Read16(var PicFile: file; Mode, Options: word);

TYPE
        PaletteBytes = array[0..2] of byte;

VAR
        Entry, Gun, PCXCode: byte;
        PalRegs: array[0..16] of byte;
        ScreenHeight: word;

begin   { READ16 }
if PCXHeader.NumPlanes <> 4 then
begin
  FileError:= ErrColors;
  exit;
end;
if Mode >= $100 then
begin
  GetModeInfo(Mode, ModeInfo);
  ScreenWidth:= ModeInfo.BytesPerLine;
  ScreenHeight:= ModeInfo.YRes;
end
else case Mode of
  $0D: begin ScreenWidth:= 40; ScreenHeight:= 200; end;
  $0E: begin ScreenWidth:= 80; ScreenHeight:= 200; end;
  $10: begin ScreenWidth:= 80; ScreenHeight:= 350; end;
  $12: begin ScreenWidth:= 80; ScreenHeight:= 480; end;
end;
GetMargin(ScreenWidth, Margin, LineEnd);
if FileError <> 0 then exit;
VideoOffs:= GetFirstPix(PCXHeader, Options, ScreenWidth, ScreenHeight);
VideoSeg:= $A000;         { Segment of video memory }
port[$3C4]:= 2;           { Index to map mask register }
Plane:= 1;                { Initialize plane }
port[$3C5]:= Plane;       { Set sequencer to mask out other planes }

{ --- Decipher 16-color palette --- }

{  The palette information is stored in bytes 16-63 of the header. Each of
   the 16 palette slots is allotted 3 bytes - one for each primary color.
   Any of these bytes can have a value of 0-255. However, the VGA is
   capable only of 6-bit RGB values (making for 64x64x64 = 256K possible
   colors), so we take only the 6 most significant bits from each PCX
   color value.

   In 16-color modes, the VGA uses the 16 CGA/EGA palette registers.
   However, the actual color values (18 bits per slot) won't fit here,
   so the palette registers are used as pointers to 16 of the 256 color
   registers, which hold the RGB values.

   What we have to do is extract the RGB values from the PCX header, put
   them in the first 16 color registers, then set the palette to point to
   those registers. }

for Entry:= 0 to 15 do
begin
  for Gun:= 0 to 2 do
  begin
    PCXCode:= PaletteBytes(PCXHeader.Palette[entry])[Gun];
    with RGBPal[Entry] do
    case gun of
      0: RedVal:= PCXCode shr 2;
      1: GreenVal:= PCXCode shr 2;
      2: BlueVal:= PCXCode shr 2;
    end;
  end;  { gun }
  PalRegs[Entry]:= Entry;
end;  { Entry }
PalRegs[16]:= 0;                       { overscan color }
SetColorRegisters(RGBPal);             { RGB values into registers 0-15 }
SetPalette(PalRegs);                   { point to registers 0-15 }

{ --- Read and decode the image data --- }

BytesPerLine:= PCXHeader.BytesPerLine;
RepeatCount:= 0;                       { Initialize assembler vars. }
ColumnCount:= 0;
seek(PicFile, 128);
BufferSize:= SetBufferSize;
getmem(Scratch, BufferSize);           { Allocate scratchpad }
repeat
  blockread(PicFile, Scratch^, BufferSize, DataLength);
  Decode16;                           { Call assembler routine }
until eof(PicFile);
port[$3C5]:= $F;                       { Reset mask map }
freemem(Scratch,BufferSize);           { Discard scratchpad }
end;  { READ16 }

{ ------------------------- VGA 256-color files ------------------------- }

PROCEDURE ReadVGA256(var PicFile: file; Mode, Options: word);

VAR     TotalRead: longint;
        PaletteStart: longint;

begin
if PCXHeader.NumPlanes <> 1 then
begin
  FileError:= ErrColors;
  exit;
end;
{ --- Set palette  --- }
if not Get256Palette(PicFile, PaletteStart) then exit;
{ If clearing video memory before displaying the picture (the default),
  we wait till the entire picture is in memory before displaying it,
  to give a better effect. This is done by setting all color registers
  to black. Otherwise the picture colors are set before any of it is
  displayed. }
SetColorRegisters(RGB256);
ScreenWidth:= 320;
GetMargin(ScreenWidth, Margin, LineEnd);
if FileError <> 0 then exit;

{ --- Read image data --- }
seek(PicFile, 128);
TotalRead:= 128;
repeatcount:= 0;                           { Initialize assembler vars. }
VideoOffs:= GetFirstPix(PCXHeader, Options, ScreenWidth, 200);
VideoSeg:= $A000;
BufferSize:= SetBufferSize;
getmem(Scratch, BufferSize);                { Allocate scratchpad }
repeat
  blockread(PicFile, Scratch^, BufferSize, DataLength);
  inc(TotalRead, DataLength);
  if (TotalRead > PaletteStart) then
      dec(DataLength, TotalRead - PaletteStart);
  Decode256;
until (eof(PicFile)) or (TotalRead>= PaletteStart);
freemem(Scratch, BufferSize);
end;  { ReadVGA256 }

{ ------------------------- SVGA 256-color files ------------------------ }

{$IFDEF RegisteredVersion}
  {$I SVGA256.PAS}
{$ELSE}

PROCEDURE ReadSVGA256(var PicFile: file; Mode, Options: word);

begin
  SetMode(3, NoOptions);
  Writeln('Support for this video mode is available only to registered');
  Writeln('users of PCX.PAS. Please see READ.ME for details.');
  Writeln;
end;

{$ENDIF}

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

FUNCTION ReadIt(PicFileName: pathstr; var Mode: word; Options: word): integer;

VAR  PCXfile: file;

begin
FileError:= 0;
if not OpenFile(PicFileName, PCXFile, PCXHeader) then           { Gets PCX header }
begin
  ReadIt:= 1;
  exit;
end;
{ Trap CGA files }
if (PCXHeader.BitsPerPlane < 8) and (PCXHeader.NumPlanes = 1) then
begin
  close(PCXFile);
  ReadIt:= 5;
  exit;
end;
if Mode = AutoSet then Mode:= BestMode(PCXHeader);
if Mode = $FFFF then             { couldn't find a workable mode }
begin
  FileError:= ErrNoSupp;
  exit;
end;
SetMode(Mode, Options);
if (Options and Blackout) > 0 then VideoOff(true);
case Mode of
  $0D, $0E, $10, $12, $102: Read16(PCXFile, Mode, Options);
  $13: ReadVGA256(PCXFile, Mode, Options);
  $100, $101, $103, $105, $107: ReadSVGA256(PCXFile, Mode, Options);
end;
if (Options and Blackout) > 0 then VideoOff(false);
close(PCXFile);
ReadIt:= FileError;
end;

BEGIN
END.