Pascal PCX

PCX

{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄPCX-file viewer, 256 colors only.ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄ( C ) Copyright 1994 By Kimmo Fredriksson.ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}

{$A+,B-,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+}

UNIT	PCX;

	INTERFACE

PROCEDURE InitPCX( BytesPerRow : Word; ScreenPtr : Pointer );
PROCEDURE LoadPCX( CONST f : STRING; X, Y : Word; PC : Boolean );

	IMPLEMENTATION

USES	VGAPal,
	BinFiles,
	Error,
	AsmSys;

TYPE	BytePtr		= ^Byte;

	PtrTYPE		= RECORD
			    Ofs : Word;
			    Seg : Word;
			  END;

VAR	BPR		: Word;
	ScrOfs		: Word;
	ScrSeg		: Word;
	ScrPtr		: BytePtr;

	CurrPos		: BytePtr;

PROCEDURE SetPix( x, y : Word; color : Byte );
BEGIN
  BytePtr( Ptr( ScrSeg, ScrOfs + y * BPR + x ))^ := color
END;

PROCEDURE HorizLine( x0, x1, y : Word; color : Byte );
BEGIN
  IF x0 > x1 THEN SwapInt( x0, x1 );
  FillCharFast( Ptr( ScrSeg, ScrOfs + y * BPR + x0 )^, x1 - x0, color )
END;

{ Load file f, to position X, Y. If PC = TRUE, load the palette too }

PROCEDURE LoadPCX( CONST f : STRING; X, Y : Word; PC : Boolean );
TYPE	PCXFile	= RECORD
		    CASE Word OF
		      0 : ( Id0 : Byte;
			    d0  : Word;
			    Id1 : Byte;
			    x0  : Word;
			    y0  : Word;
			    x1  : Word;
			    y1  : Word );
		      1 : ( d   : ARRAY[ 0..2047 ] OF Byte )
		    END;

VAR	q : FILE;
	b : PCXFile;
	BytesRead, pos, w, h, eX, eY, n : Word;
	cb : Byte;

{ Only 256-color files }

FUNCTION ValidFile : Boolean;
BEGIN
  BlockRead( q, b, 128, BytesRead );
  IF ( b.Id0 <> 10 ) OR ( b.Id1 <> 8 ) THEN
    BEGIN
      Close( q );
      ValidFile := FALSE
    END
  ELSE
    ValidFile := TRUE
END;

{ Set the palette registers }

PROCEDURE SetPCXPal;
VAR i : Word;
BEGIN
  Seek( q, FileSize( q ) - 3 * 256 - 1 );
  BlockRead( q, b, 3 * 256 + 1 );
  IF b.Id0 = 12 THEN
    BEGIN
      FOR i := 1 TO 3 * 256 + 1 DO b.d[ i ] := b.d[ i ] SHR 2;
      SetDACs( 0, 256, @b.d[ 1 ] )
    END
END;
{	PCX-file is coded as follows:

	  - If two hi bits in the byte = 0 --> this is the pixel color
	  - If two hi bits in the byte = 1 --> six lo bits is the pixel run
	    length, and next byte is the color of these pixels }
BEGIN
  IF NOT FOpenRead( q, f ) THEN FatalError('Cannot load file ' + f + '!');
  IF NOT ValidFile THEN Exit;
  w := Succ( b.x1 - b.x0 );	{ width }
  h := Succ( b.y1 - b.y0 );	{ height }
  n := 0;                       { run-length }
  eX := X + w;                  { X, Y end points }
  eY := Y + h;
  CurrPos := BytePtr( Ptr( ScrSeg, ScrOfs + Y * BPR + X ));
  REPEAT
    BlockRead( q, b, 2048, BytesRead );
    pos := 0;
    WHILE ( pos < BytesRead ) AND ( y < eY ) DO
      BEGIN
	cb := b.d[ pos ];
	IF n <> 0 THEN
	  BEGIN
	    HorizLine( X, X + n, Y, cb );
	    Inc( Word( CurrPos ), n );
	    Inc( X, n );
	    n := 0
	  END ELSE
	IF ( cb AND $C0 ) = $C0 THEN n := cb AND $3F ELSE
	  BEGIN
	  { SetPix( X, Y, cb ); }
	    CurrPos^ := cb;
	    Inc( Word( CurrPos ));
	    Inc( X )
	  END;
	Inc( pos );
	IF X >= eX THEN
	  BEGIN
	    Inc( Word( CurrPos ), BPR - w );
	    Dec( X, w );
	    Inc( Y )
	  END
      END
  UNTIL ( BytesRead = 0 ) OR ( Y >= eY );
  IF PC THEN SetPCXPal;
  Close( q )
END;

PROCEDURE InitPCX( BytesPerRow : Word; ScreenPtr : Pointer );
BEGIN
  BPR := BytesPerRow;
  ScrPtr := ScreenPtr;
  ScrOfs := PtrTYPE( ScrPtr ).Ofs;
  ScrSeg := PtrTYPE( ScrPtr ).Seg;
END;

END.