home *** CD-ROM | disk | FTP | other *** search
/ PC Underground / UNDERGROUND.ISO / doom / source / gou_tex.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-02-05  |  13.0 KB  |  657 lines
  1. {----------------------------------------------------------------------------
  2.   Gouraud-shading/texture-mapping
  3.   Copyright (c) 1994,95 by J.E. Hoffmann
  4.   All rights reserved
  5.  ----------------------------------------------------------------------------}
  6. {$A+,B-,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y-}
  7. {$M 16384,0,655360}
  8. uses Crt,_Math,_Frame,_VGAPas;
  9.  
  10.  
  11.  
  12. procedure CxyTexturedPoly(P,T :Pointer; Count :Word; Texture :Pointer); far; external;
  13. {$L CxyGPOLY.OBJ}
  14. procedure CxyShadedPoly(P,C :Pointer; Count :Word); far; external;
  15. {$L CxyTPOLY.OBJ}
  16.  
  17.  
  18.  
  19. procedure Error(Msg :String);
  20. begin
  21.   asm
  22.     mov ax,3
  23.     int 10h
  24.   end;
  25.   writeln('[ERROR]: ',Msg);
  26.   halt(1);
  27. end;
  28.  
  29.  
  30.  
  31. procedure CheckKey;
  32. begin
  33.   if KeyPressed then begin
  34.     if ReadKey=#27 then begin
  35.       asm
  36.         mov ax,3
  37.         int 10h
  38.       end;
  39.       halt(2);
  40.     end;
  41.   end;
  42. end;
  43.  
  44.  
  45.  
  46. type
  47.   PPointList = ^TPointList;
  48.   TPointList = array[0..2447] of T3D;
  49.  
  50.   PProjectList = ^TProjectList;
  51.   TProjectList = array[0..2447] of T2D;
  52.  
  53.   PMappingList = ^TMappingList;
  54.   TMappingList = array[0..2447] of T2D;
  55.  
  56.   PColorList = ^TColorList;
  57.   TColorList = array[0..2447] of Byte;
  58.  
  59.  
  60.   PFace = ^TFace;
  61.   TFace = RECORD
  62.     Count :Integer;
  63.     List  :array[0..255] of Word;
  64.   end;
  65.  
  66.   PFaceList = ^TFaceList;
  67.   TFaceList = array[0..2447] of PFace;
  68.  
  69.  
  70.   PZEntry = ^TZEntry;
  71.   TZEntry = RECORD
  72.     z  :LongInt;
  73.     P  :PFace;
  74.   end;
  75.  
  76.   PZList = ^TZList;
  77.   TZList = array[0..2047] of TZEntry;
  78.  
  79.  
  80.  
  81. var
  82.   PCount  :Integer;
  83.   VL      :PPointList;
  84.   TL      :PPointList;
  85.   PL      :PProjectList;
  86.   NL      :PPointList;
  87.   ML      :PMappingList;
  88.   ZL      :PZList;
  89.   CL      :PColorList;
  90.   FCount  :Integer;
  91.   FL      :PFaceList;
  92.   Texture :Pointer;
  93.   DAC     :TDACBlock;
  94.   tx      :LongInt;
  95.   ty      :LongInt;
  96.   tz      :LongInt;
  97.   rx      :Integer;
  98.   ry      :Integer;
  99.   rz      :Integer;
  100.   OldExit :Pointer;
  101.  
  102.  
  103.  
  104. procedure ShowShadedFace(F :PFace);
  105. var
  106.   i      :Integer;
  107.   w      :Word;
  108.   Buffer :array[0..31] of T2D;
  109.   ColBuf :array[0..31] of Byte;
  110.   P2,P1  :T2D;
  111.   A,B    :T3D;
  112. begin
  113.   for i := 0 to F^.Count-1 do begin
  114.     w:=F^.List[i];
  115.     Buffer[i] := PL^[w];
  116.     ColBuf[i] := Cl^[w];
  117.   end;
  118.   VecSub2D(Buffer[1],Buffer[0],P1);
  119.   VecSub2D(Buffer[2],Buffer[0],P2);
  120.   if LongInt(P1[y])*P2[x]-LongInt(P1[x])*P2[y] <= 0 then begin
  121.     CxyShadedPoly(@Buffer,@ColBuf, 3);
  122.   end;
  123. end;
  124.  
  125.  
  126.  
  127. procedure ShowTextureFace(F :PFace);
  128. var
  129.   i      :Integer;
  130.   w      :Word;
  131.   Buffer :array[0..31] of T2D;
  132.   TexBuf :array[0..31] of T2D;
  133.   P2,P1  :T2D;
  134.   A,B    :T3D;
  135.   g      :T2D;
  136.   h1     :Boolean;
  137.   h2     :Boolean;
  138. begin
  139.   h1:=false;
  140.   h2:=false;
  141.   for i := 0 to F^.Count-1 do begin
  142.     w:=F^.List[i];
  143.     Buffer[i] := PL^[w];
  144.     g:=ML^[w];
  145.     TexBuf[i] := g;
  146.     if g[0]>128 then h1:=true;
  147.     if g[1]>128 then h2:=true;
  148.   end;
  149.   if h1 then for i:= 0 to F^.Count-1 do if TexBuf[i,0]<128 then Inc(TexBuf[i,0],256);
  150.   if h2 then for i:= 0 to F^.Count-1 do if TexBuf[i,1]<128 then Inc(TexBuf[i,1],256);
  151.   VecSub2D(Buffer[1],Buffer[0],P1);
  152.   VecSub2D(Buffer[2],Buffer[0],P2);
  153.   if LongInt(P1[y])*P2[x]-LongInt(P1[x])*P2[y] <= 0 then begin
  154.     CxyTexturedPoly(@Buffer,@TexBuf, 3, Texture);
  155.   end;
  156. end;
  157.  
  158.  
  159.  
  160. procedure Project(M :TMatrix);
  161. var
  162.   i :Integer;
  163.   V :T3D;
  164. begin
  165.   for i:= 0 to PCount-1 do begin
  166.     Transform(VL^[i],M,V);
  167.     TL^[i]:=V;
  168.     PL^[i,0] := 160+ (LongInt(V[x])*$200) div V[z];
  169.     PL^[i,1] := 100- (LongInt(V[y])*$200) div V[z];
  170.   end;
  171. end;
  172.  
  173.  
  174.  
  175. procedure InitZList;
  176. var
  177.   i :Integer;
  178. begin
  179.   for i := 0 to FCount-1 do ZL^[i].P := FL^[i]
  180. end;
  181.  
  182.  
  183.  
  184. procedure UpdateZList;
  185. var
  186.   i,j :Integer;
  187.   _z  :LongInt;
  188.   F   :PFace;
  189. begin
  190.   for i := 0 to FCount-1 do begin
  191.     with ZL^[i].P^ do begin
  192.       _z:=List[0];
  193.       for j:=1 to Count-1 do Inc(_z,TL^[List[j],2]);
  194.       _z:= _z div Count;
  195.     end;
  196.     ZL^[i].z:=_z;
  197.   end;
  198. end;
  199.  
  200.  
  201.  
  202. procedure SortZList(l, r: Integer);
  203. var
  204.   i,
  205.   j :Integer;
  206.   x :LongInt;
  207.   S :TZEntry;
  208. begin
  209.   i := l;
  210.   j := r;
  211.   x := ZL^[(l+r) shr 1].z;
  212.   repeat
  213.     while ZL^[i].z < x do Inc(i);
  214.     while ZL^[j].z > x do Dec(j);
  215.     if i <= j then begin
  216.       S := ZL^[i];
  217.       ZL^[i] := ZL^[j];
  218.       ZL^[j] := S;
  219.       Inc(i);
  220.       Dec(j);
  221.     end;
  222.   until i > j;
  223.   if l < j then SortZList(l, j);
  224.   if i < r then SortZList(i, r);
  225. end;
  226.  
  227.  
  228.  
  229. procedure UpdateColorList(R :TMatrix);
  230. var
  231.   i :Integer;
  232.   N :T3D;
  233.   w :Word;
  234. begin
  235.   for i := 0 to PCount-1 do begin
  236.     Transform(NL^[i],R,N);
  237.     w:= abs(N[2]) shr 1;
  238.     if w> 255 then CL^[i]:= 255 else CL^[i]:= w;
  239.   end;
  240. end;
  241.  
  242.  
  243.  
  244. procedure ShowShadedObject;
  245. var
  246.   M :TMatrix;
  247.   R :TMatrix;
  248.   i :Integer;
  249. begin
  250.   ClearScreen(0);
  251.   Create(tx,ty,tz, $200,$1B0,$200, rx,ry,rz, M);
  252.   Rotate(rx,ry,rz, R);
  253.   Project(M);
  254.   UpdateZList;
  255.   SortZList(0,FCount-1);
  256.   UpdateColorList(R);
  257.   for i := FCount-1 downto 0 do ShowShadedFace(ZL^[i].P);
  258.   ShowVBuffer;
  259.   CheckKey;
  260. end;
  261.  
  262.  
  263.  
  264. procedure ShowTexturedObject;
  265. var
  266.   M :TMatrix;
  267.   i :Integer;
  268. begin
  269.   ClearScreen(0);
  270.   Create(tx,ty,tz, $200,$1B0,$200, rx,ry,rz, M);
  271.   Project(M);
  272.   UpdateZList;
  273.   SortZList(0,FCount-1);
  274.   for i := FCount-1 downto 0 do ShowTextureFace(ZL^[i].P);
  275.   ShowVBuffer;
  276.   CheckKey;
  277. end;
  278.  
  279.  
  280.  
  281. procedure InitVectorData(FCE :String; MM :Word);
  282. var
  283.   i :Integer;
  284.   f :Text;
  285.   s :String;
  286.   r :Real;
  287.   c :Word;
  288. begin
  289.   PCount:=-1;
  290.   New(VL);
  291.   New(TL);
  292.   New(PL);
  293.   New(ML);
  294.   FillChar(ML^,SizeOf(ML^),0);
  295.   New(ZL);
  296.   New(NL);
  297.   New(CL);
  298.   FillChar(NL^,SizeOf(NL^),0);
  299.   FCount:=0;
  300.   New(FL);
  301.   Assign(f,FCE);
  302.   Reset(f);
  303.   if IOResult<>0 then Error('Opening vector data file...');
  304.  
  305.   while 1=1 do begin
  306.     readln(f,s);
  307.     if s='[END]' then
  308.       break
  309.     else
  310.     if s='[POINT]' then begin
  311.       Inc(PCount);
  312.       for i:=0 to 2 do begin
  313.         readln(f,r);
  314.         if IOResult<>0 then Error('Reading vector data...');
  315.         VL^[PCount,i]:=round(r*$200);
  316.       end;
  317.     end
  318.     else
  319.     if s='[NORMAL]' then begin
  320.       for i:=0 to 2 do begin
  321.         readln(f,r);
  322.         if IOResult<>0 then Error('Reading vector data...');
  323.         NL^[PCount,i]:=round(r*$200);
  324.       end;
  325.     end
  326.     else
  327.     if s='[MAPPING]' then begin
  328.       readln(f,r);
  329.       if IOResult<>0 then Error('Reading vector data...');
  330.       ML^[PCount,0]:=round(r*(TexYSize-1)*MM);
  331.       readln(f,r);
  332.       if IOResult<>0 then Error('Reading vector data...');
  333.       ML^[PCount,1]:=round(r*(TexYSize-1)*MM);
  334.     end
  335.     else
  336.     if s='[FACE]' then begin
  337.       readln(f,c);
  338.       if IOResult<>0 then Error('Reading vector data...');
  339.       GetMem(FL^[FCount],c*2+2);
  340.       FL^[FCount]^.Count:=c;
  341.       for i := 0 to c-1 do begin
  342.         readln(f,c);
  343.         if IOResult<>0 then Error('Reading vector data...');
  344.         FL^[FCount]^.List[i]:=c;
  345.       end;
  346.       Inc(FCount);
  347.       if FL^[0]^.Count <> 3 then begin
  348.         readkey;
  349.       end;
  350.     end
  351.     else
  352.       Error('Bad vector data...');
  353.   end;
  354.   Inc(PCount);
  355.   Close(f);
  356.   tx:=0;
  357.   ty:=0;
  358.   tz:=400*$200;
  359.   rx:=0;
  360.   ry:=0;
  361.   rz:=0;
  362. end;
  363.  
  364.  
  365.  
  366. procedure DoneVectorData;
  367. begin
  368.   PCount:=0;
  369.   Dispose(VL);
  370.   Dispose(TL);
  371.   Dispose(PL);
  372.   Dispose(ML);
  373.   Dispose(ZL);
  374.   Dispose(NL);
  375.   Dispose(CL);
  376.   FCount:=0;
  377.   Dispose(FL);
  378. end;
  379.  
  380.  
  381.  
  382. procedure InitTEX(TEX :String; var P :Pointer; var DAC :TDACBlock);
  383. var
  384.   f   :file;
  385.   i,j :Word;
  386. begin
  387.   TexXSize:=256;
  388.   TexYSize:=256;
  389.   GetMem(P,$FFFF);
  390.   Assign(f,TEX+'.TEX');
  391.   Reset(f,1);
  392.   for i := 0 to 63 do begin
  393.     BlockRead(f,Mem[Seg(P^):i*256],64);
  394.     for j:= 1 to 3 do Move(Mem[Seg(P^):i*256],Mem[Seg(P^):i*256+j*64],64);
  395.   end;
  396.   for j:= 1 to 3 do Move(Mem[Seg(P^):0],Mem[Seg(P^):j*64*256],64*256);
  397.   Close(f);
  398.   Assign(f,TEX+'.PAL');
  399.   Reset(f,1);
  400.   BlockRead(f,DAC,3*256);
  401.   Close(f);
  402. end;
  403.  
  404.  
  405.  
  406. procedure DoneTEX(var P :Pointer);
  407. begin
  408.   FreeMem(P,$FFFF);
  409. end;
  410.  
  411.  
  412.  
  413. procedure InitPIC(PIC :String; var P :Pointer; var DAC :TDACBlock);
  414. var
  415.   f   :file;
  416. begin
  417.   TexXSize:=320;
  418.   TexYSize:=200;
  419.   GetMem(P,64000);
  420.   Assign(f,PIC+'.RAW');
  421.   Reset(f,1);
  422.   BlockRead(f,P^,64000);
  423.   Close(f);
  424.   Assign(f,PIC+'.PAL');
  425.   Reset(f,1);
  426.   BlockRead(f,DAC,3*256);
  427.   Close(f);
  428. end;
  429.  
  430.  
  431.  
  432. procedure DonePIC(var P :Pointer);
  433. begin
  434.   FreeMem(P,64000);
  435. end;
  436.  
  437.  
  438.  
  439. procedure LoadPAL(PAL :String; var DAC);
  440. var
  441.   f :file;
  442. begin
  443.   Assign(f,PAL);
  444.   Reset(f,1);
  445.   BlockRead(f,DAC,3*256);
  446.   Close(f);
  447. end;
  448.  
  449.  
  450.  
  451. procedure SHADED_DUCK;
  452. begin
  453.   FillChar(Mem[$A000:0],64000,0);
  454.   LoadPAL('NDUCK.PAL',DAC);
  455.   SetDACBlock(0,256,DAC);
  456.   InitVectorData('NDUCK.FCE',1);
  457.   InitZList;
  458.   FC:=0;
  459.   tz:= 400*$200;
  460.   rx:=-128;
  461.   repeat
  462.     tx:= -200*$200+LongInt(FC) shl 6;
  463.     ry := FC shr 2;
  464.     rz := FC shr 2;
  465.     ShowShadedObject;
  466.   until tx >=0*$200;
  467.   while FC < 4096 do begin
  468.     ry := FC shr 2;
  469.     rz := FC shr 2;
  470.     ShowShadedObject;
  471.   end;
  472.   Dec(FC,4096);
  473.   repeat
  474.     tx:= LongInt(FC) shl 6;
  475.     ry := FC shr 2;
  476.     rz := FC shr 2;
  477.     ShowShadedObject;
  478.   until tx >=200*$200;
  479.   DoneVectorData;
  480. end;
  481.  
  482.  
  483.  
  484. procedure SHADED_FACE;
  485. begin
  486.   FillChar(Mem[$A000:0],64000,0);
  487.   LoadPAL('JFACE.PAL',DAC);
  488.   SetDACBlock(0,256,DAC);
  489.   InitVectorData('JFACE.FCE',1);
  490.   InitZList;
  491.   FC:=0;
  492.   tz:= 300*$200;
  493.   rx:=-128;
  494.   repeat
  495.     tx:= -200*$200+LongInt(FC) shl 6;
  496.     rx := -128+FC shr 2;
  497.     ry := 256+FC shr 2;
  498.     ShowShadedObject;
  499.   until tx >=0;
  500.   while FC < 4096 do begin
  501.     rx := -128+FC shr 2;
  502.     ry := 256+FC shr 2;
  503.     ShowShadedObject;
  504.   end;
  505.   Dec(FC,4096);
  506.   while FC < 2048 do begin
  507.     if tz > 170*$200 then tz:= 300*$200-LongInt(FC) shl 7;
  508.     rx := -128+FC shr 2;
  509.     ry := 256+FC shr 2;
  510.     ShowShadedObject;
  511.   end;
  512.   Dec(FC,2048);
  513.   repeat
  514.     ty:= -(LongInt(FC) shl 6);
  515.     ShowShadedObject;
  516.   until ty<-150*$200;
  517.   DoneVectorData;
  518. end;
  519.  
  520.  
  521.  
  522. procedure SHADED_CHOPPER;
  523. begin
  524.   FillChar(Mem[$A000:0],64000,0);
  525.   LoadPAL('HELI.PAL',DAC);
  526.   SetDACBlock(0,256,DAC);
  527.   InitVectorData('HELI.FCE',1);
  528.   InitZList;
  529.   FC:=0;
  530.   tz:= 600*$200;
  531.   rx:=-108;
  532.   repeat
  533.     tx:= -200*$200+LongInt(FC) shl 6;
  534.     ry := FC shr 3;
  535.     ShowShadedObject;
  536.   until tx >=0*$200;
  537.   while FC < 4096 do begin
  538.     ry := FC shr 3;
  539.     ShowShadedObject;
  540.   end;
  541.   Dec(FC,4096);
  542.   repeat
  543.     tz:= 600*$200+LongInt(FC) shl 9;
  544.     tx:= LongInt(FC) shl 8;
  545.     ry := FC shr 4;
  546.     ShowShadedObject;
  547.   until tx >=700*$200;
  548.   DoneVectorData;
  549. end;
  550.  
  551.  
  552.  
  553. procedure TEXTURE_SPHERE;
  554. begin
  555.   FillChar(Mem[$A000:0],64000,0);
  556.   InitTEX('MSPHERE',Texture,DAC);
  557.   SetDACBlock(0,256,DAC);
  558.   InitVectorData('MSPHERE.FCE',1);
  559.   InitZList;
  560.   FC:=0;
  561.   tz:= 600*$200;
  562.   repeat
  563.     tx := (FC shr 3-300)*$200;
  564.     ty := -30*$200+round((1+Sin(FC/100))*50*$200);
  565.     rx := -FC shr 2;
  566.     rz := -FC shr 2;
  567.     ShowTexturedObject;
  568.   until tx >=300*$200;
  569.   DoneVectorData;
  570.   DoneTEX(Texture);
  571. end;
  572.  
  573.  
  574.  
  575. procedure TEXTURE_TORUS;
  576. begin
  577.   FillChar(Mem[$A000:0],64000,0);
  578.   InitTEX('MTORUS',Texture,DAC);
  579.   SetDACBlock(0,256,DAC);
  580.   InitVectorData('MTORUS.FCE',1);
  581.   InitZList;
  582.   FC:=0;
  583.   repeat
  584.     ty := (FC shr 3-200)*$200;
  585.     rx := FC shr 2;
  586.     ry := FC shr 2;
  587.     ShowTexturedObject;
  588.   until ty >=0;
  589.   while FC<2048 do begin
  590.     rx := FC shr 2;
  591.     ry := FC shr 2;
  592.     ShowTexturedObject;
  593.   end;
  594.   Dec(FC,2048);
  595.   while FC<2048 do begin
  596.     rx := FC shr 2;
  597.     ry := FC shr 2;
  598.     ShowTexturedObject;
  599.   end;
  600.   Dec(FC,2048);
  601.   repeat
  602.     ty := (FC shr 3)*$200;
  603.     rx := FC shr 2;
  604.     ry := FC shr 2;
  605.     ShowTexturedObject;
  606.   until ty >=200*$200;
  607.   DoneVectorData;
  608.   DoneTEX(Texture);
  609. end;
  610.  
  611.  
  612.  
  613. procedure NewExit; far;
  614. begin
  615.   ExitProc:=OldExit;
  616.   DoneFrameHandler;
  617. end;
  618.  
  619.  
  620.  
  621. var
  622.   i :Integer;
  623. begin
  624.   ClrScr;
  625.   writeln('-------------------------------------------------------------------------------');
  626.   writeln(' Gouraud-shading/texture-mapping presentation');
  627.   writeln('-------------------------------------------------------------------------------');
  628.   writeln;
  629.   writeln(' Copyright (c) 1994,95 by J.E. Hoffmann');
  630.   writeln(' All rights reserved');
  631.   writeln;
  632.   writeln('-------------------------------------------------------------------------------');
  633.   writeln;
  634.   writeln(' YOU ARE USING THIS SOFTWARE AT YOUR OWN RISK!');
  635.   writeln(' IN NO EVENT SHALL THE AUTHOR(S) BE LIABLE FOR ANY SPECIAL, INDIRECT OR');
  636.   writeln(' CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE,');
  637.   writeln(' DATA OR PROFITS!');
  638.   writeln;
  639.   writeln('-------------------------------------------------------------------------------');
  640.   writeln('                              SPECIAL THANX TO ');
  641.   writeln('                        A N Y  M O T I O N  G m b H ');
  642.   writeln('                        FOR THE NICE VECTOR OBJECTS');
  643.   writeln('-------------------------------------------------------------------------------');
  644.   writeln(' (Press return)');
  645.   readln;
  646.   Init13h;
  647.   InitVBuffer;
  648.   InitFrameHandler;
  649.   OldExit:=ExitProc;
  650.   ExitProc:=@NewExit;
  651.   SHADED_DUCK;
  652.   TEXTURE_SPHERE;
  653.   SHADED_FACE;
  654.   TEXTURE_TORUS;
  655.   SHADED_CHOPPER;
  656.   Done13h;
  657. end.