Unit TCamLib2;
Interface
uses crt,gfx3,tmap2,Polygons;

Const CurMap='Remap2.Pcx';
      CurVMap='Remap2.Pcx';


type lrgarr=array[0..65534] of byte;
       myar2=array[0..32000] of integer;
       myar=^myar2;





var
 RockPal:Array[1..3,0..32] of byte;
 Mapx,Mapy:^lrgarr;
 Whe:Word;
 counter2,counter:real;
 r,g,b:byte;
 MyP:Pointer;
  stab1:array[0..256] of byte;
  segp:word;
  zobs2,zobs:integer;
  Fg:Word;
  i1,j1:integer;
  i2,j2:integer;
  Left:Boolean;
  j:integer;
  orio:array[1..1320] of word;
  mp:^lrgarr;
  rng:array[0..320] of byte;
  myyr,myxr:myar;
  xr,yr:integer;
  c:byte;
  maxmcoun,maxcount:word;
  deg:single;
  path:word;
  i,x,y:integer;
  dir:integer;
  iam:char;
  deg2:real;
  th:real;

Procedure Noise2(Where:Word);
Procedure PutRec;
Procedure PutAlways;
Procedure SetUpCamerasForVoxel;
Procedure ShutDownCamerasForVoxel;
procedure MakeVoxel(xp,yp:integer; dir:integer);



Implementation

Procedure Noise2(Where:Word);
Var o:word;
    Seq:integer;
    Fx:integer;
Begin
Fx:=0;
 For o:=0 to 31999 do
  Begin
   Inc(Fx);
   If Fx=319 Then Fx:=0;
   If Fx=0 Then Seq:=Random(50);     {<-----------}
   If Random(Seq)=1 then
    Begin
     Mem[Where:o]:=130+Random(3);
     Mem[Where:o+1]:=130+Random(3);
     Mem[Where:o+31999]:=130+Random(3);
     Mem[Where:o+31999+1]:=130+Random(3);
    End;
   If o<31999 Then Inc(o);
  End;
End;





Procedure PutRec;
Begin
 Putpixel(270,10,170,vaddr); Putpixel(271,10,170,vaddr);
 Putpixel(270,11,170,vaddr); Putpixel(271,11,170,vaddr);
 Putpixel(269,9,170,vaddr); Putpixel(269,10,170,vaddr);
 Putpixel(269,11,170,vaddr); Putpixel(269,12,170,vaddr);
 Putpixel(270,9,170,vaddr); Putpixel(271,9,170,vaddr);
 Putpixel(272,9,170,vaddr); Putpixel(272,10,170,vaddr);
 Putpixel(272,9,170,vaddr); Putpixel(272,11,170,vaddr);
 Putpixel(272,12,170,vaddr); Putpixel(271,12,170,vaddr);
 Putpixel(270,12,170,vaddr); Putpixel(273,10,170,vaddr);
 Putpixel(273,11,170,vaddr); Putpixel(268,10,170,vaddr);
 Putpixel(268,11,170,vaddr); Putpixel(270,8,170,vaddr);
 Putpixel(271,8,170,vaddr); Putpixel(270,13,170,vaddr);
 Putpixel(271,13,170,vaddr);

End;

Procedure PutAlways;

