home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / pasgraph / move3d.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-24  |  8KB  |  209 lines
  1. Program TextureMapping;
  2. Uses Dos, Crt;
  3. Const k=127;   { Multiplier }
  4.       et1=170; { Perspective effect value }
  5.       et2=50;
  6.       zoommax=100; { Maximum Zoom = 100 (2x zoom) }
  7.       MaxLL=100;   { Maximum length of one line in a face }
  8.  hlp:array[0..9] of string =(
  9.   ('. . ... ...   ... . . ...   ... ... . . ... ...   ...   ... ... ... ... ......   ... . . ...   ... ...   . ... ... ...'),
  10.   ('. . .   .      .  . . .     ... . . . . .   .       .   . . . .  .  . .  ..      .  . . .     . . . .   . .   .    . '),
  11.   ('. . ... ...    .  ... ...   . . . . . . ... ...   ...   ..  . .  .  ...  . ...    .  ... ...   . . ..    . ... .    . '),
  12.   ('. .   . .      .  . . .     . . . . . .   . .     .     . . . .  .  . .  . .      .  . . .     . . . . . . .   .    . '),
  13.   ('... ... ...    .  . . ...   . . ... ... ... ...   ...   . . ...  .  . .  . ...    .  . . ...   ... ... ... ... ...  . '),
  14.   (' ... ... . .   . . ... . .   ... . . . ... ... '),
  15.   (' . . . . . .   . . .   . .   .   . . .  .  .   '),
  16.   (' ... . . ...   ..  ... ...   ...  .  .  .  ... '),
  17.   (' . . . .  .    . . .    .    .   . . .  .    . '),
  18.   (' . . . .  .    . . ...  .    ... . . .  .  ... '));
  19.   { Help texts ... nice, eh? ;-}
  20.  Var p_x,p_y,p_z:array[0..3] of integer;
  21.      r_x,r_y:array[0..3] of integer;
  22.      i,j:integer;r:real;              
  23.      sins,coss:array[1..360] of integer; 
  24.      x,y:integer;reg:registers;
  25.      zoom:array[1..zoommax,1..zoommax] of integer; 
  26.      lx,ly:array[0..1,0..MaxLL] of word;  
  27.      lgtl:array[0..1] of word; 
  28.      P,PP:pointer;sg,os,sp,op:word;   
  29.      mouse_x,mouse_y,napit:integer;  
  30. Function checkmouse :boolean;
  31. Begin
  32.      reg.ax:=0; intr($33,reg);
  33.      if reg.ax<>0 then checkmouse:=false else checkmouse:=true;
  34. End;
  35. Procedure showmouse;
  36. Begin
  37. reg.ax := 1; intr ($33,reg);
  38. End;
  39. Procedure hidemouse;
  40. Begin
  41. reg.ax :=2; intr($33,reg);
  42. End;
  43. Procedure readmouse;
  44. Begin
  45. reg.ax := 3; intr($33,reg);
  46. mouse_y := reg.dx; mouse_x:= reg.cx;
  47. napit := reg.bx;
  48. End;
  49. Procedure mouse_area(x1,x2,y1,y2 :integer);
  50. Begin
  51. reg.ax := 8; reg.cx := y1; reg.dx :=y2;
  52. intr ($33,reg);
  53. reg.ax := 7; reg.cx := x1 ; reg.dx :=x2;
  54. intr ($33,reg);
  55. End;
  56. Procedure FakeLine(x1,y1,x2,y2:integer;num:byte);
  57. Var   dx,dy,ax,rx,ry,i,count:integer;
  58.       k:shortint;
  59. label Xmajor1,Ymajor1,Ymajor2;
  60. Begin
  61.   k:=1;lgtl[num]:=1;count:=0;
  62.   dx:=abs(x1-x2)+1;dy:=abs(y1-y2)+1;rx:=x1;ry:=y1;
  63.       if (dx<dy) then goto Ymajor1;
  64.  ax:=dx;if (y1-y2>0) then k:=-1;    (* X-major line *)
  65.  if x1>x2 then goto Xmajor1;
  66. For rx:=x1 to x2 do Begin
  67.            lx[num,count]:=rx;ly[num,count]:=ry;inc(lgtl[num]);inc(count);
  68.            ax:=ax-dy;if (ax<=0) then Begin inc(ax,dx);inc(ry,k);End;
  69. End;exit;
  70. xmajor1:  (* X-major line Right-to-left *)
  71. For rx:=x1 downto x2 do Begin
  72.            lx[num,count]:=rx;ly[num,count]:=ry;inc(lgtl[num]);inc(count);
  73.            ax:=ax-dy;if (ax<=0) then Begin inc(ax,dx);inc(ry,k);End;
  74. End;exit;
  75. ymajor1:                            (* Y-major line *)
  76.  ax:=dy;if (x1-x2>0) then k:=-1;
  77.  if y1>y2 then goto Ymajor2;
  78. For ry:=y1 to y2 do Begin
  79.            lx[num,count]:=rx;ly[num,count]:=ry;inc(lgtl[num]);inc(count);
  80.            ax:=ax-dx;if (ax<=0) then Begin inc(ax,dy);inc(rx,k);End;
  81. End;exit;
  82. ymajor2:
  83.  For ry:=y1 downto y2 do Begin
  84.            lx[num,count]:=rx;ly[num,count]:=ry;inc(lgtl[num]);inc(count);
  85.             ax:=ax-dx;if (ax<=0) then Begin inc(ax,dy);inc(rx,k);End;
  86. End;End;
  87. Procedure Viiva(x1,y1,x2,y2:integer;color:byte);
  88. Var   dx,dy,ax,rx,ry,i,count:integer;
  89.       k:shortint;
  90. label Ymajor1,Ymajor2;
  91. Begin
  92.   k:=1;count:=0;
  93.   if (x1>x2) then Begin i:=x1;x1:=x2;x2:=i;
  94.                         i:=y1;y1:=y2;y2:=i;End;
  95.   dx:=abs(x1-x2)+1;dy:=abs(y1-y2)+1;rx:=x1;ry:=y1;
  96.       if (dx<dy) then goto Ymajor1;
  97.  ax:=dx;if (y1-y2>0) then k:=-1;    (* X-major line *)
  98. For rx:=x1 to x2 do Begin
  99.            i:=mem[sp:op+(color*50)+zoom[dx,count]];
  100.            mem[sg:os+rx+ry*100]:=i;
  101.            mem[sg:os+rx+ry*100+100]:=i;inc(count);
  102.            ax:=ax-dy;if (ax<=0) then Begin inc(ax,dx);inc(ry,k);
  103.            End;
  104. End;exit;
  105. ymajor1:                            (* Y-major line *)
  106.  ax:=dy;if (x1-x2>0) then k:=-1;
  107.  if y1>y2 then goto Ymajor2;
  108. For ry:=y1 to y2 do Begin
  109.            i:=mem[sp:op+(color*50)+zoom[dy,count]];
  110.            mem[sg:os+rx+ry*100]:=i;
  111.            mem[sg:os+rx+ry*100+100]:=i;inc(count);
  112.            ax:=ax-dx;if (ax<=0) then Begin inc(ax,dy);inc(rx,k);End;
  113. End;exit;
  114. ymajor2:
  115.  For ry:=y1 downto y2 do Begin
  116.            i:=mem[sp:op+(color*50)+zoom[dy,count]];
  117.            mem[sg:os+rx+ry*100]:=i;
  118.            mem[sg:os+rx+ry*100+100]:=i;inc(count);
  119.             ax:=ax-dx;if (ax<=0) then Begin inc(ax,dy);inc(rx,k);End;
  120. End;End;
  121. Procedure Kierto(x_kierto,y_kierto,z_kierto:integer;num:byte);
  122. Var p,x1,y1,z1,x2,y2,z2:integer;
  123. Begin
  124.  x1:= (p_x[num]);
  125.  y1:= (p_y[num]*coss[x_kierto] div k)+(p_z[num]*sins[x_kierto] div k);
  126.  z1:=-(p_y[num]*sins[x_kierto] div k)+(p_z[num]*coss[x_kierto] div k);
  127.  x2:= (x1*coss[y_kierto] div k)-(z1*sins[y_kierto] div k);
  128.  z2:= (x1*sins[y_kierto] div k)+(z1*coss[y_kierto] div k);
  129.  x1:= (x2*coss[z_kierto] div k)+(y1*sins[z_kierto] div k);
  130.  y2:=-(x2*sins[z_kierto] div k)+(y1*coss[z_kierto] div k);
  131.  p:=(k*et1) div ((z2)+et1+et2);
  132.  x:=(x1*p) div k;
  133.  y:=(y2*p) div k;
  134.  x:=x+50;
  135.  y:=-y+50;
  136. End;
  137. Procedure PreCalculate;
  138. Begin TextColor(3);
  139.  write(' 3D Textured vector routine, 100% Pascal ');
  140.  delay(1000);
  141.  
  142. For i:=0 to 360 do Begin
  143.   r:=i;sins[i]:=round(sin(r/180*pi)*k);
  144.        coss[i]:=round(cos(r/180*pi)*k);
  145.   End;
  146.  For i:=1 to zoommax do For j:=1 to i do Begin
  147.   r:=50/i;zoom[i,j]:=round(j*r);End;
  148. End;
  149. Procedure SetObject;
  150. Begin
  151.  p_x[0]:= 40;p_y[0]:=-40;p_z[0]:=0;
  152.  p_x[1]:= 40;p_y[1]:= 40;p_z[1]:=0;
  153.  p_x[2]:=-40;p_y[2]:= 40;p_z[2]:=0;
  154.  p_x[3]:=-40;p_y[3]:=-40;p_z[3]:=0;
  155. End;
  156. Procedure ShowFace;
  157. Var pt:array[0..ZoomMax] of integer;kk:integer;a0,a1:byte;
  158. Begin
  159.   fakeline(r_x[1],r_y[1],r_x[0],r_y[0],0);
  160.   fakeline(r_x[2],r_y[2],r_x[3],r_y[3],1);
  161.   dec(lgtl[0],2);dec(lgtl[1],2);
  162. a0:=0;a1:=1;if lgtl[0]<lgtl[1] then Begin a0:=1;a1:=0;End;
  163.  r:=lgtl[a1]/lgtl[a0];
  164.  kk:=round(r*k);
  165. For i:=1 to lgtl[a0] do Pt[i]:=(i*kk) div k;
  166. For i:=1 to lgtl[a0] do
  167. viiva(lx[a0,i],ly[a0,i],lx[a1,pt[i]],ly[a1,pt[i]],zoom[lgtl[a0],i]);
  168. End;
  169. Procedure ShowWorkspace;
  170. Begin
  171. For i:=0 to 99 do
  172.  move(mem[sg:os+(i*100)],mem[$a000:16100+(i*320)],100);
  173. End;
  174. Procedure ClearWorkspace;
  175. Begin
  176.  fillchar(mem[sg:os],10000,0);
  177. End;
  178. Procedure ShowHelp;
  179. Begin
  180.  For j:=0 to 4 do For i:=1 to length(hlp[j]) do if (ord(hlp[j,i])<>32) then
  181. mem[$a000:1610+i+(j*320)]:=15;
  182.  For j:=5 to 9 do For i:=1 to length(hlp[j]) do if (ord(hlp[j,i])<>32) then
  183. mem[$a000:57225+i+(j*320)]:=15;
  184. End;
  185. (* Main Program *)
  186. Begin clrscr;
  187.    if checkmouse then Begin TextColor(12);Writeln(' Warning! No mouse found!');writeln('');End;
  188.    getmem(p,10000);sg:=seg(p^);os:=ofs(p^);
  189.    getmem(PP,2550);sp:=seg(pp^);op:=ofs(pp^); 
  190.  PreCalculate;
  191.     SetObject;
  192.   Begin  For i:=0 to 49 do For j:=0 to 50 do mem[sp:op+i+(j*50)]:=i+j;
  193.  reg.ax:=$13;intr($10,reg);End;ShowHelp; { MCGA mode }
  194.    Mouse_area(0,716,0,716);
  195.  readmouse;
  196. repeat
  197.   ClearWorkspace;
  198.  For i:=0 to 3 do Begin
  199.      Kierto((mouse_y div 2)+1,(mouse_x div 2)+1,1,i);r_x[i]:=x;r_y[i]:=y;End;
  200.  ShowFace;   
  201. repeat until port[$3da] and 8=8;
  202.  ShowWorkSpace; 
  203.  ReadMouse;
  204. until keypressed;
  205.   reg.ax:=$03;intr($10,reg); { Normal text-mode }
  206. writeln(' - The reason why this routine is so "slow"');
  207. writeln('   is that  it is  coded  100% in  pascal. ');
  208. End.
  209.