Pascal 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.