Begin
 Putpixel(280,8,170,vaddr); Putpixel(280,9,170,vaddr);
 Putpixel(280,10,170,vaddr); Putpixel(280,11,170,vaddr);
 Putpixel(280,12,170,vaddr); Putpixel(281,8,170,vaddr);
 Putpixel(282,8,170,vaddr); Putpixel(283,8,170,vaddr);
 Putpixel(283,9,170,vaddr); Putpixel(282,10,170,vaddr);
 Putpixel(283,11,170,vaddr); Putpixel(283,12,170,vaddr);
 Putpixel(286,8,170,vaddr); Putpixel(286,9,170,vaddr);
 Putpixel(286,10,170,vaddr); Putpixel(286,11,170,vaddr);
 Putpixel(286,12,170,vaddr); Putpixel(287,8,170,vaddr);
 Putpixel(288,8,170,vaddr); Putpixel(289,8,170,vaddr);
 Putpixel(287,10,170,vaddr); Putpixel(288,10,170,vaddr);
 Putpixel(287,12,170,vaddr); Putpixel(288,12,170,vaddr);
 Putpixel(289,12,170,vaddr); Putpixel(292,9,170,vaddr);
 Putpixel(292,10,170,vaddr); Putpixel(292,11,170,vaddr);
 Putpixel(293,8,170,vaddr); Putpixel(294,8,170,vaddr);
 Putpixel(295,8,170,vaddr); Putpixel(293,12,170,vaddr);
 Putpixel(294,12,170,vaddr); Putpixel(295,12,170,vaddr);
End;




procedure DoText;
var kline,mycoun,count:word;


begin
 cls32(vaddr,0);
 mycoun:=maxmcoun;
 kline:=0;
 for count:=maxcount downto 5 do
  begin
   if myyr^[orio[mycoun]-kline-1]>149 then myyr^[orio[mycoun]-kline-1]:=159;
   if myyr^[orio[mycoun]-kline]>149 then myyr^[orio[mycoun]-kline]:=159;
   If myyr^[count+1]>149 Then myyr^[count+1]:=159;
   If myyr^[count]>149 Then myyr^[count]:=159;

   if myyr^[orio[mycoun]-kline-1]<-20 then myyr^[orio[mycoun]-kline-1]:=-25;
   if myyr^[orio[mycoun]-kline]<-20 then myyr^[orio[mycoun]-kline]:=-25;
   If myyr^[count+1]<-20 Then myyr^[count+1]:=-25;
   If myyr^[count]<-20 Then myyr^[count]:=-25;

   if ((myxr^[orio[mycoun]-kline]>myxr^[orio[mycoun]-kline-1])
      Or (myxr^[count]<myxr^[Count+1]))
   and
      (abs(myxr^[count]-myxr^[orio[mycoun]-kline-1])<100)
     { and (kline+1<orio[mycoun]) and (count+1<maxcount) }then
    begin
     PhongClipPolygon
     (myxr^[count],myyr^[count]+40, myxr^[count+1],myyr^[count+1]+40,
     myxr^[orio[mycoun]-kline],myyr^[orio[mycoun]-kline]+40,
    Mapx^[Count],Mapy^[Count],Mapx^[Count+1],Mapy^[Count+1],
    Mapx^[orio[mycoun]-kline],Mapy^[orio[mycoun]-kline],Vaddr,Myp);

     PhongClipPolygon(myxr^[count],myyr^[count]+40,myxr^[orio[mycoun]-kline-1],myyr^[orio[mycoun]-kline-1]+40,
                 myxr^[orio[mycoun]-kline],myyr^[orio[mycoun]-kline]+40,
    Mapx^[Count],Mapy^[Count],
    Mapx^[orio[mycoun]-kline-1],Mapy^[orio[mycoun]-kline-1],
    Mapx^[orio[mycoun]-kline],Mapy^[orio[mycoun]-kline],Vaddr,Myp);

    end;
 {   end;}

   kline:=kline+1;
   if orio[mycoun]=count then
    begin
     kline:=0;
     mycoun:=mycoun-1;
    end;
  end;
{FillBox(0,0,25,199,0,vaddr);
FillBox(300,0,320,199,0,vaddr);}
Hline(0,319,199,0,vaddr);
waitretrace;
end;




procedure MakeVoxel(xp,yp:integer; dir:integer);
var oldj,z,ix,iy,iy1,iyp,ixp,x,y,csf,snf,mpc,i,j:integer;
    mycoun,counter:word;
    sde:real;
    Temp:Word;
