Unit Lens;
Interface
Uses CRT,DOS,GraphVGA,LibUses;
{ IffLoad,LibUses;}
Const
  Mx    : Word = 80;
  My    : Word = 80;
  defo  : Word = 150;
  size  	= (84*84);
	O_ORG		= (0*(Size*2));
	O_NORM	= (1*(Size*2));
	O_TFM		= (2*(Size*2));
	O_CMAP	= (3*(Size*2));
  Rc    : Word = 40;
  RC2   : Word = 40*40;
  Dis   : Word = 0;
  Dis2  : Word = 0;


Procedure InitLens;

Procedure CloseLens;

Procedure LensPath;

implementation

Var
  P    		: ImageInfo;
  P3   		: ImageInfo;
  Pict 		: Pointer;
  Par  		: Byte;
  Mx2  		: Word;
	Memory 	: Pointer;
  Org  		: Pointer; { Array[0..Size] of Word; }
  Norm		: Pointer; { Array[0..Size] of word; }
  TFm  		: Pointer; { Array[0..Size] of word; }
  CMap 		: Pointer; { Array[0..Size] of word; }
  X,Y  		: integer;
  SX,SY 	: integer;
  Speed		: Integer;

  {
Procedure GetMask;
Var
  X,Y : Word;
Begin
  LoadIFF('MASK.LBM',P);
  PutImage(P,3);
  FreeImage(p);
  DirectVideo(True);
  for Y:=0 to mY-1 do
    for X:=0 to mX-1 do
      CMap[(Y*Mx)+X] := GetPixel(100+X,Y+1);
  DirectVideo(False);
end;

Procedure WriteMask;
Var
  F        : File;
Begin
  Assign(F,'LENS.PRE');
  ReWrite(F,1);
  BlockWrite(F,TFM,SizeOf(TFM));
  BlockWrite(F,CMap,SizeOf(CMap));
  Close(F);
End;

Procedure ReadMask;
Var
  F        : File;
Begin
  Assign(F,'LENS.PRE');
  Reset(F,1);
  BlockRead(F,TFM,SizeOf(TFM));
  BlockRead(F,CMap,SizeOf(CMap));
  Close(F);
End;
}

Procedure Precal;
Var
  P : Pointer;
	MemSeg : Word;
	MemOfs : Word;
Begin
  Defo  := 150;
  Dis   := 0;
  mx    := 84;
  my    := Mx;
  Rc    := Mx Div 2;
  RC2   := RC * Rc;
  Mx2   := Mx Div 2;
	
	MemSeg := Seg(Memory^);
	MemOfs := Ofs(Memory^);

{  ReadMask;}
  OpenSub(Lens_Precal);
{  BlockWrite(LibraryFile,Tfm,SizeOf(Tfm));
  BlockWrite(LibraryFile,Cmap,SizeOf(Cmap));
}
	P := Ptr(MemSeg,MemOfs+O_TFM);
  LoadRaw(P^,Size*2);
	P := Ptr(MemSeg,MemOfs+O_CMAP);
  Loadraw(P^,Size*2);
{  GetMask;
  WriteMask;}
End;

Procedure InitLens;
Var
  I,J : Byte;
  A   : Word;
  f   : Text;
Begin
  GetMem(Memory,$FFFF);		{ Working memory (for transformations)}
	Precal;
  Par := 0;
  SX := -2;
  SY := -3;
  X := 0;
  Y := 0;
  Speed := 2;
  LoadImage(Parchemin_Non,P);
  LoadImage(Parchemin_Code,P3);
  GetMem(Pict,$FFFF);
	
	{ 
	GetMem(Org,Size*Sizeof(Word)); 
  GetMem(Norm,Size*Sizeof(Word)); 
  GetMem(TFm,Size*Sizeof(Word)); 
  GetMem(CMap,Size*Sizeof(Word)); 
	}
		
  Move(P3.Picture^,Pict^,64000);
  Move(P.Palette[0].Rouge,P.Palette[ 64].Rouge,64*3);
  Move(P.Palette[0].Rouge,P.Palette[128].Rouge,64*3);
  Move(P.Palette[0].Rouge,P.Palette[192].Rouge,64*3);
  For J:=1 to 3 do
  for I:=1 to 63 do
    With P.Palette[(J*64)+I] do
        Case Par Of
          0 : Begin
                if Rouge-(3*j) >  0 Then dec(Rouge,(3*j));
                If Vert- (3*j) >  0 then dec(vert ,(3*j));
                If Bleu+ (2*j) < 63 Then Inc(Bleu ,(2*j));
              End;
          1 : Begin
                A := (Rouge+Vert+Bleu) Div 3;
                Rouge := A;
                Vert  := A;
                Bleu  := A;
              End;
          2 : Begin
                if Rouge-(4*j) >  0 Then dec(Rouge,(4*j));
                If Vert- (4*j) >  0 then dec(vert ,(4*j));
                If Bleu+ (8*j) < 63 Then Inc(Bleu ,(8*j));
              End;
          3 : Begin
                Rouge := 0;
                Vert  := 0;
                Bleu  := 0;
              End;
          End;
  PutImage(P,0);
  Move(ptr($A000,0)^,PageW^,64000);
