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

Pascal/Delphi Source File | 1991-10-16 | 13.5 KB | 576 lines

PROGRAM LBM;
{
  PROGRAMM ZUM ANZEIGEN VON DELUXE PAINT ENHANCED *.LBM UND *.BBM- FILES

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

}
{$R-}
{$S-}


{.$DEFINE PAUL}


USES  TPCRT,TPDOS,TPMOUSE,TPPICK
      ,DIRUNIT,TPSTRING
      ,SVGA
      ;


CONST LINLEN   = 2048;

CONST POWERSOF2 : ARRAY[0..8] OF WORD = (1,2,4,8,16,32,64,128,256);


TYPE  IDTYPE        = ARRAY[1..4] OF CHAR;
      CMAPTYP       = ARRAY[0..255,0..2] OF BYTE;

TYPE  CHUNKTYP = RECORD
        KORR    : BOOLEAN;
        ID      : IDTYPE;
        CASE BOOLEAN OF
          TRUE  : (LEN : LONGINT);
          FALSE : (LBA : ARRAY[1..4] OF BYTE);
      END;

      CRNGTYP = RECORD
        FILL       : WORD;
        RATE       : WORD;
        FILL2      : BYTE;
        FLAGS      : BYTE;
        START,STOP : BYTE;
      END;


TYPE  HDRTYP = RECORD
        WID,HIG   : WORD;
        FILL0     : ARRAY[1..4] OF BYTE;
        BPP       : BYTE;
        AMI1      : BYTE;
        COMPR     : BYTE;
        FILL      : BYTE;
        FGCOL     : BYTE;
        BKCOL     : BYTE;
        XRAT,YRAT : BYTE;
        SCWID     : WORD;
        SCHIG     : WORD;
      END;


VAR   I,J                  : INTEGER;
      CH1,CH2              : CHAR;
      PATH,FN,S            : STRING;
      F                    : FILE;
      CHUNK                : CHUNKTYP;
      FTYP                 : IDTYPE;
      FLEN,CHUNKPOS        : LONGINT;
      CMAPSIZ              : WORD;
      CMAP                 : CMAPTYP;
      PAL                  : VGAPALETTETYP ABSOLUTE CMAP;
      HDR                  : HDRTYP;
      TW,TH                : WORD;
      X,Y,XW               : WORD;
      ILBM,CUT             : BOOLEAN;
      LINBUF               : ARRAY[0..LINLEN] OF BYTE;
      RDWID,DSPWID         : WORD;
      CRNG                 : ARRAY[1..16] OF CRNGTYP;
      CRNP                 : BYTE;

      FIRST,AUTO,ZINFO,
      QUIET,ENDFILE,ENDE   : BOOLEAN;



PROCEDURE GRAPHEIN(VORGABE:BYTE);
BEGIN { GRAPHEIN }
  SET320X200;

  IF VORGABE = 0 THEN BEGIN
    WITH HDR DO BEGIN
      IF HIG > 200 THEN SET640X350;
      IF HIG > 350 THEN SET640X400;
      IF HIG > 400 THEN SET640X480;
      IF HIG > 480 THEN SET800X600;
      IF HIG > 600 THEN SET1024X768;

      IF WID > XWID THEN BEGIN
        SET640X350;
        IF WID > 640 THEN SET800X600;
        IF WID > 800 THEN SET1024X768;
      END;
    END; { WITH HDR }
  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);

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

  DIRECTVIDEO := FALSE;
END; { GRAPHEIN }


FUNCTION READCHUNK:BOOLEAN;
VAR   B  : BYTE;
      W  : WORD;
BEGIN
  READCHUNK := FALSE;
  IF EOF(F) THEN EXIT;
  WITH CHUNK DO BEGIN
    BLOCKREAD(F,ID,8,W);
    IF W <> 8 THEN EXIT;
    CHUNKPOS := FILEPOS(F);
    B := LBA[4]; LBA[4] := LBA[1]; LBA[1] := B;
    B := LBA[3]; LBA[3] := LBA[2]; LBA[2] := B;

    KORR := ODD(LEN);
    IF KORR THEN INC(LEN);
  END; { WITH CHUNK }
  READCHUNK := TRUE;
