Unit IFFLOAD;
interface
USES
  CRT,DOS,GRAPHVGA;

Procedure LoadIFF(N : String; Var Vers : ImageInfo);

Procedure WaitKey;

Implementation
Type
  CmprInfo = Record
               Raw   : Pointer;
               Size  : Word;
             End;
  Char4  = Array[1..4] of Char;
  Str4   = String[4];
  rBMHD  = Record
             Len   : LongInt;
             LX    : Word;
             LY    : Word;
             OX    : Word;
             OY    : Word;
             Plan  : Byte;
             Mask  : Byte;
             Cmprs : byte;
             Dummy : Byte;
             Trans : Word;
             AspX  : Byte;
             aspY  : Byte;
             LaX   : Word;
             LaY   : Word;
           End;
  rCRNG  = Record
             Len   : Longint;
             Dummy : Word;
             Speed : Word;
             Actv  : Word;
             LInf  : Byte;
             LSup  : Byte;
           End;
  rCAMG  = record
             Len   : LongInt;
             Vport : LongInt;
           end;

Function SwapLong(L : Longint) : Longint;
Var
  J,I : Byte;
  L2  : LongInt;
Begin
  J := 3;
  For I:= 0 to 3 do
    Begin
      Mem[Seg(L2):Ofs(L2)+I] := Mem[Seg(L):Ofs(L)+j];
      Dec(J);
    End;
  SwapLong := L2;
End;

Function SwapWord(L : Word) : Word;
Var
  J,I : Byte;
  L2  : word;
Begin
  J := 1;
  For I:= 0 to 1 do
    Begin
      Mem[Seg(L2):Ofs(L2)+I] := Mem[Seg(L):Ofs(L)+j];
      Dec(J);
    End;
  SwapWord := L2;
End;

Function Char2Str(Source : Char4) : Str4;
Var
  I : Byte;
  B : Str4;
Begin
  B := '';
  For I:=1 to 4 do
    B := B + Source[I];
  Char2Str := B;
End;

Procedure LoadIFF(N : String; Var Vers : ImageInfo);
Var
  F     : File;
  Size  : Longint;
  Cmp   : Boolean;
  Plan  : Byte;
  TypeR : Char4;
  Mask  : Boolean;
  ToP   : Boolean;

Procedure FORM;
Begin
  BlockRead(F,Size,4);
  Size := SwapLong(Size);
  inc(Size,4);
  BlockRead(F,TypeR,4);
  If TypeR = 'ILBM' Then Top := False else
  If TypeR = 'PBM ' Then Top := True;
End;

Procedure BMHD;
Var
 Chunk : rBMHD;
Begin
  BlockRead(F,Chunk,Sizeof(Chunk));
  Plan := Chunk.Plan;
  WIth Vers do
    Begin
      SizeX := SwapWord(Chunk.LX);
      SizeY := SwapWord(Chunk.LY);
    End;
  Cmp  := Chunk.Cmprs = 1;
  Mask := Chunk.Mask <> 0;
End;

Procedure CMAP;
Var
  Len : Longint;
  I   : Longint;
  J   : Byte;
Begin
  BlockRead(F,Len,SizeOf(Len));
  Len := SwapLong(Len);
  With Vers do
    Begin
      FillChar(Palette,$ff*3,0);
      BlockRead(F,Palette,Len);
      For J:=0 to $FF do
        Begin
          Palette[J].Rouge := Palette[J].Rouge Shr 2;
          Palette[J].Vert  := Palette[J].Vert Shr 2;
          Palette[J].Bleu  := Palette[J].Bleu shr 2;
        end;
   End;
end;

Procedure CRNG;
Var
  Chunk : rCRNG;
Begin
  BlockRead(F,Chunk,SizeOf(Chunk));
End;

Procedure CAMG;
Var
Chunk : rCAMG;
Begin
  BlockRead(F,Chunk,SizeOf(Chunk));
End;

Procedure Put(P : Pointer; S : Word);
Var
  X,Y  : Word;
  T    : Word;
  Os   : ShortInt;
  Sp   : Word;
  SW   : Word;
  OW   : Word;
  Bits : Boolean;
  Buf  : Pointer;
  Pl   : Byte;
  Bc   : Byte;