begin
  zobs:=zobs2{+mp^[yp shl 8 +xp]*2}+Abs(TXoff-160)*2;
  csf:=round(256*cos(dir/180*pi));
  snf:=round(256*sin(dir/180*pi));
  counter:=0;
  mycoun:=0;
  for iy:=yp to yp+97 do
   begin
    iy1:=10+(iy-yp) shl 1;
    for ix:=xp+yp-iy to xp-yp+iy do
     begin
      ixp:=xp+((ix-xp)*csf+(iy-yp)*snf) shr 8;
      iyp:=yp+((iy-yp)*csf-(ix-xp)*snf) shr 8;
      x:=160+360*(ix-xp) div iy1;
      if (x>=0) and (x<=318) then
       begin
        z:=integer(mp^[word(iyp shl 8+ixp) mod 65534])*4;
        mpc:=z shr 1;
        if z<161 then z:=160;
        y:=40+(zobs-z) shl 5 div iy1;
        j:=x;
           begin
            inc(counter);
            if j<oldj then
             begin
              mycoun:=mycoun+1;
              orio[mycoun]:=counter;
              sde:=-deg2*2.25;
             end;
             If J<35 Then myxr^[counter]:=0 Else
             If J>295 Then myxr^[counter]:=319
              Else MyXr^[Counter]:=j;
            sde:=sde+deg2/8;
            Temp:=round(y-((iy-yp)/5)*deg+sde);
            If Temp>180 Then myyr^[counter]:=199
             Else myyr^[counter]:=Temp;
            oldj:=j;
            MapX^[Counter]:=Byte(ixp) mod 250;
            MapY^[Counter]:=Byte(iyp) mod 250;
           end;
          if y<rng[j] then rng[j]:=y
      end;
      inc(ix,3);
      if ix>xp-yp+iy then ix:=xp-yp+iy;
    end;
    inc(iy,1);
    if iy>yp+97 then iy:=yp+97;
  end;
  maxcount:=counter;
  maxmcoun:=mycoun;
  DoText;
end;


Procedure Smooth(Where:Word);assembler;
Var M:Word;
Asm
 Mov Es,Where
 Xor Di,Di
 Xor Ah,ah
 Xor bh,bh
 Xor Ch,Ch
 Xor Dh,Dh
 @MainLoop:
  Inc Di
  Dec Di
  Mov Al,Es:[Di]
  Add Di,2
  Mov Bl,Es:[Di]
  Add Di,320
  Mov Cl,Es:[Di]
  Sub Di,2
  Mov Dl,Es:[Di]
  Sub Di,319
  Mov M,Ax
  Add M,Bx
  Add M,Cx
  Add M,Dx
  Shr M,2
  Mov Ax,M
  Mov Es:[Di],Al
  Xor Ah,Ah

  Cmp Di,63678
 Jne @MainLoop
End;




Procedure GetMap2;
begin
  segp:=seg(mp^);
    Lpcx(CurVMap,vaddr);
 For i:=1 to 30 do smooth(Vaddr);
{For i:=1 to 30 do AsmFade(VirScr);}


 counter2:=0;

 for i:=0 to 128 do
  begin
   counter:=0;
  for j:=0 to 128 do
   begin
    counter:=counter+0.775;
    c:=getpixel(round(counter2),round(counter),vaddr);
    mem[segp:word(j shl 8+i+1) mod 65534]:=c;
   end;
  counter2:=counter2+0.775;
  end;

 counter2:=0;
 for i:=0 to 128 do
  begin
  counter:=101;
  for j:=128 to 255 do
   begin
    counter:=counter-0.7873;
    c:=getpixel(round(counter2),round(counter),vaddr);
    mem[segp:word(j shl 8+i+1) mod 65534]:=c;
   end;
  counter2:=counter2+0.775;
  end;

 counter2:=100;
 for i:=128 to 255 do
  begin
  counter:=101;
  for j:=128 to 254 do
   begin
    counter:=counter-0.793;
    c:=getpixel(round(counter2) mod 320,round(counter) mod 200,vaddr);
    mem[segp:word(j shl 8+i+1) mod 65534]:=c;
   end;
  counter2:=counter2-0.778;
  end;

 counter2:=100;
 for i:=128 to 255 do
  begin
  counter:=0;
  for j:=0 to 128 do
   begin
    counter:=counter+0.778;
    c:=getpixel(round(counter2),round(counter),vaddr);
    mem[segp:word(j shl 8+i+1) mod 65534]:=c;
   end;
  counter2:=counter2-0.778;
  end;