END; { READCHUNK }


PROCEDURE NXTCHUNK;
BEGIN
  IF (CHUNKPOS+CHUNK.LEN) <= FILESIZE(F) THEN BEGIN
    SEEK(F,CHUNKPOS+CHUNK.LEN);
  END ELSE BEGIN
    WRITE('CHUNK- Größe falsch : ',CHUNKPOS+CHUNK.LEN:8,FILESIZE(F):8);
  END;
END; { NXTCHUNK }


PROCEDURE PUTLINE;
VAR   I,J,K  : INTEGER;
      W,IDX  : WORD;
      B,MSK  : BYTE;
      OTLN   : ARRAY[0..LINLEN] OF BYTE;
BEGIN
  IF HDR.BPP = 1 THEN BEGIN
    I := PRED(XW SHL 3);
    J := PRED(XW);
    REPEAT
      FOR K := 0 TO 7 DO BEGIN
        IF ODD(LINBUF[J]) THEN LINBUF[I] := 1 ELSE LINBUF[I] := 0;
        LINBUF[J] := LINBUF[J] SHR 1;
        DEC(I);
      END; { NEXT K }
      DEC(J);
    UNTIL I < 0;
    RAMTOVGA(@LINBUF,LONGINT(Y) * LONGINT(XWID),DSPWID);
  END ELSE BEGIN
    IF ILBM THEN BEGIN
      IF HDR.BPP = 4 THEN MSK := $F ELSE MSK := $FF;
      W := XW DIV HDR.BPP;
      X := 0;
      I := 0;
      REPEAT
        FOR J := 0 TO 7 DO BEGIN
          B := 0;
          IDX := I;
          FOR K := 0 TO 7 DO BEGIN
            B := (B SHR 1) OR (LINBUF[IDX] AND $80);
            LINBUF[IDX] := LINBUF[IDX] SHL 1;
            INC(IDX,W);
          END;
          OTLN[X] := B AND MSK;
          INC(X);
        END; { NEXT J }
        INC(I);
      UNTIL I >= W;
      RAMTOVGA(@OTLN,LONGINT(Y) * LONGINT(XWID),DSPWID);
    END ELSE
      RAMTOVGA(@LINBUF,LONGINT(Y) * LONGINT(XWID),DSPWID);
  END;
  INC(Y);
  X := 0;
END; { PUTLINE }


PROCEDURE READLINE;
VAR   B,B2 : BYTE;
BEGIN
  WITH HDR DO BEGIN
    IF COMPR = 0 THEN BEGIN
      BLOCKREAD(F,LINBUF,XW);
      PUTLINE;
    END ELSE BEGIN
      BLOCKREAD(F,B,1);
      IF B > $7F THEN BEGIN
        BLOCKREAD(F,B2,1);
        FILLCHAR(LINBUF[X],257 - B,B2);
        INC(X,257); DEC(X,B);
        IF X >= XW THEN PUTLINE;
      END ELSE BEGIN
        INC(B);
        BLOCKREAD(F,LINBUF[X],B);
        INC(X,B);
        IF X >= XW THEN PUTLINE;
      END;
    END;
  END; { WITH HDR }
END; { READLINE }


PROCEDURE DISPLAYTINY;
VAR   MKB  : WORD;
BEGIN { DISPLAYTINY }
  MKB := READKEYORBUTTON;
  IF (MKB <> MOUSERT) AND (LO(MKB) <> $20) THEN EXIT;
  CASE HDR.BPP OF
    1 : XW := TW SHR 3;
    4 : XW := TW SHR 1;
    8 : XW := TW;
  ELSE
    EXIT;
  END;
  GRAPHEIN(1);
  DSPWID := TW;
  X  := 0;
  Y  := 0;
  REPEAT READLINE UNTIL Y >= TH;
  MKB := READKEYORBUTTON;
  TEXTMODE(CO80);
END; { DISPLAYTINY }


