Power-Programmierung/CD1.mdf/pascal/library/dos/grafik/vgakit/pcx/pcx.pas

Pascal/Delphi Source File | 1991-10-16 | 10.5 KB | 462 lines

PROGRAM PCX;
{
  PROGRAMM ZUM ANZEIGEN VON PCX- FILES

  Paul Schubert, Rottweiler Str. 8, D6000 Frankfurt /M 1, 069 / 231145

}
{$R-}
{$S-}


{.$DEFINE PAUL}


USES  TPCRT,DIRUNIT,TPSTRING,SVGA;


CONST LINLEN   = 2048;
      PCXHDRSIZE  = 128;


TYPE  CMAPTYP  = ARRAY[0..255,0..2] OF BYTE;
      PALTYP   = ARRAY[0..15,0..2] OF BYTE;

TYPE  HDRTYP = RECORD
        ID,VER,COMPR,BPP  : BYTE;
        X1,Y1,X2,Y2       : WORD;
        RX,RY             : WORD;
        HDRPAL            : PALTYP;
        RES               : BYTE;
        PLANES            : BYTE;
        BYTES             : WORD;
        PAL2              : WORD;
        FILL              : ARRAY[1..58] OF BYTE;
{ ERRECHNETE WERTE }
        WID,HIG           : WORD;
        CMAPSIZ           : WORD;
        MONO              : BOOLEAN;
      END;


VAR   I,J                  : INTEGER;
      S                    : STRING;
      CH1,CH2              : CHAR;
      PATH,FN              : STRING;
      F                    : FILE;
      ENDE,AUTO            : BOOLEAN;

      CMAP                 : CMAPTYP;
      PAL                  : VGAPALETTETYP ABSOLUTE CMAP;
      HDR                  : HDRTYP;
      LINBUF               : ARRAY[0..LINLEN] OF BYTE;


PROCEDURE GRAPHEIN(VORGABE:BYTE);

PROCEDURE SET1024X768;
BEGIN
  IF HDR.MONO THEN VMOD := $37 { 16 COLOR }
              ELSE VMOD := $38;
  XWID := 1024;
  YWID := 768;
END; { SET1024X768 }

PROCEDURE SET800X600;
BEGIN
  IF HDR.MONO THEN VMOD := $29 { 16 COLOR }
              ELSE VMOD := $30;
  XWID := 800;
  YWID := 600;
END; { SET800X600 }

PROCEDURE SET640X480;
BEGIN
  IF HDR.MONO THEN VMOD := $11
              ELSE VMOD := $2E;
  XWID := 640;
  YWID := 480;
END; { SET640X480 }

PROCEDURE SET640X400;
BEGIN
  IF HDR.MONO THEN BEGIN
    SET640X480;
    EXIT;
  END ELSE VMOD := $2F;
  XWID := 640;
  YWID := 400;
END; { SET640X400 }

PROCEDURE SET640X350;
BEGIN
  IF HDR.MONO THEN VMOD := $0F
              ELSE VMOD := $2D;
  XWID := 640;
  YWID := 350;
END; { SET640X350 }

PROCEDURE SET320X200;
BEGIN
  IF HDR.MONO THEN BEGIN
    VMOD := $0D { 16 COLOR }
(*
    SET640X350;
    EXIT;
*)
  END ELSE VMOD := $13;
  XWID := 320;
  YWID := 200;
END; { SET320X200 }

