{----------------------------------------------------------------------------
  Gouraud-shading/texture-mapping
  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 16384,0,655360}
uses Crt,_Math,_Frame,_VGAPas;



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



procedure Error(Msg :String);
begin
  asm
    mov ax,3
    int 10h
  end;
  writeln('[ERROR]: ',Msg);
  halt(1);
end;



procedure CheckKey;
begin
  if KeyPressed then begin
    if ReadKey=#27 then begin
      asm
        mov ax,3
        int 10h
      end;
      halt(2);
    end;
  end;
end;



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

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

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

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


  PFace = ^TFace;
  TFace = RECORD
    Count :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;



var
  PCount  :Integer;
  VL      :PPointList;
  TL      :PPointList;
  PL      :PProjectList;
  NL      :PPointList;
  ML      :PMappingList;
  ZL      :PZList;
  CL      :PColorList;
  FCount  :Integer;
  FL      :PFaceList;
  Texture :Pointer;
  DAC     :TDACBlock;
  tx      :LongInt;
  ty      :LongInt;
  tz      :LongInt;
  rx      :Integer;
  ry      :Integer;
  rz      :Integer;
  OldExit :Pointer;



procedure ShowShadedFace(F :PFace);
var
  i      :Integer;
  w      :Word;
  Buffer :array[0..31] of T2D;
  ColBuf :array[0..31] of Byte;
  P2,P1  :T2D;
  A,B    :T3D;
begin
  for i := 0 to F^.Count-1 do begin
    w:=F^.List[i];
    Buffer[i] := PL^[w];
    ColBuf[i] := Cl^[w];
  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
    CxyShadedPoly(@Buffer,@ColBuf, 3);
  end;
end;



procedure ShowTextureFace(F :PFace);
var
  i      :Integer;
  w      :Word;
  Buffer :array[0..31] of T2D;
  TexBuf :array[0..31] of T2D;
  P2,P1  :T2D;
  A,B    :T3D;
  g      :T2D;
  h1     :Boolean;
  h2     :Boolean;
begin
  h1:=false;
  h2:=false;
  for i := 0 to F^.Count-1 do begin
    w:=F^.List[i];
    Buffer[i] := PL^[w];
    g:=ML^[w];
    TexBuf[i] := g;
    if g[0]>128 then h1:=true;
    if g[1]>128 then h2:=true;
  end;
  if h1 then for i:= 0 to F^.Count-1 do if TexBuf[i,0]<128 then Inc(TexBuf[i,0],256);
  if h2 then for i:= 0 to F^.Count-1 do if TexBuf[i,1]<128 then Inc(TexBuf[i,1],256);
  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
    CxyTexturedPoly(@Buffer,@TexBuf, 3, Texture);
  end;
end;



procedure Project(M :TMatrix);
var
  i :Integer;
  V :T3D;
begin
  for i:= 0 to PCount-1 do begin
    Transform(VL^[i],M,V);
    TL^[i]:=V;
    PL^[i,0] := 160+ (LongInt(V[x])*$200) div V[z];
    PL^[i,1] := 100- (LongInt(V[y])*$200) div V[z];
  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 UpdateColorList(R :TMatrix);
var
  i :Integer;
  N :T3D;
  w :Word;
begin
  for i := 0 to PCount-1 do begin
    Transform(NL^[i],R,N);
    w:= abs(N[2]) shr 1;
    if w> 255 then CL^[i]:= 255 else CL^[i]:= w;
  end;
end;



procedure ShowShadedObject;
var
  M :TMatrix;
  R :TMatrix;
  i :Integer;
begin
  ClearScreen(0);
  Create(tx,ty,tz, $200,$1B0,$200, rx,ry,rz, M);
  Rotate(rx,ry,rz, R);
  Project(M);
  UpdateZList;
  SortZList(0,FCount-1);
  UpdateColorList(R);
  for i := FCount-1 downto 0 do ShowShadedFace(ZL^[i].P);
  ShowVBuffer;
  CheckKey;
end;



procedure ShowTexturedObject;
var
  M :TMatrix;
  i :Integer;
begin
  ClearScreen(0);
  Create(tx,ty,tz, $200,$1B0,$200, rx,ry,rz, M);
  Project(M);
  UpdateZList;
  SortZList(0,FCount-1);
  for i := FCount-1 downto 0 do ShowTextureFace(ZL^[i].P);
  ShowVBuffer;
  CheckKey;
end;



procedure InitVectorData(FCE :String; MM :Word);
var
  i :Integer;
  f :Text;
  s :String;
  r :Real;
  c :Word;
