PC Underground/UNDERGROUND.ISO/doom/source/dungeon.pas

Pascal/Delphi Source File | 1995-02-05 | 9.9 KB | 515 lines

{----------------------------------------------------------------------------
  Vector DUNGEON
  Copyright (c) 1994,95 by J.E. Hoffmann
  All rights reserved
 ----------------------------------------------------------------------------}
{$A+,B-,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y-}
{$M $4000,$60000,$60000}
program __DUNGEON__;



uses Crt,_Keyb,_Math,_Matrix,_VGApas,_Frame;



{$I FX_DOOM.PAH}


const
  zClipPlane = $5*$200;



procedure GetCrossing(A,B :T3D; var C :T3D);
var
  L1,L2 :LongInt;
begin
  L1 :=zClipPlane-A[2];
  L2 := B[2]-A[2];
  if L2= 0 then begin
    C := A;
    C[2] :=$5*$200;
    exit;
  end;
  C[0] := FixDiv(FixMul(L1,B[0]-A[0]),L2) +A[0];
  C[1] := FixDiv(FixMul(L1,B[1]-A[1]),L2) +A[1];
  C[2] := zClipPlane;
end;



var
  OldExit :Pointer;

procedure NewExit; far;
begin
  ExitProc := OldExit;
  DoneFrameHandler;
  Done13h;
end;



type
  TProject = RECORD
    P  :T2D;
    Visible :Boolean;
    _res :array[1..3] of Byte;
  end;

  PPointList = ^TPointList;
  TPointList = array[0..2447] of T3D;

  PProjectList = ^TProjectList;
  TProjectList = array[0..2447] of TProject;

  PMappingList = ^TMappingList;
  TMappingList = array[0..2447] of T2D;

  PColorList = ^TColorList;
  TColorList = array[0..2447] of Byte;


  PFace = ^TFace;
  TFace = RECORD
    Count   :Integer;
    texture :Integer;
    List    :array[0..255] of Word;
  end;

  PFaceList = ^TFaceList;
  TFaceList = array[0..2447] of PFace;


  PZEntry = ^TZEntry;
  TZEntry = RECORD
    z  :LongInt;
    P  :PFace;
  end;

  PZList = ^TZList;
  TZList = array[0..2047] of TZEntry;


const
  PointDef :array[0..3] of T2D = (
    (0,0),
    (319,0),
    (319,199),
    (0,199)
  );


var
  M         :TMatrix;
  rx,ry,rz  :Integer;
  Textures  :array[0..2] of Pointer;
  DAC       :TDACBlock;
  t      :T3D;

  PCount :Integer;
  VL     :PPointList;
  TL     :PPointList;
  PL     :PProjectList;
  FCount :Integer;
  FL     :PFaceList;
  ZL     :PZList;


procedure CxyTexturedPoly(P,T :Pointer; Count :Word; Texture :Pointer); far; external;
{$L CXYTPOLY.OBJ}


procedure DrawFace(F :PFace);
var
  Buffer  :array[0..15] of T2D;
  i,j,
  p,q,l,h :Integer;
  P2,P1   :T2D;
  V       :T3D;
  Clip    :Boolean;

  procedure Calc;
  begin
    with F^ do begin
      GetCrossing(TL^[List[i]], TL^[List[h]], V);
      Project(V,Buffer[j]);
    end;
  end;