End;

Procedure LensASM;
Var
  Segmts: Word;			{ Source Segment }
	SegMem: Word;			{ Memory Segment }
	SegDat: Word;			{ Data Segment }
  SegWrt: Word;     { Write Segment }
  I     : Byte;
  L_X2,
	L_Y2  : Word;
  C     : Word;
  L_Dss : Word;
  Ofst  : Word;
  L_Mxx : Word;
	L_MX	: Word;
	L_MX2	: Word;
	L_MY	: Word;
	L_SPE	: Integer;
	
Begin
  Move(P.Picture^,PageW^,64000);
  Segmts := Seg(Pict^);
	SegMem := Seg(Memory^);
	SegWrt := WriteS;
  L_Mxx  := 320-Mx;
	L_MX 	 := MX;
	L_MX2	 := MX2;
	L_MY	 := MY;
  L_X2   := X;
  L_Y2   := Y;
	L_SPE	 := Speed;
	
      Asm
        cli
        Push   DS
				Pop	   AX
				Mov	   SegDat,AX								{; Preserve DATA Segment }
				
        Mov    BX,320								
        Mov    AX,L_Y2
        Mul    BX
        Add    AX,L_X2									{; AX = (Y2*320)+X2 }
        Mov    DX,L_MX									{; DX = MX }
        Mov    BX,L_MX2	 						  	{; BX = MX2 }
        Mov    L_DSS,AX									{; DSS = (Y2*320)+X2 }
        Mov    SI,AX
{	
	For Y1:=1 to My do
    For X1:=1 to Mx do
      Begin
        Org[C] := getPixel(X+X1,Y+Y1);
        inc(C);
      end;
}			
				Mov		 AX,SegMem								{; ES = Memory Segment }
        Mov    ES,AX

				MOV		 DI,O_ORG									{; ES:DI = MemSeg:ORG }

				Mov    AX,Segmts                {; Get source background image }
        MOV    DS,AX										{; DS:SI }
				
@@Bcl1: Mov    CX,BX										{; copy BX (MX2) Words }
        rep    MovsW
        add    SI,L_MXX									{; Align to 320-MX bytes }
        Dec    DX												{; Next Line }
        Jnz    @@BCL1
{ end }				
				
				Mov		 AX,SegDat								{; restore DATA Segment }
        Mov		 DS,AX
				
        Mov    DX,L_MY
        Mov    DI,O_NORM
        Mov    SI,L_DSS
				
        Mov    AX,SegWrt     						{; Get writing buffer }
        Mov    DS,AX
				
@@Bcl5: Mov    CX,BX										{; copy BX (MX2) Words }
        rep    MovsW
        add    SI,L_MXX		  						{; Align to 320-MX bytes }
        Dec    DX												{; Next Line }
        Jnz    @@BCL5
				Mov		 AX,SegMem
        MOV    DS,AX										{; Recover DATA SEGMENT }

        Mov    AX,SegWrt   							{; Put New }
				Mov		 ES,AX										{; ES:DI = WriteSegment target }
        Xor    AX,AX
        Mov    CX,L_MY
        Xor    SI,SI
				Mov    DI,L_DSS			            {; DI = DSS (Y2*320) }