Begin
  T := 0;
  Pl := 0;
  Sp := Seg(P^);
  GetMem(Buf,64000);
  Ow := 0;
  SW := Seg(Buf^);
  Ow := Ofs(Buf^);
  FillChar(Buf^,64000,0);
  With Vers do
    Begin
      For Y:=0 to 199 do
        For Pl := 0 to Plan do
          Begin
            X := 0;
              For BC:=0 to 39 do
                For Os := 7 DownTo 0 do
                  Begin
                    Bits:=(Mem[SP:(Y*SizeX+(pl*40))+BC] AND (1 Shl Os))<>0;
                    If Bits Then
                      Mem[SW:Ow+((Y*320)+x)] :=
                        Mem[SW:OW+((Y*320)+x)] + (1 Shl Pl);
                    inc(X);
                  End;
          End;
   end;
  Move(Mem[Seg(Buf^):Ofs(Buf^)],
       Mem[Seg(Vers.Picture^):Ofs(Vers.Picture^)],64000);
  FreeMem(Buf,64000);
End;

Procedure Decomprs( RAW : Pointer;
                    Len : Word);
Var
  SegR  : Word;
  SegD  : Word;
Begin
  segR := Seg(Raw^);
  With Vers do
    Begin
      Size := 64000;
      GetMem(Picture,Size);
      SegD := seg(Picture^);
    End;
  Asm
    Push   DS
    Xor    SI,SI
    Xor    DI,DI
    Mov    AX,[SegR]
    Mov    DS,AX
    Mov    AX,[SegD]
    mov    ES,ax

@encore:
         lodsb
         cmp    al,-128
         je     @suivant
         cmp    al,-1
         jle    @copie
         { Prendre al+1 Octets }
         xor    cx,cx
         mov    cl,al
         inc    cx
         rep    Movsb
         jmp    @suivant
         { Recopie [Si+1] 1-al fois }
@Copie:  xor    CX,CX
         mov    cl,1
         sub    cl,al
         lodsb
         rep    stosb

@suivant:cmp    SI,[Len]
         jbe   @encore

    Pop    DS
  End;
End;

Procedure BODY;
Var
  Len   : Longint;
  P     : Pointer;
Begin
  BlockRead(F,Len,4);
  Len := SwapLong(Len);
  GetMem(P,Len);
  BlockRead(F,P^,Len);
  If Cmp Then
    Decomprs(P,Len)
  Else
    With Vers do
      begin
        Size := Word(Len);
        GetMem(Picture,Size);
        Move(P^,Picture^,Size);
      End;
  Case ToP  of
    False : Put(Vers.Picture,Vers.Size);
    True  :{ Move(Ptr(Seg(Vers.picture^),Ofs(Vers.picture^))^,
                 Ptr(Seg(Vers.picture^),Ofs(Vers.picture^)+8)^,64000)};
  End;
  FreeMem(P,Len);
End;

Procedure Unknow;
Var
  L : Longint;
  P : LongInt;
Begin
  BlockRead(F,L,4);
  L := SwapLong(L);
  P := FilePos(F);
  Seek(F,P+L);
End;

Procedure DPPS;
Var
  L : Longint;
  P : LongInt;
Begin
  BlockRead(F,L,4);
  L := SwapLong(L);
  P := FilePos(F);
  Seek(F,P+L);
  Top := True;
End;

Procedure TINY;
Var
  Len : Longint;
  P   : Longint;
Begin
  BlockRead(F,Len,4);
  Len := SwapLong(Len);
  P := FilePos(F);
  If (Len Mod 2) <> 0 Then
    Inc(Len);
  Seek(F,P+Len);
End;

Var
  Hdr : Char4;
  S   : Str4;
  I  : byte;
begin
  Assign(F,N);
  reset(F,1);
  Top := False;
  Size := 12;
  While (FilePos(F) < Size) AND NOT Eof(f) do
    Begin
      Blockread(F,Hdr,SizeOf(Hdr));
      S := Char2Str(Hdr);
      I := 0;
      If S = 'FORM' Then FORM Else
      If S = 'BMHD' Then BMHD Else
      If S = 'CMAP' Then CMAP Else
      If S = 'CRNG' Then CRNG Else
      If S = 'TINY' Then TINY Else
      If S = 'BODY' Then BODY Else
      Unknow;
    End;
  Close(F);
End;

Procedure WaitKey;
Var
  C: Char;
Begin
  repeat
  Until KeyPressed;
  C := readKey;
End;

End.