begin
  Clip := false;
  with F^ do begin
    j := 0;
    i := 0;
    h := Count-1;

    if PL^[List[0]].Visible then begin
      while PL^[List[i]].Visible do begin
        Buffer[j] := PL^[List[i]].P;
        Inc(j);
        Inc(h);
        if h >= Count then h := 0;
        Inc(i);
        if i >= Count then break;
      end;

      if i < Count then begin
        Clip := true;
        Calc;
        Inc(j);

        while not PL^[List[i]].Visible do begin
          Inc(i);
          if i >= Count then i := 0;
          Inc(h);
          if h >= Count then h := 0;
        end;
        Calc;
        Inc(j);

        if i <> 0 then begin
          while PL^[List[i]].Visible do begin
            Buffer[j] := PL^[List[i]].P;
            Inc(j);
            Inc(h);
            if h >= Count then h := 0;
            Inc(i);
            if i >= Count then break;
          end;
        end;
      end;
    end
    else begin
      Clip := true;
      while not PL^[List[i]].Visible do begin
        Inc(i);
        if i >= Count then break;
      end;
      if i < Count then begin
        h := i-1;
        Calc;
        Inc(j);
        while PL^[List[i]].Visible do begin
          Buffer[j] := PL^[List[i]].P;
          Inc(j);
          Inc(h);
          if h >= Count then h := 0;
          Inc(i);
          if i >= Count then i := 0;
        end;
        Calc;
        Inc(j);
      end
    end;
    VecSub2D(Buffer[1],Buffer[0],P1);
    VecSub2D(Buffer[2],Buffer[0],P2);
    if LongInt(P1[y])*P2[x]-LongInt(P1[x])*P2[y] <= 0 then begin
      if not Clip then begin
        CxyTexturedPoly(@Buffer,@PointDef,j,Textures[Texture])
      end;
    end;
  end;
end;



procedure InitZList;
var
  i :Integer;
begin
  for i := 0 to FCount-1 do ZL^[i].P := FL^[i]
end;



procedure UpdateZList;
var
  i,j :Integer;
  _z  :LongInt;
  F   :PFace;
begin
  for i := 0 to FCount-1 do begin
    with ZL^[i].P^ do begin
      _z:=List[0];
      for j:=1 to Count-1 do Inc(_z,TL^[List[j],2]);
      _z:= _z div Count;
    end;
    ZL^[i].z:=_z;
  end;
end;



procedure SortZList(l, r: Integer);
var
  i,
  j :Integer;
  x :LongInt;
  S :TZEntry;
begin
  i := l;
  j := r;
  x := ZL^[(l+r) shr 1].z;
  repeat
    while ZL^[i].z < x do Inc(i);
    while ZL^[j].z > x do Dec(j);
    if i <= j then begin
      S := ZL^[i];
      ZL^[i] := ZL^[j];
      ZL^[j] := S;
      Inc(i);
      Dec(j);
    end;
  until i > j;
  if l < j then SortZList(l, j);
  if i < r then SortZList(i, r);
end;



procedure TransformPoints(M :TMatrix);
var
  i :Integer;
  V :T3D;
begin
  for i := 0 to PCount-1 do begin
    Transform(VL^[i],M,TL^[i]);
    if TL^[i][2]<zClipPlane then PL^[i].Visible:=false
    else begin
      PL^[i].Visible:=true;
      Project(TL^[i],PL^[i].P);
    end;
  end;
end;


procedure ShowWorld;
var
  i :Integer;
begin
  if KeyPressed then begin
    while KeyPressed do ReadKey;
    halt(0);
  end;
  ShowVBuffer;
  UpdateZList;
  SortZList(0, FCount-1);
  MakeMatrix(t[0],t[1],t[2], $200,$1B0,$200, rx,ry,rz, M);
  TransformPoints(M);
  for i := FCount-1 downto 0 do DrawFace(ZL^[i].P);
end;


procedure DOOM_PART;
var
  i :Word;
begin
  t[0] := 0;
  t[1] := -6*$200;
  t[2] := -30*$200;
  rx := 0;
  ry := 0;
  rz := 0;
  FC:= 0;
  i := 0;
  while FC < 512 do begin
    ry := FC shr 2;
    ShowWorld;
  end;
  Dec(FC,512);
  while FC < 1024 do begin
    ry := 512 shr 2-FC shr 2;
    ShowWorld;
  end;
  Dec(FC,1024);

  while FC < 512 do begin
    rz := (FC shr 1);
    ry := -128+FC shr 1;
    rx := FC shr 1;
    ShowWorld;
  end;
  Dec(FC,512);

  rx := 256;
  while FC < 512 do begin
    rz := 256-FC shr 1;
    ry := 128-FC shr 1;
    ShowWorld;
  end;
  Dec(FC,512);

  rz := 0;
  ry := -128;
  while FC < 512 do begin
    rz := -FC;
    rx := 256-FC shr 1;
    ShowWorld;
  end;
  Dec(FC,512);

  rx := 0;
  while FC < 4096-512+256 do begin
    rz := -512-FC;
    t[0] := FC;
    t[2] := -$3C00+FC*$14;
    ShowWorld;
  end;
  Dec(FC,4096-512+256);

  t[0] := 4096-256;
  while FC < 896 do begin
    rz := -256+FC shr 1;
    ry := -128-FC;
    t[2] := -$3C00+(4096-256)*$14+FC*17;
    ShowWorld;
  end;
  t[2] := -$3C00+(4096-256)*$14+896*17;
  Dec(FC,896);

  ry := -1024;
  while FC < 512 do begin
    t[0] := 4096-256+FC*$15*2;
    rz := 192-FC;
    ShowWorld;
  end;
  Dec(FC,512);

  while FC < 1048 do begin
    t[0] := 4096-256+(512+FC)*$15*2;
    t[1] := -6*$200-FC*9;
    rz := 192-512-FC;
    ShowWorld;
  end;
  Dec(FC,1048);