@@Bcl3: Mov    DX,L_MY
@@Bcl2: Mov    BX,O_TFM     				    {; get Transistion Offset }
        Mov    AX,Word Ptr[BX+SI]
        Mov    Ofst,AX
        Mov    BX,O_Org 						    {; Get Pixel Value At Ofs }
        Add    BX,AX
        Mov    AL,Byte Ptr[BX]
        Mov    BX,O_CMAP
        cmp    Word Ptr[BX+SI],0
        je     @@TR1
        CMP    Word Ptr[BX+SI],63 			{; Bit Map normal }
        Jb     @@TR3
@@TR4:  Add    AX,WORD Ptr[BX+SI] 			{; Add Color Masking }
        Jmp    @@TR2

@@TR1:  Mov    BX,O_NORM
        Add    BX,OFST
        mov    AL,Byte Ptr[BX]
        jmp    @@TR2
@@TR3:  mov    AL,Byte Ptr[BX+SI]
@@TR2:  inc    SI
        Inc    SI
        StosB
        dec    DX
        Jnz    @@Bcl2
        Add    DI,L_MXX
        Loop   @@Bcl3

        mov    AX,SegWrt							{; Transfert SegWrt to Screen }
        Mov    DS,AX
        Mov    CX,32000
        Xor    DI,DI
        Mov    SI,DI
        Mov    AX,0A000h
        mov    ES,AX
        rep    MovsW
				
				MOV		 AX,SegDat							{; Restore DS }
				Mov		 DS,AX

        { WAIT VBL }
        MOV    CX,Speed
        MOV    DX,$3DA
@@W1:   IN     AL,DX
        TEST   AL,$08
        JNE    @@W1

@@W2:   IN     AL,DX
        TEST   AL,$08
        JE     @@W2
        DEC    CX
        JNZ    @@W1

        sti
      end;
End;
{
Procedure DrawMask;
Var
  X,Y : Word;
Begin
  DirectVideo(True);
  FillChar(ptr($A000,0)^,64000,0);
  for Y:=0 to mY-1 do
    for X:=0 to mX-1 do
      Begin
        PutPixel(X+1,Y+1,Tfm[(Y*Mx)+X]);
        If CMap[(Y*Mx)+X] <> 0 Then
          PutPixel(100+X,Y+1,64)
        Else PutPixel(100+X,Y+1,15);
      end;
  DirectVideo(False);
end;
}
Procedure LensPath;
var
  Z : Word;
Begin
  Y := 1;
  setRGB(P.Palette);
	Speed := 1;
  While (Y<=90) do
    Begin
      X := 10;
      While (X <=320-90) do
        Begin
          LensAsm;
          inc(x,2);
        End;
      Z := 0;
      While (X>10) do
        Begin
          LensAsm;
          dec(X,5);
          inc(Z);
          If Z Mod 3 = 0 Then inc(Y,2);
        End;
    End;
    X := 10;
     While (X <=320-100) do
       Begin
         LensAsm;
         inc(x,2);
       End;
  Z := 0;
  X := 230;
  Speed := 1;
  Y := 101;
  While (Z<10) do
    begin
      Inc(X,SX);
      Inc(Y,SY);
      if (X+SX<1) Or (X+SX > 320-90) then Begin Sx := -SX; inc(Z); end;
      if (Y+SY<1) Or (Y+Sy > 200-90) then Begin SY := -SY; inc(Z); end;
      LensAsm;
    End;
  Z:=0;
  SX := -1;
  Speed := 2;
  Sy := 1;
   While (Z<4) do
    begin
      Inc(X,SX);
      Inc(Y,SY);
      if (X+SX<1) Or (X+SX > 320-90) then Begin Sx := -SX; inc(Z); end;
      if (Y+SY<1) Or (Y+Sy > 200-90) then Begin SY := -SY; inc(Z); end;
      LensAsm;
    End;
  FadeOut(0,$FF,1);
End;


Procedure CloseLens;
Begin
  FreeImage(P);
  FreeImage(P3);
  FreeMem(Pict,$FFFF);
  FreeMem(Memory,$FFFF);

{	FreeMem(Org,Size*Sizeof(Word));
  FreeMem(Norm,Size*Sizeof(Word));
  FreeMem(TFm,Size*Sizeof(Word));
  FreeMem(CMap,Size*Sizeof(Word));}
End;

End.