BEGIN { GRAPHEIN }
  WITH HDR DO BEGIN
    SET320X200;

    IF VORGABE = 0 THEN BEGIN
      IF WID > 320 THEN BEGIN
        SET640X350;
        IF HIG > 350 THEN SET640X400;
        IF HIG > 400 THEN SET640X480;
        IF HIG > 480 THEN SET800X600;
        IF HIG > 600 THEN SET1024X768;
      END;
      IF WID > 640 THEN BEGIN
        IF HIG <= 600 THEN SET800X600
                      ELSE SET1024X768;
      END;
      IF WID > 800 THEN SET1024X768;
    END ELSE BEGIN
      CASE VORGABE OF
        2 : SET640X350;
        3 : SET640X400;
        4 : SET640X480;
        5 : SET800X600;
        6 : SET1024X768;
      END;
    END;

    IF CHECKVGA(VMOD) < 0 THEN BEGIN
      TEXTMODE(CO80);
      WRITELN;
      WRITELN('KEINE VGA- KARTE VORHANDEN, ODER DIE VGA UNTERSTÜTZT');
      WRITELN('DEN GEWÜNSCHTEN VIDEO- MODUS NICHT');
      HALT(1);
    END;
    MAXX := PRED(XWID);
    MAXY := PRED(YWID);

    DIRECTVIDEO := FALSE;

    IF (VER = 3) AND NOT (CMAPSIZ = 2) THEN EXIT;

    VGASETPALETTE(PAL,0,PRED(CMAPSIZ));

  END; { WITH HDR }
END; {GRAPHEIN }


PROCEDURE AUS;
BEGIN
  TEXTMODE(CO80);
  HALT(3);
END; { AUS }


FUNCTION LIESHDR:BOOLEAN;
VAR   FP   : LONGINT;
      I,J  : INTEGER;
BEGIN
  LIESHDR := FALSE;
  BLOCKREAD(F,HDR,PCXHDRSIZE);
  WITH HDR DO BEGIN
    IF ID <> 10 THEN EXIT;
    WID := SUCC(X2 - X1);
    HIG := SUCC(Y2 - Y1);
    CMAPSIZ := 1 SHL (BPP * PLANES);

    IF CMAPSIZ = 2 THEN BEGIN
      CMAP[0,0] := 0;   CMAP[0,1] := 0;   CMAP[0,2] := 0;
      CMAP[1,0] := $FF; CMAP[1,1] := $FF; CMAP[1,2] := $FF;
    END;
    IF CMAPSIZ = 4 THEN BEGIN
      CMAP[0,0] := 0;   CMAP[0,1] := 0;   CMAP[0,2] := 0;
      CMAP[1,0] := 85;  CMAP[1,1] := $FF; CMAP[1,2] := $FF;
      CMAP[2,0] := $FF; CMAP[2,1] := 85;  CMAP[2,2] := $FF;
      CMAP[3,0] := $FF; CMAP[3,1] := $FF; CMAP[3,2] := $FF;
    END;
    IF CMAPSIZ = 16 THEN BEGIN
      MOVE(HDR.HDRPAL,CMAP,48);
    END;
    IF CMAPSIZ = 256 THEN BEGIN
      FP := FILEPOS(F);
      SEEK(F,FILESIZE(F) - 768);
      BLOCKREAD(F,CMAP,768);
      SEEK(F,FP);
    END;
    FOR I := 0 TO PRED(CMAPSIZ) DO BEGIN
      FOR J := 0 TO 2 DO CMAP[I][J] := CMAP[I][J] SHR 2;
    END;
    MONO := (BPP = 1) AND (PLANES = 1);
  END; { WITH HDR }
  LIESHDR := TRUE;
END; { LIESHDR }


PROCEDURE ZEIGEHDR;
BEGIN
  WITH HDR DO BEGIN
  WRITELN('Version ',VER,',    Komprimiert ',COMPR);
  WRITELN(WID:5,'*',HIG:5);
  WRITELN(BPP:3,' Bits / Pixel,  ',PLANES,' Planes');
  WRITELN;
  WRITELN('linksoben = ',X1,',',Y1,'     rechtsunten = ',X2,',',Y2,'   Auflösung = ',RX,',',RY);
  WRITELN('Linelength = ',BYTES,'    PAL2 = ',PAL2,' (',HEXW(PAL2),')');
  END; { WITH HDR }
END; { ZEIGEHDR }


PROCEDURE ZEIGEBILD;
CONST MASKS  : ARRAY[0..7] OF BYTE = ($80,$40,$20,$10,8,4,2,1);
VAR   X,Y,Z  : WORD;
      B,B2   : BYTE;
      BW     : WORD;
      BITMSK : BYTE;
      BBUF   : ARRAY[0..LINLEN] OF BYTE;