PROCEDURE ZEIGINFO;
CONST SS     = 65535;
VAR   P      : ^BYTE;
      TC,TB  : BYTE;
      I,J,L  : WORD;
      T      : LONGINT;
      NP     : VGAPALETTETYP;
      S,S1   : STRING;
BEGIN
  IF NOT ZINFO THEN EXIT;
  IF MAXAVAIL < SS THEN BEGIN
    WRITE(#7);
    EXIT;
  END;
  GETMEM(P,SS);
  SETSEG(0); { VORSICHTSHALBER }

  VGAGETPALETTE(NP);
  TC := 0; TB := 0;
  FOR I := 0 TO 255 DO BEGIN
    IF (NP[I].R >= NP[TC].R) AND
       (NP[I].G >= NP[TC].G) AND
       (NP[I].B >= NP[TC].B) THEN TC := I;
    IF (NP[I].R <= NP[TB].R) AND
       (NP[I].G <= NP[TB].G) AND
       (NP[I].B <= NP[TB].B) THEN TB := I;
  END; { NEXT I }

  IF YWID > 200 THEN BEGIN
    SETFONT(16);
    L := 20;
  END ELSE BEGIN
    SETFONT(8);
    L := 10;
  END;
  MOVE(MEM[$A000:0],P^,SS);

  FOR I := 0 TO L DO BEGIN
    FOR J := 0 TO 255 DO BEGIN
      IF XWID > 320 THEN BEGIN
        MEM[$A000:I * XWID + (J SHL 1)] := J;
        MEM[$A000:I * XWID + SUCC(J SHL 1)] := J;
      END ELSE BEGIN
        MEM[$A000:I * XWID + J] := J;
      END;
    END; { NEXT J }
  END; { NEXT I }

  FGBGTEXT(2,L+5,TC,TB,FN);
  S := '»'+FTYP+'« ';
  STR(HDR.WID,S1); S := S + S1 + ' * ';
  STR(HDR.HIG,S1); S := S + S1 + ' / ';
  STR(POWERSOF2[HDR.BPP],S1);
  FGBGTEXT(2,L+5+SUCC(CHRHIG),TC,TB,S+S1);

  T := TIMEMS;
  REPEAT
  UNTIL KEYPRESSED OR MOUSEPRESSED OR ((TIMEMS - T) > 10000);
  IF KEYPRESSED OR MOUSEPRESSED THEN I := READKEYORBUTTON;

  MOVE(P^,MEM[$A000:0],SS);
  FREEMEM(P,SS);
END; { ZEIGINFO }


PROCEDURE DISPLAYBODY;
VAR   I,J   : INTEGER;
      B,B2  : BYTE;
      MKB   : WORD;
      P     : VGAPALETTETYP;
      C     : COLORVALUE;
      Z     : ARRAY[1..16] OF WORD;
      CY    : BOOLEAN;
BEGIN
  IF NOT AUTO THEN BEGIN
    MKB := READKEYORBUTTON;
    IF (MKB <> MOUSERT) AND (LO(MKB) <> $20) THEN EXIT;
  END;
  WITH HDR DO BEGIN
    CASE BPP OF
      1 : XW := RDWID SHR 3;
      4 : XW := RDWID SHR 1;
      8 : XW := RDWID;
    ELSE
      EXIT;
    END;
    GRAPHEIN(0);
    DSPWID := WID;
    IF DSPWID > XWID THEN DSPWID := XWID;
    X  := 0;
    Y  := 0;
    REPEAT
      READLINE;
    UNTIL Y >= HIG;
  END; { WITH HDR }
  ZEIGINFO;

  CY := FALSE;
  P  := PAL;
  J  := 0;
  REPEAT
    REPEAT
      IF CY THEN BEGIN
        FOR I := 1 TO CRNP DO BEGIN
          WITH CRNG[I] DO BEGIN
            IF Z[I] > 0 THEN BEGIN
              DEC(Z[I]);
              IF Z[I] = 0 THEN BEGIN
                Z[I] := RATE DIV 76;
                IF (FLAGS AND 2) = 2 THEN BEGIN
                  C := P[START];
                  MOVE(P[SUCC(START)],P[START],(STOP-START) * 3);
                  P[STOP] := C;
                END ELSE BEGIN
                  C := P[STOP];
                  MOVE(P[START],P[SUCC(START)],(STOP-START) * 3);
                  P[START] := C;
                END;
              END;
            END;
          END; { WITH }
        END; { NEXT I }
        INC(J);
        IF J = 6 THEN BEGIN
          VGASETPALETTE(P,0,127);
          VGASETPALETTE(P,128,255);
          J := 0;
        END;
      END;
    UNTIL KEYPRESSED OR MOUSEPRESSED;
    MKB := READKEYORBUTTON;
    IF LO(MKB) = 9 THEN BEGIN
      CY := NOT CY;
      FOR I := 1 TO CRNP DO Z[I] := CRNG[I].RATE DIV 76;
      VGASETPALETTE(PAL,0,255);
    END;
  UNTIL (LO(MKB) <> 9);
  TEXTMODE(CO80);
END; { DISPLAYBODY }


FUNCTION DISPLAYCHUNK:BOOLEAN;
VAR   I,J  : INTEGER;
BEGIN
  DISPLAYCHUNK := FALSE;

  IF FIRST AND (CHUNK.ID <> 'FORM') THEN BEGIN
    WRITELN('Der 1. Chunk muß Typ ''FORM'' sein !');
    EXIT;
  END;
  FIRST := FALSE;
  DISPLAYCHUNK := TRUE;

  IF NOT QUIET THEN BEGIN
    WRITE  (CHUNK.ID,CHUNK.LEN:8,' ');
    IF CHUNK.KORR THEN WRITE('* ') ELSE WRITE('  ');
  END;

  IF CHUNK.ID = 'CRNG' THEN BEGIN
    INC(CRNP);
    BLOCKREAD(F,CRNG[CRNP],SIZEOF(CRNGTYP));
    CRNG[CRNP].RATE  := SWAP(CRNG[CRNP].RATE);
    IF NOT QUIET THEN WRITE(' ');
    NXTCHUNK;
    EXIT;
  END;

  IF CHUNK.ID = 'FORM' THEN BEGIN
    FLEN := CHUNK.LEN;
    BLOCKREAD(F,FTYP,4);
    ILBM := (FTYP = 'ILBM');
    IF NOT QUIET THEN BEGIN
      WRITE  ('Filetyp >',FTYP,'<   ');
      WRITE  ('Filegröße : ',FILESIZE(F):8,FLEN:8);
      IF FILESIZE(F) <> (FLEN + 8) THEN WRITE(' !!!');
      WRITELN;
    END;
    EXIT;
  END;

  IF CHUNK.ID = 'TINY' THEN BEGIN
    BLOCKREAD(F,TW,2); TW := SWAP(TW); WRITE(TW:6);
    BLOCKREAD(F,TH,2); TH := SWAP(TH); WRITE(TH:6);
    IF NOT QUIET THEN DISPLAYTINY;
  END;

  IF CHUNK.ID = 'CMAP' THEN BEGIN
    CMAPSIZ := CHUNK.LEN;
    BLOCKREAD(F,CMAP,CMAPSIZ);
    CMAPSIZ := CMAPSIZ DIV 3;
    FOR I := 0 TO PRED(CMAPSIZ) DO BEGIN
      FOR J := 0 TO 2 DO CMAP[I][J] := CMAP[I][J] SHR 2;
    END;
    IF NOT QUIET THEN WRITELN;
    EXIT;
  END;

  IF CHUNK.ID = 'BMHD' THEN BEGIN
    BLOCKREAD(F,HDR,SIZEOF(HDR));
    WITH HDR DO BEGIN
      CUT := (WID < SCWID) OR (HIG < SCHIG);

      WID := SWAP(WID);
      RDWID := WID;
      IF ODD(RDWID) THEN INC(RDWID);
      IF ILBM AND (BPP > 1) THEN BEGIN
        IF ((RDWID AND 2) > 0) THEN INC(RDWID,2);
        IF ((RDWID AND 4) > 0) THEN INC(RDWID,4);
        IF ((RDWID AND 8) > 0) THEN INC(RDWID,8);
      END;

      HIG := SWAP(HIG);
      SCWID := SWAP(SCWID);
      SCHIG := SWAP(SCHIG);

      IF NOT QUIET THEN BEGIN
        WRITE('<',RDWID,'> ');
        WRITE(WID,'*',HIG,' (',SCWID,'*',SCHIG,') ',BPP,' Bit/Pixel, ',COMPR);

        WRITELN;
        FOR I := 1 TO 4 DO WRITE(HEXB(FILL0[I]),' ');
        WRITE(HEXB(AMI1),' ',HEXB(FILL),' ');
        WRITE('  ',HEXB(XRAT),' ',HEXB(YRAT));
        WRITE('  FG = ',FGCOL,',  BK = ',BKCOL,',  CUT = ',CUT);
      END;
    END; { WITH HDR }
  END;

  IF CHUNK.ID = 'BODY' THEN BEGIN
    DISPLAYBODY;
  END;

  NXTCHUNK;
  IF NOT QUIET THEN WRITELN;
END; { DISPLAYCHUNK }


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


BEGIN { MAIN }
  INITIALIZEMOUSE;
  ENABLEEVENTHANDLING;
  ENABLEPICKMOUSE;

  AUTO  := FALSE;
  QUIET := FALSE;
  ZINFO := FALSE;
  ENDE  := FALSE;
  FN    := '*';
{$IFDEF PAUL}
  PATH  := 'C:\DPAINT\ARTWORK\';
{$ELSE}
  PATH  := '';
{$ENDIF}

  FOR I := 1 TO PARAMCOUNT DO BEGIN
    S := STUPCASE(PARAMSTR(I));
    IF S[1] IN ['-','/'] THEN BEGIN
      CASE S[2] OF
        'A' : BEGIN
                AUTO := TRUE;
                QUIET := TRUE;
              END;
        'E' : ENDE := TRUE;
        'I' : BEGIN
                AUTO := TRUE;
                QUIET := TRUE;
                ZINFO := TRUE;
              END;
        'Q' : QUIET := TRUE;
      END; { CASE }
    END ELSE BEGIN
      PATH := S;
      IF NOT (PATH[LENGTH(PATH)] IN [':','\']) THEN BEGIN
        FN := PATH;
        WHILE (LENGTH(PATH) > 0) AND (PATH[LENGTH(PATH)] <> '\') DO DELETE(PATH,LENGTH(PATH),1);
      END;
    END;
    IF NOT (PATH[LENGTH(PATH)] IN ['\',':']) THEN PATH := PATH + '\';
    IF PATH[2] <> ':' THEN PATH := DEFAULTDRIVE + ':' + PATH;
  END; { NEXT I }
  IF FN <> '*' THEN BEGIN
    IF POS('.',FN) = 0 THEN FN := FN + '.LBM';
  END;

  CLRSCR;
  REPEAT
    IF FN = '*' THEN BEGIN
      FN := DIRECTORY(PATH+'*.?BM');
      IF (FN <> '*') AND (FN <> '') THEN BEGIN
        PATH := JUSTPATHNAME(FN);
        IF NOT (PATH[LENGTH(PATH)] IN ['\',':']) THEN PATH := PATH + '\';
      END;
    END;
    IF (FN <> '*') AND (FN <> '') THEN BEGIN
      GOTOXY(1,25);
      IF NOT QUIET THEN BEGIN
        WRITELN;
        WRITELN;
        WRITELN('Filename : ',FN);
      END;
      ASSIGN(F,FN);
      RESET(F,1);
      FIRST := TRUE;
      CRNP  := 0;
      REPEAT
        ENDFILE := NOT READCHUNK;
        IF NOT ENDFILE THEN ENDFILE := NOT DISPLAYCHUNK;
      UNTIL ENDFILE;
      CLOSE(F);
      FN := '*';
    END;
  UNTIL ENDE OR (FN = '');

END.