end;



procedure LoadTexture(TEX :String; var P :Pointer);
var
  f :file;
begin
  GetMem(P,64000);
  Assign(f,TEX);
  Reset(f,1);
  if IOResult <> 0 then begin
    writeln('[ERROR]: File not found...');
    halt(1);
  end;
  BlockRead(f,P^,64000);
  Close(f);
end;



procedure LoadPal(var DAC :TDACBlock; PAL :String);
var
  f :file;
begin
  Assign(f,PAL);
  Reset(f,1);
  BlockRead(f,DAC,3*256);
  Close(f);
end;


procedure LoadVectorData;
var
  f :Text;
  s :String;
  i :Integer;
  r :Real;
  v :Integer;
begin
  PCount:=0;
  FCount:=0;
  New(VL);
  New(TL);
  New(PL);
  New(FL);
  New(ZL);
  Assign(f,'DUNGEON.FCE');
  Reset(f);
  if IOResult <> 0 then begin
    writeln('[ERROR]: Opening vector data failed...');
    halt(1);
  end;
  while not eof(f) do begin
    readln(f,s);
    if s='[POINT]' then begin
      for i:=0 to 2 do begin
        readln(f,r);
        VL^[PCount][i]:=round(r*$200);
      end;
      Inc(PCount);
    end
    else
    if s='[FACE]' then begin
      readln(f,v);
      Getmem(FL^[FCount],4+v*2);
      FL^[FCount]^.Count:=v;
      for i:=0 to v-1 do begin
        readln(f,FL^[FCount]^.List[i]);
      end;
      readln(f,s);
      if s='[TEXTURE]' then begin
        readln(f,FL^[FCount]^.Texture);
      end
      else begin
        writeln('[ERROR]: Bad vector data...');
        halt;
      end;
      Inc(FCount);
    end
    else begin
      writeln('[ERROR]: Bad vector data...');
      halt;
    end;
  end;
  Close(f);
  InitZList;
end;


begin
  ClrScr;
  writeln('-------------------------------------------------------------------------------');
  writeln(' Vector dungeon (from the UNEATABLE megademo by THE COEXiSTENCE)');
  writeln('-------------------------------------------------------------------------------');
  writeln;
  writeln(' Copyright (c) 1994,95 by J.E. Hoffmann');
  writeln(' All rights reserved');
  writeln;
  writeln('-------------------------------------------------------------------------------');
  writeln;
  writeln(' YOU ARE USING THIS SOFTWARE AT YOUR OWN RISK!');
  writeln(' IN NO EVENT SHALL THE AUTHOR(S) BE LIABLE FOR ANY SPECIAL, INDIRECT OR');
  writeln(' CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE,');
  writeln(' DATA OR PROFITS!');
  writeln;
  writeln('-------------------------------------------------------------------------------');
  writeln;
  writeln(' (Press return)');
  readln;
  LoadVectorData;
  TexXSize := 320;
  TexYSize := 200;
  LoadTexture('FLOOR.RAW',Textures[0]);
  LoadTexture('TEXTURE.RAW',Textures[1]);
  GetMem(Textures[2],64000);
  FillChar(Textures[2]^,64000,0);
  LoadPal(DAC,'FLOOR.PAL');
  Init13h;
  InitVBuffer;
  ClearScreen(0);
  SetDACBlock(0,256,DAC);
  InitFrameHandler;
  OldExit := ExitProc;
  ExitProc := @NewExit;
  DOOM_PART;
end.