PROCEDURE VGABILD;
(*
VAR   XX,YY  : WORD;
*)
BEGIN
  WITH HDR DO BEGIN
    REPEAT
      IF COMPR = 1 THEN BEGIN
        REPEAT
          BLOCKREAD(F,LINBUF[X],1);
          IF LINBUF[X] > $BF THEN BEGIN
            B := LINBUF[X] AND $3F;
            IF B > 0 THEN BEGIN
              BLOCKREAD(F,B2,1);
              FILLCHAR(LINBUF[X],B,B2);
              INC(X,B);
            END;
          END ELSE BEGIN
            INC(X);
          END;
IF KEYPRESSED THEN
IF READKEY = ^[ THEN AUS;
        UNTIL X >= BW;
        X := 0;
      END ELSE BEGIN
        BLOCKREAD(F,LINBUF,WID);
      END;
      RAMTOVGA(@LINBUF,LONGINT(Y)*LONGINT(XWID),WID);
      INC(Y);
    UNTIL Y >= HIG;
  END; { WITH HDR }
(*
  FOR YY := 0 TO 5 DO
    FOR XX := 0 TO 255 DO PLOT(XX,YY,XX);
*)
END; { VGABILD }

PROCEDURE MONOBILD;
VAR  I,J  : INTEGER;
BEGIN
  WITH HDR DO BEGIN
    REPEAT
      REPEAT
        BLOCKREAD(F,B,1);
        IF B > $BF THEN BEGIN
          B := B AND $3F;
          IF B > 0 THEN BEGIN
            BLOCKREAD(F,B2,1);
            FILLCHAR(LINBUF[X],B,B2);
            INC(X,B);
          END;
        END ELSE BEGIN
          LINBUF[X] := B;
          INC(X);
        END;
IF KEYPRESSED THEN
IF READKEY = ^[ THEN AUS;
      UNTIL X >= BW;
      X := 0;
      RAMTOVGA(@LINBUF,LONGINT(Y)*LONGINT(XWID SHR 3),BW);
      INC(Y);
    UNTIL Y >= HIG;
  END; { WITH HDR }
END; { MONOBILD }

PROCEDURE PLANEBILD;
VAR  I,J,K  : INTEGER;
     RW     : WORD;
BEGIN
  RW := BW * 4; { 4 PLANES }
  WITH HDR DO BEGIN
    REPEAT
      REPEAT
        BLOCKREAD(F,B,1);
        IF B > $BF THEN BEGIN
          B := B AND $3F;
          IF B > 0 THEN BEGIN
            BLOCKREAD(F,B2,1);
            FILLCHAR(BBUF[X],B,B2);
            INC(X,B);
          END;
        END ELSE BEGIN
          BBUF[X] := B;
          INC(X);
        END;
IF KEYPRESSED THEN
IF READKEY = ^[ THEN AUS;
      UNTIL X >= RW;
      BITMSK := 1;
      FILLCHAR(LINBUF,SIZEOF(LINBUF),0);
      X := 0;
      FOR K := 0 TO 3 DO BEGIN
        FOR I := 0 TO PRED(BW) DO BEGIN
          FOR J := 0 TO 7 DO
            IF (BBUF[X] AND MASKS[J]) <> 0 THEN
              LINBUF[8*I+J] := LINBUF[8*I+J] OR BITMSK;
          INC(X);
        END;
        BITMSK := BITMSK SHL 1;
      END; { NEXT Z }
      X := 0;
      RAMTOVGA(@LINBUF,LONGINT(Y)*LONGINT(XWID),WID);
      INC(Y);
    UNTIL Y >= HIG;
  END; { WITH HDR }
END; { PLANEBILD }

PROCEDURE ANDERESBILD;
VAR   PTRN  : ARRAY[0..3] OF BYTE;
BEGIN
  WITH HDR DO BEGIN
    REPEAT
      REPEAT
        BLOCKREAD(F,B,1);
        IF B > $BF THEN BEGIN
          B := B AND $3F;
          IF B > 0 THEN BEGIN
            BLOCKREAD(F,B2,1);
            PTRN[0] := B2 SHR 6;
            PTRN[1] := (B2 SHR 4) AND 3;
            PTRN[2] := (B2 SHR 2) AND 3;
            PTRN[3] := B2 AND 3;
            FOR I := 1 TO B DO BEGIN
              MOVE(PTRN,LINBUF[X],4);
              INC(X,4);
            END;
          END;
        END ELSE BEGIN
          LINBUF[X] := B SHR 6;
          INC(X);
          LINBUF[X] := (B SHR 4) AND 3;
          INC(X);
          LINBUF[X] := (B SHR 2) AND 3;
          INC(X);
          LINBUF[X] := B AND 3;
          INC(X);
        END;
IF KEYPRESSED THEN
IF READKEY = ^[ THEN AUS;
      UNTIL X >= WID;
      X := 0;
      RAMTOVGA(@LINBUF,LONGINT(Y)*LONGINT(XWID),WID);
      INC(Y);
    UNTIL Y >= HIG;
  END; { WITH HDR }
END; { ANDERESBILD }

BEGIN { ZEIGEBILD }
  GRAPHEIN(0);
  X := 0;
  Y := 0;
  WITH HDR DO BEGIN
    BW := BYTES;
    IF MONO THEN MONOBILD
    ELSE BEGIN
      IF PLANES > 1 THEN PLANEBILD
      ELSE BEGIN
        IF BPP = 8 THEN VGABILD
                   ELSE ANDERESBILD;
      END;
    END;
  END; { WITH HDR }
(*
  FOR I := 0 TO 15 DO
  BLOCK(I*10,0,I*10+9,9,I);
*)
  IF READKEY = ' ' THEN;
  TEXTMODE(CO80);
  DIRECTVIDEO := TRUE;
END; { ZEIGEBILD }


{ DIE ETWAS UMFANGREICHERE AUFBEREITUNG DES PATHNAMENS IST LEIDER NICHT
  ZU UMGEHEN !
}
FUNCTION PATHNAME(NAME:STRING):STRING;
VAR   S  : STRING;
BEGIN
  S := JUSTPATHNAME(NAME);
  IF NOT (S[LENGTH(S)] IN ['\',':']) THEN S := S + '\';
  PATHNAME := S;
END; { PATHNAME }


BEGIN { MAIN }
  FN := '*';
  PATH := '';
  ENDE := FALSE;
  AUTO := FALSE;
  IF PARAMCOUNT > 0 THEN BEGIN
    FOR I := 1 TO PARAMCOUNT DO BEGIN
      S := STUPCASE(PARAMSTR(I));
      IF S[1] IN ['-','/'] THEN BEGIN
        DELETE(S,1,1);
        IF S[1] = 'E' THEN ENDE := TRUE;
        IF S[1] = 'A' THEN AUTO := TRUE;
      END ELSE BEGIN
        FN := S;
        PATH := PATHNAME(FN);
        FN := JUSTFILENAME(PARAMSTR(1));
        IF (LENGTH(FN) > 0) AND (POS('.',FN) = 0) THEN FN := FN + '.PCX';
      END;
    END; { NEXT I }
  END ELSE BEGIN
{$IFDEF PAUL}
    PATH := 'D:\PCX\';
{$ENDIF}
  END;

  REPEAT
    IF FN = '*' THEN FN := DIRECTORY(PATH+'*.PC?');
    IF FN = '' THEN HALT;
    PATH := JUSTPATHNAME(FN);
    IF PATH[LENGTH(PATH)] <> '\' THEN PATH := PATH + '\';

    ASSIGN(F,FN);
    RESET(F,1);
    WRITELN;
    WRITELN('Filename : ',FN);
    IF NOT LIESHDR THEN BEGIN
      WRITELN('***** Lesefehler PCX- Header *****');
    END ELSE BEGIN
      IF NOT AUTO THEN BEGIN
        ZEIGEHDR;
        IF READKEY = ' ' THEN ZEIGEBILD;
      END ELSE ZEIGEBILD;
    END;
    CLOSE(F);
    FN := '*';
  UNTIL (FN = '') OR ENDE;

END.