end;




Procedure GetMap;
var counter2,counter:real;
    r,g,b:byte;
    o:Word;
begin
  GetMem(myp,65535);
  segp:=seg(myp^);
  LPCX(CurMap,Vaddr);
  For o:=0 to 63999 do
   Mem[Vaddr:o]:=Round(Mem[Vaddr:o]/1.6);
 counter2:=0;

 for i:=0 to 128 do
  begin
   counter:=0;
  for j:=0 to 128 do
   begin
    counter:=counter+0.78123;
    c:=getpixel(round(counter2),round(counter),vaddr);
    mem[segp:word(j shl 8+i+1) mod 65534]:=c;
   end;
  counter2:=counter2+0.8;
  end;

 counter2:=0;
 for i:=0 to 128 do
  begin
  counter:=101;
  for j:=128 to 255 do
   begin
    counter:=counter-0.7873;
    c:=getpixel(round(counter2),round(counter),vaddr);
    mem[segp:word(j shl 8+i+1) mod 65534]:=c;
   end;
  counter2:=counter2+0.8;
  end;

 counter2:=100;
 for i:=128 to 255 do
  begin
  counter:=101;
  for j:=128 to 254 do
   begin
    counter:=counter-0.783;
    c:=getpixel(round(counter2) mod 320,round(counter) mod 200,vaddr);
    mem[segp:word(j shl 8+i+1) mod 65534]:=c;
   end;
  counter2:=counter2-0.79;
  end;

 counter2:=100;
 for i:=128 to 255 do
  begin
  counter:=0;
  for j:=0 to 128 do
   begin
    counter:=counter+0.7813;
    c:=getpixel(round(counter2),round(counter),vaddr);
    mem[segp:word(j shl 8+i+1) mod 65534]:=c;
   end;
  counter2:=counter2-0.77;
  end;
end;




Procedure SetUpVoxel;
Begin
 new(mp); fillchar(mp^,65534,70);
 GetMap2;
 GetMap;
 New(Mapx);
 New(Mapy);
  for maxcount:=0 to 65534 do
    If mp^[maxcount]>230 then Mp^[MaxCount]:=230;
 new(myxr);
 new(myyr);
End;



Procedure  GetRockPal;
Begin
 For i:=223 to 255 do
  Begin
   GetPal(i,r,g,b);
   RockPal[1,i-223]:=R;
   RockPal[2,i-223]:=G;
   RockPal[3,i-223]:=B;
  End;
End;



Procedure PutRockPal;
Begin
 For i:=223 to 255 do
   Pal(i,RockPal[1,i-223],RockPal[2,i-223],RockPal[3,i-223]);
End;


Procedure SetupRock;
Begin
 Tsetup('rocket.euv');
 Tsetrocket('romap.pcx',vaddr);
 GetRockPal;
 TZoff:=-500;
End;



Procedure SetUpCamerasForVoxel;
Begin
  SetUpVoxel;
  SetUpRock;
  pal(0,0,0,0);
  zobs:=200;
  pal(255,0,0,0);
  path:=0;
  zobs2:=570;
  dir:=1;
  deg:=1;
  deg2:=0;
  TYOff:=100;
  Whe:=0;
  Tzoff:=-2430;
  Fg:=0;
  X:=200;
  Y:=100;
  Lpcx(CurMap,Vaddr);
  Pal(170,53,0,0);
  PutRockPal;
End;



Procedure ShutDownCamerasForVoxel;
Begin
 dispose(myxr);
 dispose(myyr);
 Dispose(Mp);
 Dispose(Mapx);
 Dispose(Mapy);

End;



End.