begin
  PCount:=-1;
  New(VL);
  New(TL);
  New(PL);
  New(ML);
  FillChar(ML^,SizeOf(ML^),0);
  New(ZL);
  New(NL);
  New(CL);
  FillChar(NL^,SizeOf(NL^),0);
  FCount:=0;
  New(FL);
  Assign(f,FCE);
  Reset(f);
  if IOResult<>0 then Error('Opening vector data file...');

  while 1=1 do begin
    readln(f,s);
    if s='[END]' then
      break
    else
    if s='[POINT]' then begin
      Inc(PCount);
      for i:=0 to 2 do begin
        readln(f,r);
        if IOResult<>0 then Error('Reading vector data...');
        VL^[PCount,i]:=round(r*$200);
      end;
    end
    else
    if s='[NORMAL]' then begin
      for i:=0 to 2 do begin
        readln(f,r);
        if IOResult<>0 then Error('Reading vector data...');
        NL^[PCount,i]:=round(r*$200);
      end;
    end
    else
    if s='[MAPPING]' then begin
      readln(f,r);
      if IOResult<>0 then Error('Reading vector data...');
      ML^[PCount,0]:=round(r*(TexYSize-1)*MM);
      readln(f,r);
      if IOResult<>0 then Error('Reading vector data...');
      ML^[PCount,1]:=round(r*(TexYSize-1)*MM);
    end
    else
    if s='[FACE]' then begin
      readln(f,c);
      if IOResult<>0 then Error('Reading vector data...');
      GetMem(FL^[FCount],c*2+2);
      FL^[FCount]^.Count:=c;
      for i := 0 to c-1 do begin
        readln(f,c);
        if IOResult<>0 then Error('Reading vector data...');
        FL^[FCount]^.List[i]:=c;
      end;
      Inc(FCount);
      if FL^[0]^.Count <> 3 then begin
        readkey;
      end;
    end
    else
      Error('Bad vector data...');
  end;
  Inc(PCount);
  Close(f);
  tx:=0;
  ty:=0;
  tz:=400*$200;
  rx:=0;
  ry:=0;
  rz:=0;
end;



procedure DoneVectorData;
begin
  PCount:=0;
  Dispose(VL);
  Dispose(TL);
  Dispose(PL);
  Dispose(ML);
  Dispose(ZL);
  Dispose(NL);
  Dispose(CL);
  FCount:=0;
  Dispose(FL);
end;



procedure InitTEX(TEX :String; var P :Pointer; var DAC :TDACBlock);
var
  f   :file;
  i,j :Word;
begin
  TexXSize:=256;
  TexYSize:=256;
  GetMem(P,$FFFF);
  Assign(f,TEX+'.TEX');
  Reset(f,1);
  for i := 0 to 63 do begin
    BlockRead(f,Mem[Seg(P^):i*256],64);
    for j:= 1 to 3 do Move(Mem[Seg(P^):i*256],Mem[Seg(P^):i*256+j*64],64);
  end;
  for j:= 1 to 3 do Move(Mem[Seg(P^):0],Mem[Seg(P^):j*64*256],64*256);
  Close(f);
  Assign(f,TEX+'.PAL');
  Reset(f,1);
  BlockRead(f,DAC,3*256);
  Close(f);
end;



procedure DoneTEX(var P :Pointer);
begin
  FreeMem(P,$FFFF);
end;



procedure InitPIC(PIC :String; var P :Pointer; var DAC :TDACBlock);
var
  f   :file;
begin
  TexXSize:=320;
  TexYSize:=200;
  GetMem(P,64000);
  Assign(f,PIC+'.RAW');
  Reset(f,1);
  BlockRead(f,P^,64000);
  Close(f);
  Assign(f,PIC+'.PAL');
  Reset(f,1);
  BlockRead(f,DAC,3*256);
  Close(f);
end;



procedure DonePIC(var P :Pointer);
begin
  FreeMem(P,64000);
end;



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



procedure SHADED_DUCK;
begin
  FillChar(Mem[$A000:0],64000,0);
  LoadPAL('NDUCK.PAL',DAC);
  SetDACBlock(0,256,DAC);
  InitVectorData('NDUCK.FCE',1);
  InitZList;
  FC:=0;
  tz:= 400*$200;
  rx:=-128;
  repeat
    tx:= -200*$200+LongInt(FC) shl 6;
    ry := FC shr 2;
    rz := FC shr 2;
    ShowShadedObject;
  until tx >=0*$200;
  while FC < 4096 do begin
    ry := FC shr 2;
    rz := FC shr 2;
    ShowShadedObject;
  end;
  Dec(FC,4096);
  repeat
    tx:= LongInt(FC) shl 6;
    ry := FC shr 2;
    rz := FC shr 2;
    ShowShadedObject;
  until tx >=200*$200;
  DoneVectorData;
end;



procedure SHADED_FACE;
begin
  FillChar(Mem[$A000:0],64000,0);
  LoadPAL('JFACE.PAL',DAC);
  SetDACBlock(0,256,DAC);
  InitVectorData('JFACE.FCE',1);
  InitZList;
  FC:=0;
  tz:= 300*$200;
  rx:=-128;
  repeat
    tx:= -200*$200+LongInt(FC) shl 6;
    rx := -128+FC shr 2;
    ry := 256+FC shr 2;
    ShowShadedObject;
  until tx >=0;
  while FC < 4096 do begin
    rx := -128+FC shr 2;
    ry := 256+FC shr 2;
    ShowShadedObject;
  end;
  Dec(FC,4096);
  while FC < 2048 do begin
    if tz > 170*$200 then tz:= 300*$200-LongInt(FC) shl 7;
    rx := -128+FC shr 2;
    ry := 256+FC shr 2;
    ShowShadedObject;
  end;
  Dec(FC,2048);
  repeat
    ty:= -(LongInt(FC) shl 6);
    ShowShadedObject;
  until ty<-150*$200;
  DoneVectorData;
end;



procedure SHADED_CHOPPER;
begin
  FillChar(Mem[$A000:0],64000,0);
  LoadPAL('HELI.PAL',DAC);
  SetDACBlock(0,256,DAC);
  InitVectorData('HELI.FCE',1);
  InitZList;
  FC:=0;
  tz:= 600*$200;
  rx:=-108;
  repeat
    tx:= -200*$200+LongInt(FC) shl 6;
    ry := FC shr 3;
    ShowShadedObject;
  until tx >=0*$200;
  while FC < 4096 do begin
    ry := FC shr 3;
    ShowShadedObject;
  end;
  Dec(FC,4096);
  repeat
    tz:= 600*$200+LongInt(FC) shl 9;
    tx:= LongInt(FC) shl 8;
    ry := FC shr 4;
    ShowShadedObject;
  until tx >=700*$200;
  DoneVectorData;
end;



procedure TEXTURE_SPHERE;
begin
  FillChar(Mem[$A000:0],64000,0);
  InitTEX('MSPHERE',Texture,DAC);
  SetDACBlock(0,256,DAC);
  InitVectorData('MSPHERE.FCE',1);
  InitZList;
  FC:=0;
  tz:= 600*$200;
  repeat
    tx := (FC shr 3-300)*$200;
    ty := -30*$200+round((1+Sin(FC/100))*50*$200);
    rx := -FC shr 2;
    rz := -FC shr 2;
    ShowTexturedObject;
  until tx >=300*$200;
  DoneVectorData;
  DoneTEX(Texture);
end;



procedure TEXTURE_TORUS;
begin
  FillChar(Mem[$A000:0],64000,0);
  InitTEX('MTORUS',Texture,DAC);
  SetDACBlock(0,256,DAC);
  InitVectorData('MTORUS.FCE',1);
  InitZList;
  FC:=0;
  repeat
    ty := (FC shr 3-200)*$200;
    rx := FC shr 2;
    ry := FC shr 2;
    ShowTexturedObject;
  until ty >=0;
  while FC<2048 do begin
    rx := FC shr 2;
    ry := FC shr 2;
    ShowTexturedObject;
  end;
  Dec(FC,2048);
  while FC<2048 do begin
    rx := FC shr 2;
    ry := FC shr 2;
    ShowTexturedObject;
  end;
  Dec(FC,2048);
  repeat
    ty := (FC shr 3)*$200;
    rx := FC shr 2;
    ry := FC shr 2;
    ShowTexturedObject;
  until ty >=200*$200;
  DoneVectorData;
  DoneTEX(Texture);
end;



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



var
  i :Integer;
begin
  ClrScr;
  writeln('-------------------------------------------------------------------------------');
  writeln(' Gouraud-shading/texture-mapping presentation');
  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('                              SPECIAL THANX TO ');
  writeln('                        A N Y  M O T I O N  G m b H ');
  writeln('                        FOR THE NICE VECTOR OBJECTS');
  writeln('-------------------------------------------------------------------------------');
  writeln(' (Press return)');
  readln;
  Init13h;
  InitVBuffer;
  InitFrameHandler;
  OldExit:=ExitProc;
  ExitProc:=@NewExit;
  SHADED_DUCK;
  TEXTURE_SPHERE;
  SHADED_FACE;
  TEXTURE_TORUS;
  SHADED_CHOPPER;
  Done13h;
end.